Merge pull request #150 from sopvop/expireSecureCookie

Add cookie domain support to Session and Auth snaplets

src/Snap/Snaplet/Auth/AuthManager.hs

@@ -81,6 +81,9 @@ data AuthManager b = forall r. IAuthBackend r => AuthManager {
     , rememberCookieName    :: ByteString
         -- ^ Cookie name for the remember token
 
+    , rememberCookieDomain  :: Maybe ByteString
+        -- ^ Domain for which remember cookie will be created.
+
     , rememberPeriod        :: Maybe Int
         -- ^ Remember period in seconds. Defaults to 2 weeks.
 

src/Snap/Snaplet/Auth/Backends/JsonFile.hs

@@ -57,6 +57,7 @@ initJsonFileAuthManager s l db = do
                        , activeUser            = Nothing
                        , minPasswdLen          = asMinPasswdLen s
                        , rememberCookieName    = asRememberCookieName s
+                       , rememberCookieDomain  = Nothing
                        , rememberPeriod        = asRememberPeriod s
                        , siteKey               = key
                        , lockout               = asLockout s

src/Snap/Snaplet/Auth/Handlers.hs

@@ -67,18 +67,20 @@ loginByUsername _ (Encrypted _) _ = return $ Left EncryptedPassword
 loginByUsername unm pwd shouldRemember = do
     sk <- gets siteKey
     cn <- gets rememberCookieName
+    cd <- gets rememberCookieDomain
     rp <- gets rememberPeriod
-    withBackend $ loginByUsername' sk cn rp
+    withBackend $ loginByUsername' sk cn cd rp
 
   where
     --------------------------------------------------------------------------
     loginByUsername' :: (IAuthBackend t) =>
                         Key
                      -> ByteString
+                     -> Maybe ByteString
                      -> Maybe Int
                      -> t
                      -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
-    loginByUsername' sk cn rp r =
+    loginByUsername' sk cn cd rp r =
         liftIO (lookupByLogin r unm) >>=
         maybe (return $! Left UserNotFound) found
 
@@ -93,7 +95,7 @@ loginByUsername unm pwd shouldRemember = do
                   token <- gets randomNumberGenerator >>=
                            liftIO . randomToken 64
 
-                  setRememberToken sk cn rp token
+                  setRememberToken sk cn cd rp token
 
                   let user' = user {
                                 userRememberToken = Just (decodeUtf8 token)
@@ -132,7 +134,8 @@ logout = do
     s <- gets session
     withTop s $ withSession s removeSessionUserId
     rc <- gets rememberCookieName
-    forgetRememberToken rc
+    rd <- gets rememberCookieDomain
+    expireSecureCookie rc rd
     modify $ \mgr -> mgr { activeUser = Nothing }
 
 
@@ -319,17 +322,11 @@ getRememberToken sk rc rp = getSecureCookie rc sk rp
 setRememberToken :: (Serialize t, MonadSnap m)
                  => Key
                  -> ByteString
+                 -> Maybe ByteString
                  -> Maybe Int
                  -> t
                  -> m ()
-setRememberToken sk rc rp token = setSecureCookie rc sk rp token
-
-
-------------------------------------------------------------------------------
-forgetRememberToken :: MonadSnap m => ByteString -> m ()
-forgetRememberToken rc = expireCookie cookie
-  where
-   cookie = Cookie rc "" Nothing (Just "/") Nothing False False
+setRememberToken sk rc rd rp token = setSecureCookie rc rd sk rp token
 
 
 ------------------------------------------------------------------------------
@@ -499,7 +496,7 @@ withBackend ::
       -- ^ The function to run with the handler.
   -> Handler b (AuthManager v) a
 withBackend f = join $ do
-  (AuthManager backend_ _ _ _ _ _ _ _ _) <- get
+  (AuthManager backend_ _ _ _ _ _ _ _ _ _) <- get
   return $ f backend_
 
 

src/Snap/Snaplet/Session/Backends/CookieSession.hs

@@ -78,6 +78,10 @@ data CookieSessionManager = CookieSessionManager {
         -- ^ A long encryption key used for secure cookie transport
     , cookieName            :: ByteString
         -- ^ Cookie name for the session system
+    , 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.
     , timeOut               :: Maybe Int
         -- ^ Session cookies will be considered "stale" after this many
         -- seconds.
@@ -88,7 +92,7 @@ data CookieSessionManager = CookieSessionManager {
 
 ------------------------------------------------------------------------------
 loadDefSession :: CookieSessionManager -> IO CookieSessionManager
-loadDefSession mgr@(CookieSessionManager ses _ _ _ rng) =
+loadDefSession mgr@(CookieSessionManager ses _ _ _ _ rng) =
     case ses of
       Nothing -> do ses' <- mkCookieSession rng
                     return $! mgr { session = Just ses' }
@@ -109,22 +113,23 @@ modSession f (CookieSession t ses) = CookieSession t (f ses)
 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 fp cn to =
+initCookieSessionManager fp cn dom to =
     makeSnaplet "CookieSession"
                 "A snaplet providing sessions via HTTP cookies."
                 Nothing $ liftIO $ do
         key <- getKey fp
         rng <- liftIO mkRNG
-        return $! SessionManager $ CookieSessionManager Nothing key cn to rng
+        return $! SessionManager $ CookieSessionManager Nothing key cn dom to rng
 
 
 ------------------------------------------------------------------------------
 instance ISessionManager CookieSessionManager where
 
     --------------------------------------------------------------------------
-    load mgr@(CookieSessionManager r _ _ _ _) =
+    load mgr@(CookieSessionManager r _ _ _ _ _) =
         case r of
           Just _ -> return mgr
           Nothing -> do
@@ -138,7 +143,7 @@ instance ISessionManager CookieSessionManager where
                   Right cs -> return $ mgr { session = Just cs }
 
     --------------------------------------------------------------------------
-    commit mgr@(CookieSessionManager r _ _ _ rng) = do
+    commit mgr@(CookieSessionManager r _ _ _ _ rng) = do
         pl <- case r of
                 Just r' -> return . Payload $ S.encode r'
                 Nothing -> liftIO (mkCookieSession rng) >>=
@@ -154,25 +159,25 @@ instance ISessionManager CookieSessionManager where
     touch = id
 
     --------------------------------------------------------------------------
-    insert k v mgr@(CookieSessionManager r _ _ _ _) = case r of
+    insert k v mgr@(CookieSessionManager r _ _ _ _ _) = case r of
         Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }
         Nothing -> mgr
 
     --------------------------------------------------------------------------
-    lookup k (CookieSessionManager r _ _ _ _) = r >>= HM.lookup k . csSession
+    lookup k (CookieSessionManager r _ _ _ _ _) = r >>= HM.lookup k . csSession
 
     --------------------------------------------------------------------------
-    delete k mgr@(CookieSessionManager r _ _ _ _) = case r of
+    delete k mgr@(CookieSessionManager r _ _ _ _ _) = case r of
         Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }
         Nothing -> mgr
 
     --------------------------------------------------------------------------
-    csrf (CookieSessionManager r _ _ _ _) = case r of
+    csrf (CookieSessionManager r _ _ _ _ _) = case r of
         Just r' -> csCSRFToken r'
         Nothing -> ""
 
     --------------------------------------------------------------------------
-    toList (CookieSessionManager r _ _ _ _) = case r of
+    toList (CookieSessionManager r _ _ _ _ _) = case r of
         Just r' -> HM.toList . csSession $ r'
         Nothing -> []
 
@@ -192,5 +197,5 @@ getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr)
 ------------------------------------------------------------------------------
 -- | Set the client-side value
 setPayload :: CookieSessionManager -> Payload -> Snap ()
-setPayload mgr x = setSecureCookie (cookieName mgr) (siteKey mgr)
-                                   (timeOut mgr) x
+setPayload mgr x = setSecureCookie (cookieName mgr) (cookieDomain mgr)
+                                   (siteKey mgr) (timeOut mgr) x

src/Snap/Snaplet/Session/SecureCookie.hs

@@ -12,25 +12,27 @@
 --     cookie. This will limit intercept-and-replay attacks by disallowing
 --     cookies older than the timeout threshold.
 
-module Snap.Snaplet.Session.SecureCookie where
+module Snap.Snaplet.Session.SecureCookie
+       ( SecureCookie(..)
+       , getSecureCookie
+       , setSecureCookie
+       , expireSecureCookie
+       -- ** Helper functions
+       , encodeSecureCookie
+       , decodeSecureCookie
+       , checkTimeout
+       ) where
 
 ------------------------------------------------------------------------------
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Trans
-import Data.ByteString (ByteString)
-import Data.Time
-import Data.Time.Clock.POSIX
-import Data.Serialize
-import Snap.Core
-import Web.ClientSession
-
-
-------------------------------------------------------------------------------
--- | Serialize UTCTime
---instance Serialize UTCTime where
---    put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)
---    get   = posixSecondsToUTCTime . fromInteger <$> get
+import           Control.Applicative
+import           Control.Monad
+import           Control.Monad.Trans
+import           Data.ByteString       (ByteString)
+import           Data.Serialize
+import           Data.Time
+import           Data.Time.Clock.POSIX
+import           Snap.Core
+import           Web.ClientSession
 
 
 ------------------------------------------------------------------------------
