{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

{- | Live coding backend to the [@warp@](https://hackage.haskell.org/package/warp) server.

If you write a cell that consumes 'Request's and produces 'Response's,
you can use the functions here that run this cell as a @warp@ application.
-}
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
    { 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
    }

{- | 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 :: 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 -- Prevent too much CPU load
      forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. Maybe a
Nothing

-- | A simple live-codable web application is a cell that consumes HTTP 'Request's and emits 'Response's for each.
type LiveWebApp = Cell IO Request Response

{- | Like 'runWarpC', but don't consume additional input or produce additional output.

Suitable for a main program, for example like this:

@
mainCell :: Cell IO Request Response
mainCell = undefined

liveProgram :: LiveProgram (HandlingStateT IO)
liveProgram = liveCell mainCell

main :: IO ()
main = liveMain liveProgram
@
-}
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 ())