persistence api

1 files changed, 43 insertions, 0 deletions

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