fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(serversessions): move session storage to dedicated memcached

Browse Source 
fixes #390
This commit is contained in:
Gregor Kleen 2020-03-13 17:26:47 +01:00
parent 26f8f392a9
commit 996005935d
44 changed files with 1047 additions and 403 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
config/settings.yml
View File

@ -31,8 +31,8 @@ notification-rate-limit: 3600
notification-collate-delay: 7200 notification-collate-delay: 7200
notification-expiration: 259200 notification-expiration: 259200
session-timeout: 7200 session-timeout: 7200
jwt-expiration: 604800 bearer-expiration: 604800
jwt-encoding: HS256 bearer-encoding: HS256
maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728" maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
session-files-expire: 3600 session-files-expire: 3600
prune-unreferenced-files: 86400 prune-unreferenced-files: 86400
@ -67,6 +67,7 @@ ip-retention-time: 1209600
# Debugging # Debugging
auth-dummy-login: "_env:DUMMY_LOGIN:false" auth-dummy-login: "_env:DUMMY_LOGIN:false"
allow-deprecated: "_env:ALLOW_DEPRECATED:false" allow-deprecated: "_env:ALLOW_DEPRECATED:false"
server-session-acid-fallback: "_env:SERVER_SESSION_ACID_FALLBACK:false"
auth-pw-hash: auth-pw-hash:
algorithm: "pbkdf2" algorithm: "pbkdf2"
@ -119,13 +120,32 @@ smtp:
limit: "_env:SMTPLIMIT:10" limit: "_env:SMTPLIMIT:10"
widget-memcached: widget-memcached:
host: "_env:MEMCACHEDHOST:" host: "_env:WIDGET_MEMCACHED_HOST:"
port: "_env:MEMCACHEDPORT:11211" port: "_env:WIDGET_MEMCACHED_PORT:11211"
auth: [] auth: []
limit: "_env:MEMCACHEDLIMIT:10" limit: "_env:WIDGET_MEMCACHED_LIMIT:10"
timeout: "_env:MEMCACHEDTIMEOUT:20" timeout: "_env:WIDGET_MEMCACHED_TIMEOUT:20"
base-url: "_env:MEMCACHEDROOT:" base-url: "_env:WIDGET_MEMCACHED_ROOT:"
expiration: "_env:MEMCACHEDEXPIRATION:3600" 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: user-defaults:
max-favourites: 12 max-favourites: 12

12
ghci.sh
View File

