diff --git a/apiary-clientsession.cabal b/apiary-clientsession.cabal --- a/apiary-clientsession.cabal +++ b/apiary-clientsession.cabal @@ -1,14 +1,12 @@ name: apiary-clientsession -version: 1.1.0 +version: 1.2.0 synopsis: clientsession support for apiary web framework. description: examples: . - + . - . - license: MIT license-file: LICENSE author: HirotomoMoriwaki @@ -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 diff --git a/src/Web/Apiary/ClientSession.hs b/src/Web/Apiary/ClientSession.hs deleted file mode 100644 --- a/src/Web/Apiary/ClientSession.hs +++ /dev/null @@ -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 diff --git a/src/Web/Apiary/ClientSession/Internal.hs b/src/Web/Apiary/ClientSession/Internal.hs deleted file mode 100644 --- a/src/Web/Apiary/ClientSession/Internal.hs +++ /dev/null @@ -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 diff --git a/src/Web/Apiary/Session/ClientSession.hs b/src/Web/Apiary/Session/ClientSession.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Session/ClientSession.hs @@ -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