apiary-clientsession 1.1.0 → 1.2.0

raw patch · 4 files changed

+119/−308 lines, 4 filesdep +apiary-sessiondep +cerealdep +unix-compatdep −base64-bytestringdep −binarydep −blaze-htmldep ~apiarydep ~apiary-cookiedep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: apiary-session, cereal, unix-compat, vault

Dependencies removed: base64-bytestring, binary, blaze-html, cprng-aes, crypto-random, directory, http-types, template-haskell

Dependency ranges changed: apiary, apiary-cookie, time

API changes (from Hackage documentation)

Files

• apiary-clientsession.cabal +11/−19
• src/Web/Apiary/ClientSession.hs +0/−71
• src/Web/Apiary/ClientSession/Internal.hs +0/−218
• src/Web/Apiary/Session/ClientSession.hs +108/−0

@@ -1,14 +1,12 @@ name:                apiary-clientsession-version:             1.1.0+version:             1.2.0 synopsis:            clientsession support for apiary web framework. description:   examples:     .-    <https://github.com/philopon/apiary/blob/master/examples/csrf.hs>+    <https://github.com/philopon/apiary/blob/master/examples/session.hs>     .     <https://github.com/philopon/apiary/blob/master/examples/auth.hs>-    .-    <https://github.com/philopon/apiary/blob/master/examples/embed_key.hs> license:             MIT license-file:        LICENSE author:              HirotomoMoriwaki<philopon.dependence@gmail.com>@@ -23,25 +21,19 @@ cabal-version:       >=1.10  library-  exposed-modules:     Web.Apiary.ClientSession-  other-modules:       Web.Apiary.ClientSession.Internal+  exposed-modules:     Web.Apiary.Session.ClientSession   build-depends:       base               >=4.6   && <4.8-                     , template-haskell-                     , clientsession      >=0.9   && <0.10-                     , apiary             >=1.1   && <1.2-                     , apiary-cookie      >=1.1   && <1.2--                     , directory          >=1.2   && <1.3-                     , crypto-random      >=0.0   && <0.1-                     , cprng-aes          >=0.5   && <0.6+                     , apiary             >=1.2   && <1.3+                     , apiary-cookie      >=1.2   && <1.3+                     , apiary-session     >=1.2   && <1.3 -                     , binary             >=0.7   && <0.8+                     , clientsession      >=0.9   && <0.10+                     , vault              >=0.3   && <0.4+                     , cereal             >=0.4   && <0.5                      , bytestring         >=0.10  && <0.11-                     , base64-bytestring  >=1.0   && <1.1-                     , time               >=1.4   && <1.6+                     , time               >=1.4   && <1.5+                     , unix-compat        >=0.4   && <0.5                      , data-default-class >=0.0   && <0.1-                     , http-types         >=0.8   && <0.9-                     , blaze-html         >=0.7   && <0.8    hs-source-dirs:      src   ghc-options:         -O2 -Wall

@@ -1,71 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}--module Web.Apiary.ClientSession-    ( I.Session-    -- * config-    , I.SessionConfig(..), I.KeySource(..)-    , I.embedKeyConfig, I.embedDefaultKeyConfig-    -- * initializer-    , initSession-    -- * getter-    , getSessionConfig-    -- * setter-    , setSession-    , csrfToken-    -- ** with sessionConfig-    , setSessionWith-    -- * filter-    , I.session-    , I.checkToken-    -- * Reexport-    -- | deleteCookie-    , module Web.Apiary.Cookie-    ) where--import Web.Apiary--import Data.Apiary.Extension-import Data.Apiary.Compat--import Control.Monad.Apiary.Action-import qualified Web.Apiary.ClientSession.Internal as I-import Web.Apiary.Cookie (deleteCookie)-import qualified Data.ByteString as S--initSession :: MonadIO m => I.SessionConfig -> Initializer' m I.Session-initSession c = initializer' $ I.makeSession c--setSession :: (Has I.Session exts, MonadIO m)-           => S.ByteString -> S.ByteString-           -> ActionT exts prms m ()-setSession k v = do-    sess <- getExt (Proxy :: Proxy I.Session)-    I.setSession sess k v--getSessionConfig :: (Has I.Session exts, Monad m)-                 => ActionT exts prms m I.SessionConfig-getSessionConfig = do-    sess <- getExt (Proxy :: Proxy I.Session)-    return $ I.sessionConfig sess--setSessionWith :: (Has I.Session exts, MonadIO m)-               => I.SessionConfig-               -> S.ByteString -> S.ByteString-               -> ActionT exts prms m ()-setSessionWith cfg k v = do-    sess <- getExt (Proxy :: Proxy I.Session)-    I.setSession sess { I.sessionConfig = cfg } k v----- | 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 :: (Has I.Session exts, MonadIO m) => ActionT exts prms m S.ByteString-csrfToken = getExt (Proxy :: Proxy I.Session) >>= I.csrfToken

