{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Snap.Snaplet.Session.Backends.CookieSession
( initCookieSessionManager
) where
import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.Typeable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Serialize (Serialize)
import qualified Data.Serialize as S
import Data.Text (Text)
import Data.Text.Encoding
import Snap.Core (Snap)
import Web.ClientSession
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Snap.Snaplet
import Snap.Snaplet.Session
import Snap.Snaplet.Session.SessionManager
type Session = HashMap Text Text
data CookieSession = CookieSession
{ CookieSession -> Text
csCSRFToken :: Text
, CookieSession -> Session
csSession :: Session
}
deriving (CookieSession -> CookieSession -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CookieSession -> CookieSession -> Bool
$c/= :: CookieSession -> CookieSession -> Bool
== :: CookieSession -> CookieSession -> Bool
$c== :: CookieSession -> CookieSession -> Bool
Eq, Int -> CookieSession -> ShowS
[CookieSession] -> ShowS
CookieSession -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CookieSession] -> ShowS
$cshowList :: [CookieSession] -> ShowS
show :: CookieSession -> String
$cshow :: CookieSession -> String
showsPrec :: Int -> CookieSession -> ShowS
$cshowsPrec :: Int -> CookieSession -> ShowS
Show)
instance Serialize CookieSession where
put :: Putter CookieSession
put (CookieSession Text
a Session
b) =
forall t. Serialize t => Putter t
S.put (Text -> ByteString
encodeUtf8 Text
a, forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (ByteString, ByteString)
encodeTuple forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HM.toList Session
b)
get :: Get CookieSession
get =
let unpack :: (ByteString, [(ByteString, ByteString)]) -> CookieSession
unpack (ByteString
a,[(ByteString, ByteString)]
b) = Text -> Session -> CookieSession
CookieSession (ByteString -> Text
decodeUtf8 ByteString
a)
(forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> (Text, Text)
decodeTuple [(ByteString, ByteString)]
b)
in (ByteString, [(ByteString, ByteString)]) -> CookieSession
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Serialize t => Get t
S.get
encodeTuple :: (Text, Text) -> (ByteString, ByteString)
encodeTuple :: (Text, Text) -> (ByteString, ByteString)
encodeTuple (Text
a,Text
b) = (Text -> ByteString
encodeUtf8 Text
a, Text -> ByteString
encodeUtf8 Text
b)
decodeTuple :: (ByteString, ByteString) -> (Text, Text)
decodeTuple :: (ByteString, ByteString) -> (Text, Text)
decodeTuple (ByteString
a,ByteString
b) = (ByteString -> Text
decodeUtf8 ByteString
a, ByteString -> Text
decodeUtf8 ByteString
b)
mkCookieSession :: RNG -> IO CookieSession
mkCookieSession :: RNG -> IO CookieSession
mkCookieSession RNG
rng = do
Text
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RNG -> IO Text
mkCSRFToken RNG
rng
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Session -> CookieSession
CookieSession Text
t forall k v. HashMap k v
HM.empty
data CookieSessionManager = CookieSessionManager {
CookieSessionManager -> Maybe CookieSession
session :: Maybe CookieSession
, CookieSessionManager -> Key
siteKey :: Key
, CookieSessionManager -> ByteString
cookieName :: ByteString
, CookieSessionManager -> Maybe ByteString
cookieDomain :: Maybe ByteString
, CookieSessionManager -> Maybe Int
timeOut :: Maybe Int
, CookieSessionManager -> RNG
randomNumberGenerator :: RNG
} deriving (Typeable)
loadDefSession :: CookieSessionManager -> IO CookieSessionManager
loadDefSession :: CookieSessionManager -> IO CookieSessionManager
loadDefSession mgr :: CookieSessionManager
mgr@(CookieSessionManager Maybe CookieSession
ses Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
rng) =
case Maybe CookieSession
ses of
Maybe CookieSession
Nothing -> do CookieSession
ses' <- RNG -> IO CookieSession
mkCookieSession RNG
rng
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! CookieSessionManager
mgr { session :: Maybe CookieSession
session = forall a. a -> Maybe a
Just CookieSession
ses' }
Just CookieSession
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return CookieSessionManager
mgr
modSession :: (Session -> Session) -> CookieSession -> CookieSession
modSession :: (Session -> Session) -> CookieSession -> CookieSession
modSession Session -> Session
f (CookieSession Text
t Session
ses) = Text -> Session -> CookieSession
CookieSession Text
t (Session -> Session
f Session
ses)
initCookieSessionManager
:: FilePath
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> SnapletInit b SessionManager
initCookieSessionManager :: forall b.
String
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> SnapletInit b SessionManager
initCookieSessionManager String
fp ByteString
cn Maybe ByteString
dom Maybe Int
to =
forall b v.
Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
"CookieSession"
Text
"A snaplet providing sessions via HTTP cookies."
forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Key
key <- String -> IO Key
getKey String
fp
RNG
rng <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RNG
mkRNG
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. ISessionManager a => a -> SessionManager
SessionManager forall a b. (a -> b) -> a -> b
$ Maybe CookieSession
-> Key
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> RNG
-> CookieSessionManager
CookieSessionManager forall a. Maybe a
Nothing Key
key ByteString
cn Maybe ByteString
dom Maybe Int
to RNG
rng
instance ISessionManager CookieSessionManager where
load :: CookieSessionManager -> Snap CookieSessionManager
load mgr :: CookieSessionManager
mgr@(CookieSessionManager Maybe CookieSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_) =
case Maybe CookieSession
r of
Just CookieSession
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return CookieSessionManager
mgr
Maybe CookieSession
Nothing -> do
Maybe Payload
pl <- CookieSessionManager -> Snap (Maybe Payload)
getPayload CookieSessionManager
mgr
case Maybe Payload
pl of
Maybe Payload
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CookieSessionManager -> IO CookieSessionManager
loadDefSession CookieSessionManager
mgr
Just (Payload ByteString
x) -> do
let c :: Either String CookieSession
c = forall a. Serialize a => ByteString -> Either String a
S.decode ByteString
x
case Either String CookieSession
c of
Left String
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CookieSessionManager -> IO CookieSessionManager
loadDefSession CookieSessionManager
mgr
Right CookieSession
cs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CookieSessionManager
mgr { session :: Maybe CookieSession
session = forall a. a -> Maybe a
Just CookieSession
cs }
commit :: CookieSessionManager -> Snap ()
commit mgr :: CookieSessionManager
mgr@(CookieSessionManager Maybe CookieSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
rng) = do
Payload
pl <- case Maybe CookieSession
r of
Just CookieSession
r' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Payload
Payload forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
S.encode CookieSession
r'
Maybe CookieSession
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (RNG -> IO CookieSession
mkCookieSession RNG
rng) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Payload
Payload forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
S.encode
CookieSessionManager -> Payload -> Snap ()
setPayload CookieSessionManager
mgr Payload
pl
reset :: CookieSessionManager -> Snap CookieSessionManager
reset CookieSessionManager
mgr = do
CookieSession
cs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RNG -> IO CookieSession
mkCookieSession (CookieSessionManager -> RNG
randomNumberGenerator CookieSessionManager
mgr)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CookieSessionManager
mgr { session :: Maybe CookieSession
session = forall a. a -> Maybe a
Just CookieSession
cs }
touch :: CookieSessionManager -> CookieSessionManager
touch = forall a. a -> a
id
insert :: Text -> Text -> CookieSessionManager -> CookieSessionManager
insert Text
k Text
v mgr :: CookieSessionManager
mgr@(CookieSessionManager Maybe CookieSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_) = case Maybe CookieSession
r of
Just CookieSession
r' -> CookieSessionManager
mgr { session :: Maybe CookieSession
session = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Session -> Session) -> CookieSession -> CookieSession
modSession (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
k Text
v) CookieSession
r' }
Maybe CookieSession
Nothing -> CookieSessionManager
mgr
lookup :: Text -> CookieSessionManager -> Maybe Text
lookup Text
k (CookieSessionManager Maybe CookieSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_) = Maybe CookieSession
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieSession -> Session
csSession
delete :: Text -> CookieSessionManager -> CookieSessionManager
delete Text
k mgr :: CookieSessionManager
mgr@(CookieSessionManager Maybe CookieSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_) = case Maybe CookieSession
r of
Just CookieSession
r' -> CookieSessionManager
mgr { session :: Maybe CookieSession
session = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Session -> Session) -> CookieSession -> CookieSession
modSession (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
k) CookieSession
r' }
Maybe CookieSession
Nothing -> CookieSessionManager
mgr
csrf :: CookieSessionManager -> Text
csrf (CookieSessionManager Maybe CookieSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_) = case Maybe CookieSession
r of
Just CookieSession
r' -> CookieSession -> Text
csCSRFToken CookieSession
r'
Maybe CookieSession
Nothing -> Text
""
toList :: CookieSessionManager -> [(Text, Text)]
toList (CookieSessionManager Maybe CookieSession
r Key
_ ByteString
_ Maybe ByteString
_ Maybe Int
_ RNG
_) = case Maybe CookieSession
r of
Just CookieSession
r' -> forall k v. HashMap k v -> [(k, v)]
HM.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieSession -> Session
csSession forall a b. (a -> b) -> a -> b
$ CookieSession
r'
Maybe CookieSession
Nothing -> []
newtype Payload = Payload ByteString
deriving (Payload -> Payload -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Payload -> Payload -> Bool
$c/= :: Payload -> Payload -> Bool
== :: Payload -> Payload -> Bool
$c== :: Payload -> Payload -> Bool
Eq, Int -> Payload -> ShowS
[Payload] -> ShowS
Payload -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Payload] -> ShowS
$cshowList :: [Payload] -> ShowS
show :: Payload -> String
$cshow :: Payload -> String
showsPrec :: Int -> Payload -> ShowS
$cshowsPrec :: Int -> Payload -> ShowS
Show, Eq Payload
Payload -> Payload -> Bool
Payload -> Payload -> Ordering
Payload -> Payload -> Payload
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Payload -> Payload -> Payload
$cmin :: Payload -> Payload -> Payload
max :: Payload -> Payload -> Payload
$cmax :: Payload -> Payload -> Payload
>= :: Payload -> Payload -> Bool
$c>= :: Payload -> Payload -> Bool
> :: Payload -> Payload -> Bool
$c> :: Payload -> Payload -> Bool
<= :: Payload -> Payload -> Bool
$c<= :: Payload -> Payload -> Bool
< :: Payload -> Payload -> Bool
$c< :: Payload -> Payload -> Bool
compare :: Payload -> Payload -> Ordering
$ccompare :: Payload -> Payload -> Ordering
Ord, Get Payload
Putter Payload
forall t. Putter t -> Get t -> Serialize t
get :: Get Payload
$cget :: Get Payload
put :: Putter Payload
$cput :: Putter Payload
Serialize)
getPayload :: CookieSessionManager -> Snap (Maybe Payload)
getPayload :: CookieSessionManager -> Snap (Maybe Payload)
getPayload CookieSessionManager
mgr = forall (m :: * -> *) t.
(MonadSnap m, Serialize t) =>
ByteString -> Key -> Maybe Int -> m (Maybe t)
getSecureCookie (CookieSessionManager -> ByteString
cookieName CookieSessionManager
mgr) (CookieSessionManager -> Key
siteKey CookieSessionManager
mgr) (CookieSessionManager -> Maybe Int
timeOut CookieSessionManager
mgr)
setPayload :: CookieSessionManager -> Payload -> Snap ()
setPayload :: CookieSessionManager -> Payload -> Snap ()
setPayload CookieSessionManager
mgr Payload
x = forall (m :: * -> *) t.
(MonadSnap m, Serialize t) =>
ByteString -> Maybe ByteString -> Key -> Maybe Int -> t -> m ()
setSecureCookie (CookieSessionManager -> ByteString
cookieName CookieSessionManager
mgr) (CookieSessionManager -> Maybe ByteString
cookieDomain CookieSessionManager
mgr)
(CookieSessionManager -> Key
siteKey CookieSessionManager
mgr) (CookieSessionManager -> Maybe Int
timeOut CookieSessionManager
mgr) Payload
x