apiary-clientsession 0.8.0.0 → 0.9.0.0

raw patch · 4 files changed

+188/−66 lines, 4 filesdep +base64-bytestringdep +binarydep +cprng-aesdep −mtldep ~apiarydep ~apiary-cookiePVP ok

version bump matches the API change (PVP)

Dependencies added: base64-bytestring, binary, cprng-aes, crypto-random, http-types

Dependencies removed: mtl

Dependency ranges changed: apiary, apiary-cookie

API changes (from Hackage documentation)

Files

• apiary-clientsession.cabal +9/−4
• src/Web/Apiary/ClientSession.hs +43/−6
• src/Web/Apiary/ClientSession/Explicit.hs +20/−0
• src/Web/Apiary/ClientSession/Internal.hs +116/−56

@@ -1,5 +1,5 @@ name:                apiary-clientsession-version:             0.8.0.0+version:             0.9.0.0 synopsis:            clientsession support for apiary web framework. description:   example: <https://github.com/philopon/apiary/blob/master/examples/auth.hs>@@ -18,18 +18,23 @@  library   exposed-modules:     Web.Apiary.ClientSession+                       Web.Apiary.ClientSession.Explicit   other-modules:       Web.Apiary.ClientSession.Internal   other-extensions:       build-depends:       base               >=4.6   && <4.8-                     , mtl                >=2.1   && <2.3                      , bytestring         >=0.10  && <0.11-                     , apiary             >=0.8   && <0.9-                     , apiary-cookie      >=0.8   && <0.9+                     , apiary             >=0.9   && <0.10+                     , apiary-cookie      >=0.9   && <0.10                      , clientsession      >=0.9   && <0.10                      , tagged             >=0.7   && <0.8                      , time               >=1.4   && <1.5                      , data-default-class >=0.0   && <0.1                      , reflection         >=1.4   && <1.5+                     , binary             >=0.7   && <0.8+                     , crypto-random      >=0.0   && <0.1+                     , cprng-aes          >=0.5   && <0.6+                     , base64-bytestring  >=1.0   && <1.1+                     , http-types         >=0.8   && <0.9    hs-source-dirs:      src   ghc-options:         -O2 -Wall

@@ -1,19 +1,56 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+ module Web.Apiary.ClientSession     ( HasSession-    , SessionConfig(..)+    , I.SessionConfig(..)     , withSession     -- * setter     , setSession-    , setSessionWith-    , setRawSession+    , csrfToken     -- * filter     , session+    , checkToken     -- * Reexport-    -- | def     , module Data.Default.Class+    -- | deleteCookie     , module Web.Apiary.Cookie     ) where +import Web.Apiary+ import Data.Default.Class-import Web.Apiary.ClientSession.Internal-import Web.Apiary.Cookie+import qualified Web.Apiary.ClientSession.Internal as I+import Web.Apiary.Cookie (deleteCookie)+import Data.Reflection+import qualified Data.ByteString as S+import Control.Monad.Apiary.Filter.Internal.Strategy+import Data.Proxy++type HasSession = Given I.Session++withSession :: MonadIO m => I.SessionConfig -> (HasSession => m b) -> m b+withSession c m = I.withSession c (\s -> give s m)++setSession :: (MonadIO m, HasSession)+           => S.ByteString -> S.ByteString -> ActionT m ()+setSession = I.setSession given++-- | create crypto random (generate random by AES CTR(cprng-aes package) and encode by base64),+--+-- set it client session cookie, set XSRF-TOKEN header(when Just angularXsrfCookieName),+--+-- and return value. since 0.9.0.0.+csrfToken :: (MonadIO m, HasSession) => ActionT m S.ByteString+csrfToken = I.csrfToken given++session :: (Functor n, MonadIO n, Strategy w, Query a, HasSession)+        => S.ByteString -> Proxy (w a)+        -> ApiaryT (SNext w as a) n m b -> ApiaryT as n m b+session = I.session given++-- | check csrf token. since 0.9.0.0.+checkToken :: (Functor n, MonadIO n, HasSession)+           => ApiaryT c n m a -> ApiaryT c n m a+checkToken = I.checkToken given