@ -4,10 +4,16 @@ set -e
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || : [ "${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 unset HOST
export DETAILED_LOGGING=true
export LOG_ALL=true
export DUMMY_LOGIN=true
move-back() { move-back() {
mv -v .stack-work .stack-work-ghci mv -v .stack-work .stack-work-ghci

5
package.yaml
View File

@ -61,6 +61,7 @@ dependencies:
- cryptoids - cryptoids
- cryptoids-class - cryptoids-class
- binary - binary
- binary-instances
- cereal - cereal
- mtl - mtl
- esqueleto >=3.1.0 - esqueleto >=3.1.0
@ -103,7 +104,9 @@ dependencies:
- postgresql-simple - postgresql-simple
- word24 - word24
- mmorph - mmorph
- clientsession - serversession
- serversession-backend-acid-state
- acid-state
- monad-memo - monad-memo
- xss-sanitize - xss-sanitize
- text-metrics - text-metrics

48
src/Application.hs
View File

@ -18,7 +18,7 @@ module Application
import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
pgPoolSize, runSqlPool) pgPoolSize, runSqlPool, ConnectionPool)
import Import hiding (cancel) import Import hiding (cancel)
import Language.Haskell.TH.Syntax (qLocation) import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai (Middleware) import Network.Wai (Middleware)
@ -88,6 +88,9 @@ import qualified Data.Set as Set
import Handler.Utils.Routes (classifyHandler) 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. -- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.) -- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.News import Handler.News
@ -125,7 +128,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- performs initialization and returns a foundation datatype value. This is also -- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database -- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod. -- 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 makeFoundation appSettings'@AppSettings{..} = do
registerGHCMetrics registerGHCMetrics
@ -168,7 +171,7 @@ makeFoundation appSettings'@AppSettings{..} = do
-- logging function. To get out of this loop, we initially create a -- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function -- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation. -- 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 -- The UniWorX {..} syntax is an example of record wild cards. For more
-- information, see: -- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html -- 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 "smtpPool forced in tempFoundation")
(error "ldapPool forced in tempFoundation") (error "ldapPool forced in tempFoundation")
(error "cryptoIDKey forced in tempFoundation") (error "cryptoIDKey forced in tempFoundation")
(error "sessionKey forced in tempFoundation") (error "sessionStore forced in tempFoundation")
(error "secretBoxKey forced in tempFoundation") (error "secretBoxKey forced in tempFoundation")
(error "widgetMemcached forced in tempFoundation") (error "widgetMemcached forced in tempFoundation")
(error "JSONWebKeySet forced in tempFoundation") (error "JSONWebKeySet forced in tempFoundation")
@ -191,9 +194,9 @@ makeFoundation appSettings'@AppSettings{..} = do
$logDebugS "setup" "SMTP-Pool" $logDebugS "setup" "SMTP-Pool"
createSmtpPool c createSmtpPool c
appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do appWidgetMemcached <- for appWidgetMemcachedConf $ \WidgetMemcachedConf{ widgetMemcachedConf } -> do
$logDebugS "setup" "Widget-Memcached" $logDebugS "setup" "Widget-Memcached"
createWidgetMemcached c createMemcached widgetMemcachedConf
-- Create the database connection pool -- Create the database connection pool
$logDebugS "setup" "PostgreSQL-Pool" $logDebugS "setup" "PostgreSQL-Pool"
@ -215,17 +218,42 @@ makeFoundation appSettings'@AppSettings{..} = do
liftIO . exitWith $ ExitFailure 2 liftIO . exitWith $ ExitFailure 2
$logDebugS "setup" "Cluster-Config" $logDebugS "setup" "Cluster-Config"
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `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 -- Return the foundation
$logDebugS "setup" "Done" $logDebugS "setup" "Done"
return foundation 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. clusterSetting :: forall key m p.
( MonadIO m ( MonadIO m
, ClusterSetting key , ClusterSetting key
@ -285,8 +313,8 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
return conn return conn
liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection createMemcached :: (MonadLogger m, MonadResource m) => MemcachedConf -> m Memcached.Connection
createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close createMemcached MemcachedConf{memcachedConnectInfo} = snd <$> allocate (Memcached.connect memcachedConnectInfo) Memcached.close
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares. -- applying some additional middlewares.

7
src/Data/Aeson/Types/Instances.hs
View File

@ -9,11 +9,6 @@ import ClassyPrelude
import Data.Aeson.Types (Parser, Value) import Data.Aeson.Types (Parser, Value)
import Control.Monad.Catch import Control.Monad.Catch
import Data.Binary (Binary)
import Data.HashMap.Strict.Instances ()
import Data.Vector.Instances ()
import Model.Types.TH.JSON (derivePersistFieldJSON) import Model.Types.TH.JSON (derivePersistFieldJSON)
import Control.Monad.Fail import Control.Monad.Fail
@ -22,7 +17,5 @@ import Control.Monad.Fail
instance MonadThrow Parser where instance MonadThrow Parser where
throwM = fail . show throwM = fail . show
instance Binary Value
derivePersistFieldJSON ''Value derivePersistFieldJSON ''Value

8
src/Data/CaseInsensitive/Instances.hs
View File

@ -26,9 +26,6 @@ import qualified Database.Esqueleto as E
import Web.HttpApiData import Web.HttpApiData
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import qualified Data.Csv as Csv 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 fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
toPathMultiPiece = toPathMultiPiece . CI.original 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 instance Csv.ToField s => Csv.ToField (CI s) where
toField = Csv.toField . CI.original toField = Csv.toField . CI.original

15
src/Data/HashMap/Strict/Instances.hs
View File

@ -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

16
src/Data/HashSet/Instances.hs
View File

@ -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

2
src/Data/Time/Calendar/Instances.hs
View File

@ -6,7 +6,6 @@ module Data.Time.Calendar.Instances
) where ) where
import ClassyPrelude import ClassyPrelude
import Data.Binary (Binary)
import Data.Time.Calendar import Data.Time.Calendar
@ -14,7 +13,6 @@ import Data.Universe
deriving newtype instance Hashable Day deriving newtype instance Hashable Day
deriving newtype instance Binary Day
deriving instance Ord DayOfWeek deriving instance Ord DayOfWeek
instance Universe DayOfWeek where instance Universe DayOfWeek where

10
src/Data/Time/Clock/Instances.hs
View File

@ -9,9 +9,6 @@ import Database.Persist.Sql
import Data.Proxy import Data.Proxy
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Calendar.Instances () import Data.Time.Calendar.Instances ()
import Web.PathPieces import Web.PathPieces
@ -44,10 +41,3 @@ instance Csv.ToField UTCTime where
instance Csv.FromField UTCTime where instance Csv.FromField UTCTime where
parseField = iso8601ParseM <=< Csv.parseField parseField = iso8601ParseM <=< Csv.parseField
instance Binary DiffTime where
get = fromRational <$> Binary.get
put = Binary.put . toRational
instance Binary UTCTime

3
src/Data/Time/LocalTime/Instances.hs
View File

@ -8,8 +8,6 @@ import ClassyPrelude
import Data.Time.LocalTime import Data.Time.LocalTime
import Data.Binary (Binary)
import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Syntax as TH
@ -17,7 +15,6 @@ deriving instance Generic TimeOfDay
deriving instance Typeable TimeOfDay deriving instance Typeable TimeOfDay
instance Hashable TimeOfDay instance Hashable TimeOfDay
instance Binary TimeOfDay
deriving instance TH.Lift TimeZone deriving instance TH.Lift TimeZone

17
src/Data/Vector/Instances.hs
View File

@ -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

1
src/Database/Persist/Class/Instances.hs
View File

@ -13,6 +13,7 @@ import Database.Persist.Sql
import Data.Binary (Binary) import Data.Binary (Binary)
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
import Data.Binary.Instances ()
import qualified Data.Map as Map import qualified Data.Map as Map

1
src/Database/Persist/Types/Instances.hs
View File

@ -11,6 +11,7 @@ import Database.Persist.Types
import Data.Time.Calendar.Instances () import Data.Time.Calendar.Instances ()
import Data.Time.LocalTime.Instances () import Data.Time.LocalTime.Instances ()
import Data.Time.Clock.Instances () import Data.Time.Clock.Instances ()
import Data.Binary.Instances ()
import Data.Binary (Binary) import Data.Binary (Binary)

67
src/Foundation.hs
View File

@ -97,6 +97,9 @@ import qualified Ldap.Client as Ldap
import UnliftIO.Pool import UnliftIO.Pool
import qualified Web.ServerSession.Core as ServerSession
import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
-- | Convenient Type Synonyms: -- | Convenient Type Synonyms:
type DB = YesodDB UniWorX type DB = YesodDB UniWorX
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget) 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 falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
askTokenUnsafe :: forall m. askBearerUnsafe :: forall m.
( MonadHandler m ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadCatch m , MonadCatch m
@ -307,23 +310,23 @@ askTokenUnsafe :: forall m.
-- | This performs /no/ meaningful validation of the `BearerToken` -- | This performs /no/ meaningful validation of the `BearerToken`
-- --
-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead -- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
askTokenUnsafe = $cachedHere $ do askBearerUnsafe = $cachedHere $ do
jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer
catch (decodeToken jwt) $ \case catch (decodeBearer bearer) $ \case
BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
other -> do other -> do
$logWarnS "AuthToken" $ tshow other $logWarnS "AuthToken" $ tshow other
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult validateBearer :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token' validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token'
where where
validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute) guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
tokenAuthority' <- case tokenAuthority of bearerAuthority' <- case bearerAuthority of
Left tVal Left tVal
| JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
@ -331,8 +334,8 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
| otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
Right uid -> return uid Right uid -> return uid
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority' User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get bearerAuthority'
guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
let let
-- Prevent infinite loops -- Prevent infinite loops
@ -341,10 +344,10 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
authorityVal <- do authorityVal <- do
dnf <- either throwM return $ routeAuthTags route 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 guardExceptT (is _Authorized authorityVal) authorityVal
whenIsJust tokenAddAuth $ \addDNF -> do whenIsJust bearerAddAuth $ \addDNF -> do
$logDebugS "validateToken" $ tshow addDNF $logDebugS "validateToken" $ tshow addDNF
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
guardExceptT (is _Authorized additionalVal) additionalVal guardExceptT (is _Authorized additionalVal) additionalVal
@ -447,7 +450,7 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
return Authorized return Authorized
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ 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 tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
@ -1466,11 +1469,31 @@ instance Yesod UniWorX where
Nothing -> getApprootText guessApproot app req Nothing -> getApprootText guessApproot app req
Just root -> root Just root -> root
-- Store session data on the client in encrypted cookies, makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = case appSessionStore of
-- default session idle timeout is 120 minutes SessionStorageMemcachedSql sqlStore
makeSessionBackend app = do -> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
(getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout) SessionStorageAcid acidStore
return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate | 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 maximumContentLength app _ = app ^. _appMaximumContentLength
@ -1567,8 +1590,8 @@ instance Yesod UniWorX where
addStaticContent ext _mime content = do addStaticContent ext _mime content = do
UniWorX{appWidgetMemcached, appSettings'} <- getYesod UniWorX{appWidgetMemcached, appSettings'} <- getYesod
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
let expiry = (maybe 0 ceiling widgetMemcachedExpiry) let expiry = maybe 0 ceiling memcachedExpiry
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName absoluteLink = unpack widgetMemcachedBaseUrl </> fileName

48
src/Foundation/Type.hs
View File

@ -1,14 +1,14 @@
module Foundation.Type module Foundation.Type
( UniWorX(..) ( UniWorX(..)
, SomeSessionStorage(..)
, _SessionStorageMemcachedSql, _SessionStorageAcid
, SMTPPool , 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 ) where
import Import.NoFoundation import Import.NoFoundation
import Database.Persist.Sql (ConnectionPool) import Database.Persist.Sql (ConnectionPool)
import qualified Web.ClientSession as ClientSession
import Jobs.Types import Jobs.Types
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
@ -21,33 +21,41 @@ import qualified Database.Memcached.Binary.IO as Memcached
type SMTPPool = Pool SMTPConnection 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 -- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
-- access to the data present here. -- access to the data present here.
data UniWorX = UniWorX data UniWorX = UniWorX
{ appSettings' :: AppSettings { appSettings' :: AppSettings
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving. , appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool. , appConnPool :: ConnectionPool -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool , appSmtpPool :: Maybe SMTPPool
, appLdapPool :: Maybe LdapPool , appLdapPool :: Maybe LdapPool
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
, appHttpManager :: Manager , appHttpManager :: Manager
, appLogger :: (ReleaseKey, TVar Logger) , appLogger :: (ReleaseKey, TVar Logger)
, appLogSettings :: TVar LogSettings , appLogSettings :: TVar LogSettings
, appCryptoIDKey :: CryptoIDKey , appCryptoIDKey :: CryptoIDKey
, appClusterID :: ClusterId , appClusterID :: ClusterId
, appInstanceID :: InstanceId , appInstanceID :: InstanceId
, appJobState :: TMVar JobState , appJobState :: TMVar JobState
, appSessionKey :: ClientSession.Key , appSessionStore :: SomeSessionStorage
, appSecretBoxKey :: SecretBox.Key , appSecretBoxKey :: SecretBox.Key
, appJSONWebKeySet :: Jose.JwkSet , appJSONWebKeySet :: Jose.JwkSet
, appHealthReport :: TVar (Set (UTCTime, HealthReport)) , appHealthReport :: TVar (Set (UTCTime, HealthReport))
} }
makeLenses_ ''UniWorX makeLenses_ ''UniWorX
instance HasInstanceID UniWorX InstanceId where instance HasInstanceID UniWorX InstanceId where
instanceID = _appInstanceID instanceID = _appInstanceID
instance HasClusterID UniWorX ClusterId where
clusterID = _appClusterID
instance HasJSONWebKeySet UniWorX Jose.JwkSet where instance HasJSONWebKeySet UniWorX Jose.JwkSet where
jsonWebKeySet = _appJSONWebKeySet jsonWebKeySet = _appJSONWebKeySet
instance HasHttpManager UniWorX Manager where instance HasHttpManager UniWorX Manager where

4
src/Handler/Metrics.hs
View File

@ -23,11 +23,11 @@ getMetricsR = selectRep $ do
metricsHtml = do metricsHtml = do
samples <- collectMetrics samples <- collectMetrics
metricsToken <- runMaybeT . hoist runDB $ do metricsBearer <- runMaybeT . hoist runDB $ do
uid <- MaybeT maybeAuthId uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid 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 defaultLayout $ do
setTitleI MsgTitleMetrics setTitleI MsgTitleMetrics

10
src/Handler/Profile.hs
View File

@ -766,8 +766,8 @@ postUserNotificationR cID = do
uid <- decrypt cID uid <- decrypt cID
User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
mJwt <- askJwt mBearer <- askBearer
isModal <- hasCustomHeader HeaderIsModal isModal <- hasCustomHeader HeaderIsModal
let formWidget = wrapForm nsInnerWdgt def let formWidget = wrapForm nsInnerWdgt def
{ formAction = Just . SomeRoute $ UserNotificationR cID { formAction = Just . SomeRoute $ UserNotificationR cID
@ -775,7 +775,7 @@ postUserNotificationR cID = do
, formAttrs = [ asyncSubmitAttr | isModal ] , 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 ] lift . runDB $ update uid [ UserNotificationSettings =. ns ]
tell . pure =<< messageI Success MsgNotificationSettingsUpdate tell . pure =<< messageI Success MsgNotificationSettingsUpdate
@ -800,12 +800,12 @@ getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html
getSetDisplayEmailR = postSetDisplayEmailR getSetDisplayEmailR = postSetDisplayEmailR
postSetDisplayEmailR = do postSetDisplayEmailR = do
uid <- requireAuthId uid <- requireAuthId
mDisplayEmail <- requireCurrentTokenRestrictions mDisplayEmail <- requireCurrentBearerRestrictions
case mDisplayEmail of case mDisplayEmail of
Nothing -> invalidArgs ["Bearer token required"] Nothing -> invalidArgs ["Bearer token required"]
Just displayEmail -> do Just displayEmail -> do
((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedJwtPost buttonForm ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedBearerPost buttonForm
let btnView' = wrapForm btnView def let btnView' = wrapForm btnView def
{ formSubmit = FormNoSubmit { formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute SetDisplayEmailR , formAction = Just $ SomeRoute SetDisplayEmailR

4
src/Handler/Users.hs
View File

@ -476,13 +476,13 @@ postUserPasswordR cID = do
[ False <$ guard (isn't _AuthPWHash userAuthentication) [ False <$ guard (isn't _AuthPWHash userAuthentication)
, False <$ guard isAdmin , False <$ guard isAdmin
, do , do
authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentTokenRestrictions authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $ unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
invalidArgsI [MsgUnauthorizedPasswordResetToken] invalidArgsI [MsgUnauthorizedPasswordResetToken]
return False return False
] ]
((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
currentResult <- if currentResult <- if
| AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication | AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
, requireCurrent , requireCurrent

12
src/Handler/Utils/Invitations.hs
View File

@ -218,9 +218,9 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
route <- mapReaderT liftHandler $ invitationRoute fEnt dat route <- mapReaderT liftHandler $ invitationRoute fEnt dat
InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) let token = protoToken & bearerRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
jwt <- encodeToken token bearer <- encodeBearer token
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)])
jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat
jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat) jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat)
@ -228,7 +228,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
{ invitationEmail = jInvitee { invitationEmail = jInvitee
, invitationFor = invRef @junction fid , invitationFor = invRef @junction fid
, invitationData = toJSON $ dat ^. _invitationDBData , invitationData = toJSON $ dat ^. _invitationDBData
, invitationExpiresAt = tokenExpiresAt token , invitationExpiresAt = bearerExpiresAt token
} }
queueDBJob JobInvitation{..} queueDBJob JobInvitation{..}
@ -362,7 +362,7 @@ invitationR' :: forall junction m.
-> m Html -> m Html
-- | Generic handler for incoming invitations -- | Generic handler for incoming invitations
invitationR' InvitationConfig{..} = liftHandler $ do invitationR' InvitationConfig{..} = liftHandler $ do
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction) InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentBearerRestrictions :: Handler (InvitationTokenRestriction junction)
invitee <- requireAuthId invitee <- requireAuthId
cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute
@ -379,7 +379,7 @@ invitationR' InvitationConfig{..} = liftHandler $ do
iData :: InvitationData junction iData :: InvitationData junction
iData = review _InvitationData (dbData, itData) iData = review _InvitationData (dbData, itData)
guardAuthResult =<< hoist lift (invitationRestriction fEnt iData) 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 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)) btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
case btnRes of case btnRes of

24
src/Handler/Utils/Tokens.hs
View File

@ -1,6 +1,6 @@
module Handler.Utils.Tokens module Handler.Utils.Tokens
( maybeBearerToken, requireBearerToken ( maybeBearerToken, requireBearerToken
, maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions , maybeCurrentBearerRestrictions, requireCurrentBearerRestrictions
) where ) where
import Import import Import
@ -16,32 +16,32 @@ maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX) requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
requireBearerToken = liftHandler $ do 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 mAuthId <- maybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute isWrite <- isWriteRequest currentRoute
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token guardAuthResult <=< runDB $ validateBearer mAuthId currentRoute isWrite bearer
return token return bearer
requireCurrentTokenRestrictions :: ( MonadHandler m requireCurrentBearerRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, FromJSON a , FromJSON a
, ToJSON a , ToJSON a
) )
=> m (Maybe a) => m (Maybe a)
requireCurrentTokenRestrictions = runMaybeT $ do requireCurrentBearerRestrictions = runMaybeT $ do
token <- requireBearerToken bearer <- requireBearerToken
route <- MaybeT getCurrentRoute route <- MaybeT getCurrentRoute
hoistMaybe $ token ^? _tokenRestrictionIx route hoistMaybe $ bearer ^? _bearerRestrictionIx route
maybeCurrentTokenRestrictions :: ( MonadHandler m maybeCurrentBearerRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadCatch m , MonadCatch m
, FromJSON a , FromJSON a
, ToJSON a , ToJSON a
) )
=> m (Maybe a) => m (Maybe a)
maybeCurrentTokenRestrictions = runMaybeT $ do maybeCurrentBearerRestrictions = runMaybeT $ do
token <- MaybeT maybeBearerToken bearer <- MaybeT maybeBearerToken
route <- MaybeT getCurrentRoute route <- MaybeT getCurrentRoute
hoistMaybe $ token ^? _tokenRestrictionIx route hoistMaybe $ bearer ^? _bearerRestrictionIx route

3
src/Import/NoFoundation.hs
View File

@ -19,3 +19,6 @@ import Settings.WellKnownFiles as Import
import CryptoID as Import import CryptoID as Import
import Audit as Import import Audit as Import
import Web.ServerSession.Backend.Persistent.Memcached as Import
import Web.ServerSession.Backend.Acid as Import (AcidStorage(..))

4
src/Import/NoModel.hs
View File

@ -61,6 +61,7 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Min(..), Max(..)) import Data.Semigroup as Import (Min(..), Max(..))
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..)) import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..))
import Data.Binary as Import (Binary) import Data.Binary as Import (Binary)
import Data.Binary.Instances as Import ()
import System.FilePath as Import hiding (joinPath, normalise, isValid, makeValid) 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.Fixed.Instances as Import ()
import Data.Scientific.Instances as Import () import Data.Scientific.Instances as Import ()
import Data.Set.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.Clock.Instances as Import ()
import Data.Time.LocalTime.Instances as Import () import Data.Time.LocalTime.Instances as Import ()
import Data.Time.Calendar.Instances as Import () import Data.Time.Calendar.Instances as Import ()

4
src/Jobs/Handler/ChangeUserDisplayEmail.hs
View File

@ -12,8 +12,8 @@ import Text.Hamlet
dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler () dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
jwt <- encodeToken token jwt <- encodeBearer bearer
let let
setDisplayEmailUrl :: SomeRoute UniWorX setDisplayEmailUrl :: SomeRoute UniWorX
setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)]) setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)])

2
src/Jobs/Handler/SendNotification/Utils.hs
View File

@ -16,7 +16,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX)) mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandler $ do mkEditNotifications uid = liftHandler $ do
cID <- encrypt uid 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 let
editNotificationsUrl :: SomeRoute UniWorX editNotificationsUrl :: SomeRoute UniWorX
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)]) editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])

10
src/Jobs/Handler/SendPasswordReset.hs
View File

@ -29,11 +29,11 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
LTUUnique utc' _ -> utc' LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays 2 $ utctDay now) 0 _other -> UTCTime (addDays 2 $ utctDay now) 0
resetToken' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing resetBearer' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
let resetToken = resetToken' let resetBearer = resetBearer'
& tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication) & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
encodedToken <- encodeToken resetToken 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)) addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/passwordReset.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

8
src/Jobs/HealthReport.hs
View File

@ -43,10 +43,10 @@ dispatchHealthCheckMatchingClusterConfig
ourSetting <- getsYesod appCryptoIDKey ourSetting <- getsYesod appCryptoIDKey
dbSetting <- clusterSetting @'ClusterCryptoIDKey dbSetting <- clusterSetting @'ClusterCryptoIDKey
return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting
clusterSettingMatches ClusterClientSessionKey = do clusterSettingMatches ClusterServerSessionKey = do
ourSetting <- getsYesod appSessionKey ourSetting <- getsYesod . preview $ _appSessionStore . _SessionStorageMemcachedSql . _mcdSqlMemcachedKey
dbSetting <- clusterSetting @'ClusterClientSessionKey dbSetting <- clusterSetting @'ClusterServerSessionKey
return $ Just ourSetting == dbSetting return $ maybe True ((== dbSetting) . Just) ourSetting
clusterSettingMatches ClusterSecretBoxKey = do clusterSettingMatches ClusterSecretBoxKey = do
ourSetting <- getsYesod appSecretBoxKey ourSetting <- getsYesod appSecretBoxKey
dbSetting <- clusterSetting @'ClusterSecretBoxKey dbSetting <- clusterSetting @'ClusterSecretBoxKey

2
src/Model.hs
View File

@ -26,7 +26,7 @@ import Text.Blaze (ToMarkup(..))
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities
-- at: -- at:
-- http://www.yesodweb.com/book/persistent/ -- 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") $(persistDirectoryWith lowerCaseSettings "models")

8
src/Model/Migration.hs
View File

@ -34,6 +34,8 @@ import qualified Net.IPv6 as IPv6
import qualified Data.Char as Char import qualified Data.Char as Char
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
-- Database versions must follow https://pvp.haskell.org: -- 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) -- - 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) -- - 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 deriving Show Eq Ord
|] |]
migrateAll' :: Migration
migrateAll' = sequence_
[ migrateUniWorX
, migrateMemcachedSqlStorage
]
migrateAll :: ( MonadLogger m migrateAll :: ( MonadLogger m
, MonadResource m , MonadResource m
, MonadUnliftIO m , MonadUnliftIO m

151
src/Model/Tokens.hs
View File

@ -1,150 +1,7 @@
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE UndecidableInstances #-}
module Model.Tokens module Model.Tokens
( BearerToken(..) ( module Model.Tokens
, _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
, tokenRestrict
, tokenToJSON, tokenParseJSON
) where ) where
import ClassyPrelude.Yesod import Model.Tokens.Lens as Model.Tokens
import Yesod.Core.Instances () import Model.Tokens.Bearer as Model.Tokens
import Model.Tokens.Session as Model.Tokens
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

164
src/Model/Tokens/Bearer.hs Normal file
View 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
View 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
View 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

86
src/Settings.hs
View File

@ -59,6 +59,10 @@ import Jose.Jwt (JwtEncoding(..))
import System.FilePath.Glob import System.FilePath.Glob
import Handler.Utils.Submission.TH 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 -- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files, -- loaded from various sources: defaults, environment variables, config files,
@ -88,6 +92,13 @@ data AppSettings = AppSettings
, appIpFromHeader :: Bool , appIpFromHeader :: Bool
-- ^ Get the IP address from the header when logging. Useful when sitting -- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy. -- behind a reverse proxy.
, appServerSessionConfig :: ServerSessionSettings
, appServerSessionAcidFallback :: Bool
, appSessionMemcachedConf :: Maybe MemcachedConf
, appSessionTokenExpiration :: Maybe NominalDiffTime
, appSessionTokenEncoding :: JwtEncoding
, appMailFrom :: Address , appMailFrom :: Address
, appMailObjectDomain :: Text , appMailObjectDomain :: Text
, appMailVerp :: VerpMode , appMailVerp :: VerpMode
@ -101,8 +112,8 @@ data AppSettings = AppSettings
, appNotificationExpiration :: NominalDiffTime , appNotificationExpiration :: NominalDiffTime
, appSessionTimeout :: NominalDiffTime , appSessionTimeout :: NominalDiffTime
, appMaximumContentLength :: Maybe Word64 , appMaximumContentLength :: Maybe Word64
, appJwtExpiration :: Maybe NominalDiffTime , appBearerExpiration :: Maybe NominalDiffTime
, appJwtEncoding :: JwtEncoding , appBearerEncoding :: JwtEncoding
, appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime , appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime
, appHealthCheckDelayNotify :: Bool , appHealthCheckDelayNotify :: Bool
@ -145,7 +156,13 @@ data AppSettings = AppSettings
, appInitialInstanceID :: Maybe (Either FilePath UUID) , appInitialInstanceID :: Maybe (Either FilePath UUID)
, appRibbon :: Maybe Text , 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 data LogSettings = LogSettings
{ logAll, logDetailed :: Bool { logAll, logDetailed :: Bool
@ -211,25 +228,34 @@ data SmtpConf = SmtpConf
} deriving (Show) } deriving (Show)
data WidgetMemcachedConf = WidgetMemcachedConf data WidgetMemcachedConf = WidgetMemcachedConf
{ widgetMemcachedConnectInfo :: Memcached.ConnectInfo { widgetMemcachedConf :: MemcachedConf
, widgetMemcachedBaseUrl :: Text , widgetMemcachedBaseUrl :: Text
, widgetMemcachedExpiry :: Maybe NominalDiffTime } deriving (Show)
data MemcachedConf = MemcachedConf
{ memcachedConnectInfo :: Memcached.ConnectInfo
, memcachedExpiry :: Maybe NominalDiffTime
} deriving (Show) } deriving (Show)
instance FromJSON Memcached.Auth where instance FromJSON Memcached.Auth where
parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
instance FromJSON WidgetMemcachedConf where instance FromJSON MemcachedConf where
parseJSON = withObject "WidgetMemcachedConf" $ \o -> do parseJSON = withObject "MemcachedConf" $ \o -> do
connectHost <- o .:? "host" .!= "" connectHost <- o .:? "host" .!= ""
connectPort <- o .: "port" connectPort <- o .: "port"
connectAuth <- o .: "auth" connectAuth <- o .: "auth"
numConnection <- o .: "limit" numConnection <- o .: "limit"
connectionIdleTime <- o .: "timeout" connectionIdleTime <- o .: "timeout"
widgetMemcachedBaseUrl <- o .:? "base-url" .!= "" memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
widgetMemcachedExpiry <- 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 data ResourcePoolConf = ResourcePoolConf
{ poolStripes :: Int { poolStripes :: Int
@ -343,6 +369,25 @@ instance FromJSON JwtEncoding where
return $ JweEncoding alg enc 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 instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do parseJSON = withObject "AppSettings" $ \o -> do
@ -363,13 +408,17 @@ instance FromJSON AppSettings where
Ldap.Plain host -> not $ null host Ldap.Plain host -> not $ null host
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap" appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" 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 connectHost
, not $ null widgetMemcachedBaseUrl
, numConnection > 0 , numConnection > 0
, connectionIdleTime >= 0 , connectionIdleTime >= 0
] ]
validWidgetMemcachedConf WidgetMemcachedConf{..} = and
[ not $ null widgetMemcachedBaseUrl
, validMemcachedConf widgetMemcachedConf
]
appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached" appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached"
appRoot <- o .:? "approot" appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host" appHost <- fromString <$> o .: "host"
appPort <- o .: "port" appPort <- o .: "port"
@ -387,8 +436,8 @@ instance FromJSON AppSettings where
appNotificationRateLimit <- o .: "notification-rate-limit" appNotificationRateLimit <- o .: "notification-rate-limit"
appNotificationCollateDelay <- o .: "notification-collate-delay" appNotificationCollateDelay <- o .: "notification-collate-delay"
appNotificationExpiration <- o .: "notification-expiration" appNotificationExpiration <- o .: "notification-expiration"
appJwtExpiration <- o .:? "jwt-expiration" appBearerExpiration <- o .:? "bearer-expiration"
appJwtEncoding <- o .: "jwt-encoding" appBearerEncoding <- o .: "bearer-encoding"
appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval" appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
appHealthCheckDelayNotify <- o .: "health-check-delay-notify" appHealthCheckDelayNotify <- o .: "health-check-delay-notify"
@ -417,6 +466,7 @@ instance FromJSON AppSettings where
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev
appServerSessionAcidFallback <- o .:? "server-session-acid-fallback" .!= defaultDev
appInitialLogSettings <- o .: "log-settings" appInitialLogSettings <- o .: "log-settings"
@ -438,7 +488,11 @@ instance FromJSON AppSettings where
appRibbon <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon" 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 makeClassy_ ''AppSettings

22
src/Settings/Cluster.hs
View File

@ -9,20 +9,18 @@ import ClassyPrelude.Yesod
import Web.HttpApiData import Web.HttpApiData
import Utils import Utils
import Control.Lens
import Data.Universe import Data.Universe
import qualified Data.Aeson as Aeson 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.SecretBox as SecretBox
import qualified Crypto.Saltine.Core.AEAD as AEAD
import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Saltine.Class as Saltine
import Data.CryptoID.ByteString (CryptoIDKey) import Data.CryptoID.ByteString (CryptoIDKey)
import qualified Data.CryptoID.ByteString as CryptoID import qualified Data.CryptoID.ByteString as CryptoID
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
import qualified Data.Serialize as Serialize
import qualified Data.ByteString.Base64.URL as Base64 import qualified Data.ByteString.Base64.URL as Base64
import qualified Jose.Jwa as Jose import qualified Jose.Jwa as Jose
@ -39,7 +37,7 @@ import Model.Types.TH.PathPiece
data ClusterSettingsKey data ClusterSettingsKey
= ClusterCryptoIDKey = ClusterCryptoIDKey
| ClusterClientSessionKey | ClusterServerSessionKey
| ClusterSecretBoxKey | ClusterSecretBoxKey
| ClusterJSONWebKeySet | ClusterJSONWebKeySet
| ClusterId | ClusterId
@ -83,18 +81,18 @@ instance FromJSON CryptoIDKey where
| otherwise -> fail $ show (length bs) ++ " extra bytes" | otherwise -> fail $ show (length bs) ++ " extra bytes"
instance ClusterSetting 'ClusterClientSessionKey where instance ClusterSetting 'ClusterServerSessionKey where
type ClusterSettingValue 'ClusterClientSessionKey = ClientSession.Key type ClusterSettingValue 'ClusterServerSessionKey = AEAD.Key
initClusterSetting _ = liftIO $ view _2 <$> ClientSession.randomKey initClusterSetting _ = liftIO AEAD.newKey
knownClusterSetting _ = ClusterClientSessionKey knownClusterSetting _ = ClusterServerSessionKey
instance ToJSON ClientSession.Key where instance ToJSON AEAD.Key where
toJSON = Aeson.String . decodeUtf8 . Base64.encode . Serialize.encode toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode
instance FromJSON ClientSession.Key where instance FromJSON AEAD.Key where
parseJSON = Aeson.withText "Key" $ \t -> do parseJSON = Aeson.withText "Key" $ \t -> do
bytes <- either fail return . Base64.decode $ encodeUtf8 t 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 instance ClusterSetting 'ClusterSecretBoxKey where

3
src/Utils.hs
View File

@ -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 :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT f g = either f g <=< runExceptT 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 :: (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) catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)

3
src/Utils/Lens.hs
View File

@ -240,6 +240,9 @@ makeLenses_ ''ExternalExamResult
class HasInstanceID s a | s -> a where class HasInstanceID s a | s -> a where
instanceID :: Lens' s a instanceID :: Lens' s a
class HasClusterID s a | s -> a where
clusterID :: Lens' s a
class HasHttpManager s a | s -> a where class HasHttpManager s a | s -> a where
httpManager :: Lens' s a httpManager :: Lens' s a

84
src/Utils/Tokens.hs
View File

@ -1,9 +1,9 @@
module Utils.Tokens module Utils.Tokens
( bearerToken ( bearerToken
, encodeToken, BearerTokenException(..), decodeToken , encodeBearer, BearerTokenException(..), decodeBearer
, tokenParseJSON' , bearerParseJSON'
, askJwt , askBearer
, formEmbedJwtPost, formEmbedJwtGet , formEmbedBearerPost, formEmbedBearerGet
) where ) where
import Import.NoModel import Import.NoModel
@ -32,7 +32,7 @@ import CryptoID
import Text.Blaze (Markup) import Text.Blaze (Markup)
tokenParseJSON' :: forall m. bearerParseJSON' :: forall m.
( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser) ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
, ParseRoute (HandlerSite m) , ParseRoute (HandlerSite m)
, Hashable (Route (HandlerSite m)) , Hashable (Route (HandlerSite m))
@ -42,14 +42,15 @@ tokenParseJSON' :: forall m.
) )
=> m (Value -> Parser (BearerToken (HandlerSite m))) => m (Value -> Parser (BearerToken (HandlerSite m)))
-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s -- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
tokenParseJSON' = do bearerParseJSON' = do
cidKey <- cryptoIDKey return cidKey <- cryptoIDKey return
return $ flip runReaderT cidKey . tokenParseJSON return $ flip runReaderT cidKey . bearerParseJSON
bearerToken :: forall m. bearerToken :: forall m.
( MonadHandler m ( MonadHandler m
, HasInstanceID (HandlerSite m) InstanceId , HasInstanceID (HandlerSite m) InstanceId
, HasClusterID (HandlerSite m) ClusterId
, HasAppSettings (HandlerSite m) , HasAppSettings (HandlerSite m)
) )
=> Either Value (AuthId (HandlerSite m)) => Either Value (AuthId (HandlerSite m))
@ -59,26 +60,27 @@ bearerToken :: forall m.
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
-> m (BearerToken (HandlerSite m)) -> m (BearerToken (HandlerSite m))
-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict` -- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do
tokenIdentifier <- liftIO getRandom bearerIdentifier <- liftIO getRandom
tokenIssuedAt <- liftIO getCurrentTime bearerIssuedAt <- liftIO getCurrentTime
tokenIssuedBy <- getsYesod $ view instanceID bearerIssuedBy <- getsYesod $ view instanceID
bearerIssuedFor <- getsYesod $ view clusterID
defaultExpiration <- getsYesod $ view _appJwtExpiration defaultExpiration <- getsYesod $ view _appBearerExpiration
let tokenExpiresAt let bearerExpiresAt
| Just t <- mTokenExpiresAt | Just t <- mBearerExpiresAt
= t = t
| Just tDiff <- defaultExpiration | Just tDiff <- defaultExpiration
= Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt = Just $ tDiff `addUTCTime` fromMaybe bearerIssuedAt bearerStartsAt
| otherwise | otherwise
= Nothing = Nothing
tokenRestrictions = HashMap.empty bearerRestrictions = HashMap.empty
return BearerToken{..} return BearerToken{..}
encodeToken :: forall m. encodeBearer :: forall m.
( MonadHandler m ( MonadHandler m
, HasJSONWebKeySet (HandlerSite m) JwkSet , HasJSONWebKeySet (HandlerSite m) JwkSet
, HasAppSettings (HandlerSite m) , HasAppSettings (HandlerSite m)
@ -86,11 +88,11 @@ encodeToken :: forall m.
, RenderRoute (HandlerSite m) , RenderRoute (HandlerSite m)
) )
=> BearerToken (HandlerSite m) -> m Jwt => BearerToken (HandlerSite m) -> m Jwt
-- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `appJwtEncoding` -- ^ Call `bearerToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
encodeToken token = do encodeBearer token = do
payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token payload <- Jose.Claims . toStrict . JSON.encode <$> bearerToJSON token
JwkSet jwks <- getsYesod $ view jsonWebKeySet JwkSet jwks <- getsYesod $ view jsonWebKeySet
jwtEncoding <- getsYesod $ view _appJwtEncoding jwtEncoding <- getsYesod $ view _appBearerEncoding
either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload) either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
@ -103,7 +105,7 @@ data BearerTokenException
instance Exception BearerTokenException instance Exception BearerTokenException
decodeToken :: forall m. decodeBearer :: forall m.
( MonadHandler m ( MonadHandler m
, HasJSONWebKeySet (HandlerSite m) JwkSet , HasJSONWebKeySet (HandlerSite m) JwkSet
, HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser) , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
@ -113,50 +115,50 @@ decodeToken :: forall m.
, Hashable (Route (HandlerSite m)) , Hashable (Route (HandlerSite m))
) )
=> Jwt -> m (BearerToken (HandlerSite m)) => Jwt -> m (BearerToken (HandlerSite m))
-- ^ Decode a `Jwt` and call `tokenParseJSON` -- ^ Decode a `Jwt` and call `bearerParseJSON`
-- --
-- Throws `bearerTokenException`s -- Throws `bearerTokenException`s
decodeToken (Jwt bs) = do decodeBearer (Jwt bs) = do
JwkSet jwks <- getsYesod $ view jsonWebKeySet JwkSet jwks <- getsYesod $ view jsonWebKeySet
content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs) content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
content' <- case content of content' <- case content of
Jose.Unsecured _ -> throwM BearerTokenUnsecured Jose.Unsecured _ -> throwM BearerTokenUnsecured
Jose.Jws (_header, payload) -> return payload Jose.Jws (_header, payload) -> return payload
Jose.Jwe (_header, payload) -> return payload Jose.Jwe (_header, payload) -> return payload
parser <- tokenParseJSON' parser <- bearerParseJSON'
token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content' bearer@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
unless (NTop tokenExpiresAt > NTop (Just now)) $ unless (NTop bearerExpiresAt > NTop (Just now)) $
throwM BearerTokenExpired throwM BearerTokenExpired
unless (tokenStartsAt <= Just now) $ unless (bearerStartsAt <= Just now) $
throwM BearerTokenNotStarted throwM BearerTokenNotStarted
return token return bearer
askJwt :: forall m. ( MonadHandler m ) askBearer :: forall m. ( MonadHandler m )
=> m (Maybe Jwt) => m (Maybe Jwt)
-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter -- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
askJwt = runMaybeT $ asum askBearer = runMaybeT $ asum
[ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
, MaybeT $ lookupGlobalPostParam PostBearer , MaybeT $ lookupGlobalPostParam PostBearer
, MaybeT $ lookupGlobalGetParam GetBearer , MaybeT $ lookupGlobalGetParam GetBearer
, fmap Jwt . MaybeT $ lookupSessionBS (toPathPiece SessionBearer) , fmap Jwt . MaybeT $ lookupSessionBS (toPathPiece SessionBearer)
] ]
formEmbedJwtPost, formEmbedJwtGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a) formEmbedBearerPost, formEmbedBearerGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
formEmbedJwtPost f fragment = do formEmbedBearerPost f fragment = do
mJwt <- askJwt mBearer <- askBearer
f [shamlet| f [shamlet|
$newline never $newline never
$maybe jwt <- mJwt $maybe bearer <- mBearer
<input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}> <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece bearer}>
#{fragment} #{fragment}
|] |]
formEmbedJwtGet f fragment = do formEmbedBearerGet f fragment = do
mJwt <- askJwt mBearer <- askBearer
f [shamlet| f [shamlet|
$newline never $newline never
$maybe jwt <- mJwt $maybe bearer <- mBearer
<input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece jwt}> <input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece bearer}>
#{fragment} #{fragment}
|] |]

175
src/Web/ServerSession/Backend/Persistent/Memcached.hs Normal file
View 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
View 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
View File

@ -23,6 +23,12 @@ extra-deps:
commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git - git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git
commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 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 - colonnade-1.2.0.2
- hsass-0.8.0 - hsass-0.8.0
@ -92,5 +98,9 @@ extra-deps:
# - skylighting-core-0.8.3.2 # - skylighting-core-0.8.3.2
# - texmath-0.12.0.1 # - texmath-0.12.0.1
- binary-instances-1
- acid-state-0.16.0
resolver: lts-15.0 resolver: lts-15.0
allow-newer: true allow-newer: true

46
stack.yaml.lock
View File

@ -88,6 +88,38 @@ packages:
original: original:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git
commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 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: - completed:
hackage: colonnade-1.2.0.2@sha256:c95c2ecff5cfa28c736d8fa662d28b71129f67457068e3f4467b296a621607ab,2099 hackage: colonnade-1.2.0.2@sha256:c95c2ecff5cfa28c736d8fa662d28b71129f67457068e3f4467b296a621607ab,2099
pantry-tree: pantry-tree:
@ -228,6 +260,20 @@ packages:
sha256: 9d4d8e7a85166ffd951b02f87be540607b55084c04730932346072329adf4913 sha256: 9d4d8e7a85166ffd951b02f87be540607b55084c04730932346072329adf4913
original: original:
hackage: doctemplates-0.8.1 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: snapshots:
- completed: - completed:
size: 488576 size: 488576

2
start.sh
View File

@ -10,6 +10,8 @@ export DETAILED_LOGGING=${DETAILED_LOGGING:-true}
export LOG_ALL=${LOG_ALL:-false} export LOG_ALL=${LOG_ALL:-false}
export LOGLEVEL=${LOGLEVEL:-info} export LOGLEVEL=${LOGLEVEL:-info}
export DUMMY_LOGIN=${DUMMY_LOGIN:-true} 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 ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
export RIBBON=${RIBBON:-${__HOST:-localhost}} export RIBBON=${RIBBON:-${__HOST:-localhost}}
unset HOST unset HOST

2
templates/metrics.hamlet
View File

@ -1,5 +1,5 @@
$newline never $newline never
$maybe t <- metricsToken $maybe t <- metricsBearer
<section> <section>
<pre style="font-family: monospace; white-space: pre-wrap; word-break: break-all;"> <pre style="font-family: monospace; white-space: pre-wrap; word-break: break-all;">
#{toPathPiece t} #{toPathPiece t}