routing

8 files changed, 160 insertions, 40 deletions

diff --git a/cgi/index.hs b/cgi/index.hs
deleted file mode 100644
index c01e79d..0000000
--- a/cgi/index.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-import Settlr.Storage
-import Network.CGI (runCGI, handleErrors, CGIResult, CGI, outputFPS)
-import Text.Blaze.Html5 (Html, (!))
-import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html5.Attributes as A
-import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
-
-page :: Html
-page = H.docTypeHtml $ do
-         H.head $ do
-           H.title "Test"
-           H.meta ! A.charset "utf-8"
-         H.body $ do
-           H.p "Hello, world!"
-
-cgiMain :: CGI CGIResult
-cgiMain = outputFPS $ renderHtml page
-
-main :: IO ()
-main = runCGI (handleErrors cgiMain)
diff --git a/settlr.cabal b/settlr.cabal
index 29c28b1..4bfdc09 100644
--- a/settlr.cabal
+++ b/settlr.cabal
@@ -7,27 +7,20 @@ build-type:         Simple
 common warnings
   ghc-options: -Wall
 
-common script
+executable settlr.cgi
   import:           warnings
-  hs-source-dirs:   cgi
+  main-is:          Main.hs
+  hs-source-dirs:   src
   build-depends:    base ^>=4.20.2.0,
-                    settlr,
                     bytestring,
+                    mtl,
+                    text,
+                    exceptions,
                     cgi,
                     blaze-html
   default-language: Haskell2010
-
-
-library
-  import:           warnings
-  exposed-modules:  Settlr.Storage
-  hs-source-dirs:   lib
-  build-depends:    base ^>=4.20.2.0,
-                    bytestring,
-                    cgi,
-                    blaze-html
-  default-language: Haskell2010
-
-executable index.cgi
-  import:  script
-  main-is: index.hs
+  other-modules:    Settlr.Storage,
+                    Settlr.Config,
+                    Settlr.Routes,
+                    Settlr.Views.ErrorNotFound,
+                    Settlr.Views.Home
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/lib/Settlr/Storage.hs b/src/Settlr/Storage.hs
index d646134..d646134 100644
--- a/lib/Settlr/Storage.hs
+++ b/src/Settlr/Storage.hs
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!"