gidl/support/rpc/Base.hs.template

-- vim: ft=haskell

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

module $module_path$.Base where

import           Data.Word (Word32)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Control.Concurrent (forkIO)
import           Control.Concurrent.STM
                     (atomically,STM,TVar,newTVar,writeTVar,readTVar
                     ,TQueue,readTQueue,writeTQueue
                     ,TMVar,newEmptyTMVarIO,takeTMVar,putTMVar,newTVarIO
                     ,modifyTVar)
import           Control.Monad (forever)
import           Snap.Core (Snap,route)
import qualified Snap.Http.Server as HTTP
import           Snap.Util.FileServe (serveDirectory)

data Config = Config { cfgPort :: !Int
                       -- ^ The port to run on

                     , cfgStaticDir :: Maybe FilePath
                       -- ^ Content to be served off of the root, relative to
                       -- the directory that the server was started in

                     } deriving (Show)

-- | A default @Config@ value that will produce a server that runs on port 8080,
-- and serves no static content.
defaultConfig :: Config
defaultConfig  = Config { cfgPort = 8080, cfgStaticDir = Nothing }


-- | Spawn a snap server, and run the given RPC action.
runServer :: Config -> Snap () -> IO ()
runServer Config { .. } serveRpc =
  do let snapCfg :: HTTP.Config Snap ()
         snapCfg  = HTTP.setPort cfgPort HTTP.defaultConfig
     HTTP.simpleHttpServe snapCfg body

  where

  body =
    do serveRpc

       case cfgStaticDir of
         Just path -> route [ ("", serveDirectory path) ]
         Nothing   -> return ()


data Request req resp = ReadRequest req (resp -> IO ())
                      | WriteRequest req


-- Sample Variables ------------------------------------------------------------

-- | A TVar that blocks when it's empty, but allows writes even when it's full.
newtype TSampleVar a = TSampleVar (TVar (Maybe a))

newTSampleVar :: STM (TSampleVar a)
newTSampleVar  = TSampleVar `fmap` newTVar Nothing

newTSampleVarIO :: IO (TSampleVar a)
newTSampleVarIO  = atomically (TSampleVar `fmap` newTVar Nothing)

writeTSampleVar :: TSampleVar a -> a -> STM ()
writeTSampleVar (TSampleVar tv) a = writeTVar tv (Just a)

readTSampleVar :: TSampleVar a -> STM (Maybe a)
readTSampleVar (TSampleVar tv) = readTVar tv

-- Response Handling -----------------------------------------------------------

data Conn req resp = Conn { connRequests :: TQueue req
                          , connWaiting  :: TVar (Map Word32 (TMVar resp))
                          , connSeqNum   :: TVar Word32
                          }


-- | Fork a handler thread that will apply handlers to incoming messages.  If
-- the handler queue is empty when a response arrives, the response is dropped.
newConn :: TQueue req -> TQueue resp -> (resp -> Word32) -> IO (Conn req resp)
newConn connRequests connResps toSeqNum =
  do connWaiting <- newTVarIO Map.empty
     connSeqNum  <- newTVarIO 0

     _ <- forkIO (forever
        (do resp <- atomically (readTQueue connResps)
            let snum = toSeqNum resp
            mb   <- atomically (do
                     m <- readTVar connWaiting
                     let (mb, m') = Map.updateLookupWithKey (\\_ _ -> Nothing) snum m
                     writeTVar connWaiting m'
                     return mb)
            case mb of
              Just var -> atomically (putTMVar var resp)
              Nothing  -> return ()))

     return Conn { .. }


-- | Send a request, and block until a response is received.
sendRequest :: Conn req resp -> (Word32 -> req) -> IO resp
sendRequest Conn { .. } req =
  do var <- newEmptyTMVarIO

     atomically (do snum <- readTVar connSeqNum
                    writeTVar connSeqNum (snum + 1)
                    modifyTVar connWaiting (Map.insert snum var)
                    writeTQueue connRequests (req snum))

     atomically (takeTMVar var)