feat(serversessions): move session storage to dedicated memcached
fixes #390
This commit is contained in:
Gregor Kleen
parent
26f8f392a9
commit
996005935d
@ -31,8 +31,8 @@ notification-rate-limit: 3600
|
||||
notification-collate-delay: 7200
|
||||
notification-expiration: 259200
|
||||
session-timeout: 7200
|
||||
jwt-expiration: 604800
|
||||
jwt-encoding: HS256
|
||||
bearer-expiration: 604800
|
||||
bearer-encoding: HS256
|
||||
maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
|
||||
session-files-expire: 3600
|
||||
prune-unreferenced-files: 86400
|
||||
@ -67,6 +67,7 @@ ip-retention-time: 1209600
|
||||
# Debugging
|
||||
auth-dummy-login: "_env:DUMMY_LOGIN:false"
|
||||
allow-deprecated: "_env:ALLOW_DEPRECATED:false"
|
||||
server-session-acid-fallback: "_env:SERVER_SESSION_ACID_FALLBACK:false"
|
||||
|
||||
auth-pw-hash:
|
||||
algorithm: "pbkdf2"
|
||||
@ -119,13 +120,32 @@ smtp:
|
||||
limit: "_env:SMTPLIMIT:10"
|
||||
|
||||
widget-memcached:
|
||||
host: "_env:MEMCACHEDHOST:"
|
||||
port: "_env:MEMCACHEDPORT:11211"
|
||||
host: "_env:WIDGET_MEMCACHED_HOST:"
|
||||
port: "_env:WIDGET_MEMCACHED_PORT:11211"
|
||||
auth: []
|
||||
limit: "_env:MEMCACHEDLIMIT:10"
|
||||
timeout: "_env:MEMCACHEDTIMEOUT:20"
|
||||
base-url: "_env:MEMCACHEDROOT:"
|
||||
expiration: "_env:MEMCACHEDEXPIRATION:3600"
|
||||
limit: "_env:WIDGET_MEMCACHED_LIMIT:10"
|
||||
timeout: "_env:WIDGET_MEMCACHED_TIMEOUT:20"
|
||||
base-url: "_env:WIDGET_MEMCACHED_ROOT:"
|
||||
expiration: "_env:WIDGET_MEMCACHED_EXPIRATION:3600"
|
||||
|
||||
session-memcached:
|
||||
host: "_env:SESSION_MEMCACHED_HOST:"
|
||||
port: "_env:SESSION_MEMCACHED_PORT:11211"
|
||||
auth: []
|
||||
limit: "_env:SESSION_MEMCACHED_LIMIT:10"
|
||||
timeout: "_env:SESSION_MEMCACHED_TIMEOUT:20"
|
||||
expiration: "_env:SESSION_MEMCACHED_EXPIRATION:28807"
|
||||
|
||||
server-sessions:
|
||||
cookie-name: "_SESSION"
|
||||
idle-timeout: 28807
|
||||
absolute-timeout: 604801
|
||||
timeout-resolution: 601
|
||||
persistent-cookies: true
|
||||
http-only-cookies: true
|
||||
secure-cookies: "_env:SERVER_SESSION_COOKIES_SECURE:true"
|
||||
session-token-expiration: 28807
|
||||
session-token-encoding: HS256
|
||||
|
||||
user-defaults:
|
||||
max-favourites: 12
|
||||
|
||||
12
ghci.sh
12
ghci.sh
@ -4,10 +4,16 @@ set -e
|
||||
|
||||
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
|
||||
|
||||
export DETAILED_LOGGING=${DETAILED_LOGGING:-true}
|
||||
export LOG_ALL=${LOG_ALL:-false}
|
||||
export LOGLEVEL=${LOGLEVEL:-info}
|
||||
export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
|
||||
export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
|
||||
export SERVER_SESSION_COOKIES_SECURE=${SERVER_SESSION_COOKIES_SECURE:-false}
|
||||
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
|
||||
export RIBBON=${RIBBON:-${__HOST:-localhost}}
|
||||
unset HOST
|
||||
export DETAILED_LOGGING=true
|
||||
export LOG_ALL=true
|
||||
export DUMMY_LOGIN=true
|
||||
|
||||
|
||||
move-back() {
|
||||
mv -v .stack-work .stack-work-ghci
|
||||
|
||||
@ -61,6 +61,7 @@ dependencies:
|
||||
- cryptoids
|
||||
- cryptoids-class
|
||||
- binary
|
||||
- binary-instances
|
||||
- cereal
|
||||
- mtl
|
||||
- esqueleto >=3.1.0
|
||||
@ -103,7 +104,9 @@ dependencies:
|
||||
- postgresql-simple
|
||||
- word24
|
||||
- mmorph
|
||||
- clientsession
|
||||
- serversession
|
||||
- serversession-backend-acid-state
|
||||
- acid-state
|
||||
- monad-memo
|
||||
- xss-sanitize
|
||||
- text-metrics
|
||||
|
||||
@ -18,7 +18,7 @@ module Application
|
||||
|
||||
import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
|
||||
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
|
||||
pgPoolSize, runSqlPool)
|
||||
pgPoolSize, runSqlPool, ConnectionPool)
|
||||
import Import hiding (cancel)
|
||||
import Language.Haskell.TH.Syntax (qLocation)
|
||||
import Network.Wai (Middleware)
|
||||
@ -88,6 +88,9 @@ import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils.Routes (classifyHandler)
|
||||
|
||||
import qualified Data.Acid.Memory as Acid
|
||||
import qualified Web.ServerSession.Backend.Acid as Acid
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
import Handler.News
|
||||
@ -125,7 +128,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
|
||||
-- performs initialization and returns a foundation datatype value. This is also
|
||||
-- the place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX
|
||||
makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadThrow m) => AppSettings -> m UniWorX
|
||||
makeFoundation appSettings'@AppSettings{..} = do
|
||||
registerGHCMetrics
|
||||
|
||||
@ -168,7 +171,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
-- logging function. To get out of this loop, we initially create a
|
||||
-- temporary foundation without a real connection pool, get a log function
|
||||
-- from there, and then create the real foundation.
|
||||
let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..}
|
||||
let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..}
|
||||
-- The UniWorX {..} syntax is an example of record wild cards. For more
|
||||
-- information, see:
|
||||
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
||||
@ -177,7 +180,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
(error "smtpPool forced in tempFoundation")
|
||||
(error "ldapPool forced in tempFoundation")
|
||||
(error "cryptoIDKey forced in tempFoundation")
|
||||
(error "sessionKey forced in tempFoundation")
|
||||
(error "sessionStore forced in tempFoundation")
|
||||
(error "secretBoxKey forced in tempFoundation")
|
||||
(error "widgetMemcached forced in tempFoundation")
|
||||
(error "JSONWebKeySet forced in tempFoundation")
|
||||
@ -191,9 +194,9 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
$logDebugS "setup" "SMTP-Pool"
|
||||
createSmtpPool c
|
||||
|
||||
appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do
|
||||
appWidgetMemcached <- for appWidgetMemcachedConf $ \WidgetMemcachedConf{ widgetMemcachedConf } -> do
|
||||
$logDebugS "setup" "Widget-Memcached"
|
||||
createWidgetMemcached c
|
||||
createMemcached widgetMemcachedConf
|
||||
|
||||
-- Create the database connection pool
|
||||
$logDebugS "setup" "PostgreSQL-Pool"
|
||||
@ -215,17 +218,42 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
liftIO . exitWith $ ExitFailure 2
|
||||
$logDebugS "setup" "Cluster-Config"
|
||||
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
|
||||
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
|
||||
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
|
||||
appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
|
||||
appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool
|
||||
|
||||
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID
|
||||
appSessionStore <- mkSessionStore appSettings' sqlPool `runSqlPool` sqlPool
|
||||
|
||||
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID
|
||||
|
||||
-- Return the foundation
|
||||
$logDebugS "setup" "Done"
|
||||
return foundation
|
||||
|
||||
data SessionStoreException
|
||||
= SessionStoreNotAvailable
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception SessionStoreException
|
||||
|
||||
mkSessionStore :: forall m.
|
||||
( MonadIO m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
)
|
||||
=> AppSettings -> ConnectionPool -> ReaderT SqlBackend m SomeSessionStorage
|
||||
mkSessionStore AppSettings{..} mcdSqlConnPool
|
||||
| Just mcdConf@MemcachedConf{..} <- appSessionMemcachedConf = do
|
||||
mcdSqlMemcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterServerSessionKey)
|
||||
$logDebugS "setup" "Session-Memcached"
|
||||
mcdSqlMemcached <- createMemcached mcdConf
|
||||
let mcdSqlMemcachedExpiration = memcachedExpiry
|
||||
return $ _SessionStorageMemcachedSql # MemcachedSqlStorage{..}
|
||||
| appServerSessionAcidFallback = liftIO $
|
||||
review _SessionStorageAcid . Acid.AcidStorage <$> Acid.openMemoryState Acid.emptyState
|
||||
| otherwise = throwM SessionStoreNotAvailable
|
||||
|
||||
|
||||
clusterSetting :: forall key m p.
|
||||
( MonadIO m
|
||||
, ClusterSetting key
|
||||
@ -285,8 +313,8 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
|
||||
return conn
|
||||
liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
|
||||
|
||||
createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection
|
||||
createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close
|
||||
createMemcached :: (MonadLogger m, MonadResource m) => MemcachedConf -> m Memcached.Connection
|
||||
createMemcached MemcachedConf{memcachedConnectInfo} = snd <$> allocate (Memcached.connect memcachedConnectInfo) Memcached.close
|
||||
|
||||
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
|
||||
-- applying some additional middlewares.
|
||||
|
||||
@ -9,11 +9,6 @@ import ClassyPrelude
|
||||
import Data.Aeson.Types (Parser, Value)
|
||||
import Control.Monad.Catch
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import Data.HashMap.Strict.Instances ()
|
||||
import Data.Vector.Instances ()
|
||||
|
||||
import Model.Types.TH.JSON (derivePersistFieldJSON)
|
||||
|
||||
import Control.Monad.Fail
|
||||
@ -22,7 +17,5 @@ import Control.Monad.Fail
|
||||
instance MonadThrow Parser where
|
||||
throwM = fail . show
|
||||
|
||||
instance Binary Value
|
||||
|
||||
|
||||
derivePersistFieldJSON ''Value
|
||||
|
||||
@ -26,9 +26,6 @@ import qualified Database.Esqueleto as E
|
||||
|
||||
import Web.HttpApiData
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
|
||||
@ -99,11 +96,6 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
|
||||
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
|
||||
toPathMultiPiece = toPathMultiPiece . CI.original
|
||||
|
||||
instance (CI.FoldCase s, Binary s) => Binary (CI s) where
|
||||
get = CI.mk <$> Binary.get
|
||||
put = Binary.put . CI.original
|
||||
putList = Binary.putList . map CI.original
|
||||
|
||||
instance Csv.ToField s => Csv.ToField (CI s) where
|
||||
toField = Csv.toField . CI.original
|
||||
|
||||
|
||||
@ -1,15 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.HashMap.Strict.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.Binary (Binary(..))
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
|
||||
instance (Binary k, Binary v, Hashable k, Eq k) => Binary (HashMap k v) where
|
||||
put = put . HashMap.toList
|
||||
get = HashMap.fromList <$> get
|
||||
@ -1,16 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.HashSet.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.Binary (Binary(..))
|
||||
|
||||
|
||||
instance (Binary a, Hashable a, Eq a) => Binary (HashSet a) where
|
||||
get = HashSet.fromList <$> get
|
||||
put = put . HashSet.toList
|
||||
@ -6,7 +6,6 @@ module Data.Time.Calendar.Instances
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import Data.Time.Calendar
|
||||
|
||||
@ -14,7 +13,6 @@ import Data.Universe
|
||||
|
||||
|
||||
deriving newtype instance Hashable Day
|
||||
deriving newtype instance Binary Day
|
||||
|
||||
deriving instance Ord DayOfWeek
|
||||
instance Universe DayOfWeek where
|
||||
|
||||
@ -9,9 +9,6 @@ import Database.Persist.Sql
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Calendar.Instances ()
|
||||
import Web.PathPieces
|
||||
@ -44,10 +41,3 @@ instance Csv.ToField UTCTime where
|
||||
|
||||
instance Csv.FromField UTCTime where
|
||||
parseField = iso8601ParseM <=< Csv.parseField
|
||||
|
||||
|
||||
instance Binary DiffTime where
|
||||
get = fromRational <$> Binary.get
|
||||
put = Binary.put . toRational
|
||||
|
||||
instance Binary UTCTime
|
||||
|
||||
@ -8,8 +8,6 @@ import ClassyPrelude
|
||||
|
||||
import Data.Time.LocalTime
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
|
||||
@ -17,7 +15,6 @@ deriving instance Generic TimeOfDay
|
||||
deriving instance Typeable TimeOfDay
|
||||
|
||||
instance Hashable TimeOfDay
|
||||
instance Binary TimeOfDay
|
||||
|
||||
|
||||
deriving instance TH.Lift TimeZone
|
||||
|
||||
@ -1,17 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Vector.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
instance Binary a => Binary (Vector a) where
|
||||
get = Vector.fromList <$> Binary.get
|
||||
put = Binary.put . Vector.toList
|
||||
@ -13,6 +13,7 @@ import Database.Persist.Sql
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
import Data.Binary.Instances ()
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
@ -11,6 +11,7 @@ import Database.Persist.Types
|
||||
import Data.Time.Calendar.Instances ()
|
||||
import Data.Time.LocalTime.Instances ()
|
||||
import Data.Time.Clock.Instances ()
|
||||
import Data.Binary.Instances ()
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
|
||||
@ -97,6 +97,9 @@ import qualified Ldap.Client as Ldap
|
||||
|
||||
import UnliftIO.Pool
|
||||
|
||||
import qualified Web.ServerSession.Core as ServerSession
|
||||
import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB = YesodDB UniWorX
|
||||
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
|
||||
@ -298,7 +301,7 @@ trueAP = APPure . const . const . const $ trueAR <$> ask
|
||||
falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
|
||||
|
||||
|
||||
askTokenUnsafe :: forall m.
|
||||
askBearerUnsafe :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
@ -307,23 +310,23 @@ askTokenUnsafe :: forall m.
|
||||
-- | This performs /no/ meaningful validation of the `BearerToken`
|
||||
--
|
||||
-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
|
||||
askTokenUnsafe = $cachedHere $ do
|
||||
jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
|
||||
catch (decodeToken jwt) $ \case
|
||||
askBearerUnsafe = $cachedHere $ do
|
||||
bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer
|
||||
catch (decodeBearer bearer) $ \case
|
||||
BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
|
||||
BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
|
||||
other -> do
|
||||
$logWarnS "AuthToken" $ tshow other
|
||||
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
|
||||
|
||||
validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
|
||||
validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
|
||||
validateBearer :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
|
||||
validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token'
|
||||
where
|
||||
validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
|
||||
validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
|
||||
guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
|
||||
validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
|
||||
validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
|
||||
guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
|
||||
|
||||
tokenAuthority' <- case tokenAuthority of
|
||||
bearerAuthority' <- case bearerAuthority of
|
||||
Left tVal
|
||||
| JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
|
||||
Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
|
||||
@ -331,8 +334,8 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
|
||||
| otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
|
||||
Right uid -> return uid
|
||||
|
||||
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority'
|
||||
guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
|
||||
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get bearerAuthority'
|
||||
guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
|
||||
|
||||
let
|
||||
-- Prevent infinite loops
|
||||
@ -341,10 +344,10 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
|
||||
|
||||
authorityVal <- do
|
||||
dnf <- either throwM return $ routeAuthTags route
|
||||
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority') route isWrite
|
||||
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just bearerAuthority') route isWrite
|
||||
guardExceptT (is _Authorized authorityVal) authorityVal
|
||||
|
||||
whenIsJust tokenAddAuth $ \addDNF -> do
|
||||
whenIsJust bearerAddAuth $ \addDNF -> do
|
||||
$logDebugS "validateToken" $ tshow addDNF
|
||||
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
|
||||
guardExceptT (is _Authorized additionalVal) additionalVal
|
||||
@ -447,7 +450,7 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
||||
return Authorized
|
||||
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
|
||||
lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
|
||||
lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
|
||||
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
|
||||
AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
|
||||
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
@ -1466,11 +1469,31 @@ instance Yesod UniWorX where
|
||||
Nothing -> getApprootText guessApproot app req
|
||||
Just root -> root
|
||||
|
||||
-- Store session data on the client in encrypted cookies,
|
||||
-- default session idle timeout is 120 minutes
|
||||
makeSessionBackend app = do
|
||||
(getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout)
|
||||
return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = case appSessionStore of
|
||||
SessionStorageMemcachedSql sqlStore
|
||||
-> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
|
||||
SessionStorageAcid acidStore
|
||||
| appServerSessionAcidFallback
|
||||
-> mkBackend =<< stateSettings <$> ServerSession.createState acidStore
|
||||
_other
|
||||
-> return Nothing
|
||||
where
|
||||
cfg = JwtSession.ServerSessionJwtConfig
|
||||
{ sJwtJwkSet = appJSONWebKeySet
|
||||
, sJwtStart = Nothing
|
||||
, sJwtExpiration = appSessionTokenExpiration
|
||||
, sJwtEncoding = appSessionTokenEncoding
|
||||
, sJwtIssueBy = appInstanceID
|
||||
, sJwtIssueFor = appClusterID
|
||||
}
|
||||
mkBackend :: forall sto.
|
||||
( ServerSession.SessionData sto ~ Map Text ByteString
|
||||
, ServerSession.Storage sto
|
||||
)
|
||||
=> ServerSession.State sto -> IO (Maybe SessionBackend)
|
||||
mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
|
||||
stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
|
||||
stateSettings = applyServerSessionSettings appServerSessionConfig
|
||||
|
||||
maximumContentLength app _ = app ^. _appMaximumContentLength
|
||||
|
||||
@ -1567,8 +1590,8 @@ instance Yesod UniWorX where
|
||||
|
||||
addStaticContent ext _mime content = do
|
||||
UniWorX{appWidgetMemcached, appSettings'} <- getYesod
|
||||
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
|
||||
let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
|
||||
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
|
||||
let expiry = maybe 0 ceiling memcachedExpiry
|
||||
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
|
||||
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
|
||||
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
|
||||
|
||||
@ -1,14 +1,14 @@
|
||||
module Foundation.Type
|
||||
( UniWorX(..)
|
||||
, SomeSessionStorage(..)
|
||||
, _SessionStorageMemcachedSql, _SessionStorageAcid
|
||||
, SMTPPool
|
||||
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionKey, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
|
||||
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Database.Persist.Sql (ConnectionPool)
|
||||
|
||||
import qualified Web.ClientSession as ClientSession
|
||||
|
||||
import Jobs.Types
|
||||
|
||||
import Yesod.Core.Types (Logger)
|
||||
@ -21,33 +21,41 @@ import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
type SMTPPool = Pool SMTPConnection
|
||||
|
||||
data SomeSessionStorage
|
||||
= SessionStorageMemcachedSql { sessionStorageMemcachedSql :: MemcachedSqlStorage SessionMap }
|
||||
| SessionStorageAcid { sessionStorageAcid :: AcidStorage SessionMap }
|
||||
|
||||
makePrisms ''SomeSessionStorage
|
||||
|
||||
-- | The foundation datatype for your application. This can be a good place to
|
||||
-- keep settings and values requiring initialization before your application
|
||||
-- starts running, such as database connections. Every handler will have
|
||||
-- access to the data present here.
|
||||
data UniWorX = UniWorX
|
||||
{ appSettings' :: AppSettings
|
||||
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
|
||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||
, appSmtpPool :: Maybe SMTPPool
|
||||
, appLdapPool :: Maybe LdapPool
|
||||
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: (ReleaseKey, TVar Logger)
|
||||
, appLogSettings :: TVar LogSettings
|
||||
, appCryptoIDKey :: CryptoIDKey
|
||||
, appClusterID :: ClusterId
|
||||
, appInstanceID :: InstanceId
|
||||
, appJobState :: TMVar JobState
|
||||
, appSessionKey :: ClientSession.Key
|
||||
, appSecretBoxKey :: SecretBox.Key
|
||||
, appJSONWebKeySet :: Jose.JwkSet
|
||||
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
|
||||
{ appSettings' :: AppSettings
|
||||
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
|
||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||
, appSmtpPool :: Maybe SMTPPool
|
||||
, appLdapPool :: Maybe LdapPool
|
||||
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: (ReleaseKey, TVar Logger)
|
||||
, appLogSettings :: TVar LogSettings
|
||||
, appCryptoIDKey :: CryptoIDKey
|
||||
, appClusterID :: ClusterId
|
||||
, appInstanceID :: InstanceId
|
||||
, appJobState :: TMVar JobState
|
||||
, appSessionStore :: SomeSessionStorage
|
||||
, appSecretBoxKey :: SecretBox.Key
|
||||
, appJSONWebKeySet :: Jose.JwkSet
|
||||
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
|
||||
}
|
||||
|
||||
makeLenses_ ''UniWorX
|
||||
instance HasInstanceID UniWorX InstanceId where
|
||||
instanceID = _appInstanceID
|
||||
instance HasClusterID UniWorX ClusterId where
|
||||
clusterID = _appClusterID
|
||||
instance HasJSONWebKeySet UniWorX Jose.JwkSet where
|
||||
jsonWebKeySet = _appJSONWebKeySet
|
||||
instance HasHttpManager UniWorX Manager where
|
||||
|
||||
@ -23,11 +23,11 @@ getMetricsR = selectRep $ do
|
||||
metricsHtml = do
|
||||
samples <- collectMetrics
|
||||
|
||||
metricsToken <- runMaybeT . hoist runDB $ do
|
||||
metricsBearer <- runMaybeT . hoist runDB $ do
|
||||
uid <- MaybeT maybeAuthId
|
||||
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
|
||||
|
||||
encodeToken =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
|
||||
encodeBearer =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI MsgTitleMetrics
|
||||
|
||||
@ -766,8 +766,8 @@ postUserNotificationR cID = do
|
||||
uid <- decrypt cID
|
||||
User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
|
||||
|
||||
((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
|
||||
mJwt <- askJwt
|
||||
((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
|
||||
mBearer <- askBearer
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
let formWidget = wrapForm nsInnerWdgt def
|
||||
{ formAction = Just . SomeRoute $ UserNotificationR cID
|
||||
@ -775,7 +775,7 @@ postUserNotificationR cID = do
|
||||
, formAttrs = [ asyncSubmitAttr | isModal ]
|
||||
}
|
||||
|
||||
formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
|
||||
formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \ns -> do
|
||||
lift . runDB $ update uid [ UserNotificationSettings =. ns ]
|
||||
tell . pure =<< messageI Success MsgNotificationSettingsUpdate
|
||||
|
||||
@ -800,12 +800,12 @@ getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html
|
||||
getSetDisplayEmailR = postSetDisplayEmailR
|
||||
postSetDisplayEmailR = do
|
||||
uid <- requireAuthId
|
||||
mDisplayEmail <- requireCurrentTokenRestrictions
|
||||
mDisplayEmail <- requireCurrentBearerRestrictions
|
||||
|
||||
case mDisplayEmail of
|
||||
Nothing -> invalidArgs ["Bearer token required"]
|
||||
Just displayEmail -> do
|
||||
((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedJwtPost buttonForm
|
||||
((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedBearerPost buttonForm
|
||||
let btnView' = wrapForm btnView def
|
||||
{ formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute SetDisplayEmailR
|
||||
|
||||
@ -476,13 +476,13 @@ postUserPasswordR cID = do
|
||||
[ False <$ guard (isn't _AuthPWHash userAuthentication)
|
||||
, False <$ guard isAdmin
|
||||
, do
|
||||
authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentTokenRestrictions
|
||||
authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
|
||||
unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
|
||||
invalidArgsI [MsgUnauthorizedPasswordResetToken]
|
||||
return False
|
||||
]
|
||||
|
||||
((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
|
||||
((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
|
||||
currentResult <- if
|
||||
| AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
|
||||
, requireCurrent
|
||||
|
||||
@ -218,9 +218,9 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
|
||||
route <- mapReaderT liftHandler $ invitationRoute fEnt dat
|
||||
InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat
|
||||
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
|
||||
let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
||||
jwt <- encodeToken token
|
||||
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
let token = protoToken & bearerRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
||||
bearer <- encodeBearer token
|
||||
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)])
|
||||
jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat
|
||||
jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat)
|
||||
|
||||
@ -228,7 +228,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
|
||||
{ invitationEmail = jInvitee
|
||||
, invitationFor = invRef @junction fid
|
||||
, invitationData = toJSON $ dat ^. _invitationDBData
|
||||
, invitationExpiresAt = tokenExpiresAt token
|
||||
, invitationExpiresAt = bearerExpiresAt token
|
||||
}
|
||||
|
||||
queueDBJob JobInvitation{..}
|
||||
@ -362,7 +362,7 @@ invitationR' :: forall junction m.
|
||||
-> m Html
|
||||
-- | Generic handler for incoming invitations
|
||||
invitationR' InvitationConfig{..} = liftHandler $ do
|
||||
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
|
||||
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentBearerRestrictions :: Handler (InvitationTokenRestriction junction)
|
||||
invitee <- requireAuthId
|
||||
cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute
|
||||
|
||||
@ -379,7 +379,7 @@ invitationR' InvitationConfig{..} = liftHandler $ do
|
||||
iData :: InvitationData junction
|
||||
iData = review _InvitationData (dbData, itData)
|
||||
guardAuthResult =<< hoist lift (invitationRestriction fEnt iData)
|
||||
((dataRes, dataWidget), dataEnctype) <- hoist lift . runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
|
||||
((dataRes, dataWidget), dataEnctype) <- hoist lift . runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
|
||||
dataRes <- aFormToWForm $ invitationForm fEnt iData invitee
|
||||
btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
|
||||
case btnRes of
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Handler.Utils.Tokens
|
||||
( maybeBearerToken, requireBearerToken
|
||||
, maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions
|
||||
, maybeCurrentBearerRestrictions, requireCurrentBearerRestrictions
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -16,32 +16,32 @@ maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
|
||||
|
||||
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
|
||||
requireBearerToken = liftHandler $ do
|
||||
token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
|
||||
bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
|
||||
mAuthId <- maybeAuthId
|
||||
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
|
||||
isWrite <- isWriteRequest currentRoute
|
||||
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
|
||||
return token
|
||||
guardAuthResult <=< runDB $ validateBearer mAuthId currentRoute isWrite bearer
|
||||
return bearer
|
||||
|
||||
requireCurrentTokenRestrictions :: ( MonadHandler m
|
||||
requireCurrentBearerRestrictions :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, FromJSON a
|
||||
, ToJSON a
|
||||
)
|
||||
=> m (Maybe a)
|
||||
requireCurrentTokenRestrictions = runMaybeT $ do
|
||||
token <- requireBearerToken
|
||||
requireCurrentBearerRestrictions = runMaybeT $ do
|
||||
bearer <- requireBearerToken
|
||||
route <- MaybeT getCurrentRoute
|
||||
hoistMaybe $ token ^? _tokenRestrictionIx route
|
||||
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|
||||
|
||||
maybeCurrentTokenRestrictions :: ( MonadHandler m
|
||||
maybeCurrentBearerRestrictions :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, FromJSON a
|
||||
, ToJSON a
|
||||
)
|
||||
=> m (Maybe a)
|
||||
maybeCurrentTokenRestrictions = runMaybeT $ do
|
||||
token <- MaybeT maybeBearerToken
|
||||
maybeCurrentBearerRestrictions = runMaybeT $ do
|
||||
bearer <- MaybeT maybeBearerToken
|
||||
route <- MaybeT getCurrentRoute
|
||||
hoistMaybe $ token ^? _tokenRestrictionIx route
|
||||
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|
||||
|
||||
@ -19,3 +19,6 @@ import Settings.WellKnownFiles as Import
|
||||
|
||||
import CryptoID as Import
|
||||
import Audit as Import
|
||||
|
||||
import Web.ServerSession.Backend.Persistent.Memcached as Import
|
||||
import Web.ServerSession.Backend.Acid as Import (AcidStorage(..))
|
||||
|
||||
@ -61,6 +61,7 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Min(..), Max(..))
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..))
|
||||
import Data.Binary as Import (Binary)
|
||||
import Data.Binary.Instances as Import ()
|
||||
|
||||
import System.FilePath as Import hiding (joinPath, normalise, isValid, makeValid)
|
||||
|
||||
@ -125,9 +126,6 @@ import Data.Sum.Instances as Import ()
|
||||
import Data.Fixed.Instances as Import ()
|
||||
import Data.Scientific.Instances as Import ()
|
||||
import Data.Set.Instances as Import ()
|
||||
import Data.HashMap.Strict.Instances as Import ()
|
||||
import Data.HashSet.Instances as Import ()
|
||||
import Data.Vector.Instances as Import ()
|
||||
import Data.Time.Clock.Instances as Import ()
|
||||
import Data.Time.LocalTime.Instances as Import ()
|
||||
import Data.Time.Calendar.Instances as Import ()
|
||||
|
||||
@ -12,8 +12,8 @@ import Text.Hamlet
|
||||
|
||||
dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
|
||||
dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
|
||||
token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
|
||||
jwt <- encodeToken token
|
||||
bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
|
||||
jwt <- encodeBearer bearer
|
||||
let
|
||||
setDisplayEmailUrl :: SomeRoute UniWorX
|
||||
setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
|
||||
@ -16,7 +16,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
|
||||
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
mkEditNotifications uid = liftHandler $ do
|
||||
cID <- encrypt uid
|
||||
jwt <- encodeToken =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
|
||||
jwt <- encodeBearer =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
|
||||
let
|
||||
editNotificationsUrl :: SomeRoute UniWorX
|
||||
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
|
||||
@ -29,11 +29,11 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
|
||||
LTUUnique utc' _ -> utc'
|
||||
_other -> UTCTime (addDays 2 $ utctDay now) 0
|
||||
|
||||
resetToken' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
|
||||
let resetToken = resetToken'
|
||||
& tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
|
||||
encodedToken <- encodeToken resetToken
|
||||
resetBearer' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
|
||||
let resetBearer = resetBearer'
|
||||
& bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
|
||||
encodedBearer <- encodeBearer resetBearer
|
||||
|
||||
resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedToken)])
|
||||
resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedBearer)])
|
||||
|
||||
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/passwordReset.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
|
||||
@ -43,10 +43,10 @@ dispatchHealthCheckMatchingClusterConfig
|
||||
ourSetting <- getsYesod appCryptoIDKey
|
||||
dbSetting <- clusterSetting @'ClusterCryptoIDKey
|
||||
return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting
|
||||
clusterSettingMatches ClusterClientSessionKey = do
|
||||
ourSetting <- getsYesod appSessionKey
|
||||
dbSetting <- clusterSetting @'ClusterClientSessionKey
|
||||
return $ Just ourSetting == dbSetting
|
||||
clusterSettingMatches ClusterServerSessionKey = do
|
||||
ourSetting <- getsYesod . preview $ _appSessionStore . _SessionStorageMemcachedSql . _mcdSqlMemcachedKey
|
||||
dbSetting <- clusterSetting @'ClusterServerSessionKey
|
||||
return $ maybe True ((== dbSetting) . Just) ourSetting
|
||||
clusterSettingMatches ClusterSecretBoxKey = do
|
||||
ourSetting <- getsYesod appSecretBoxKey
|
||||
dbSetting <- clusterSetting @'ClusterSecretBoxKey
|
||||
|
||||
@ -26,7 +26,7 @@ import Text.Blaze (ToMarkup(..))
|
||||
-- You can find more information on persistent and how to declare entities
|
||||
-- at:
|
||||
-- http://www.yesodweb.com/book/persistent/
|
||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
|
||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"]
|
||||
$(persistDirectoryWith lowerCaseSettings "models")
|
||||
|
||||
|
||||
|
||||
@ -34,6 +34,8 @@ import qualified Net.IPv6 as IPv6
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
|
||||
|
||||
-- Database versions must follow https://pvp.haskell.org:
|
||||
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
|
||||
-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
|
||||
@ -63,6 +65,12 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
|
||||
deriving Show Eq Ord
|
||||
|]
|
||||
|
||||
migrateAll' :: Migration
|
||||
migrateAll' = sequence_
|
||||
[ migrateUniWorX
|
||||
, migrateMemcachedSqlStorage
|
||||
]
|
||||
|
||||
migrateAll :: ( MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadUnliftIO m
|
||||
|
||||
@ -1,150 +1,7 @@
|
||||
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model.Tokens
|
||||
( BearerToken(..)
|
||||
, _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
|
||||
, tokenRestrict
|
||||
, tokenToJSON, tokenParseJSON
|
||||
( module Model.Tokens
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Yesod.Core.Instances ()
|
||||
|
||||
import Model
|
||||
import Utils (assertM')
|
||||
import Utils.Lens hiding ((.=))
|
||||
import Data.Aeson.Lens (AsJSON(..))
|
||||
|
||||
import Yesod.Auth (AuthId)
|
||||
|
||||
import Jose.Jwt (IntDate(..))
|
||||
import qualified Jose.Jwt as Jose
|
||||
|
||||
import Jose.Jwt.Instances ()
|
||||
import Data.Aeson.Types.Instances ()
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.HashMap.Strict.Instances ()
|
||||
import Data.HashSet.Instances ()
|
||||
import Data.Time.Clock.Instances ()
|
||||
|
||||
import Data.Aeson.Types (Parser, (.:?), (.!=))
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Types as JSON
|
||||
|
||||
import CryptoID
|
||||
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
||||
|
||||
|
||||
|
||||
-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
|
||||
data BearerToken site = BearerToken
|
||||
{ tokenIdentifier :: TokenId
|
||||
-- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
|
||||
, tokenAuthority :: Either Value (AuthId site)
|
||||
-- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
|
||||
, tokenRoutes :: Maybe (HashSet (Route site))
|
||||
-- ^ Tokens can optionally be restricted to only be usable on a subset of routes
|
||||
, tokenAddAuth :: Maybe AuthDNF
|
||||
-- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
|
||||
, tokenRestrictions :: HashMap (Route site) Value
|
||||
-- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
|
||||
--
|
||||
-- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
|
||||
, tokenIssuedAt :: UTCTime
|
||||
, tokenIssuedBy :: InstanceId
|
||||
, tokenExpiresAt
|
||||
, tokenStartsAt :: Maybe UTCTime
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
|
||||
deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
|
||||
deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
|
||||
|
||||
instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
|
||||
|
||||
makeLenses_ ''BearerToken
|
||||
|
||||
_tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
|
||||
-- ^ Focus a singular restriction (by route) if it exists
|
||||
--
|
||||
-- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` or `tokenRestrict` instead
|
||||
_tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
|
||||
|
||||
_tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
|
||||
-- ^ Focus a singular restriction (by route) whether it exists, or not
|
||||
_tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
|
||||
|
||||
tokenRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
|
||||
-- ^ Add a restriction to a `BearerToken`
|
||||
--
|
||||
-- If a restriction already exists for the targeted route, it's silently overwritten
|
||||
tokenRestrict route (toJSON -> resVal) = over _tokenRestrictions $ HashMap.insert route resVal
|
||||
|
||||
|
||||
|
||||
tokenToJSON :: forall m.
|
||||
( MonadHandler m
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) m
|
||||
, RenderRoute (HandlerSite m)
|
||||
) => BearerToken (HandlerSite m) -> m Value
|
||||
-- ^ Encode a `BearerToken` analogously to `toJSON`
|
||||
--
|
||||
-- Monadic context is needed because `AuthId`s are encrypted during encoding
|
||||
tokenToJSON BearerToken{..} = do
|
||||
cID <- either (return . Left) (fmap Right . I.encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
|
||||
let stdPayload = Jose.JwtClaims
|
||||
{ jwtIss = Just $ toPathPiece tokenIssuedBy
|
||||
, jwtSub = Nothing
|
||||
, jwtAud = Nothing
|
||||
, jwtExp = IntDate . utcTimeToPOSIXSeconds <$> tokenExpiresAt
|
||||
, jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> tokenStartsAt
|
||||
, jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds tokenIssuedAt
|
||||
, jwtJti = Just $ toPathPiece tokenIdentifier
|
||||
}
|
||||
return . JSON.object $
|
||||
catMaybes [ Just $ "authority" .= either id toJSON cID
|
||||
, ("routes" .=) <$> tokenRoutes
|
||||
, ("add-auth" .=) <$> tokenAddAuth
|
||||
, ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
|
||||
]
|
||||
++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
|
||||
|
||||
tokenParseJSON :: forall site.
|
||||
( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
|
||||
, ParseRoute site
|
||||
, Hashable (Route site)
|
||||
)
|
||||
=> Value
|
||||
-> ReaderT CryptoIDKey Parser (BearerToken site)
|
||||
-- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
|
||||
--
|
||||
-- Monadic context is needed because `AuthId`s are encrypted during encoding
|
||||
--
|
||||
-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
|
||||
tokenParseJSON v@(Object o) = do
|
||||
tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
|
||||
tokenAuthority <- either (return . Left) (fmap Right . I.decrypt) tokenAuthority'
|
||||
|
||||
tokenRoutes <- lift $ o .:? "routes"
|
||||
tokenAddAuth <- lift $ o .:? "add-auth"
|
||||
tokenRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
|
||||
Jose.JwtClaims{..} <- lift $ parseJSON v
|
||||
|
||||
let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
|
||||
|
||||
Just tokenIssuedBy <- return $ jwtIss >>= fromPathPiece
|
||||
Just tokenIdentifier <- return $ jwtJti >>= fromPathPiece
|
||||
Just tokenIssuedAt <- return $ unIntDate <$> jwtIat
|
||||
let tokenExpiresAt = unIntDate <$> jwtExp
|
||||
tokenStartsAt = unIntDate <$> jwtNbf
|
||||
|
||||
return BearerToken{..}
|
||||
tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
|
||||
|
||||
import Model.Tokens.Lens as Model.Tokens
|
||||
import Model.Tokens.Bearer as Model.Tokens
|
||||
import Model.Tokens.Session as Model.Tokens
|
||||
|
||||
164
src/Model/Tokens/Bearer.hs
Normal file
164
src/Model/Tokens/Bearer.hs
Normal file
@ -0,0 +1,164 @@
|
||||
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model.Tokens.Bearer
|
||||
( BearerToken(..)
|
||||
, _bearerIdentifier, _bearerAuthority, _bearerRoutes, _bearerAddAuth, _bearerRestrictions, _bearerRestrictionIx, _bearerRestrictionAt, _bearerIssuedAt, _bearerIssuedBy, _bearerExpiresAt, _bearerStartsAt
|
||||
, bearerRestrict
|
||||
, bearerToJSON, bearerParseJSON
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Yesod.Core.Instances ()
|
||||
|
||||
import Model
|
||||
import Model.Tokens.Lens
|
||||
import Utils (assertM')
|
||||
import Utils.Lens hiding ((.=))
|
||||
import Data.Aeson.Lens (AsJSON(..))
|
||||
|
||||
import Yesod.Auth (AuthId)
|
||||
|
||||
import Jose.Jwt (IntDate(..))
|
||||
import qualified Jose.Jwt as Jose
|
||||
|
||||
import Jose.Jwt.Instances ()
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Time.Clock.Instances ()
|
||||
|
||||
import Data.Aeson.Types (Parser, (.:?), (.!=))
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Types as JSON
|
||||
|
||||
import CryptoID
|
||||
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
||||
|
||||
|
||||
|
||||
-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
|
||||
data BearerToken site = BearerToken
|
||||
{ bearerIdentifier :: TokenId
|
||||
-- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
|
||||
, bearerAuthority :: Either Value (AuthId site)
|
||||
-- ^ Tokens only grant rights the `bearerAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `bearerAuthority`)
|
||||
, bearerRoutes :: Maybe (HashSet (Route site))
|
||||
-- ^ Tokens can optionally be restricted to only be usable on a subset of routes
|
||||
, bearerAddAuth :: Maybe AuthDNF
|
||||
-- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
|
||||
, bearerRestrictions :: HashMap (Route site) Value
|
||||
-- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
|
||||
--
|
||||
-- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
|
||||
, bearerIssuedAt :: UTCTime
|
||||
, bearerIssuedBy :: InstanceId
|
||||
, bearerIssuedFor :: ClusterId
|
||||
, bearerExpiresAt
|
||||
, bearerStartsAt :: Maybe UTCTime
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
|
||||
deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
|
||||
deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
|
||||
|
||||
instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
|
||||
|
||||
makeLenses_ ''BearerToken
|
||||
instance HasTokenIdentifier (BearerToken site) TokenId where
|
||||
_tokenIdentifier = _bearerIdentifier
|
||||
instance HasTokenIssuedBy (BearerToken site) InstanceId where
|
||||
_tokenIssuedBy = _bearerIssuedBy
|
||||
instance HasTokenIssuedFor (BearerToken site) ClusterId where
|
||||
_tokenIssuedFor = _bearerIssuedFor
|
||||
instance HasTokenIssuedAt (BearerToken site) UTCTime where
|
||||
_tokenIssuedAt = _bearerIssuedAt
|
||||
instance HasTokenExpiresAt (BearerToken site) (Maybe UTCTime) where
|
||||
_tokenExpiresAt = _bearerExpiresAt
|
||||
instance HasTokenStartsAt (BearerToken site) (Maybe UTCTime) where
|
||||
_tokenStartsAt = _bearerStartsAt
|
||||
|
||||
_bearerRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
|
||||
-- ^ Focus a singular restriction (by route) if it exists
|
||||
--
|
||||
-- This /cannot/ be used to add restrictions, use `_bearerRestrictionAt` or `bearerRestrict` instead
|
||||
_bearerRestrictionIx route = _bearerRestrictions . ix route . _JSON
|
||||
|
||||
_bearerRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
|
||||
-- ^ Focus a singular restriction (by route) whether it exists, or not
|
||||
_bearerRestrictionAt route = _bearerRestrictions . at route . maybePrism _JSON
|
||||
|
||||
bearerRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
|
||||
-- ^ Add a restriction to a `BearerToken`
|
||||
--
|
||||
-- If a restriction already exists for the targeted route, it's silently overwritten
|
||||
bearerRestrict route (toJSON -> resVal) = over _bearerRestrictions $ HashMap.insert route resVal
|
||||
|
||||
|
||||
|
||||
bearerToJSON :: forall m.
|
||||
( MonadHandler m
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) m
|
||||
, RenderRoute (HandlerSite m)
|
||||
) => BearerToken (HandlerSite m) -> m Value
|
||||
-- ^ Encode a `BearerToken` analogously to `toJSON`
|
||||
--
|
||||
-- Monadic context is needed because `AuthId`s are encrypted during encoding
|
||||
bearerToJSON BearerToken{..} = do
|
||||
cID <- either (return . Left) (fmap Right . I.encrypt) bearerAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
|
||||
let stdPayload = Jose.JwtClaims
|
||||
{ jwtIss = Just $ toPathPiece bearerIssuedBy
|
||||
, jwtSub = Nothing
|
||||
, jwtAud = Just . pure $ toPathPiece bearerIssuedFor
|
||||
, jwtExp = IntDate . utcTimeToPOSIXSeconds <$> bearerExpiresAt
|
||||
, jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> bearerStartsAt
|
||||
, jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds bearerIssuedAt
|
||||
, jwtJti = Just $ toPathPiece bearerIdentifier
|
||||
}
|
||||
return . JSON.object $
|
||||
catMaybes [ Just $ "authority" .= either id toJSON cID
|
||||
, ("routes" .=) <$> bearerRoutes
|
||||
, ("add-auth" .=) <$> bearerAddAuth
|
||||
, ("restrictions" .=) <$> assertM' (not . HashMap.null) bearerRestrictions
|
||||
]
|
||||
++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
|
||||
|
||||
bearerParseJSON :: forall site.
|
||||
( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
|
||||
, ParseRoute site
|
||||
, Hashable (Route site)
|
||||
)
|
||||
=> Value
|
||||
-> ReaderT CryptoIDKey Parser (BearerToken site)
|
||||
-- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
|
||||
--
|
||||
-- Monadic context is needed because `AuthId`s are encrypted during encoding
|
||||
--
|
||||
-- It's usually easier to use `Utils.Tokens.bearerParseJSON'`
|
||||
bearerParseJSON v@(Object o) = do
|
||||
bearerAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
|
||||
bearerAuthority <- either (return . Left) (fmap Right . I.decrypt) bearerAuthority'
|
||||
|
||||
bearerRoutes <- lift $ o .:? "routes"
|
||||
bearerAddAuth <- lift $ o .:? "add-auth"
|
||||
bearerRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
|
||||
Jose.JwtClaims{..} <- lift $ parseJSON v
|
||||
|
||||
let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
|
||||
|
||||
Just bearerIssuedBy <- return $ jwtIss >>= fromPathPiece
|
||||
Just bearerIssuedFor <- return $ do
|
||||
[aud] <- jwtAud
|
||||
fromPathPiece aud
|
||||
Just bearerIdentifier <- return $ jwtJti >>= fromPathPiece
|
||||
Just bearerIssuedAt <- return $ unIntDate <$> jwtIat
|
||||
let bearerExpiresAt = unIntDate <$> jwtExp
|
||||
bearerStartsAt = unIntDate <$> jwtNbf
|
||||
|
||||
return BearerToken{..}
|
||||
bearerParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
|
||||
|
||||
24
src/Model/Tokens/Lens.hs
Normal file
24
src/Model/Tokens/Lens.hs
Normal file
@ -0,0 +1,24 @@
|
||||
module Model.Tokens.Lens
|
||||
( module Model.Tokens.Lens
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
|
||||
|
||||
class HasTokenIdentifier s a | s -> a where
|
||||
_tokenIdentifier :: Lens' s a
|
||||
|
||||
class HasTokenIssuedBy s a | s -> a where
|
||||
_tokenIssuedBy :: Lens' s a
|
||||
|
||||
class HasTokenIssuedFor s a | s -> a where
|
||||
_tokenIssuedFor :: Lens' s a
|
||||
|
||||
class HasTokenIssuedAt s a | s -> a where
|
||||
_tokenIssuedAt :: Lens' s a
|
||||
|
||||
class HasTokenExpiresAt s a | s -> a where
|
||||
_tokenExpiresAt :: Lens' s a
|
||||
|
||||
class HasTokenStartsAt s a | s -> a where
|
||||
_tokenStartsAt :: Lens' s a
|
||||
77
src/Model/Tokens/Session.hs
Normal file
77
src/Model/Tokens/Session.hs
Normal file
@ -0,0 +1,77 @@
|
||||
module Model.Tokens.Session
|
||||
( SessionToken(..)
|
||||
, _sessionIdentifier, _sessionId, _sessionIssuedBy, _sessionIssuedAt, _sessionExpiresAt, _sessionStartsAt
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
|
||||
import Model.Tokens.Lens
|
||||
import Model
|
||||
import Utils.Lens
|
||||
|
||||
import Web.ServerSession.Core
|
||||
|
||||
import Jose.Jwt (IntDate(..))
|
||||
import qualified Jose.Jwt as Jose
|
||||
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
import Control.Monad.Fail
|
||||
|
||||
|
||||
data SessionToken sess = SessionToken
|
||||
{ sessionIdentifier :: TokenId
|
||||
, sessionId :: SessionId sess
|
||||
, sessionIssuedAt :: UTCTime
|
||||
, sessionIssuedBy :: InstanceId
|
||||
, sessionIssuedFor :: ClusterId
|
||||
, sessionExpiresAt
|
||||
, sessionStartsAt :: Maybe UTCTime
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
makeLenses_ ''SessionToken
|
||||
instance HasTokenIdentifier (SessionToken sess) TokenId where
|
||||
_tokenIdentifier = _sessionIdentifier
|
||||
instance HasTokenIssuedBy (SessionToken sess) InstanceId where
|
||||
_tokenIssuedBy = _sessionIssuedBy
|
||||
instance HasTokenIssuedFor (SessionToken sess) ClusterId where
|
||||
_tokenIssuedFor = _sessionIssuedFor
|
||||
instance HasTokenIssuedAt (SessionToken sess) UTCTime where
|
||||
_tokenIssuedAt = _sessionIssuedAt
|
||||
instance HasTokenExpiresAt (SessionToken sess) (Maybe UTCTime) where
|
||||
_tokenExpiresAt = _sessionExpiresAt
|
||||
instance HasTokenStartsAt (SessionToken sess) (Maybe UTCTime) where
|
||||
_tokenStartsAt = _sessionStartsAt
|
||||
|
||||
instance ToJSON (SessionToken sess) where
|
||||
toJSON SessionToken{..} = toJSON Jose.JwtClaims{..}
|
||||
where jwtIss = Just $ toPathPiece sessionIssuedBy
|
||||
jwtSub = Just $ toPathPiece sessionId
|
||||
jwtAud = Just . pure $ toPathPiece sessionIssuedFor
|
||||
jwtExp = IntDate . utcTimeToPOSIXSeconds <$> sessionExpiresAt
|
||||
jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> sessionStartsAt
|
||||
jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds sessionIssuedAt
|
||||
jwtJti = Just $ toPathPiece sessionIdentifier
|
||||
|
||||
instance FromJSON (SessionToken sess) where
|
||||
parseJSON val = do
|
||||
Jose.JwtClaims{..} <- parseJSON val
|
||||
|
||||
sessionIdentifier <- parseMaybe "sessionIdentfier" $
|
||||
fromPathPiece =<< jwtIss
|
||||
sessionId <- parseMaybe "sessionId" $
|
||||
fromPathPiece =<< jwtSub
|
||||
sessionIssuedAt <- parseMaybe "sessionIssuedAt" $
|
||||
unIntDate <$> jwtIat
|
||||
sessionIssuedBy <- parseMaybe "sessionIssuedBy" $
|
||||
fromPathPiece =<< jwtIss
|
||||
sessionIssuedFor <- parseMaybe "sessionIssuedFor" $ do
|
||||
[aud] <- jwtAud
|
||||
fromPathPiece aud
|
||||
let sessionExpiresAt = unIntDate <$> jwtExp
|
||||
sessionStartsAt = unIntDate <$> jwtNbf
|
||||
|
||||
return SessionToken{..}
|
||||
where
|
||||
parseMaybe errId = maybe (fail $ "Could not parse " <> errId) return
|
||||
unIntDate (IntDate posix) = posixSecondsToUTCTime posix
|
||||
@ -59,6 +59,10 @@ import Jose.Jwt (JwtEncoding(..))
|
||||
import System.FilePath.Glob
|
||||
import Handler.Utils.Submission.TH
|
||||
|
||||
import qualified Web.ServerSession.Core as ServerSession
|
||||
|
||||
import Text.Show (showParen, showString)
|
||||
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
@ -88,6 +92,13 @@ data AppSettings = AppSettings
|
||||
, appIpFromHeader :: Bool
|
||||
-- ^ Get the IP address from the header when logging. Useful when sitting
|
||||
-- behind a reverse proxy.
|
||||
|
||||
, appServerSessionConfig :: ServerSessionSettings
|
||||
, appServerSessionAcidFallback :: Bool
|
||||
, appSessionMemcachedConf :: Maybe MemcachedConf
|
||||
, appSessionTokenExpiration :: Maybe NominalDiffTime
|
||||
, appSessionTokenEncoding :: JwtEncoding
|
||||
|
||||
, appMailFrom :: Address
|
||||
, appMailObjectDomain :: Text
|
||||
, appMailVerp :: VerpMode
|
||||
@ -101,8 +112,8 @@ data AppSettings = AppSettings
|
||||
, appNotificationExpiration :: NominalDiffTime
|
||||
, appSessionTimeout :: NominalDiffTime
|
||||
, appMaximumContentLength :: Maybe Word64
|
||||
, appJwtExpiration :: Maybe NominalDiffTime
|
||||
, appJwtEncoding :: JwtEncoding
|
||||
, appBearerExpiration :: Maybe NominalDiffTime
|
||||
, appBearerEncoding :: JwtEncoding
|
||||
|
||||
, appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime
|
||||
, appHealthCheckDelayNotify :: Bool
|
||||
@ -145,7 +156,13 @@ data AppSettings = AppSettings
|
||||
|
||||
, appInitialInstanceID :: Maybe (Either FilePath UUID)
|
||||
, appRibbon :: Maybe Text
|
||||
} deriving (Show)
|
||||
} deriving Show
|
||||
|
||||
newtype ServerSessionSettings
|
||||
= ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
|
||||
|
||||
instance Show ServerSessionSettings where
|
||||
showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"
|
||||
|
||||
data LogSettings = LogSettings
|
||||
{ logAll, logDetailed :: Bool
|
||||
@ -211,25 +228,34 @@ data SmtpConf = SmtpConf
|
||||
} deriving (Show)
|
||||
|
||||
data WidgetMemcachedConf = WidgetMemcachedConf
|
||||
{ widgetMemcachedConnectInfo :: Memcached.ConnectInfo
|
||||
, widgetMemcachedBaseUrl :: Text
|
||||
, widgetMemcachedExpiry :: Maybe NominalDiffTime
|
||||
{ widgetMemcachedConf :: MemcachedConf
|
||||
, widgetMemcachedBaseUrl :: Text
|
||||
} deriving (Show)
|
||||
|
||||
data MemcachedConf = MemcachedConf
|
||||
{ memcachedConnectInfo :: Memcached.ConnectInfo
|
||||
, memcachedExpiry :: Maybe NominalDiffTime
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON Memcached.Auth where
|
||||
parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
|
||||
|
||||
instance FromJSON WidgetMemcachedConf where
|
||||
parseJSON = withObject "WidgetMemcachedConf" $ \o -> do
|
||||
instance FromJSON MemcachedConf where
|
||||
parseJSON = withObject "MemcachedConf" $ \o -> do
|
||||
connectHost <- o .:? "host" .!= ""
|
||||
connectPort <- o .: "port"
|
||||
connectAuth <- o .: "auth"
|
||||
numConnection <- o .: "limit"
|
||||
connectionIdleTime <- o .: "timeout"
|
||||
widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
|
||||
widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
|
||||
memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
|
||||
|
||||
return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
|
||||
return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
|
||||
|
||||
instance FromJSON WidgetMemcachedConf where
|
||||
parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do
|
||||
widgetMemcachedConf <- parseJSON v
|
||||
widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
|
||||
return WidgetMemcachedConf{..}
|
||||
|
||||
data ResourcePoolConf = ResourcePoolConf
|
||||
{ poolStripes :: Int
|
||||
@ -343,6 +369,25 @@ instance FromJSON JwtEncoding where
|
||||
return $ JweEncoding alg enc
|
||||
]
|
||||
|
||||
instance FromJSON ServerSessionSettings where
|
||||
parseJSON = withObject "ServerSession.State" $ \o -> do
|
||||
cookieName <- o .:? "cookie-name"
|
||||
idleTimeout <- o .:? "idle-timeout"
|
||||
absoluteTimeout <- o .:? "absolute-timeout"
|
||||
timeoutResolution <- o .:? "timeout-resolution"
|
||||
persistentCookies <- o .:? "persistent-cookies"
|
||||
httpOnlyCookies <- o .:? "http-only-cookies"
|
||||
secureCookies <- o .:? "secure-cookies"
|
||||
return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes
|
||||
[ ServerSession.setCookieName <$> cookieName
|
||||
, pure $ ServerSession.setIdleTimeout idleTimeout
|
||||
, pure $ ServerSession.setAbsoluteTimeout absoluteTimeout
|
||||
, pure $ ServerSession.setTimeoutResolution timeoutResolution
|
||||
, ServerSession.setPersistentCookies <$> persistentCookies
|
||||
, ServerSession.setHttpOnlyCookies <$> httpOnlyCookies
|
||||
, ServerSession.setSecureCookies <$> secureCookies
|
||||
])
|
||||
|
||||
|
||||
instance FromJSON AppSettings where
|
||||
parseJSON = withObject "AppSettings" $ \o -> do
|
||||
@ -363,13 +408,17 @@ instance FromJSON AppSettings where
|
||||
Ldap.Plain host -> not $ null host
|
||||
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
|
||||
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
||||
let validWidgetMemcachedConf WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
|
||||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
|
||||
[ not $ null connectHost
|
||||
, not $ null widgetMemcachedBaseUrl
|
||||
, numConnection > 0
|
||||
, connectionIdleTime >= 0
|
||||
]
|
||||
validWidgetMemcachedConf WidgetMemcachedConf{..} = and
|
||||
[ not $ null widgetMemcachedBaseUrl
|
||||
, validMemcachedConf widgetMemcachedConf
|
||||
]
|
||||
appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
|
||||
appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached"
|
||||
appRoot <- o .:? "approot"
|
||||
appHost <- fromString <$> o .: "host"
|
||||
appPort <- o .: "port"
|
||||
@ -387,8 +436,8 @@ instance FromJSON AppSettings where
|
||||
appNotificationRateLimit <- o .: "notification-rate-limit"
|
||||
appNotificationCollateDelay <- o .: "notification-collate-delay"
|
||||
appNotificationExpiration <- o .: "notification-expiration"
|
||||
appJwtExpiration <- o .:? "jwt-expiration"
|
||||
appJwtEncoding <- o .: "jwt-encoding"
|
||||
appBearerExpiration <- o .:? "bearer-expiration"
|
||||
appBearerEncoding <- o .: "bearer-encoding"
|
||||
|
||||
appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
|
||||
appHealthCheckDelayNotify <- o .: "health-check-delay-notify"
|
||||
@ -417,6 +466,7 @@ instance FromJSON AppSettings where
|
||||
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
|
||||
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
|
||||
appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev
|
||||
appServerSessionAcidFallback <- o .:? "server-session-acid-fallback" .!= defaultDev
|
||||
|
||||
appInitialLogSettings <- o .: "log-settings"
|
||||
|
||||
@ -438,7 +488,11 @@ instance FromJSON AppSettings where
|
||||
|
||||
appRibbon <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon"
|
||||
|
||||
return AppSettings {..}
|
||||
appServerSessionConfig <- o .: "server-sessions"
|
||||
appSessionTokenExpiration <- o .:? "session-token-expiration"
|
||||
appSessionTokenEncoding <- o .: "session-token-encoding"
|
||||
|
||||
return AppSettings{..}
|
||||
|
||||
makeClassy_ ''AppSettings
|
||||
|
||||
|
||||
@ -9,20 +9,18 @@ import ClassyPrelude.Yesod
|
||||
import Web.HttpApiData
|
||||
|
||||
import Utils
|
||||
import Control.Lens
|
||||
import Data.Universe
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import qualified Web.ClientSession as ClientSession
|
||||
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
||||
import qualified Crypto.Saltine.Core.AEAD as AEAD
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
|
||||
import Data.CryptoID.ByteString (CryptoIDKey)
|
||||
import qualified Data.CryptoID.ByteString as CryptoID
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.Serialize as Serialize
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
|
||||
import qualified Jose.Jwa as Jose
|
||||
@ -39,7 +37,7 @@ import Model.Types.TH.PathPiece
|
||||
|
||||
data ClusterSettingsKey
|
||||
= ClusterCryptoIDKey
|
||||
| ClusterClientSessionKey
|
||||
| ClusterServerSessionKey
|
||||
| ClusterSecretBoxKey
|
||||
| ClusterJSONWebKeySet
|
||||
| ClusterId
|
||||
@ -83,18 +81,18 @@ instance FromJSON CryptoIDKey where
|
||||
| otherwise -> fail $ show (length bs) ++ " extra bytes"
|
||||
|
||||
|
||||
instance ClusterSetting 'ClusterClientSessionKey where
|
||||
type ClusterSettingValue 'ClusterClientSessionKey = ClientSession.Key
|
||||
initClusterSetting _ = liftIO $ view _2 <$> ClientSession.randomKey
|
||||
knownClusterSetting _ = ClusterClientSessionKey
|
||||
instance ClusterSetting 'ClusterServerSessionKey where
|
||||
type ClusterSettingValue 'ClusterServerSessionKey = AEAD.Key
|
||||
initClusterSetting _ = liftIO AEAD.newKey
|
||||
knownClusterSetting _ = ClusterServerSessionKey
|
||||
|
||||
instance ToJSON AEAD.Key where
|
||||
toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode
|
||||
|
||||
instance ToJSON ClientSession.Key where
|
||||
toJSON = Aeson.String . decodeUtf8 . Base64.encode . Serialize.encode
|
||||
|
||||
instance FromJSON ClientSession.Key where
|
||||
instance FromJSON AEAD.Key where
|
||||
parseJSON = Aeson.withText "Key" $ \t -> do
|
||||
bytes <- either fail return . Base64.decode $ encodeUtf8 t
|
||||
either fail return $ Serialize.decode bytes
|
||||
maybe (fail "Could not parse key") return $ Saltine.decode bytes
|
||||
|
||||
|
||||
instance ClusterSetting 'ClusterSecretBoxKey where
|
||||
|
||||
@ -613,6 +613,9 @@ guardMExceptT b err = unless b $ lift err >>= throwE
|
||||
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
|
||||
exceptT f g = either f g <=< runExceptT
|
||||
|
||||
catchIfExceptT :: (MonadCatch m, Exception e) => (e -> e') -> (e -> Bool) -> m a -> ExceptT e' m a
|
||||
catchIfExceptT err p act = catchIf p (lift act) (throwE . err)
|
||||
|
||||
catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
|
||||
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
|
||||
|
||||
|
||||
@ -240,6 +240,9 @@ makeLenses_ ''ExternalExamResult
|
||||
class HasInstanceID s a | s -> a where
|
||||
instanceID :: Lens' s a
|
||||
|
||||
class HasClusterID s a | s -> a where
|
||||
clusterID :: Lens' s a
|
||||
|
||||
class HasHttpManager s a | s -> a where
|
||||
httpManager :: Lens' s a
|
||||
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
module Utils.Tokens
|
||||
( bearerToken
|
||||
, encodeToken, BearerTokenException(..), decodeToken
|
||||
, tokenParseJSON'
|
||||
, askJwt
|
||||
, formEmbedJwtPost, formEmbedJwtGet
|
||||
, encodeBearer, BearerTokenException(..), decodeBearer
|
||||
, bearerParseJSON'
|
||||
, askBearer
|
||||
, formEmbedBearerPost, formEmbedBearerGet
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
@ -32,7 +32,7 @@ import CryptoID
|
||||
import Text.Blaze (Markup)
|
||||
|
||||
|
||||
tokenParseJSON' :: forall m.
|
||||
bearerParseJSON' :: forall m.
|
||||
( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
|
||||
, ParseRoute (HandlerSite m)
|
||||
, Hashable (Route (HandlerSite m))
|
||||
@ -42,14 +42,15 @@ tokenParseJSON' :: forall m.
|
||||
)
|
||||
=> m (Value -> Parser (BearerToken (HandlerSite m)))
|
||||
-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
|
||||
tokenParseJSON' = do
|
||||
bearerParseJSON' = do
|
||||
cidKey <- cryptoIDKey return
|
||||
return $ flip runReaderT cidKey . tokenParseJSON
|
||||
return $ flip runReaderT cidKey . bearerParseJSON
|
||||
|
||||
|
||||
bearerToken :: forall m.
|
||||
( MonadHandler m
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
, HasClusterID (HandlerSite m) ClusterId
|
||||
, HasAppSettings (HandlerSite m)
|
||||
)
|
||||
=> Either Value (AuthId (HandlerSite m))
|
||||
@ -59,26 +60,27 @@ bearerToken :: forall m.
|
||||
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
|
||||
-> m (BearerToken (HandlerSite m))
|
||||
-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
|
||||
bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
|
||||
tokenIdentifier <- liftIO getRandom
|
||||
tokenIssuedAt <- liftIO getCurrentTime
|
||||
tokenIssuedBy <- getsYesod $ view instanceID
|
||||
bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do
|
||||
bearerIdentifier <- liftIO getRandom
|
||||
bearerIssuedAt <- liftIO getCurrentTime
|
||||
bearerIssuedBy <- getsYesod $ view instanceID
|
||||
bearerIssuedFor <- getsYesod $ view clusterID
|
||||
|
||||
defaultExpiration <- getsYesod $ view _appJwtExpiration
|
||||
defaultExpiration <- getsYesod $ view _appBearerExpiration
|
||||
|
||||
let tokenExpiresAt
|
||||
| Just t <- mTokenExpiresAt
|
||||
let bearerExpiresAt
|
||||
| Just t <- mBearerExpiresAt
|
||||
= t
|
||||
| Just tDiff <- defaultExpiration
|
||||
= Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
|
||||
= Just $ tDiff `addUTCTime` fromMaybe bearerIssuedAt bearerStartsAt
|
||||
| otherwise
|
||||
= Nothing
|
||||
tokenRestrictions = HashMap.empty
|
||||
bearerRestrictions = HashMap.empty
|
||||
|
||||
return BearerToken{..}
|
||||
|
||||
|
||||
encodeToken :: forall m.
|
||||
encodeBearer :: forall m.
|
||||
( MonadHandler m
|
||||
, HasJSONWebKeySet (HandlerSite m) JwkSet
|
||||
, HasAppSettings (HandlerSite m)
|
||||
@ -86,11 +88,11 @@ encodeToken :: forall m.
|
||||
, RenderRoute (HandlerSite m)
|
||||
)
|
||||
=> BearerToken (HandlerSite m) -> m Jwt
|
||||
-- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
|
||||
encodeToken token = do
|
||||
payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
|
||||
-- ^ Call `bearerToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
|
||||
encodeBearer token = do
|
||||
payload <- Jose.Claims . toStrict . JSON.encode <$> bearerToJSON token
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
jwtEncoding <- getsYesod $ view _appJwtEncoding
|
||||
jwtEncoding <- getsYesod $ view _appBearerEncoding
|
||||
either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
|
||||
|
||||
|
||||
@ -103,7 +105,7 @@ data BearerTokenException
|
||||
|
||||
instance Exception BearerTokenException
|
||||
|
||||
decodeToken :: forall m.
|
||||
decodeBearer :: forall m.
|
||||
( MonadHandler m
|
||||
, HasJSONWebKeySet (HandlerSite m) JwkSet
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
|
||||
@ -113,50 +115,50 @@ decodeToken :: forall m.
|
||||
, Hashable (Route (HandlerSite m))
|
||||
)
|
||||
=> Jwt -> m (BearerToken (HandlerSite m))
|
||||
-- ^ Decode a `Jwt` and call `tokenParseJSON`
|
||||
-- ^ Decode a `Jwt` and call `bearerParseJSON`
|
||||
--
|
||||
-- Throws `bearerTokenException`s
|
||||
decodeToken (Jwt bs) = do
|
||||
decodeBearer (Jwt bs) = do
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
|
||||
content' <- case content of
|
||||
Jose.Unsecured _ -> throwM BearerTokenUnsecured
|
||||
Jose.Jws (_header, payload) -> return payload
|
||||
Jose.Jwe (_header, payload) -> return payload
|
||||
parser <- tokenParseJSON'
|
||||
token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
|
||||
parser <- bearerParseJSON'
|
||||
bearer@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
|
||||
now <- liftIO getCurrentTime
|
||||
unless (NTop tokenExpiresAt > NTop (Just now)) $
|
||||
unless (NTop bearerExpiresAt > NTop (Just now)) $
|
||||
throwM BearerTokenExpired
|
||||
unless (tokenStartsAt <= Just now) $
|
||||
unless (bearerStartsAt <= Just now) $
|
||||
throwM BearerTokenNotStarted
|
||||
return token
|
||||
return bearer
|
||||
|
||||
|
||||
askJwt :: forall m. ( MonadHandler m )
|
||||
=> m (Maybe Jwt)
|
||||
askBearer :: forall m. ( MonadHandler m )
|
||||
=> m (Maybe Jwt)
|
||||
-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
|
||||
askJwt = runMaybeT $ asum
|
||||
askBearer = runMaybeT $ asum
|
||||
[ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
|
||||
, MaybeT $ lookupGlobalPostParam PostBearer
|
||||
, MaybeT $ lookupGlobalGetParam GetBearer
|
||||
, fmap Jwt . MaybeT $ lookupSessionBS (toPathPiece SessionBearer)
|
||||
]
|
||||
|
||||
formEmbedJwtPost, formEmbedJwtGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
|
||||
formEmbedJwtPost f fragment = do
|
||||
mJwt <- askJwt
|
||||
formEmbedBearerPost, formEmbedBearerGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
|
||||
formEmbedBearerPost f fragment = do
|
||||
mBearer <- askBearer
|
||||
f [shamlet|
|
||||
$newline never
|
||||
$maybe jwt <- mJwt
|
||||
<input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
|
||||
$maybe bearer <- mBearer
|
||||
<input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece bearer}>
|
||||
#{fragment}
|
||||
|]
|
||||
formEmbedJwtGet f fragment = do
|
||||
mJwt <- askJwt
|
||||
formEmbedBearerGet f fragment = do
|
||||
mBearer <- askBearer
|
||||
f [shamlet|
|
||||
$newline never
|
||||
$maybe jwt <- mJwt
|
||||
<input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece jwt}>
|
||||
$maybe bearer <- mBearer
|
||||
<input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece bearer}>
|
||||
#{fragment}
|
||||
|]
|
||||
|
||||
175
src/Web/ServerSession/Backend/Persistent/Memcached.hs
Normal file
175
src/Web/ServerSession/Backend/Persistent/Memcached.hs
Normal file
@ -0,0 +1,175 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Web.ServerSession.Backend.Persistent.Memcached
|
||||
( migrateMemcachedSqlStorage
|
||||
, MemcachedSessionExpirationId, MemcachedSessionExpiration(..)
|
||||
, MemcachedSqlStorage(..)
|
||||
, _mcdSqlConnPool, _mcdSqlMemcached, _mcdSqlMemcachedKey, _mcdSqlMemcachedExpiration
|
||||
) where
|
||||
|
||||
import Import.NoModel hiding (AuthId, SessionMap, getSession)
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Web.ServerSession.Core
|
||||
|
||||
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
|
||||
import qualified Crypto.Saltine.Core.AEAD as AEAD
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
|
||||
|
||||
import Data.Text.Encoding (decodeUtf8')
|
||||
|
||||
import Data.Bits (Bits(zeroBits))
|
||||
|
||||
|
||||
share [mkPersist sqlSettings, mkMigrate "migrateMemcachedSqlStorage"]
|
||||
[persistLowerCase|
|
||||
MemcachedSessionExpiration
|
||||
authId ByteString
|
||||
time UTCTime
|
||||
UniqueMemcachedSessionExpiration authId
|
||||
deriving Show Eq Ord
|
||||
|]
|
||||
|
||||
|
||||
data MemcachedSqlStorage sess = MemcachedSqlStorage
|
||||
{ mcdSqlConnPool :: ConnectionPool
|
||||
, mcdSqlMemcached :: Memcached.Connection
|
||||
, mcdSqlMemcachedKey :: AEAD.Key
|
||||
, mcdSqlMemcachedExpiration :: Maybe NominalDiffTime
|
||||
}
|
||||
makeLenses_ ''MemcachedSqlStorage
|
||||
|
||||
data MemcachedSqlStorageException
|
||||
= MemcachedSqlStorageKeyCollision
|
||||
| MemcachedSqlStorageAEADCiphertextTooShort
|
||||
| MemcachedSqlStorageAEADCouldNotDecodeNonce
|
||||
| MemcachedSqlStorageAEADCouldNotOpenAEAD
|
||||
| MemcachedSqlStorageAEADCouldDecodeMemcachedSqlSession
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception MemcachedSqlStorageException
|
||||
|
||||
data MemcachedSqlSession sess = MemcachedSqlSession
|
||||
{ mcdSqlSessionAuthId :: Maybe AuthId
|
||||
, mcdSqlSessionData :: Decomposed sess
|
||||
, mcdSqlSessionCreatedAt, mcdSqlSessionAccessedAt :: UTCTime
|
||||
} deriving (Generic, Typeable)
|
||||
deriving instance Eq (Decomposed sess) => Eq (MemcachedSqlSession sess)
|
||||
deriving instance Ord (Decomposed sess) => Ord (MemcachedSqlSession sess)
|
||||
deriving instance Read (Decomposed sess) => Read (MemcachedSqlSession sess)
|
||||
deriving instance Show (Decomposed sess) => Show (MemcachedSqlSession sess)
|
||||
|
||||
instance Binary (Decomposed sess) => Binary (MemcachedSqlSession sess)
|
||||
instance Binary (SessionId sess) where
|
||||
get = maybe (fail "Could not decode SessionId fromPathPiece") return . fromPathPiece . decodeUtf8 . Base64.encode . BS.pack =<< replicateM 18 Binary.get
|
||||
put = mapM_ Binary.put . take 18 . BS.unpack . Base64.decodeLenient . encodeUtf8 . toPathPiece
|
||||
|
||||
memcachedSqlSession :: Iso' (SessionId sess, MemcachedSqlSession sess) (Session sess)
|
||||
memcachedSqlSession = iso toSession fromSession
|
||||
where
|
||||
toSession (mcdSqlSessionKey, MemcachedSqlSession{..}) = Session
|
||||
{ sessionKey = mcdSqlSessionKey
|
||||
, sessionAuthId = mcdSqlSessionAuthId
|
||||
, sessionData = mcdSqlSessionData
|
||||
, sessionCreatedAt = mcdSqlSessionCreatedAt
|
||||
, sessionAccessedAt = mcdSqlSessionAccessedAt
|
||||
}
|
||||
fromSession Session{..}
|
||||
= ( sessionKey
|
||||
, MemcachedSqlSession
|
||||
{ mcdSqlSessionAuthId = sessionAuthId
|
||||
, mcdSqlSessionData = sessionData
|
||||
, mcdSqlSessionCreatedAt = sessionCreatedAt
|
||||
, mcdSqlSessionAccessedAt = sessionAccessedAt
|
||||
}
|
||||
)
|
||||
|
||||
deriving newtype instance Binary SessionMap
|
||||
|
||||
|
||||
memcachedSqlSessionId :: Prism' ByteString (SessionId dat)
|
||||
memcachedSqlSessionId = prism' (encodeUtf8 . toPathPiece) (fromPathPiece <=< either (const Nothing) Just . decodeUtf8')
|
||||
|
||||
|
||||
instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSqlStorage sess) where
|
||||
type SessionData (MemcachedSqlStorage sess) = sess
|
||||
type TransactionM (MemcachedSqlStorage sess) = SqlPersistT IO
|
||||
|
||||
runTransactionM MemcachedSqlStorage{..} = flip runSqlPool mcdSqlConnPool
|
||||
|
||||
getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do
|
||||
encSession <- catchIfExceptT (\_ -> Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached
|
||||
|
||||
guardExceptT (BS.length encSession >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
|
||||
Just MemcachedSqlStorageAEADCiphertextTooShort
|
||||
let (nonceBS, encrypted) = BS.splitAt Saltine.secretBoxNonce encSession
|
||||
encSessId = LBS.toStrict $ Binary.encode sessId
|
||||
nonce <- maybeTExceptT (Just MemcachedSqlStorageAEADCouldNotDecodeNonce) . hoistMaybe $ Saltine.decode nonceBS
|
||||
decrypted <- maybeTExceptT (Just MemcachedSqlStorageAEADCouldNotOpenAEAD) . hoistMaybe $ AEAD.aeadOpen mcdSqlMemcachedKey nonce encrypted encSessId
|
||||
|
||||
let binaryDecode bs = do
|
||||
Right (unconsumed, _, res) <- return $ Binary.decodeOrFail bs
|
||||
guard $ LBS.null unconsumed
|
||||
return res
|
||||
decoded@MemcachedSqlSession{..} <- maybeTExceptT (Just MemcachedSqlStorageAEADCouldDecodeMemcachedSqlSession) . hoistMaybe . binaryDecode $ LBS.fromStrict decrypted
|
||||
|
||||
expiration <- runMaybeT $ fmap (memcachedSessionExpirationTime . entityVal) . MaybeT . lift . getBy . UniqueMemcachedSessionExpiration =<< hoistMaybe mcdSqlSessionAuthId
|
||||
|
||||
guardExceptT (maybe True (mcdSqlSessionCreatedAt >) expiration) Nothing
|
||||
|
||||
return $ (sessId, decoded) ^. memcachedSqlSession
|
||||
|
||||
where expiry = maybe 0 ceiling mcdSqlMemcachedExpiration
|
||||
|
||||
deleteSession MemcachedSqlStorage{..} sessId
|
||||
= liftIO $ Memcached.delete (memcachedSqlSessionId # sessId) mcdSqlMemcached
|
||||
|
||||
deleteAllSessionsOfAuthId MemcachedSqlStorage{..} authId = do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert
|
||||
( MemcachedSessionExpiration authId now )
|
||||
[ MemcachedSessionExpirationTime =. now
|
||||
]
|
||||
|
||||
insertSession = replaceSession' False
|
||||
replaceSession = replaceSession' True
|
||||
|
||||
replaceSession' :: forall sess.
|
||||
( Storage (MemcachedSqlStorage sess)
|
||||
, Binary (Decomposed sess)
|
||||
)
|
||||
=> Bool -- ^ Replace existing?
|
||||
-> MemcachedSqlStorage sess
|
||||
-> Session (SessionData (MemcachedSqlStorage sess))
|
||||
-> SqlPersistT IO ()
|
||||
replaceSession' isReplace s@MemcachedSqlStorage{..} seNewSession@(review memcachedSqlSession -> (sessId, decoded)) = do
|
||||
unless isReplace $ do
|
||||
mOld <- getSession @(MemcachedSqlStorage sess) s sessId
|
||||
whenIsJust mOld $ \seExistingSession ->
|
||||
throwM @_ @(StorageException (MemcachedSqlStorage sess)) $ SessionAlreadyExists{..}
|
||||
|
||||
nonce <- liftIO $ AEAD.newNonce
|
||||
let encSession = Saltine.encode nonce <> AEAD.aead mcdSqlMemcachedKey nonce encoded encSessId
|
||||
encSessId = LBS.toStrict $ Binary.encode sessId
|
||||
handleFailure
|
||||
= handleIf Memcached.isKeyExists (\_ -> throwM MemcachedSqlStorageKeyCollision)
|
||||
. handleIf Memcached.isKeyNotFound (\_ -> throwM @_ @(StorageException (MemcachedSqlStorage sess)) SessionDoesNotExist{..})
|
||||
handleFailure . liftIO $
|
||||
bool Memcached.add Memcached.replace isReplace zeroBits expiry (memcachedSqlSessionId # sessId) (LBS.fromStrict encSession) mcdSqlMemcached
|
||||
|
||||
where
|
||||
encoded = LBS.toStrict $ Binary.encode decoded
|
||||
expiry = maybe 0 ceiling mcdSqlMemcachedExpiration
|
||||
208
src/Web/ServerSession/Frontend/Yesod/Jwt.hs
Normal file
208
src/Web/ServerSession/Frontend/Yesod/Jwt.hs
Normal file
@ -0,0 +1,208 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Web.ServerSession.Frontend.Yesod.Jwt
|
||||
( backend
|
||||
, siteApproot
|
||||
, ServerSessionJwtConfig(..)
|
||||
, ServerSessionJwtException(..)
|
||||
, forceInvalidate
|
||||
) where
|
||||
|
||||
-- Module heavily inspired by:
|
||||
-- serversession-frontend-yesod-1.0@sha256:8ddb112a1ef6ee863f5ea13978dd08e1c39444c1a252f775a780013430bcc884,1230
|
||||
|
||||
|
||||
import Import.NoModel hiding (State, state, Header, deleteCookie)
|
||||
import Yesod.Core.Types
|
||||
import Model.Types.Common
|
||||
|
||||
import Model.Tokens.Session
|
||||
|
||||
import Jose.Jwk (JwkSet)
|
||||
import Jose.Jwt (Jwt(..), JwtEncoding(..))
|
||||
import qualified Jose.Jwt as Jose
|
||||
import qualified Jose.Jwk as Jose
|
||||
|
||||
import qualified Network.Wai as Wai
|
||||
|
||||
import Web.Cookie (parseCookies, SetCookie(..))
|
||||
|
||||
import Web.ServerSession.Core hiding (SessionMap, setCookieName)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
|
||||
|
||||
instance Universe ForceInvalidate
|
||||
instance Finite ForceInvalidate
|
||||
finitePathPiece ''ForceInvalidate
|
||||
[ "current", "all", "none" ]
|
||||
|
||||
|
||||
data ServerSessionJwtConfig = ServerSessionJwtConfig
|
||||
{ sJwtJwkSet :: JwkSet
|
||||
, sJwtStart
|
||||
, sJwtExpiration :: Maybe NominalDiffTime
|
||||
, sJwtEncoding :: JwtEncoding
|
||||
, sJwtIssueBy :: InstanceId
|
||||
, sJwtIssueFor :: ClusterId
|
||||
}
|
||||
|
||||
|
||||
data ServerSessionJwtException
|
||||
= SessionTokenJwtError Jose.JwtError
|
||||
| SessionTokenUnsecured
|
||||
| SessionTokenInvalidFormat String
|
||||
| SessionTokenExpired | SessionTokenNotStarted
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
instance Exception ServerSessionJwtException
|
||||
|
||||
|
||||
backend :: ( Applicative m
|
||||
, Storage sto
|
||||
, SessionData sto ~ Map Text ByteString
|
||||
)
|
||||
=> ServerSessionJwtConfig
|
||||
-> (Wai.Request -> Maybe Text)
|
||||
-> State sto
|
||||
-> m (Maybe SessionBackend)
|
||||
backend jwtCfg getApprootText' state = pure $ Just SessionBackend{..}
|
||||
where
|
||||
sbLoadSession :: Wai.Request -> IO (SessionMap, SaveSession)
|
||||
sbLoadSession req = do
|
||||
session <- runMaybeT . catchMPlus (Proxy @ServerSessionJwtException) $
|
||||
decodeSession jwtCfg =<< hoistMaybe (findSession state req)
|
||||
(sessionData, saveSessionToken) <- loadSession state $ encodeUtf8 . toPathPiece . sessionId <$> session
|
||||
|
||||
let save :: SessionMap -> IO [Header]
|
||||
save sessMap = pure <$> do
|
||||
saveRes <- saveSession state saveSessionToken sessMap
|
||||
case saveRes of
|
||||
Nothing ->
|
||||
return $ deleteCookie state approot'
|
||||
Just sess ->
|
||||
fmap (createCookie state approot' sess) . encodeSession jwtCfg =<< mkSessionToken jwtCfg sess
|
||||
|
||||
approot' = getApprootText' req
|
||||
|
||||
return (sessionData, save)
|
||||
|
||||
siteApproot :: Yesod site => site -> Wai.Request -> Maybe Text
|
||||
siteApproot master req = case approot of
|
||||
ApprootRelative -> Nothing
|
||||
ApprootStatic t -> Just t
|
||||
ApprootMaster f -> Just $ f master
|
||||
ApprootRequest f -> Just $ f master req
|
||||
|
||||
findSession :: State sto
|
||||
-> Wai.Request
|
||||
-> Maybe Jwt
|
||||
findSession state req = do
|
||||
[raw] <- return $ do
|
||||
("Cookie", header) <- Wai.requestHeaders req
|
||||
(k, v) <- parseCookies header
|
||||
guard $ k == encodeUtf8 (getCookieName state)
|
||||
return v
|
||||
return $ Jwt raw
|
||||
|
||||
|
||||
mkSessionToken :: MonadIO m
|
||||
=> ServerSessionJwtConfig
|
||||
-> Session sess
|
||||
-> m (SessionToken sess)
|
||||
mkSessionToken ServerSessionJwtConfig{..} Session{..} = liftIO $
|
||||
mkSessionToken' <$> getCurrentTime <*> getRandom
|
||||
where
|
||||
mkSessionToken' now sessionIdentifier
|
||||
= let sessionId = sessionKey
|
||||
sessionIssuedAt = now
|
||||
sessionIssuedBy = sJwtIssueBy
|
||||
sessionIssuedFor = sJwtIssueFor
|
||||
sessionExpiresAt = flip addUTCTime now <$> sJwtExpiration
|
||||
sessionStartsAt = flip addUTCTime now <$> sJwtStart
|
||||
in SessionToken{..}
|
||||
|
||||
|
||||
deleteCookie :: State sto -> Maybe Text -> Header
|
||||
deleteCookie state approot' = DeleteCookie (encodeUtf8 $ getCookieName state) $ cookiePath approot'
|
||||
|
||||
createCookie :: State sto -> Maybe Text -> Session sess -> Jwt -> Header
|
||||
createCookie state approot' session (Jwt payload) = AddCookie def
|
||||
{ setCookieName = encodeUtf8 $ getCookieName state
|
||||
, setCookieValue = payload
|
||||
, setCookiePath = Just $ cookiePath approot'
|
||||
, setCookieExpires = cookieExpires state session
|
||||
, setCookieDomain = Nothing -- Setting anything here would have browsers include subdomains, which might be wrong
|
||||
, setCookieHttpOnly = getHttpOnlyCookies state
|
||||
, setCookieSecure = getSecureCookies state
|
||||
}
|
||||
|
||||
cookiePath :: Maybe Text -> ByteString
|
||||
cookiePath = maybe "/" $ extractPath . encodeUtf8
|
||||
|
||||
|
||||
decodeSession :: ( MonadThrow m
|
||||
, MonadIO m
|
||||
)
|
||||
=> ServerSessionJwtConfig
|
||||
-> Jwt
|
||||
-> m (SessionToken sess)
|
||||
decodeSession ServerSessionJwtConfig{..} (Jwt bs) = do
|
||||
content <- either (throwM . SessionTokenJwtError) return =<< liftIO (Jose.decode (Jose.keys sJwtJwkSet) Nothing bs)
|
||||
content' <- case content of
|
||||
Jose.Unsecured _ -> throwM SessionTokenUnsecured
|
||||
Jose.Jws (_header, payload) -> return payload
|
||||
Jose.Jwe (_header, payload) -> return payload
|
||||
session@SessionToken{..} <- either (throwM . SessionTokenInvalidFormat) return $ JSON.eitherDecodeStrict content'
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
unless (NTop sessionExpiresAt > NTop (Just now)) $
|
||||
throwM SessionTokenExpired
|
||||
unless (sessionStartsAt <= Just now) $
|
||||
throwM SessionTokenNotStarted
|
||||
|
||||
return session
|
||||
|
||||
encodeSession :: MonadIO m
|
||||
=> ServerSessionJwtConfig
|
||||
-> SessionToken sess
|
||||
-> m Jwt
|
||||
encodeSession ServerSessionJwtConfig{..} token = liftIO $
|
||||
either throwM return =<< Jose.encode (Jose.keys sJwtJwkSet) sJwtEncoding payload
|
||||
where payload = Jose.Claims . toStrict $ JSON.encode token
|
||||
|
||||
|
||||
-- | Invalidate the current session ID (and possibly more, check
|
||||
-- 'ForceInvalidate'). This is useful to avoid session fixation
|
||||
-- attacks (cf. <http://www.acrossecurity.com/papers/session_fixation.pdf>).
|
||||
--
|
||||
-- Note that the invalidate /does not/ occur when the call to
|
||||
-- this action is made! The sessions will be invalidated on the
|
||||
-- end of the handler processing. This means that later calls to
|
||||
-- 'forceInvalidate' on the same handler will override earlier
|
||||
-- calls.
|
||||
--
|
||||
-- This function works by setting a session variable that is
|
||||
-- checked when saving the session. The session variable set by
|
||||
-- this function is then discarded and is not persisted across
|
||||
-- requests.
|
||||
forceInvalidate :: MonadHandler m => ForceInvalidate -> m ()
|
||||
forceInvalidate = setSessionBS forceInvalidateKey . encodeUtf8 . toPathPiece
|
||||
|
||||
|
||||
instance IsSessionData (Map Text ByteString) where
|
||||
type Decomposed (Map Text ByteString) = Map Text ByteString
|
||||
emptySession = mempty
|
||||
decomposeSession authKey session
|
||||
= let dsAuthId = Map.lookup authKey session
|
||||
dsForceInvalidate = fromMaybe DoNotForceInvalidate
|
||||
$ fromPathPiece . decodeUtf8 =<< Map.lookup forceInvalidateKey session
|
||||
dsDecomposed = session
|
||||
& Map.delete authKey
|
||||
& Map.delete forceInvalidateKey
|
||||
in DecomposedSession{..}
|
||||
recomposeSession authKey mAuthId
|
||||
= maybe id (Map.insert authKey) mAuthId
|
||||
isDecomposedEmpty _ = Map.null
|
||||
isSameDecomposed _ = (==)
|
||||
10
stack.yaml
10
stack.yaml
@ -23,6 +23,12 @@ extra-deps:
|
||||
commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
|
||||
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git
|
||||
commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
|
||||
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
|
||||
commit: 1c95b0100471279413485411032d639881012a5e
|
||||
subdirs:
|
||||
- serversession
|
||||
- serversession-backend-acid-state
|
||||
|
||||
|
||||
- colonnade-1.2.0.2
|
||||
- hsass-0.8.0
|
||||
@ -92,5 +98,9 @@ extra-deps:
|
||||
# - skylighting-core-0.8.3.2
|
||||
# - texmath-0.12.0.1
|
||||
|
||||
- binary-instances-1
|
||||
|
||||
- acid-state-0.16.0
|
||||
|
||||
resolver: lts-15.0
|
||||
allow-newer: true
|
||||
|
||||
@ -88,6 +88,38 @@ packages:
|
||||
original:
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git
|
||||
commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
|
||||
- completed:
|
||||
subdir: serversession
|
||||
cabal-file:
|
||||
size: 2081
|
||||
sha256: a958ff0007e5084e3e4c2a33acc9860c31186105f02f8ab99ecb847a7a8f9497
|
||||
name: serversession
|
||||
version: 1.0.1
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
|
||||
pantry-tree:
|
||||
size: 544
|
||||
sha256: f825236d72f8eb42bb095c08b63e34d4ea7f83b059983543a725ddb5ef808b25
|
||||
commit: 1c95b0100471279413485411032d639881012a5e
|
||||
original:
|
||||
subdir: serversession
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
|
||||
commit: 1c95b0100471279413485411032d639881012a5e
|
||||
- completed:
|
||||
subdir: serversession-backend-acid-state
|
||||
cabal-file:
|
||||
size: 1875
|
||||
sha256: 6cc9d29e788334670bc102213a8aae73bc1b8b0a00c416f06d232376750443b7
|
||||
name: serversession-backend-acid-state
|
||||
version: 1.0.3
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
|
||||
pantry-tree:
|
||||
size: 543
|
||||
sha256: 0806157c4bc259f28bcab1cc0dcb58a8becc831e3f4e5e63d28f550acae92842
|
||||
commit: 1c95b0100471279413485411032d639881012a5e
|
||||
original:
|
||||
subdir: serversession-backend-acid-state
|
||||
git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
|
||||
commit: 1c95b0100471279413485411032d639881012a5e
|
||||
- completed:
|
||||
hackage: colonnade-1.2.0.2@sha256:c95c2ecff5cfa28c736d8fa662d28b71129f67457068e3f4467b296a621607ab,2099
|
||||
pantry-tree:
|
||||
@ -228,6 +260,20 @@ packages:
|
||||
sha256: 9d4d8e7a85166ffd951b02f87be540607b55084c04730932346072329adf4913
|
||||
original:
|
||||
hackage: doctemplates-0.8.1
|
||||
- completed:
|
||||
hackage: binary-instances-1@sha256:b17565598b8df3241f9b46fa8e3a3368ecc8e3f2eb175d7c28f319042a6f5c79,2613
|
||||
pantry-tree:
|
||||
size: 1035
|
||||
sha256: 938ffc6990cac12681c657f7afa93737eecf335e6f0212d8c0b7c1ea3e0f40f4
|
||||
original:
|
||||
hackage: binary-instances-1
|
||||
- completed:
|
||||
hackage: acid-state-0.16.0@sha256:a5640fd8d99bdb5f152476a2ae56cc8eb81864b280c8ec7d1387e81296ed844d,6190
|
||||
pantry-tree:
|
||||
size: 13678
|
||||
sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f
|
||||
original:
|
||||
hackage: acid-state-0.16.0
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 488576
|
||||
|
||||
2
start.sh
2
start.sh
@ -10,6 +10,8 @@ export DETAILED_LOGGING=${DETAILED_LOGGING:-true}
|
||||
export LOG_ALL=${LOG_ALL:-false}
|
||||
export LOGLEVEL=${LOGLEVEL:-info}
|
||||
export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
|
||||
export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
|
||||
export SERVER_SESSION_COOKIES_SECURE=${SERVER_SESSION_COOKIES_SECURE:-false}
|
||||
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
|
||||
export RIBBON=${RIBBON:-${__HOST:-localhost}}
|
||||
unset HOST
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
$newline never
|
||||
$maybe t <- metricsToken
|
||||
$maybe t <- metricsBearer
|
||||
<section>
|
||||
<pre style="font-family: monospace; white-space: pre-wrap; word-break: break-all;">
|
||||
#{toPathPiece t}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user