gidl/support/rpc/Base.hs.template

-- vim: ft=haskell

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

module $module_path$.Base where

import           Control.Concurrent.STM
                     (atomically,STM,retry,TVar,newTVar,writeTVar,readTVar)
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