45 lines
1.6 KiB
Haskell
45 lines
1.6 KiB
Haskell
{-# 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
|