{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module LiveCoding.Warp (
runWarpC,
runWarpC_,
module X,
) where
import Control.Concurrent
import Control.Monad.IO.Class
import Network.HTTP.Types as X
import Network.Wai as X
import Network.Wai.Handler.Warp
import LiveCoding
data WaiHandle = WaiHandle
{ WaiHandle -> MVar Request
requestVar :: MVar Request
, WaiHandle -> MVar Response
responseVar :: MVar Response
, WaiHandle -> ThreadId
appThread :: ThreadId
}
waiHandle :: Port -> Handle IO WaiHandle
waiHandle :: Port -> Handle IO WaiHandle
waiHandle Port
port =
Handle
{ create :: IO WaiHandle
create = do
MVar Request
requestVar <- forall a. IO (MVar a)
newEmptyMVar
MVar Response
responseVar <- forall a. IO (MVar a)
newEmptyMVar
let app :: Request -> (Response -> IO b) -> IO b
app Request
request Response -> IO b
respond = do
forall a. MVar a -> a -> IO ()
putMVar MVar Request
requestVar Request
request
Response
response <- forall a. MVar a -> IO a
takeMVar MVar Response
responseVar
Response -> IO b
respond Response
response
ThreadId
appThread <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Port -> Application -> IO ()
run Port
port forall {b}. Request -> (Response -> IO b) -> IO b
app
forall (m :: * -> *) a. Monad m => a -> m a
return WaiHandle {ThreadId
MVar Request
MVar Response
appThread :: ThreadId
responseVar :: MVar Response
requestVar :: MVar Request
appThread :: ThreadId
responseVar :: MVar Response
requestVar :: MVar Request
..}
, destroy :: WaiHandle -> IO ()
destroy = \WaiHandle {ThreadId
MVar Request
MVar Response
appThread :: ThreadId
responseVar :: MVar Response
requestVar :: MVar Request
appThread :: WaiHandle -> ThreadId
responseVar :: WaiHandle -> MVar Response
requestVar :: WaiHandle -> MVar Request
..} -> ThreadId -> IO ()
killThread ThreadId
appThread
}
runWarpC ::
Port ->
Cell IO (a, Request) (b, Response) ->
Cell (HandlingStateT IO) a (Maybe b)
runWarpC :: forall a b.
Port
-> Cell IO (a, Request) (b, Response)
-> Cell (HandlingStateT IO) a (Maybe b)
runWarpC Port
port Cell IO (a, Request) (b, Response)
cell = proc a
a -> do
WaiHandle {ThreadId
MVar Request
MVar Response
appThread :: ThreadId
responseVar :: MVar Response
requestVar :: MVar Request
appThread :: WaiHandle -> ThreadId
responseVar :: WaiHandle -> MVar Response
requestVar :: WaiHandle -> MVar Request
..} <- forall h (m :: * -> *) arbitrary.
(Typeable h, Monad m) =>
Handle m h -> Cell (HandlingStateT m) arbitrary h
handling forall a b. (a -> b) -> a -> b
$ Port -> Handle IO WaiHandle
waiHandle Port
port -< ()
Maybe Request
requestMaybe <- forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO (Maybe a)
tryTakeMVar -< MVar Request
requestVar
case Maybe Request
requestMaybe of
Just Request
request -> do
(b
b, Response
response) <- forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell Cell IO (a, Request) (b, Response)
cell -< (a
a, Request
request)
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. MVar a -> a -> IO ()
putMVar -< (MVar Response
responseVar, Response
response)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. a -> Maybe a
Just b
b
Maybe Request
Nothing -> do
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> IO ()
threadDelay -< Port
1000
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. Maybe a
Nothing
type LiveWebApp = Cell IO Request Response
runWarpC_ ::
Port ->
LiveWebApp ->
Cell (HandlingStateT IO) () ()
runWarpC_ :: Port -> LiveWebApp -> Cell (HandlingStateT IO) () ()
runWarpC_ Port
port LiveWebApp
cell = forall a b.
Port
-> Cell IO (a, Request) (b, Response)
-> Cell (HandlingStateT IO) a (Maybe b)
runWarpC Port
port (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a, b) -> b
snd forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LiveWebApp
cell forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((),)) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b. a -> b -> a
const ())