persistence api

7 files changed, 140 insertions, 23 deletions

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