Base.hs.template 3.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110
  1. -- vim: ft=haskell
  2. {-# LANGUAGE RecordWildCards #-}
  3. {-# LANGUAGE OverloadedStrings #-}
  4. module $module_path$.Base where
  5. import Data.Word (Word32)
  6. import Data.Map.Strict (Map)
  7. import qualified Data.Map.Strict as Map
  8. import Control.Applicative ((<|>))
  9. import Control.Concurrent (forkIO)
  10. import Control.Concurrent.STM
  11. (atomically,STM,TVar,newTVar,writeTVar,readTVar
  12. ,TQueue,readTQueue,writeTQueue
  13. ,TMVar,newEmptyTMVarIO,takeTMVar,putTMVar,newTVarIO
  14. ,modifyTVar)
  15. import Control.Monad (forever)
  16. import Snap.Core (Snap)
  17. import qualified Snap.Http.Server as HTTP
  18. import Snap.Util.FileServe (serveDirectory)
  19. data Config = Config { cfgPort :: !Int
  20. -- ^ The port to run on
  21. , cfgStaticDir :: Maybe FilePath
  22. -- ^ Content to be served off of the root, relative to
  23. -- the directory that the server was started in
  24. } deriving (Show)
  25. -- | A default @Config@ value that will produce a server that runs on port 8080,
  26. -- and serves no static content.
  27. defaultConfig :: Config
  28. defaultConfig = Config { cfgPort = 8080, cfgStaticDir = Nothing }
  29. -- | Spawn a snap server, and run the given RPC action.
  30. runServer :: Config -> Snap () -> IO ()
  31. runServer Config { .. } serveRpc =
  32. do let snapCfg :: HTTP.Config Snap ()
  33. snapCfg = HTTP.setPort cfgPort HTTP.defaultConfig
  34. HTTP.simpleHttpServe snapCfg body
  35. where
  36. body = case cfgStaticDir of
  37. Just path -> serveDirectory path <|> serveRpc
  38. Nothing -> serveRpc
  39. data Request req resp = ReadRequest req (resp -> IO ())
  40. | WriteRequest req
  41. -- Sample Variables ------------------------------------------------------------
  42. -- | A TVar that blocks when it's empty, but allows writes even when it's full.
  43. newtype TSampleVar a = TSampleVar (TVar (Maybe a))
  44. newTSampleVar :: STM (TSampleVar a)
  45. newTSampleVar = TSampleVar `fmap` newTVar Nothing
  46. newTSampleVarIO :: IO (TSampleVar a)
  47. newTSampleVarIO = atomically (TSampleVar `fmap` newTVar Nothing)
  48. writeTSampleVar :: TSampleVar a -> a -> STM ()
  49. writeTSampleVar (TSampleVar tv) a = writeTVar tv (Just a)
  50. readTSampleVar :: TSampleVar a -> STM (Maybe a)
  51. readTSampleVar (TSampleVar tv) = readTVar tv
  52. -- Response Handling -----------------------------------------------------------
  53. data Conn req resp = Conn { connRequests :: TQueue req
  54. , connWaiting :: TVar (Map Word32 (TMVar resp))
  55. , connSeqNum :: TVar Word32
  56. }
  57. -- | Fork a handler thread that will apply handlers to incoming messages. If
  58. -- the handler queue is empty when a response arrives, the response is dropped.
  59. newConn :: TQueue req -> TQueue resp -> (resp -> Word32) -> IO (Conn req resp)
  60. newConn connRequests connResps toSeqNum =
  61. do connWaiting <- newTVarIO Map.empty
  62. connSeqNum <- newTVarIO 0
  63. _ <- forkIO (forever
  64. (do resp <- atomically (readTQueue connResps)
  65. let snum = toSeqNum resp
  66. mb <- atomically (do
  67. m <- readTVar connWaiting
  68. let (mb, m') = Map.updateLookupWithKey (\\_ _ -> Nothing) snum m
  69. writeTVar connWaiting m'
  70. return mb)
  71. case mb of
  72. Just var -> atomically (putTMVar var resp)
  73. Nothing -> return ()))
  74. return Conn { .. }
  75. -- | Send a request, and block until a response is received.
  76. sendRequest :: Conn req resp -> (Word32 -> req) -> IO resp
  77. sendRequest Conn { .. } req =
  78. do var <- newEmptyTMVarIO
  79. atomically (do snum <- readTVar connSeqNum
  80. writeTVar connSeqNum (snum + 1)
  81. modifyTVar connWaiting (Map.insert snum var)
  82. writeTQueue connRequests (req snum))
  83. atomically (takeTMVar var)