------------------------------------------------------------------------------
{-# 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
-------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | Session data are kept in a 'HashMap' for this backend
--
type Session = HashMap Text Text


------------------------------------------------------------------------------
-- | This is what the 'Payload' will be for the CookieSession backend
--
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


------------------------------------------------------------------------------
-- | The manager data type to be stuffed into 'SessionManager'
--
data CookieSessionManager = CookieSessionManager {
      CookieSessionManager -> Maybe CookieSession
session               :: Maybe CookieSession
        -- ^ Per request cache for 'CookieSession'
    , CookieSessionManager -> Key
siteKey               :: Key
        -- ^ A long encryption key used for secure cookie transport
    , CookieSessionManager -> ByteString
cookieName            :: ByteString
        -- ^ Cookie name for the session system
    , CookieSessionManager -> Maybe ByteString
cookieDomain          :: Maybe ByteString
        -- ^ Cookie domain for session system. You may want to set it to
        -- dot prefixed domain name like ".example.com", so the cookie is
        -- available to sub domains.
    , CookieSessionManager -> Maybe Int
timeOut               :: Maybe Int
        -- ^ Session cookies will be considered "stale" after this many
        -- seconds.
    , CookieSessionManager -> RNG
randomNumberGenerator :: RNG
        -- ^ handle to a random number generator
} 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)


------------------------------------------------------------------------------
-- | Initialize a cookie-backed session, returning a 'SessionManager' to be
-- stuffed inside your application's state. This 'SessionManager' will enable
-- the use of all session storage functionality defined in
-- 'Snap.Snaplet.Session'
--
initCookieSessionManager
    :: FilePath             -- ^ Path to site-wide encryption key
    -> ByteString           -- ^ Session cookie name
    -> Maybe ByteString     -- ^ Session cookie domain
    -> Maybe Int            -- ^ Session time-out (replay attack protection)
    -> 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 -> []


------------------------------------------------------------------------------
-- | A session payload to be stored in a SecureCookie.
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)


------------------------------------------------------------------------------
-- | Get the current client-side value
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)


------------------------------------------------------------------------------
-- | Set the client-side value
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