persistence api

10 files changed, 158 insertions, 31 deletions

diff --git a/settlr.cabal b/settlr.cabal
index 76dd534..d703a97 100644
--- a/settlr.cabal
+++ b/settlr.cabal
@@ -15,6 +15,7 @@ executable settlr.cgi
                     bytestring,
                     mtl,
                     text,
+                    containers,
                     exceptions,
                     cgi,
                     blaze-html
@@ -22,6 +23,8 @@ executable settlr.cgi
   other-modules:    Settlr.Storage,
                     Settlr.Config,
                     Settlr.Routes,
+                    Settlr.Scripts,
+                    Settlr.Cookies,
                     Settlr.Views.ErrorNotFound,
                     Settlr.Views.Home,
                     Settlr.UI.Page
diff --git a/src/Main.hs b/src/Main.hs
index 9fda84b..9f58327 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,18 +3,22 @@
 
 import Network.CGI (runCGI, handleErrors, outputFPS, setHeader)
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
-import Settlr.Config (withConfig, ScriptM)
+import Settlr.Config (loadConfig)
+import Settlr.Scripts (ScriptM, runScript)
 import Settlr.Routes (loadRoute, Route(..))
 import Settlr.Views.ErrorNotFound (viewErrorNotFound)
 import Settlr.Views.Home (viewHome)
 import Text.Blaze.Html5 (Html)
+import Network.CGI.Protocol (CGIResult)
 
-view :: Maybe Route -> ScriptM Html
-view (Just RouteHome) = viewHome
-view (Just RouteNew)  = viewErrorNotFound
-view Nothing          = viewErrorNotFound
+run :: Maybe Route -> ScriptM Html
+run (Just RouteHome) = viewHome
+run (Just RouteNew)  = viewErrorNotFound
+run Nothing          = viewErrorNotFound
+
+script :: ScriptM CGIResult
+script = do setHeader "Content-type" "text/html; charset=\"utf-8\""
+            loadRoute >>= run >>= outputFPS . renderHtml
 
 main :: IO ()
-main = runCGI $ handleErrors $ withConfig $ do
-         setHeader "Content-type" "text/html; charset=\"utf-8\""
-         loadRoute >>= view >>= outputFPS . renderHtml
+main = runCGI $ handleErrors $ (loadConfig >>= runScript script)
diff --git a/src/Settlr/Config.hs b/src/Settlr/Config.hs
index 1e2ff09..2987f8c 100644
--- a/src/Settlr/Config.hs
+++ b/src/Settlr/Config.hs
@@ -2,27 +2,17 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 module Settlr.Config
-  ( ScriptM
-  , Config(..)
+  ( Config(..)
   , ConfigException(..)
   , loadConfig
-  , withConfig
   ) where
 
 import Data.Text (Text)
 import qualified Data.Text as T
-import Network.CGI (getVarWithDefault, getVar, scriptName, CGIT, CGI)
+import Network.CGI (getVarWithDefault, getVar, scriptName)
 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"
@@ -49,6 +39,3 @@ loadConfig = do cssPath     <- getVarWithDefault "SETTLR_CSS_PATH" "/settlr.css"
                               , cfgScriptPath = T.pack scriptPath
                               , cfgDataPath   = T.pack dataPath
                               }