@@ -39,7 +41,7 @@ type SecureCookie t = (UTCTime, t)
 
 
 ------------------------------------------------------------------------------
--- Get the payload back
+-- | Get the cookie payload.
 getSecureCookie :: (MonadSnap m, Serialize t)
                 => ByteString       -- ^ Cookie name
                 -> Key              -- ^ Encryption key
@@ -49,34 +51,68 @@ getSecureCookie name key timeout = do
     rqCookie <- getCookie name
     rspCookie <- getResponseCookie name <$> getResponse
     let ck = rspCookie `mplus` rqCookie
-    let val = fmap cookieValue ck >>= decrypt key >>= return . decode
-    let val' = val >>= either (const Nothing) Just
-    case val' of
+    let val = fmap cookieValue ck >>= decodeSecureCookie key
+    case val of
       Nothing -> return Nothing
       Just (ts, t) -> do
-          to <- checkTimeout timeout $ posixSecondsToUTCTime $ fromInteger ts
+          to <- checkTimeout timeout ts
           return $ case to of
             True -> Nothing
             False -> Just t
 
 
 ------------------------------------------------------------------------------
--- | Inject the payload
+-- | Decode secure cookie payload wih key.
+decodeSecureCookie  :: Serialize a
+                     => Key                     -- ^ Encryption key
+                     -> ByteString              -- ^ Encrypted payload
+                     -> Maybe (SecureCookie a)
+decodeSecureCookie key value = do
+    cv <- decrypt key value
+    (i, val) <- either (const Nothing) Just $ decode cv
+    return $ (posixSecondsToUTCTime (fromInteger i), val)
+
+
+------------------------------------------------------------------------------
+-- | Inject the payload.
 setSecureCookie :: (MonadSnap m, Serialize t)
                 => ByteString       -- ^ Cookie name
