{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module LiveCoding.Warp
  ( runWarpC
  , runWarpC_
  , module X
  ) where

-- base
import Control.Concurrent
import Control.Monad.IO.Class

-- http-types
import Network.HTTP.Types as X

-- wai
import Network.Wai as X

-- warp
import Network.Wai.Handler.Warp

-- essence-of-live-coding
import LiveCoding

data WaiHandle = WaiHandle
  { WaiHandle -> MVar Request
requestVar  :: MVar Request
  , WaiHandle -> MVar Response
responseVar :: MVar Response
  , WaiHandle -> ThreadId
appThread   :: ThreadId
  }

-- I believe there is a bug here where a request is missed if the app blocks because the requestVar isn't emptied, or the response not filled.

waiHandle :: Port -> Handle IO WaiHandle
waiHandle :: Port -> Handle IO WaiHandle
waiHandle Port
port = Handle :: forall (m :: * -> *) h. m h -> (h -> m ()) -> Handle m h
Handle
  { create :: IO WaiHandle
create = do
      MVar Request
requestVar <- IO (MVar Request)
forall a. IO (MVar a)
newEmptyMVar
      MVar Response
responseVar <- IO (MVar Response)
forall a. IO (MVar a)
newEmptyMVar
      let app :: Request -> (Response -> IO b) -> IO b
app Request
request Response -> IO b
respond = do
              MVar Request -> Request -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Request
requestVar Request
request
              Response
response <- MVar Response -> IO Response
forall a. MVar a -> IO a
takeMVar MVar Response
responseVar
              Response -> IO b
respond Response
response
      ThreadId
appThread <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Port -> Application -> IO ()
run Port
port Application
forall b. Request -> (Response -> IO b) -> IO b
app
      WaiHandle -> IO WaiHandle
forall (m :: * -> *) a. Monad m => a -> m a
return WaiHandle :: MVar Request -> MVar Response -> ThreadId -> WaiHandle
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
  }

{- | Run a 'Cell' as a WARP application.

1. Starts a WARP application on the given port in a background thread
2. Waits until the next request arrives, outputting 'Nothing' in the meantime
3. Supplies the cell with the input and the current request
4. Serve the response and return the output
-}

runWarpC
  :: Port
  -> Cell IO (a, Request) (b, Response)
  -> Cell (HandlingStateT IO) a (Maybe b)
runWarpC :: 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
.. } <- Handle IO WaiHandle -> Cell (HandlingStateT IO) () WaiHandle
forall h (m :: * -> *) arbitrary.
(Typeable h, Monad m) =>
Handle m h -> Cell (HandlingStateT m) arbitrary h
handling (Handle IO WaiHandle -> Cell (HandlingStateT IO) () WaiHandle)
-> Handle IO WaiHandle -> Cell (HandlingStateT IO) () WaiHandle
forall a b. (a -> b) -> a -> b
$ Port -> Handle IO WaiHandle
waiHandle Port
port -< ()
  Maybe Request
requestMaybe <- (MVar Request -> HandlingStateT IO (Maybe Request))
-> Cell (HandlingStateT IO) (MVar Request) (Maybe Request)
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM ((MVar Request -> HandlingStateT IO (Maybe Request))
 -> Cell (HandlingStateT IO) (MVar Request) (Maybe Request))
-> (MVar Request -> HandlingStateT IO (Maybe Request))
-> Cell (HandlingStateT IO) (MVar Request) (Maybe Request)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Request) -> HandlingStateT IO (Maybe Request)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Request) -> HandlingStateT IO (Maybe Request))
-> (MVar Request -> IO (Maybe Request))
-> MVar Request
-> HandlingStateT IO (Maybe Request)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Request -> IO (Maybe Request)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar   -< MVar Request
requestVar
  case Maybe Request
requestMaybe of
    Just Request
request -> do
      (b
b, Response
response) <- Cell IO (a, Request) (b, Response)
-> Cell (HandlingStateT IO) (a, Request) (b, 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)
      ((MVar Response, Response) -> HandlingStateT IO ())
-> Cell (HandlingStateT IO) (MVar Response, Response) ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM (((MVar Response, Response) -> HandlingStateT IO ())
 -> Cell (HandlingStateT IO) (MVar Response, Response) ())
-> ((MVar Response, Response) -> HandlingStateT IO ())
-> Cell (HandlingStateT IO) (MVar Response, Response) ()
forall a b. (a -> b) -> a -> b
$ IO () -> HandlingStateT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlingStateT IO ())
-> ((MVar Response, Response) -> IO ())
-> (MVar Response, Response)
-> HandlingStateT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar Response -> Response -> IO ())
-> (MVar Response, Response) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry MVar Response -> Response -> IO ()
forall a. MVar a -> a -> IO ()
putMVar -< (MVar Response
responseVar, Response
response)
      Cell (HandlingStateT IO) (Maybe b) (Maybe b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA                         -< b -> Maybe b
forall a. a -> Maybe a
Just b
b
    Maybe Request
Nothing -> do
      (Port -> HandlingStateT IO ()) -> Cell (HandlingStateT IO) Port ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM ((Port -> HandlingStateT IO ())
 -> Cell (HandlingStateT IO) Port ())
-> (Port -> HandlingStateT IO ())
-> Cell (HandlingStateT IO) Port ()
forall a b. (a -> b) -> a -> b
$ IO () -> HandlingStateT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlingStateT IO ())
-> (Port -> IO ()) -> Port -> HandlingStateT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> IO ()
threadDelay     -< Port
1000 -- Prevent too much CPU load
      Cell (HandlingStateT IO) (Maybe b) (Maybe b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA                         -< Maybe b
forall a. Maybe a
Nothing

runWarpC_
  :: Port
  -> Cell IO Request Response
  -> Cell (HandlingStateT IO) () ()
runWarpC_ :: Port -> Cell IO Request Response -> Cell (HandlingStateT IO) () ()
runWarpC_ Port
port Cell IO Request Response
cell = Port
-> Cell IO ((), Request) ((), Response)
-> Cell (HandlingStateT IO) () (Maybe ())
forall a b.
Port
-> Cell IO (a, Request) (b, Response)
-> Cell (HandlingStateT IO) a (Maybe b)
runWarpC Port
port ((((), Request) -> Request) -> Cell IO ((), Request) Request
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((), Request) -> Request
forall a b. (a, b) -> b
snd Cell IO ((), Request) Request
-> Cell IO Request ((), Response)
-> Cell IO ((), Request) ((), Response)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Cell IO Request Response
cell Cell IO Request Response
-> Cell IO Response ((), Response)
-> Cell IO Request ((), Response)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Response -> ((), Response)) -> Cell IO Response ((), Response)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((), )) Cell (HandlingStateT IO) () (Maybe ())
-> Cell (HandlingStateT IO) (Maybe ()) ()
-> Cell (HandlingStateT IO) () ()
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe () -> ()) -> Cell (HandlingStateT IO) (Maybe ()) ()
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (() -> Maybe () -> ()
forall a b. a -> b -> a
const ())