@@ -1,218 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TypeFamilies #-}--module Web.Apiary.ClientSession.Internal where--import Language.Haskell.TH--import System.Directory--import "crypto-random" Crypto.Random-import Crypto.Random.AESCtr--import Control.Monad-import Control.Applicative-import Control.Monad.Apiary.Filter-import Control.Monad.Apiary.Action--import Web.Apiary.Wai-import Web.Apiary-import Web.Apiary.Cookie-import Web.ClientSession -import qualified Network.HTTP.Types as HTTP--import Data.Apiary.Compat-import Data.Apiary.Param-import Data.Apiary.Extension-import Data.String-import Data.Maybe-import Data.Monoid-import Data.Time-import Data.Default.Class-import Data.Binary-import Data.IORef--import Text.Blaze.Html-import qualified Data.ByteString.Base64 as Base64-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as SC-import qualified Data.ByteString.Lazy as L--data Session = Session-    { sessionKey    :: Key-    , tokenGen      :: IORef AESRNG-    , sessionConfig :: SessionConfig-    }-instance Extension Session--data KeySource-    = KeyFile       FilePath-    | KeyByteString S.ByteString--instance IsString KeySource where-    fromString = KeyByteString . fromString---- | generate and embed key at compile time. since 0.13.2.------ This function embed as SessionsessionConfig with default sessionConfig. so you can sessionConfigure it.--- but DON'T sessionConfigure sessionKey.------ this function is convenient when create heroku project.--- --- @--- embedsessionConfig = $embedDefaultKeysessionConfig { csrfTokenCookieName = \"foo\" }--- @-embedKeyConfig :: FilePath -> ExpQ-embedKeyConfig keyfile = do-    bs <- runIO $ do-        exists <- doesFileExist keyfile-        if exists-            then do -                b <- S.readFile keyfile-                case initKey b of-                    Left  _ -> newKey-                    Right _ -> return b-        else newKey-    let s = stringE $ SC.unpack bs-    [| def { sessionKeySource = KeyByteString $s } |]-  where-    newKey = do-        (bs, _) <- randomKey-        S.writeFile keyfile bs-        return bs--embedDefaultKeyConfig :: ExpQ-embedDefaultKeyConfig = embedKeyConfig defaultKeyFile--data SessionConfig = SessionConfig-    { sessionKeySource      :: KeySource-    , sessionMaxAge         :: DiffTime-    , sessionPath           :: Maybe S.ByteString-    , sessionDomain         :: Maybe S.ByteString-    , sessionHttpOnly       :: Bool-    , sessionSecure         :: Bool--    , sessionTimeoutAction  :: forall exts prms m. MonadIO m => ActionT exts prms m ()--    , angularXsrfCookieName :: Maybe S.ByteString-    , csrfTokenCookieName   :: S.ByteString--    , csrfTokenCheckingName :: Either HTTP.HeaderName S.ByteString-    , csrfTokenLength       :: Int-    }--defaultCheckTokenFailAction :: Monad actM => ActionT exts prms actM ()-defaultCheckTokenFailAction = do-    reset-    status status401-    bytes "session timeout\n"-    stop--instance Default SessionConfig where-    def = SessionConfig-        (KeyFile defaultKeyFile) (24 * 60 * 60) Nothing Nothing True True-        defaultCheckTokenFailAction Nothing "_token" (Right "_token") 40--makeSession :: MonadIO m => SessionConfig -> m Session-makeSession cfg@SessionConfig{..} = do-    k <- liftIO $ case sessionKeySource of-        KeyFile       f -> getKey f-        KeyByteString s -> either fail return $ initKey s-    p <- liftIO $ makeSystem >>= newIORef-    let sess = Session k p cfg-    return sess--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 skey k v = do-    t <- getCurrentTime-    let expire = addUTCTime (realToFrac $ sessionMaxAge conf) t-    v' <- encryptIO skey $ L.toStrict $ encode (BinUTCTime expire, v)-    return def { setCookieName     = k-               , setCookieValue    = v'-               , setCookiePath     = sessionPath conf-               , setCookieExpires  = Just expire-               , setCookieMaxAge   = Just (sessionMaxAge conf)-               , setCookieDomain   = sessionDomain conf-               , setCookieHttpOnly = sessionHttpOnly conf-               , setCookieSecure   = sessionSecure conf-               }--getSessionValue :: Session -> UTCTime -- ^ current time-                -> S.ByteString -                -> Maybe S.ByteString-getSessionValue Session{sessionKey = 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--setSession :: MonadIO m => Session -> S.ByteString -> S.ByteString -> ActionT exts prms m ()-setSession sess k v = do-    s <- liftIO $ mkSessionCookie (sessionConfig sess) (sessionKey sess) k v-    setCookie s--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)--csrfToken :: MonadIO m => Session -> ActionT exts prms m S.ByteString-csrfToken Session{..} = do-    tok <- liftIO $ newToken (csrfTokenLength sessionConfig) tokenGen -    sc <- liftIO $ mkSessionCookie sessionConfig sessionKey (csrfTokenCookieName sessionConfig) tok-    setCookie sc-    maybe (return ()) (setCookie . ngCookie sc tok) (angularXsrfCookieName sessionConfig)-    return tok-  where-    ngCookie sc tok k = sc { setCookieName     = k-                           , setCookieValue    = tok-                           , setCookieHttpOnly = False-                           }--session :: (MonadIO actM, Strategy w, Has Session exts, KnownSymbol k, NotMember k prms, Query a)-        => proxy k -> w a -> ApiaryT exts (SNext w k a prms) actM m () -> ApiaryT exts prms actM m ()-session k p = focus (DocPrecondition $ toHtml (symbolVal k) <> " session cookie required") $ do-    sess <- getExt (Proxy :: Proxy Session)-    t    <- liftIO getCurrentTime-    c    <- map (readQuery . getSessionValue sess t . snd) .-        filter ((SC.pack (symbolVal k) ==) . fst) . cookie' <$> getRequest-    strategy p k c =<< getParams--checkToken :: (MonadIO actM, Has Session exts)-           => ApiaryT exts prms actM m ()-           -> ApiaryT exts prms actM m ()-checkToken = focus (DocPrecondition "CSRF token required") $ do-    sess@Session{..} <- getExt (Proxy :: Proxy Session)-    qs <- getQueryParams-    r  <- getRequest-    p  <- getReqBodyParams--    t <- liftIO getCurrentTime-    let stok = getSessionValue sess t =<< -               lookup (csrfTokenCookieName sessionConfig) (cookie' r)-    guard (isJust stok)-    -    qtok <- return . join $ case csrfTokenCheckingName sessionConfig of-        Right name -> lookup name $ reqParams pByteString qs p []-        Left name  -> lookup name $ map (\(k,v) -> (k, Just v)) $ requestHeaders r-    guard (isJust qtok)--    if qtok == stok then getParams else sessionTimeoutAction sessionConfig >> mzero