+                -> Maybe ByteString -- ^ Cookie domain
                 -> Key              -- ^ Encryption key
                 -> Maybe Int        -- ^ Max age in seconds
                 -> t                -- ^ Serializable payload
                 -> m ()
-setSecureCookie name key to val = do
+setSecureCookie name domain key to val = do
     t <- liftIO getCurrentTime
-    let seconds = round (utcTimeToPOSIXSeconds t) :: Integer
+    val' <- encodeSecureCookie key (t, val)
     let expire = to >>= Just . flip addUTCTime t . fromIntegral
-    val' <- liftIO . encryptIO key . encode $ (seconds, val)
-    let nc = Cookie name val' expire Nothing (Just "/") False True
+    let nc = Cookie name val' expire domain (Just "/") False True
     modifyResponse $ addResponseCookie nc
 
 
+------------------------------------------------------------------------------
+-- | Encode SecureCookie with key into injectable payload
+encodeSecureCookie :: (MonadIO m, Serialize t)
+                    => Key            -- ^ Encryption key
+                    -> SecureCookie t -- ^ Payload
+                    -> m ByteString
+encodeSecureCookie key (t, val) =
+    liftIO $ encryptIO key . encode $ (seconds, val)
+  where
+    seconds = round (utcTimeToPOSIXSeconds t) :: Integer
+
+
+------------------------------------------------------------------------------
+-- | Expire secure cookie
+expireSecureCookie :: MonadSnap m
+                   => ByteString       -- ^ Cookie name
+                   -> Maybe ByteString -- ^ Cookie domain
+                   -> m ()
+expireSecureCookie name domain = expireCookie cookie
+  where
+    cookie = Cookie name "" Nothing domain (Just "/") False False
+
+
 ------------------------------------------------------------------------------
 -- | Validate session against timeout policy.
 --

test/suite/Snap/Snaplet/Test/Common/App.hs

@@ -66,7 +66,7 @@ appInit' hInterp authConfigFile =
         (HeistConfig (mempty {_scCompiledSplices = compiledSplices}) "" True)
 
   sm <- nestSnaplet "session" session $
-        initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))
+        initCookieSessionManager "sitekey.txt" "_session" Nothing (Just (30 * 60))
   fs <- nestSnaplet "foo"     foo     $ fooInit hs
   bs <- nestSnaplet ""        bar     $ nameSnaplet "baz" $ barInit hs foo
   ns <- embedSnaplet "embed" embedded embeddedInit