{-# 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 forall a. Eq a => a -> a -> Bool
== [Text
"_ping"] = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
active Bool
True
Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [] ByteString
""
| Bool
otherwise = Application
app Request
req forall a b. (a -> b) -> a -> b
$ \Response
res -> do
let isHtml :: [(a, ByteString)] -> Bool
isHtml [(a, ByteString)]
hs =
case 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 forall {a}. (Eq a, IsString a) => [(a, ByteString)] -> Bool
isHtml 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) = forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
res
(Bool
isEnc, ResponseHeaders
headers') = (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> (Bool, ResponseHeaders)
fixHeaders forall a. a -> a
id ResponseHeaders
hs
headers'' :: ResponseHeaders
headers'' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
x, ByteString
_) -> HeaderName
x forall a. Eq a => a -> a -> Bool
/= HeaderName
"content-length") ResponseHeaders
headers'
forall {a}. (StreamingBody -> IO a) -> IO a
withBody forall a b. (a -> b) -> a -> b
$ \StreamingBody
body ->
Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
s ResponseHeaders
headers'' forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush ->
(Builder -> IO ()) -> IO () -> StreamingBody -> IO ()
addInsideHead Builder -> IO ()
sendChunk IO ()
flush 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 forall a b. (a -> b) -> a -> b
$ Int -> WindowBits
Z.WindowBits Int
31
let send :: Builder -> IO ()
send Builder
builder = BuilderRecv
blazeRecv Builder
builder forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ByteString -> IO ()
goBuilderPopper
goBuilderPopper :: IO ByteString -> IO ()
goBuilderPopper IO ByteString
popper = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
ByteString
bs <- IO ByteString
popper
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
Inflate -> ByteString -> IO Popper
Z.feedInflate Inflate
inflate ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Popper -> IO ()
goZlibPopper
IO ()
loop
goZlibPopper :: Popper -> IO ()
goZlibPopper Popper
popper = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
PopperRes
res <- Popper
popper
case PopperRes
res of
PopperRes
Z.PRDone -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Z.PRNext ByteString
bs -> do
Builder -> IO ()
sendInner forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs
IO ()
loop
Z.PRError ZlibException
e -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
bs -> Inflate -> ByteString -> IO Popper
Z.feedInflate Inflate
inflate ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Popper -> IO ()
goZlibPopper
Inflate -> IO ByteString
Z.finishInflate Inflate
inflate forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Builder -> IO ()
sendInner 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 <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ByteString
S.empty, ByteString
whole)
StreamingBody
streamingBody (forall {t}.
(t -> IO (IO ByteString))
-> 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 <- 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 -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (ByteString
held, ByteString
_) -> Builder -> IO ()
sendInner forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held 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 = forall {t}.
(t -> IO (IO ByteString))
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner BuilderRecv
blazeRecv IORef (Maybe (ByteString, ByteString))
ref Builder
Builder.flush
inner :: (t -> IO (IO ByteString))
-> IORef (Maybe (ByteString, ByteString)) -> t -> IO ()
inner t -> IO (IO ByteString)
blazeRecv IORef (Maybe (ByteString, ByteString))
ref t
builder = do
Maybe (ByteString, ByteString)
state0 <- forall a. IORef a -> IO a
readIORef IORef (Maybe (ByteString, ByteString))
ref
IO ByteString
popper <- t -> IO (IO ByteString)
blazeRecv t
builder
let loop :: Maybe (ByteString, ByteString) -> IO ()
loop Maybe (ByteString, ByteString)
state = do
ByteString
bs <- IO ByteString
popper
if ByteString -> Bool
S.null ByteString
bs
then 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 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) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
atFront
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
y
forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
before
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
whole
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
toInsert
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
after
forall (m :: * -> *) a. Monad m => a -> m a
return 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
held forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
x'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 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 forall a b. (a -> b) -> a -> b
$ HasCallStack => 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 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] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
port forall a. [a] -> [a] -> [a]
++ [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 <- forall a. IO (MVar a)
newEmptyMVar
IORef Bool
active <- forall a. a -> IO (IORef a)
newIORef Bool
True
let settings :: Settings
settings =
Int -> Settings -> Settings
Warp.setPort Int
port forall a b. (a -> b) -> a -> b
$
(Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
Warp.setOnException (\Maybe Request
_ SomeException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a b. (a -> b) -> a -> b
$
HostPreference -> Settings -> Settings
Warp.setHost (forall a. IsString a => [Char] -> a
fromString [Char]
host) forall a b. (a -> b) -> a -> b
$
IO () -> Settings -> Settings
Warp.setBeforeMainLoop (forall a. MVar a -> a -> IO ()
putMVar MVar ()
ready ()) forall a b. (a -> b) -> a -> b
$
Settings
Warp.defaultSettings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ 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))
(forall a. MVar a -> IO a
takeMVar MVar ()
ready forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
launch [Char]
url 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 forall a b. (a -> b) -> a -> b
$ Int
1000000 forall a. Num a => a -> a -> a
* Int
seconds
Bool
b <- forall a. IORef a -> IO a
readIORef IORef Bool
active
if Bool
b
then forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
active Bool
False forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> IO ()
loop IORef Bool
active
else forall (m :: * -> *) a. Monad m => a -> m a
return ()