{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Main where ---------------------------------------------------------- -- Section 0: Imports. -- ---------------------------------------------------------- import Control.Applicative ((<$>), (<*>)) import Control.Concurrent.MVar (MVar, isEmptyMVar, newEmptyMVar, newMVar, putMVar, takeMVar, tryPutMVar, tryTakeMVar) import Control.Lens import Control.Monad (when) import Data.ByteString (ByteString) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Snap (Handler, Method (..), Snaplet, SnapletInit, addRoutes, getParam, liftIO, makeSnaplet, method, nestSnaplet, route, void, with, writeBS, writeText) import qualified Snap import Snap.Snaplet.Session import Snap.Snaplet.Session.Backends.CookieSession import System.Directory (doesFileExist, removeFile) import System.IO import Text.Digestive import Test.Hspec import Test.Hspec.Snap ---------------------------------------------------------- -- Section 1: Example application used for testing. -- ---------------------------------------------------------- data Foo = Foo Int String String data App = App { _mv :: MVar (), _store :: MVar (Map Int Foo), _sess :: Snaplet SessionManager } makeLenses ''App newFoo :: String -> String -> Handler App App Foo newFoo s1 s2 = do smvar <- use store mp <- liftIO $ takeMVar smvar let i = 1 + M.size mp let foo = Foo i s1 s2 liftIO $ putMVar smvar (M.insert i foo mp) return foo lookupFoo :: Int -> Handler App App (Maybe Foo) lookupFoo i = do smvar <- use store mp <- liftIO $ takeMVar smvar liftIO $ putMVar smvar mp return (M.lookup i mp) instance HasSession App where getSessionLens = sess html :: Text html = "
One | Two |