-
-withConfig :: ScriptM a -> CGI a
-withConfig x = loadConfig >>= runReaderT x
diff --git a/src/Settlr/Cookies.hs b/src/Settlr/Cookies.hs
new file mode 100644
index 0000000..56c645d
--- /dev/null
+++ b/src/Settlr/Cookies.hs
@@ -0,0 +1,26 @@
+module Settlr.Cookies
+  ( SavedGroup(..)
+  , getSavedGroups
+  , getSavedGroupSelf
+  , addGroup
+  , removeGroup
+  ) where
+import Settlr.Scripts (ScriptM)
+import Settlr.Storage (Group, Member)
+
+data SavedGroup = SavedGroup
+  { savGroupID :: !Group
+  , savSelf    :: !Member
+  }
+
+getSavedGroups :: ScriptM [SavedGroup]
+getSavedGroups = undefined
+
+getSavedGroupSelf :: Group -> ScriptM (Maybe Member)
+getSavedGroupSelf = undefined
+
+addGroup :: Group -> Member -> ScriptM ()
+addGroup = undefined
+
+removeGroup :: Group -> ScriptM ()
+removeGroup = undefined
diff --git a/src/Settlr/Scripts.hs b/src/Settlr/Scripts.hs
new file mode 100644
index 0000000..304c601
--- /dev/null
+++ b/src/Settlr/Scripts.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Settlr.Scripts
+  ( ScriptM
+  , runScript
+  , Toast(..)
+  , pushToast
+  , getToasts
+  ) where
+
+import Control.Monad.Reader (ReaderT, runReaderT)
+import Control.Monad.State (StateT, evalStateT, MonadState (get, put), gets)
+import Settlr.Config (Config)
+import Network.CGI (CGI, CGIT)
+import Network.CGI.Monad (MonadCGI(..))
+import Data.Text (Text)
+import Control.Monad.Trans (lift)
+
+newtype Toast = Toast Text
+
+-- Execution state in a script.
+data State = State
+  { stateToasts :: ![Toast] -- ^ Toast messages to display at the top of the page; collected during script execution.
+  }
+
+-- A script is an executable unit with a request config and a small state.
+type ScriptM = StateT State (ReaderT Config (CGIT IO))
+
+instance MonadCGI ScriptM where
+  cgiAddHeader x y = lift $ lift $ cgiAddHeader x y
+  cgiGet x = lift $ lift $ cgiGet x
+
+runScript :: ScriptM a -> Config -> CGI a
+runScript x = runReaderT (evalStateT x initialState)
+  where initialState = State { stateToasts = [] }
+
+pushToast :: Toast -> ScriptM ()
+pushToast toast = do state <- get
+                     put $ State { stateToasts = (toast : stateToasts state) }
+
+getToasts :: ScriptM [Toast]
+getToasts = gets stateToasts
diff --git a/src/Settlr/Storage.hs b/src/Settlr/Storage.hs
index d646134..53c29b7 100644
--- a/src/Settlr/Storage.hs
+++ b/src/Settlr/Storage.hs
@@ -1,2 +1,57 @@
-module Settlr.Storage(
+module Settlr.Storage
+  ( Group(..)
+  , Member(..)
+  , Money(..)
+  , Currency(..)
+  , GroupMetadata(..)
+  , getMetadata
+  , createGroup
+  , deleteGroup
+  , Expense(..)
+  , getExpenses
+  , getSaldo
+  , addExpense
   ) where
+
+import Data.Text (Text)
+import Data.Map (Map)
+
+-- Identifier of a group.
+newtype Group = Group Text
+
+-- Identifier of a group member.
+newtype Member = Member Text
+
+-- An amount of money in a particular currency (usually, the smallest unit for the currency).
+newtype Money = Money Int
+
+data Currency = CurrencyEUR | CurrencyUSD
+
+data GroupMetadata = GroupMetadata
+  { grpName     :: !Text
+  , grpMembers  :: ![Member]
+  , grpCurrency :: !Currency
+  }
+
+getMetadata :: Group -> IO GroupMetadata
+getMetadata = undefined
+
+createGroup :: GroupMetadata -> IO Group
+createGroup = undefined
+
+deleteGroup :: Group -> IO ()
+deleteGroup = undefined
+
+data Expense = Expense
+  { expCreditor :: !Member
+  , expDebtors  :: !(Map Member Money)
+  }
+
+getExpenses :: Group -> IO [Expense]
+getExpenses = undefined
+
+getSaldo :: Group -> Member -> IO Money
+getSaldo = undefined
+
+addExpense :: Group -> Expense -> IO ()
+addExpense = undefined
diff --git a/src/Settlr/UI/Page.hs b/src/Settlr/UI/Page.hs
index a3cd497..575b076 100644
--- a/src/Settlr/UI/Page.hs
+++ b/src/Settlr/UI/Page.hs
@@ -10,20 +10,26 @@ import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
 import Data.Text (Text)
 import Settlr.Config (Config(..))
-import Control.Monad.Reader (MonadReader, asks)
+import Settlr.Scripts (ScriptM, getToasts, Toast(..))
+import Control.Monad.Reader (asks)
+import Control.Monad (forM_)
 
 page
-  :: MonadReader Config m
-  => Text                 -- ^ the page title
-  -> Html                 -- ^ main content
-  -> m Html               -- ^ given the config, the rendered page (i.e., the entire html document)
+  :: Text         -- ^ the page title
+  -> Html         -- ^ main content
+  -> ScriptM Html -- ^ given the config, the rendered page (i.e., the entire html document)
 page title content = do
   cssPath <- asks cfgCssPath
+  toasts  <- getToasts
   pure $ H.docTypeHtml $ do
            H.head $ do
              H.meta ! A.charset "utf-8"
              H.title (text (title <> " | Settlr"))
              H.link ! A.rel "stylesheet" ! A.href (textValue cssPath)
            H.body $ do
+             H.ul $ do
+               forM_ toasts $ \(Toast msg) -> do
+                 H.li $ do
+                   H.span (text msg) ! A.class_ "toast"
              H.main $ do
                content
diff --git a/src/Settlr/Views/ErrorNotFound.hs b/src/Settlr/Views/ErrorNotFound.hs
index b8c0712..630a8a4 100644
--- a/src/Settlr/Views/ErrorNotFound.hs
+++ b/src/Settlr/Views/ErrorNotFound.hs
@@ -4,7 +4,7 @@ module Settlr.Views.ErrorNotFound
   ( viewErrorNotFound
   ) where
 
-import Settlr.Config (ScriptM)
+import Settlr.Scripts (ScriptM)
 import Settlr.UI.Page (page)
 import Text.Blaze.Html5 (Html, (!), textValue)
 import qualified Text.Blaze.Html5 as H
diff --git a/src/Settlr/Views/Home.hs b/src/Settlr/Views/Home.hs
index eb4aea5..cedc6b8 100644
--- a/src/Settlr/Views/Home.hs
+++ b/src/Settlr/Views/Home.hs
@@ -4,7 +4,7 @@ module Settlr.Views.Home
   ( viewHome
   ) where
 
-import Settlr.Config (ScriptM)
+import Settlr.Scripts (ScriptM)
 import Settlr.UI.Page (page)
 import Text.Blaze.Html5 (Html)
 import qualified Text.Blaze.Html5 as H
diff --git a/static/settlr.css b/static/settlr.css
index e69de29..43a9ee3 100644
--- a/static/settlr.css
+++ b/static/settlr.css
@@ -0,0 +1,3 @@
+h1 {
+  font-family: sans-serif;
+}