@@ -0,0 +1,108 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE LambdaCase #-}++module Web.Apiary.Session.ClientSession+    ( ClientSessionConfig(..)+    , initClientSession+    , module Web.Apiary.Session+    ) where++import Web.Apiary(MonadIO(..))+import Web.Apiary.Session+import Web.Apiary.Session.Internal+    (Session(Session), SessionBackend(backendMiddleware', genBackendModify))+import Web.Apiary.Cookie(getCookies, deleteCookie, SetCookie(..), setCookie)+import Data.Apiary.Extension(Initializer', initializer')++import Control.Monad.Apiary.Action(insertVault, lookupVault, deleteVault)+import Control.Applicative ((<$))++import Foreign.C.Types(CTime(..))++import System.PosixCompat.Time(epochTime)++import Data.Time(DiffTime, addUTCTime)+import Data.Time.Clock.POSIX(posixSecondsToUTCTime)+import qualified Data.ByteString as S+import qualified Data.Serialize as Serialize+import qualified Data.Vault.Lazy as Vault+import Data.Default.Class(Default(def))++import qualified Web.ClientSession as CS++data ClientSessionConfig = ClientSessionConfig+    { csCookieName     :: S.ByteString+    , csCookiePath     :: Maybe S.ByteString+    , csCookieDomain   :: Maybe S.ByteString+    , csCookieHttpOnly :: Bool+    , csCookieSecure   :: Bool+    , csTTL            :: Maybe DiffTime+    , csSessionKey     :: IO CS.Key+    }++data ClientSessionBackend sess (m :: * -> *) = ClientSessionBackend+    { clientSessionEncryptKey :: CS.Key+    , clientSessionVaultKey   :: Vault.Key sess+    , clientSessionConfig     :: ClientSessionConfig+    }++instance Default ClientSessionConfig where+    def = ClientSessionConfig "_sess" (Just "/") Nothing True True+        (Just $ 7 * 24 * 60 * 60) (liftIO CS.getDefaultKey)++initClientSession :: (MonadIO m, Serialize.Serialize sess)+                  => proxy sess -- ^ session type to initialize.+                  -> ClientSessionConfig+                  -> Initializer' m (Session sess m)+initClientSession _ cfg = initializer' $ do+    eKey <- liftIO $ csSessionKey cfg+    vKey <- liftIO Vault.newKey+    return $ Session (ClientSessionBackend eKey vKey cfg)++instance (Serialize.Serialize sess, MonadIO m) => SessionBackend (ClientSessionBackend sess m) sess m where+    backendMiddleware' ClientSessionBackend{clientSessionConfig = ClientSessionConfig{..}, ..} m = do+        cs  <- getCookies+        mbNow <- case lookup csCookieName cs >>= CS.decrypt clientSessionEncryptKey >>=+            either (const Nothing) Just . Serialize.decode of+                Nothing     -> return Nothing+                Just (t, v) -> do+                    case csTTL of+                        Nothing  -> Nothing <$ insertVault clientSessionVaultKey v+                        Just ttl -> do+                            CTime now <- liftIO epochTime+                            if t + round ttl < now+                            then return (Just now)+                            else Just now <$ insertVault clientSessionVaultKey v+        m+        lookupVault clientSessionVaultKey >>= \case+            Nothing -> deleteCookie csCookieName+            Just v  -> do+                now <- maybe (liftIO epochTime >>= \(CTime i) -> return i) return mbNow+                v'  <- liftIO . CS.encryptIO clientSessionEncryptKey $ Serialize.encode (now, v)+                let cCookie = def+                        { setCookieName     = csCookieName+                        , setCookieValue    = v'+                        , setCookiePath     = csCookiePath+                        , setCookieDomain   = csCookieDomain+                        , setCookieHttpOnly = csCookieHttpOnly+                        , setCookieSecure   = csCookieSecure+                        }+                case csTTL of+                    Nothing -> setCookie cCookie+                    Just d  -> do+                        let now' = posixSecondsToUTCTime $ realToFrac now+                        setCookie cCookie+                            { setCookieMaxAge  = Just d+                            , setCookieExpires = Just (addUTCTime (realToFrac d) now')+                            }++    genBackendModify ClientSessionBackend{clientSessionConfig = ClientSessionConfig{..}, ..} f = do+        sess       <- lookupVault clientSessionVaultKey+        (sess', a) <- f sess+        maybe (deleteVault clientSessionVaultKey) (insertVault clientSessionVaultKey) sess'+        return a