initial commit

src/Server.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Server (
+  servePages
+) where
+
+import Control.Applicative ((<|>))
+import Network.Wai (Application, Response, responseLBS, Request (pathInfo))
+import Network.Wai.Handler.Warp (run)
+import qualified Network.HTTP.Types as H
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Text as T
+
+import TemplatePage (PageContext, PageTemplate, buildPage)
+
+import qualified Data.ByteString as BS
+import Data.ByteString (ByteString)
+import Control.Concurrent (MVar, readMVar, tryPutMVar)
+
+app :: Map String PageTemplate -> MVar PageContext -> MVar () -> Application
+app templates context updateNotify request respond = do
+   let path = T.unpack $ T.intercalate "/" $ filter (not . T.null) $ pathInfo request
+       slashPath = if path /= "" then '/' : path else path
+       indexPath = slashPath ++ "/index.html"
+       template = Map.lookup path templates <|> Map.lookup indexPath templates
+
+   putStrLn $ "Page requested: " ++ slashPath
+   context' <- readMVar context
+
+   -- Unblock pageview cache if waiting for a request.
+   _ <- tryPutMVar updateNotify ()
+
+   respond $ respMaybe $ buildPage context' <$> template
+
+respMaybe :: Maybe ByteString -> Response
+respMaybe Nothing = notFound
+respMaybe (Just text) = responseLBS H.status200 [("content-type", "text/html")] $ BS.fromStrict text
+
+notFound :: Response
+notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "404 - File not found"
+
+servePages :: Int -> Map String PageTemplate -> MVar PageContext -> MVar () -> IO ()
+servePages port templates context updateNotify = run port $ app templates context updateNotify