{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
module Network.Wai.Handler.Launch
( run
, runUrl
, runUrlPort
, runHostPortUrl
, runHostPortFullUrl
) where
import Network.Wai
import Network.Wai.Internal
import Network.HTTP.Types
import qualified Network.Wai.Handler.Warp as Warp
import Data.IORef
import Data.Monoid (mappend)
import Data.String (fromString)
import Control.Concurrent (forkIO, threadDelay, newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.Async (race)
import Control.Monad.IO.Class (liftIO)
import Control.Monad (unless)
import Control.Exception (throwIO)
import Data.Function (fix)
import qualified Data.ByteString as S
import Data.ByteString.Builder (Builder, byteString)
import qualified Data.ByteString.Builder.Extra as Builder (flush)
#if WINDOWS
import Foreign
import Foreign.C.String
#else
import System.Process (rawSystem)
#endif
import Data.Streaming.ByteString.Builder as B (newBuilderRecv, defaultStrategy)
import qualified Data.Streaming.Zlib as Z
ping :: IORef Bool -> Middleware
ping :: IORef Bool -> Middleware
ping IORef Bool
active Application
app Request
req Response -> IO ResponseReceived
sendResponse
| Request -> [Text]
pathInfo Request
req [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
"_ping"] = do
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
active Bool
True
Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] ByteString
""
| Bool
otherwise = Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
let isHtml :: [(a, ByteString)] -> Bool
isHtml [(a, ByteString)]
hs =
case a -> [(a, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"content-type" [(a, ByteString)]
hs of
Just ByteString
ct -> ByteString
"text/html" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
ct
Maybe ByteString
Nothing -> Bool
False
if ResponseHeaders -> Bool
forall {a}. (Eq a, IsString a) => [(a, ByteString)] -> Bool
isHtml (ResponseHeaders -> Bool) -> ResponseHeaders -> Bool
forall a b. (a -> b) -> a -> b
$ Response -> ResponseHeaders
responseHeaders Response
res
then do
let (Status
s, ResponseHeaders
hs, (StreamingBody -> IO a) -> IO a
withBody) = Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
res
(Bool
isEnc, ResponseHeaders
headers') = (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> (Bool, ResponseHeaders)
fixHeaders ResponseHeaders -> ResponseHeaders
forall a. a -> a
id ResponseHeaders
hs
headers'' :: ResponseHeaders
headers'' = ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
x, ByteString
_) -> HeaderName
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
"content-length") ResponseHeaders
headers'
(StreamingBody -> IO ResponseReceived) -> IO ResponseReceived
forall {a}. (StreamingBody -> IO a) -> IO a
withBody ((StreamingBody -> IO ResponseReceived) -> IO ResponseReceived)
-> (StreamingBody -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \StreamingBody
body ->
Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
s ResponseHeaders
headers'' (StreamingBody -> Response) -> StreamingBody -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush ->
(Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
addInsideHead Builder -> IO ()
sendChunk IO ()
flush (StreamingBody -> IO ()) -> StreamingBody -> IO ()
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk' IO ()
flush' ->
if Bool
isEnc
then (Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
decode Builder -> IO ()
sendChunk' IO ()
flush' StreamingBody
body
else StreamingBody
body Builder -> IO ()
sendChunk' IO ()
flush'
else Response -> IO ResponseReceived
sendResponse Response
res
decode :: (Builder -> IO ()) -> IO ()
-> StreamingBody
-> IO ()
decode :: (Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
decode Builder -> IO ()
sendInner IO ()
flushInner StreamingBody
streamingBody = do
(BuilderRecv
blazeRecv, BuilderFinish
blazeFinish) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
newBuilderRecv BufferAllocStrategy
defaultStrategy
Inflate
inflate <- WindowBits -> IO Inflate
Z.initInflate (WindowBits -> IO Inflate) -> WindowBits -> IO Inflate
forall a b. (a -> b) -> a -> b
$ Int -> WindowBits
Z.WindowBits Int
31
let send :: Builder -> IO ()
send Builder
builder = BuilderRecv
blazeRecv Builder
builder IO BuilderPopper -> (BuilderPopper -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BuilderPopper -> IO ()
goBuilderPopper
goBuilderPopper :: BuilderPopper -> IO ()
goBuilderPopper BuilderPopper
popper = (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
ByteString
bs <- BuilderPopper
popper
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Inflate -> ByteString -> IO Popper
Z.feedInflate Inflate
inflate ByteString
bs IO Popper -> (Popper -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Popper -> IO ()
goZlibPopper
IO ()
loop
goZlibPopper :: Popper -> IO ()
goZlibPopper Popper
popper = (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
PopperRes
res <- Popper
popper
case PopperRes
res of
PopperRes
Z.PRDone -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Z.PRNext ByteString
bs -> do
Builder -> IO ()
sendInner (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs
IO ()
loop
Z.PRError ZlibException
e -> ZlibException -> IO ()
forall e a. Exception e => e -> IO a
throwIO ZlibException
e
StreamingBody
streamingBody Builder -> IO ()
send (Builder -> IO ()
send Builder
Builder.flush)
Maybe ByteString
mbs <- BuilderFinish
blazeFinish
case Maybe ByteString
mbs of
Maybe ByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
bs -> Inflate -> ByteString -> IO Popper
Z.feedInflate Inflate
inflate ByteString
bs IO Popper -> (Popper -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Popper -> IO ()
goZlibPopper
Inflate -> BuilderPopper
Z.finishInflate Inflate
inflate BuilderPopper -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Builder -> IO ()
sendInner (Builder -> IO ())
-> (ByteString -> Builder) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString
toInsert :: S.ByteString
toInsert :: ByteString
toInsert = ByteString
"<script>setInterval(function(){var x;if(window.XMLHttpRequest){x=new XMLHttpRequest();}else{x=new ActiveXObject(\"Microsoft.XMLHTTP\");}x.open(\"GET\",\"/_ping?\" + (new Date()).getTime(),true);x.send();},60000)</script>"
addInsideHead :: (Builder -> IO ())
-> IO ()
-> StreamingBody
-> IO ()
addInsideHead :: (Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
addInsideHead Builder -> IO ()
sendInner IO ()
flushInner StreamingBody
streamingBody = do
(BuilderRecv
blazeRecv, BuilderFinish
blazeFinish) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
newBuilderRecv BufferAllocStrategy
defaultStrategy
IORef (Maybe (ByteString, ByteString))
ref <- Maybe (ByteString, ByteString)
-> IO (IORef (Maybe (ByteString, ByteString)))
forall a. a -> IO (IORef a)
newIORef (Maybe (ByteString, ByteString)
-> IO (IORef (Maybe (ByteString, ByteString))))
-> Maybe (ByteString, ByteString)
-> IO (IORef (Maybe (ByteString, ByteString)))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
S.empty, ByteString
whole)
StreamingBody
streamingBody (BuilderRecv
-> IORef (Maybe (ByteString, ByteString)) -> Builder -> IO ()
forall {t}.
(t -> IO BuilderPopper)
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref) (BuilderRecv -> IORef (Maybe (ByteString, ByteString)) -> IO ()
flush BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref)
Maybe (ByteString, ByteString)
state <- IORef (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString))
forall a. IORef a -> IO a
readIORef IORef (Maybe (ByteString, ByteString))
ref
Maybe ByteString
mbs <- BuilderFinish
blazeFinish
Maybe (ByteString, ByteString)
held <- case Maybe ByteString
mbs of
Maybe ByteString
Nothing -> Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, ByteString)
state
Just ByteString
bs -> Maybe (ByteString, ByteString)
-> ByteString -> IO (Maybe (ByteString, ByteString))
push Maybe (ByteString, ByteString)
state ByteString
bs
case Maybe (ByteString, ByteString)
state of
Maybe (ByteString, ByteString)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (ByteString
held, ByteString
_) -> Builder -> IO ()
sendInner (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
where
whole :: ByteString
whole = ByteString
"<head>"
flush :: BuilderRecv -> IORef (Maybe (ByteString, ByteString)) -> IO ()
flush BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref = BuilderRecv
-> IORef (Maybe (ByteString, ByteString)) -> Builder -> IO ()
forall {t}.
(t -> IO BuilderPopper)
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref Builder
Builder.flush
inner :: (t -> IO BuilderPopper)
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner t -> IO BuilderPopper
blazeRecv IORef (Maybe (ByteString, ByteString))
ref t
builder = do
Maybe (ByteString, ByteString)
state0 <- IORef (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString))
forall a. IORef a -> IO a
readIORef IORef (Maybe (ByteString, ByteString))
ref
BuilderPopper
popper <- t -> IO BuilderPopper
blazeRecv t
builder
let loop :: Maybe (ByteString, ByteString) -> IO ()
loop Maybe (ByteString, ByteString)
state = do
ByteString
bs <- BuilderPopper
popper
if ByteString -> Bool
S.null ByteString
bs
then IORef (Maybe (ByteString, ByteString))
-> Maybe (ByteString, ByteString) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (ByteString, ByteString))
ref Maybe (ByteString, ByteString)
state
else Maybe (ByteString, ByteString)
-> ByteString -> IO (Maybe (ByteString, ByteString))
push Maybe (ByteString, ByteString)
state ByteString
bs IO (Maybe (ByteString, ByteString))
-> (Maybe (ByteString, ByteString) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (ByteString, ByteString) -> IO ()
loop
Maybe (ByteString, ByteString) -> IO ()
loop Maybe (ByteString, ByteString)
state0
push :: Maybe (ByteString, ByteString)
-> ByteString -> IO (Maybe (ByteString, ByteString))
push Maybe (ByteString, ByteString)
Nothing ByteString
x = Builder -> IO ()
sendInner (ByteString -> Builder
byteString ByteString
x) IO ()
-> IO (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
push (Just (ByteString
held, ByteString
atFront)) ByteString
x
| ByteString
atFront ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
x = do
let y :: ByteString
y = Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
atFront) ByteString
x
Builder -> IO ()
sendInner (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
atFront
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
y
Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
| ByteString
whole ByteString -> ByteString -> Bool
`S.isInfixOf` ByteString
x = do
let (ByteString
before, ByteString
rest) = ByteString -> ByteString -> (ByteString, ByteString)
S.breakSubstring ByteString
whole ByteString
x
let after :: ByteString
after = Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
whole) ByteString
rest
Builder -> IO ()
sendInner (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
before
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
whole
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
after
Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
| ByteString
x ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
atFront = do
let held' :: ByteString
held' = ByteString
held ByteString -> ByteString -> ByteString
`S.append` ByteString
x
atFront' :: ByteString
atFront' = Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
x) ByteString
atFront
Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString)))
-> Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
held', ByteString
atFront')
| Bool
otherwise = do
let (ByteString
held', ByteString
atFront', ByteString
x') = ByteString -> ByteString -> (ByteString, ByteString, ByteString)
getOverlap ByteString
whole ByteString
x
Builder -> IO ()
sendInner (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
x'
Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString)))
-> Maybe (ByteString, ByteString)
-> IO (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
held', ByteString
atFront')
getOverlap :: S.ByteString -> S.ByteString -> (S.ByteString, S.ByteString, S.ByteString)
getOverlap :: ByteString -> ByteString -> (ByteString, ByteString, ByteString)
getOverlap ByteString
whole ByteString
x =
ByteString -> (ByteString, ByteString, ByteString)
go ByteString
whole
where
go :: ByteString -> (ByteString, ByteString, ByteString)
go ByteString
piece
| ByteString -> Bool
S.null ByteString
piece = (ByteString
"", ByteString
whole, ByteString
x)
| ByteString
piece ByteString -> ByteString -> Bool
`S.isSuffixOf` ByteString
x =
let x' :: ByteString
x' = Int -> ByteString -> ByteString
S.take (ByteString -> Int
S.length ByteString
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
S.length ByteString
piece) ByteString
x
atFront :: ByteString
atFront = Int -> ByteString -> ByteString
S.drop (ByteString -> Int
S.length ByteString
piece) ByteString
whole
in (ByteString
piece, ByteString
atFront, ByteString
x')
| Bool
otherwise = ByteString -> (ByteString, ByteString, ByteString)
go (ByteString -> (ByteString, ByteString, ByteString))
-> ByteString -> (ByteString, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init ByteString
piece
fixHeaders :: ([Header] -> [Header])
-> [Header]
-> (Bool, [Header])
ResponseHeaders -> ResponseHeaders
front [] = (Bool
False, ResponseHeaders -> ResponseHeaders
front [])
fixHeaders ResponseHeaders -> ResponseHeaders
front ((HeaderName
"content-encoding", ByteString
"gzip"):ResponseHeaders
rest) = (Bool
True, ResponseHeaders -> ResponseHeaders
front ResponseHeaders
rest)
fixHeaders ResponseHeaders -> ResponseHeaders
front ((HeaderName, ByteString)
x:ResponseHeaders
xs) = (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> (Bool, ResponseHeaders)
fixHeaders (ResponseHeaders -> ResponseHeaders
front (ResponseHeaders -> ResponseHeaders)
-> (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders
-> ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) (HeaderName, ByteString)
x) ResponseHeaders
xs
#if WINDOWS
foreign import ccall "launch"
launch' :: CString -> IO ()
#endif
launch :: String -> IO ()
#if WINDOWS
launch url = withCString url launch'
#else
launch :: [Char] -> IO ()
launch [Char]
url = IO () -> IO ThreadId
forkIO ([Char] -> [[Char]] -> IO ExitCode
rawSystem
#if MAC
"open"
#else
[Char]
"xdg-open"
#endif
[[Char]
url] IO ExitCode -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IO ThreadId -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
run :: Application -> IO ()
run :: Application -> IO ()
run = [Char] -> Application -> IO ()
runUrl [Char]
""
runUrl :: String -> Application -> IO ()
runUrl :: [Char] -> Application -> IO ()
runUrl = Int -> [Char] -> Application -> IO ()
runUrlPort Int
4587
runUrlPort :: Int -> String -> Application -> IO ()
runUrlPort :: Int -> [Char] -> Application -> IO ()
runUrlPort = [Char] -> Int -> [Char] -> Application -> IO ()
runHostPortUrl [Char]
"*4"
runHostPortUrl :: String -> Int -> String -> Application -> IO ()
runHostPortUrl :: [Char] -> Int -> [Char] -> Application -> IO ()
runHostPortUrl [Char]
host Int
port [Char]
url Application
app = [Char] -> Int -> [Char] -> Application -> IO ()
runHostPortFullUrl [Char]
host Int
port ([Char]
"http://127.0.0.1:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
url) Application
app
runHostPortFullUrl :: String -> Int -> String -> Application -> IO ()
runHostPortFullUrl :: [Char] -> Int -> [Char] -> Application -> IO ()
runHostPortFullUrl [Char]
host Int
port [Char]
url Application
app = do
MVar ()
ready <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
IORef Bool
active <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
let settings :: Settings
settings =
Int -> Settings -> Settings
Warp.setPort Int
port (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
(Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException (\Maybe Request
_ SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
HostPreference -> Settings -> Settings
Warp.setHost ([Char] -> HostPreference
forall a. IsString a => [Char] -> a
fromString [Char]
host) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
IO () -> Settings -> Settings
Warp.setBeforeMainLoop (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
ready ()) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
Settings
Warp.defaultSettings
(Either () () -> ()) -> IO (Either () ()) -> IO ()
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((() -> ()) -> (() -> ()) -> Either () () -> ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either () -> ()
forall a. a -> a
id () -> ()
forall a. a -> a
id) (IO (Either () ()) -> IO ()) -> IO (Either () ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO (Either () ())
forall a b. IO a -> IO b -> IO (Either a b)
race
(Settings -> Application -> IO ()
Warp.runSettings Settings
settings (IORef Bool -> Middleware
ping IORef Bool
active Application
app))
(MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
ready IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
launch [Char]
url IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> IO ()
loop IORef Bool
active)
loop :: IORef Bool -> IO ()
loop :: IORef Bool -> IO ()
loop IORef Bool
active = do
let seconds :: Int
seconds = Int
120
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
seconds
Bool
b <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
active
if Bool
b
then IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
active Bool
False IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> IO ()
loop IORef Bool
active
else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()