diff --git a/apiary-clientsession.cabal b/apiary-clientsession.cabal --- a/apiary-clientsession.cabal +++ b/apiary-clientsession.cabal @@ -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: @@ -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 diff --git a/src/Web/Apiary/ClientSession.hs b/src/Web/Apiary/ClientSession.hs --- a/src/Web/Apiary/ClientSession.hs +++ b/src/Web/Apiary/ClientSession.hs @@ -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 diff --git a/src/Web/Apiary/ClientSession/Explicit.hs b/src/Web/Apiary/ClientSession/Explicit.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/ClientSession/Explicit.hs @@ -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) diff --git a/src/Web/Apiary/ClientSession/Internal.hs b/src/Web/Apiary/ClientSession/Internal.hs --- a/src/Web/Apiary/ClientSession/Internal.hs +++ b/src/Web/Apiary/ClientSession/Internal.hs @@ -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 +