Session.lhs

> -- | Defines functions for state that can persist accross server requests
> module Frame.Session (
>  -- * Session management
>  startSession,
>  saveSession,
>  deleteSession,
>  withSession,
>  genSessionId,
>  -- * Session manipulation
>  getSessionField,
>  delSessionField,
>  copyToSession,
>  copyFromSession,
>  updateFlash,
>  getDelFlash,
>  flash
> ) where

> import Prelude hiding (lookup)
> import IO
> import Data.Map
> import qualified Data.Binary as B
> import Data.Binary.Get
> import qualified Data.ByteString.Lazy as L
> import System.Directory
> import System.Time

> import Frame.Router
> import Frame.View
> import Frame.Model (liftIO)
> import Frame.Types
> import Frame.State
> import Frame.Config
> import Frame.Utilities

> -- | Recovers a session from persistent storage
> startSession :: FrameRouter m => m Fields
> startSession = do
>               p <- asks sessionPath
>               i <- asks sessionId
>               e <- liftIO $ doesFileExist $ p ++ i
>               case e of
>                  True  -> do 
>                       f <- liftIO $ strictDecodeFile $ p ++ i
>                       let s = fromList f in do
>                        putSession s
>                        return s
>                  False -> return empty

> strictDecodeFile :: B.Binary a => FilePath -> IO a
> strictDecodeFile f = do
>        h  <- openFile f ReadMode
>        o <- L.hGetContents h
>        let !v = runGet (do v <- B.get
>                            return v) o
>        hClose h
>        return v

> -- | Saves a session to persistent storage
> saveSession :: FrameRouter m => m ()
> saveSession = do
>              s <- gets session
>              writeFields s
>              return ()

> writeFields :: FrameRouter m => Fields -> m ()
> writeFields s = do 
>              p <- asks sessionPath
>              i <- asks sessionId
>              liftIO $ B.encodeFile (p ++ i) $ toList s
>              return ()

> -- | Deletes a session from persistent storage
> deleteSession :: FrameRouter m => m ()
> deleteSession = do
>              putSession $ fromList []
>              p <- asks sessionPath
>              i <- asks sessionId
>              liftIO $ removeFile $ p ++ i
>              return ()

> -- | Get a field from the session by FieldName
> getSessionField :: FrameReader m 
>                 => FieldName             -- ^ The FieldName to get from the session
>                 -> m (Maybe WrapperType) -- ^ The session field (if found)
> getSessionField fn = do 
>                   s <- gets session
>                   return $ lookup fn s

> -- | Replaces the fields in the session
> putSession :: FrameState m => Fields -- ^ Fields to replace with
>                            -> m ()   -- ^ Nothing (but the modified state) is returned
> putSession s = do 
>                   v <- get
>                   put v {session=s}

> -- | Associate a set of value with a FieldName in the state
> putSessionField :: FrameState m => FieldName   -- ^ The FieldName being updated
>                                 -> WrapperType -- ^ The (wrapped) value to be assigned
>                                 -> m ()        -- ^ Nothing (but the modified state) is returned
> putSessionField fn s = do 
>                   ss <- gets session
>                   v <- get
>                   put v {session=insert fn s ss}

> -- | Deletes a specific field in the session by the given field name
> delSessionField :: FrameState m 
>                 => FieldName -- ^ FieldName to be deleted
>                 -> m ()
> delSessionField fn = do
>                    ss <- gets session
>                    v <- get
>                    put v {session=delete fn ss}

> -- | Copy a particular field to the session from the fields in the state
> copyToSession :: FrameState m => FieldName -- ^ The FieldName to be copied to the session
>                               -> m ()      -- ^ Nothing (but the modified state) is returned
> copyToSession fn = do 
>                   mf <- getField fn
>                   case mf of
>                      (Just f) -> putSessionField fn f
>                      Nothing  -> return ()

> -- | Copy a particular field to the session from the fields in the state
> copyFromSession :: (FrameState m, FrameConfig m)
>                 => FieldName -- ^ The FieldName to be copied from the session
>                 -> m ()      -- ^ Nothing (but the modified state) is returned
> copyFromSession fn = do 
>                   mf <- getSessionField fn
>                   case mf of
>                      (Just f) -> putField fn f
>                      Nothing  -> return ()

> -- | Overwrite a message to be flashed to the screen (persisting across requests)
> updateFlash :: FrameState m => String -- ^ Message to flash to the screen
>                             -> m ()   -- ^ Nothing (but the modified state) is returned 
> updateFlash s = do 
>                   ss <- gets session
>                   v <- get
>                   put v {session=insert "flash" (WrapString Nothing s) ss}

> getDelFlash :: FrameState m
>             => m (Maybe String)
> getDelFlash = do
>     mf <- getSessionField "flash"
>     delSessionField "flash"
>     return $ appMaybe unwrap mf

> -- | Given a router, flashes the current message to screen before deleting it
> flash :: FrameRouter m
>       => m Data -- ^ The router to have the message flashed to
>       -> m Data
> flash d = do
>    d' <- d
>    case d' of 
>       d@(View _)     -> appFlash d
>       d@(ViewPart _) -> appFlash d
>       d              -> return d

> appFlash :: (FrameRouter m) 
>          => Data -> m Data
> appFlash d = do 
>                mf <- getDelFlash
>                return $ case mf of
>                  (Just s) -> Paragraph [text s] ["flash"] +> d
>                  Nothing  -> d

> {-|
>     A convenience function when running a router, starting and saving a function before
>     and after the router is run
> -}
> withSession :: FrameRouter m 
>             => ([String] -> m a) -- ^ A router to run
>             -> ([String] -> m a) -- ^ A router wrapped with a session
> withSession f ps = do
>    startSession
>    d <- f ps
>    saveSession
>    return d

> -- | Generate a unique session ID 
> genSessionId :: IO String
> genSessionId = do 
>     TOD s ps <- getClockTime 
>     return $ show s ++ show ps