diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 20 | ||||
| -rw-r--r-- | src/Settlr/Config.hs | 54 | ||||
| -rw-r--r-- | src/Settlr/Routes.hs | 33 | ||||
| -rw-r--r-- | src/Settlr/Storage.hs | 2 | ||||
| -rw-r--r-- | src/Settlr/Views/ErrorNotFound.hs | 24 | ||||
| -rw-r--r-- | src/Settlr/Views/Home.hs | 18 |
6 files changed, 151 insertions, 0 deletions
diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..20da414 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +import Network.CGI (runCGI, handleErrors, CGIResult, CGI, outputFPS) +import Text.Blaze.Html.Renderer.Utf8 (renderHtml) +import Settlr.Config (withConfig) +import Settlr.Routes (loadRoute, Route(..)) +import Settlr.Views.ErrorNotFound (viewErrorNotFound) +import Settlr.Views.Home (viewHome) + +cgiMain :: CGI CGIResult +cgiMain = withConfig $ do + view <- loadRoute >>= \case + Nothing -> viewErrorNotFound + Just RouteHome -> viewHome + Just RouteNew -> viewErrorNotFound + outputFPS (renderHtml view) + +main :: IO () +main = runCGI (handleErrors cgiMain) diff --git a/src/Settlr/Config.hs b/src/Settlr/Config.hs new file mode 100644 index 0000000..1e2ff09 --- /dev/null +++ b/src/Settlr/Config.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +module Settlr.Config + ( ScriptM + , Config(..) + , ConfigException(..) + , loadConfig + , withConfig + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Network.CGI (getVarWithDefault, getVar, scriptName, CGIT, CGI) +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Reader (ReaderT(runReaderT)) +import Network.CGI.Monad (MonadCGI(..)) +import Control.Monad.Trans (lift) + +type ScriptM = ReaderT Config (CGIT IO) + +instance MonadCGI ScriptM where + cgiAddHeader x y = lift $ cgiAddHeader x y + cgiGet x = lift $ cgiGet x + +data Config = Config + { cfgCssPath :: !Text -- ^ $SETTLR_CSS_PATH, defaults to "/settlr.css" + , cfgScriptPath :: !Text -- ^ $SETTLR_SCRIPT_PATH, defaults to the CGI variable $SCRIPT_PATH or "/" + , cfgDataPath :: !Text -- ^ $SETTLR_DATA_PATH, required + } + +data ConfigException + = CfgDataPathNotSet + +instance Show ConfigException where + show CfgDataPathNotSet = "Server misconfiguration: Required environment variable SETTLR_DATA_PATH not set." + +instance Exception ConfigException + +loadConfig :: MonadCGI m => MonadThrow m => m Config +loadConfig = do cssPath <- getVarWithDefault "SETTLR_CSS_PATH" "/settlr.css" + scriptPath' <- scriptName + scriptPath <- getVarWithDefault "SETTLR_SCRIPT_PATH" scriptPath' + dataPath <- getVar "SETTLR_DATA_PATH" >>= \case + Nothing -> throwM CfgDataPathNotSet + Just x -> pure x + pure $ Config { cfgCssPath = T.pack cssPath + , cfgScriptPath = T.pack scriptPath + , cfgDataPath = T.pack dataPath + } + +withConfig :: ScriptM a -> CGI a +withConfig x = loadConfig >>= runReaderT x diff --git a/src/Settlr/Routes.hs b/src/Settlr/Routes.hs new file mode 100644 index 0000000..d5b0158 --- /dev/null +++ b/src/Settlr/Routes.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Settlr.Routes + ( Route(..) + , formatRoute + , loadRoute + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Control.Monad.Reader (MonadReader, asks) +import Settlr.Config (Config(..)) +import Data.Maybe (fromMaybe) +import Network.CGI (MonadCGI, pathInfo) + +data Route + = RouteHome + | RouteNew + +formatRoute :: MonadReader Config m => Route -> m Text +formatRoute route = do base <- asks cfgScriptPath + pure (fromMaybe base (T.stripSuffix "/" base) <> relative route) + where relative :: Route -> Text + relative RouteHome = "/" + relative RouteNew = "/new" + +loadRoute :: MonadCGI m => m (Maybe Route) +loadRoute = decode . filter (/= T.empty) . T.splitOn "/" . T.pack <$> pathInfo + where decode :: [Text] -> Maybe Route + decode [] = Just RouteHome + decode ["new"] = Just RouteNew + decode _ = Nothing diff --git a/src/Settlr/Storage.hs b/src/Settlr/Storage.hs new file mode 100644 index 0000000..d646134 --- /dev/null +++ b/src/Settlr/Storage.hs @@ -0,0 +1,2 @@ +module Settlr.Storage( + ) where diff --git a/src/Settlr/Views/ErrorNotFound.hs b/src/Settlr/Views/ErrorNotFound.hs new file mode 100644 index 0000000..d087c5e --- /dev/null +++ b/src/Settlr/Views/ErrorNotFound.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Settlr.Views.ErrorNotFound + ( viewErrorNotFound + ) where + +import Settlr.Config (ScriptM) +import Text.Blaze.Html5 (Html, (!), textValue) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Settlr.Routes (Route(..), formatRoute) +import Network.CGI (setStatus) + +viewErrorNotFound :: ScriptM Html +viewErrorNotFound = do setStatus 404 "Not Found" + homePath <- formatRoute RouteHome + pure $ H.docTypeHtml $ do + H.head $ do + H.title "Not Found" + H.meta ! A.charset "utf-8" + H.body $ do + H.h1 "Page Not Found" + H.p "The requested page could not be found" + H.a "Go back home" ! A.href (textValue homePath) diff --git a/src/Settlr/Views/Home.hs b/src/Settlr/Views/Home.hs new file mode 100644 index 0000000..14fedfd --- /dev/null +++ b/src/Settlr/Views/Home.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Settlr.Views.Home + ( viewHome + ) where + +import Settlr.Config (ScriptM) +import Text.Blaze.Html5 (Html, (!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +viewHome :: ScriptM Html +viewHome = pure $ H.docTypeHtml $ do + H.head $ do + H.title "Test" + H.meta ! A.charset "utf-8" + H.body $ do + H.p "Hello, world!" |