@@ -0,0 +1,20 @@+module Web.Apiary.ClientSession.Explicit+    (+      Session, SessionConfig(..)+    , withSession+    -- * actions+    , setSession+    , csrfToken+    -- * filters+    , session, checkToken+    -- * lowlevels+    , mkSessionCookie, getSessionValue+    -- * reexports+    , module Data.Default.Class+    -- | deleteCookie+    , module Web.Apiary.Cookie+    ) where++import Web.Apiary.ClientSession.Internal+import Data.Default.Class+import Web.Apiary.Cookie(deleteCookie)

@@ -5,95 +5,155 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PackageImports #-}  module Web.Apiary.ClientSession.Internal where -import Control.Monad.Trans+import Control.Monad+import Control.Applicative+import Control.Arrow +import Web.Apiary.Wai+import qualified Network.HTTP.Types as HTTP+ import Web.Apiary hiding (Default(..)) import Web.Apiary.Cookie import Web.Apiary.Cookie.Internal import Web.ClientSession  import Data.Proxy+import Data.Maybe import Data.Time import Data.Default.Class-import Data.Reflection+import Data.Binary+import Data.IORef+import qualified Data.ByteString.Base64 as Base64 +import "crypto-random" Crypto.Random+import Crypto.Random.AESCtr+ import Control.Monad.Apiary.Filter.Internal import Control.Monad.Apiary.Filter.Internal.Strategy  import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L + data Session = Session     { key       :: Key+    , tokenGen  :: IORef AESRNG     , config    :: SessionConfig     }  data SessionConfig = SessionConfig-    { keyFile  :: FilePath-    , maxAge   :: Maybe DiffTime-    , path     :: Maybe S.ByteString-    , domain   :: Maybe S.ByteString-    , httpOnly :: Bool-    , secure   :: Bool+    { keyFile               :: FilePath+    , maxAge                :: DiffTime+    , path                  :: Maybe S.ByteString+    , domain                :: Maybe S.ByteString+    , httpOnly              :: Bool+    , secure                :: Bool++    , angularXsrfCookieName :: Maybe S.ByteString+    , csrfTokenCookieName   :: S.ByteString++    , csrfTokenCheckingName :: Either HTTP.HeaderName S.ByteString+    , csrfTokenLength       :: Int     }  instance Default SessionConfig where     def = SessionConfig-        defaultKeyFile (Just (24 * 60 * 60)) Nothing Nothing True True--type HasSession = Given Session--cond :: (a -> Bool) -> (a -> b) -> (a -> b) -> a -> b-cond p t f a = if p a then t a else f a+        defaultKeyFile (24 * 60 * 60) Nothing Nothing True True+        Nothing "_token" (Right "_token") 40 -withSession :: MonadIO m => SessionConfig -> (HasSession => m b) -> m b+withSession :: MonadIO m => SessionConfig -> (Session -> m b) -> m b withSession cfg@SessionConfig{..} m = do     k <- liftIO $ getKey keyFile-    let sess = Session k cfg-    give sess m+    p <- liftIO $ makeSystem >>= newIORef+    let sess = Session k p cfg+    m sess -setMaxAge :: SetCookie -> Maybe DiffTime -> IO SetCookie-setMaxAge s (Just a) = do+newtype BinUTCTime = BinUTCTime { getUTCTime :: UTCTime }++instance Binary BinUTCTime where+    put (BinUTCTime t) = do+        put . toModifiedJulianDay $ utctDay t+        put . toRational $ utctDayTime t+    get = do+        d <- ModifiedJulianDay <$> get+        t <- fromRational      <$> get+        return . BinUTCTime $ UTCTime d t++mkSessionCookie :: SessionConfig -> Key -> S.ByteString -> S.ByteString -> IO SetCookie+mkSessionCookie conf key k v = do     t <- getCurrentTime-    return s { setCookieExpires = Just $ addUTCTime (realToFrac a) t-             , setCookieMaxAge  = Just a-             }-setMaxAge s Nothing = return s+    let expire = addUTCTime (realToFrac $ maxAge conf) t+    v' <- encryptIO key $ L.toStrict $ encode (BinUTCTime expire, v)+    return def { setCookieName     = k+               , setCookieValue    = v'+               , setCookiePath     = path conf+               , setCookieExpires  = Just expire+               , setCookieMaxAge   = Just (maxAge conf)+               , setCookieDomain   = domain conf+               , setCookieHttpOnly = httpOnly conf+               , setCookieSecure   = secure conf+               } -encryptValue :: HasSession => SetCookie -> IO SetCookie-encryptValue s = do-    v' <- encryptIO (key given) (setCookieValue s)-    return $ s { setCookieValue = v' }-    -setRawSession :: (MonadIO m, HasSession) => Maybe DiffTime -> SetCookie -> ActionT m ()-setRawSession age s = do-    s' <- liftIO $ encryptValue =<< setMaxAge s age-    setCookie s'+getSessionValue :: Session -> UTCTime -- ^ current time+                -> S.ByteString +                -> Maybe S.ByteString+getSessionValue Session{key = k} c s = decrypt k s >>= \s' -> case decodeOrFail (L.fromStrict s') of+        Right (_, _, (BinUTCTime t, v)) -> if c < t then Just v else Nothing+        _ -> Nothing -setSessionWith :: (MonadIO m, HasSession)-               => (SetCookie -> SetCookie) -- ^ postprocess-               -> S.ByteString -- ^ key-               -> S.ByteString -- ^ value-               -> ActionT m ()-setSessionWith f k v = do-    let Session{..} = given-    setRawSession (maxAge config) $ f def-        { setCookieName     = k -        , setCookieValue    = v-        , setCookiePath     = path config-        , setCookieDomain   = domain config-        , setCookieHttpOnly = httpOnly config-        , setCookieSecure   = secure config-        }+setSession :: MonadIO m => Session -> S.ByteString -> S.ByteString -> ActionT m ()+setSession sess k v = do+    s <- liftIO $ mkSessionCookie (config sess) (key sess) k v+    setCookie s -setSession :: (MonadIO m, HasSession)-           => S.ByteString -- ^ key-           -> S.ByteString -- ^ value-           -> ActionT m ()-setSession = setSessionWith id+newToken :: Int -> IORef AESRNG -> IO S.ByteString+newToken len gen = do+    atomicModifyIORef' gen (\rng -> swap $ withRandomBytes rng len Base64.encode)+  where +    swap (a,b) = (b,a) -session :: (Strategy w, Query a, HasSession, Monad n, Functor n)-        => S.ByteString -> Proxy (w a) -> ApiaryT (SNext w as a) n m b -> ApiaryT as n m b-session ky p = function $ \l r -> readStrategy readQuery ((ky ==) . fst) p-    (map (\(k,b) -> (k, decrypt (key given) b)) $ cookie' r) l+csrfToken :: MonadIO m => Session -> ActionT m S.ByteString+csrfToken Session{..} = do+    tok <- liftIO $ newToken (csrfTokenLength config) tokenGen +    sc <- liftIO $ mkSessionCookie config key (csrfTokenCookieName config) tok+    setCookie sc+    maybe (return ()) (setCookie . ngCookie sc tok) (angularXsrfCookieName config)+    return tok+  where+    ngCookie sc tok k = sc { setCookieName     = k+                           , setCookieValue    = tok+                           , setCookieHttpOnly = False+                           }++session :: (Functor n, MonadIO n, Strategy w, Query a) => Session+        -> S.ByteString -> Proxy (w a) -> ApiaryT (SNext w as a) n m b -> ApiaryT as n m b+session sess k p = focus $ \l -> do+    r   <- getRequest+    t   <- liftIO getCurrentTime+    let mbr = readStrategy readQuery ((k ==) . fst) p+            (map (second $ getSessionValue sess t) $ cookie' r) l+    maybe empty return mbr++checkToken :: (Functor n, MonadIO n)+           => Session+           -> ApiaryT c n m a+           -> ApiaryT c n m a+checkToken sess@Session{..} = focus $ \l -> do+    r <- getRequest+    p <- getReqParams++    t <- liftIO getCurrentTime+    let stok = getSessionValue sess t =<< +               lookup (csrfTokenCookieName config) (cookie' r)+    guard (isJust stok)+    +    qtok <- return . join $ case csrfTokenCheckingName config of+        Right name -> lookup name $ reqParams pByteString r p []+        Left name  -> lookup name $ map (\(k,v) -> (k, Just v)) $ requestHeaders r+    guard (isJust qtok)++    if qtok == stok then return l else empty+