>
> module Frame.Session (
>
> startSession,
> saveSession,
> deleteSession,
> withSession,
> genSessionId,
>
> 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
>
> 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
>
> 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 ()
>
> deleteSession :: FrameRouter m => m ()
> deleteSession = do
> putSession $ fromList []
> p <- asks sessionPath
> i <- asks sessionId
> liftIO $ removeFile $ p ++ i
> return ()
>
> getSessionField :: FrameReader m
> => FieldName
> -> m (Maybe WrapperType)
> getSessionField fn = do
> s <- gets session
> return $ lookup fn s
>
> putSession :: FrameState m => Fields
> -> m ()
> putSession s = do
> v <- get
> put v {session=s}
>
> putSessionField :: FrameState m => FieldName
> -> WrapperType
> -> m ()
> putSessionField fn s = do
> ss <- gets session
> v <- get
> put v {session=insert fn s ss}
>
> delSessionField :: FrameState m
> => FieldName
> -> m ()
> delSessionField fn = do
> ss <- gets session
> v <- get
> put v {session=delete fn ss}
>
> copyToSession :: FrameState m => FieldName
> -> m ()
> copyToSession fn = do
> mf <- getField fn
> case mf of
> (Just f) -> putSessionField fn f
> Nothing -> return ()
>
> copyFromSession :: (FrameState m, FrameConfig m)
> => FieldName
> -> m ()
> copyFromSession fn = do
> mf <- getSessionField fn
> case mf of
> (Just f) -> putField fn f
> Nothing -> return ()
>
> updateFlash :: FrameState m => String
> -> m ()
> 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
>
> flash :: FrameRouter m
> => m Data
> -> 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
>
> withSession :: FrameRouter m
> => ([String] -> m a)
> -> ([String] -> m a)
> withSession f ps = do
> startSession
> d <- f ps
> saveSession
> return d
>
> genSessionId :: IO String
> genSessionId = do
> TOD s ps <- getClockTime
> return $ show s ++ show ps