gidl/support/rpc/Base.hs.template

-- vim: ft=haskell

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

module $module_path$.Base where

import           Control.Concurrent (forkIO)
import           Control.Concurrent.STM
                     (atomically,STM,retry,TVar,newTVar,writeTVar,readTVar
                     ,TQueue,readTQueue,writeTQueue,newTQueueIO,tryReadTQueue
                     ,TMVar,newEmptyTMVarIO,takeTMVar,putTMVar)
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 a
readTSampleVar (TSampleVar tv) =
  do mb <- readTVar tv
     case mb of
       Just a  -> return a
       Nothing -> retry


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

data Conn req resp = Conn { connRequests :: TQueue req
                          , connWaiting  :: TQueue (TMVar resp)
                          }


-- | 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 -> IO (Conn req resp)
newConn connRequests connResps =
  do connWaiting <- newTQueueIO

     _ <- forkIO (forever
        (do resp <- atomically (readTQueue connResps)
            mb   <- atomically (tryReadTQueue connWaiting)
            case mb of
              Just var -> atomically (putTMVar var resp)
              Nothing  -> return ()))

     return Conn { .. }


-- | Send a request that doesn't expect a response.
sendRequest_ :: Conn req resp -> req -> IO ()
sendRequest_ Conn { .. } req =
  atomically (writeTQueue connRequests req)


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

     atomically (do writeTQueue connWaiting var
                    writeTQueue connRequests req)

     atomically (takeTMVar var)