diff --git a/config/settings.yml b/config/settings.yml
index d305be6a2..e9d4787ed 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -31,8 +31,8 @@ notification-rate-limit: 3600
notification-collate-delay: 7200
notification-expiration: 259200
session-timeout: 7200
-jwt-expiration: 604800
-jwt-encoding: HS256
+bearer-expiration: 604800
+bearer-encoding: HS256
maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
session-files-expire: 3600
prune-unreferenced-files: 86400
@@ -67,6 +67,7 @@ ip-retention-time: 1209600
# Debugging
auth-dummy-login: "_env:DUMMY_LOGIN:false"
allow-deprecated: "_env:ALLOW_DEPRECATED:false"
+server-session-acid-fallback: "_env:SERVER_SESSION_ACID_FALLBACK:false"
auth-pw-hash:
algorithm: "pbkdf2"
@@ -119,13 +120,32 @@ smtp:
limit: "_env:SMTPLIMIT:10"
widget-memcached:
- host: "_env:MEMCACHEDHOST:"
- port: "_env:MEMCACHEDPORT:11211"
+ host: "_env:WIDGET_MEMCACHED_HOST:"
+ port: "_env:WIDGET_MEMCACHED_PORT:11211"
auth: []
- limit: "_env:MEMCACHEDLIMIT:10"
- timeout: "_env:MEMCACHEDTIMEOUT:20"
- base-url: "_env:MEMCACHEDROOT:"
- expiration: "_env:MEMCACHEDEXPIRATION:3600"
+ limit: "_env:WIDGET_MEMCACHED_LIMIT:10"
+ timeout: "_env:WIDGET_MEMCACHED_TIMEOUT:20"
+ base-url: "_env:WIDGET_MEMCACHED_ROOT:"
+ expiration: "_env:WIDGET_MEMCACHED_EXPIRATION:3600"
+
+session-memcached:
+ host: "_env:SESSION_MEMCACHED_HOST:"
+ port: "_env:SESSION_MEMCACHED_PORT:11211"
+ auth: []
+ limit: "_env:SESSION_MEMCACHED_LIMIT:10"
+ timeout: "_env:SESSION_MEMCACHED_TIMEOUT:20"
+ expiration: "_env:SESSION_MEMCACHED_EXPIRATION:28807"
+
+server-sessions:
+ cookie-name: "_SESSION"
+ idle-timeout: 28807
+ absolute-timeout: 604801
+ timeout-resolution: 601
+ persistent-cookies: true
+ http-only-cookies: true
+ secure-cookies: "_env:SERVER_SESSION_COOKIES_SECURE:true"
+session-token-expiration: 28807
+session-token-encoding: HS256
user-defaults:
max-favourites: 12
diff --git a/ghci.sh b/ghci.sh
index 441f9f649..ab5479c78 100755
--- a/ghci.sh
+++ b/ghci.sh
@@ -4,10 +4,16 @@ set -e
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+export DETAILED_LOGGING=${DETAILED_LOGGING:-true}
+export LOG_ALL=${LOG_ALL:-false}
+export LOGLEVEL=${LOGLEVEL:-info}
+export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
+export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
+export SERVER_SESSION_COOKIES_SECURE=${SERVER_SESSION_COOKIES_SECURE:-false}
+export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
+export RIBBON=${RIBBON:-${__HOST:-localhost}}
unset HOST
-export DETAILED_LOGGING=true
-export LOG_ALL=true
-export DUMMY_LOGIN=true
+
move-back() {
mv -v .stack-work .stack-work-ghci
diff --git a/package.yaml b/package.yaml
index c4616ebab..713a25260 100644
--- a/package.yaml
+++ b/package.yaml
@@ -61,6 +61,7 @@ dependencies:
- cryptoids
- cryptoids-class
- binary
+ - binary-instances
- cereal
- mtl
- esqueleto >=3.1.0
@@ -103,7 +104,9 @@ dependencies:
- postgresql-simple
- word24
- mmorph
- - clientsession
+ - serversession
+ - serversession-backend-acid-state
+ - acid-state
- monad-memo
- xss-sanitize
- text-metrics
diff --git a/src/Application.hs b/src/Application.hs
index 59007c31e..918495cc6 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -18,7 +18,7 @@ module Application
import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
- pgPoolSize, runSqlPool)
+ pgPoolSize, runSqlPool, ConnectionPool)
import Import hiding (cancel)
import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai (Middleware)
@@ -88,6 +88,9 @@ import qualified Data.Set as Set
import Handler.Utils.Routes (classifyHandler)
+import qualified Data.Acid.Memory as Acid
+import qualified Web.ServerSession.Backend.Acid as Acid
+
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.News
@@ -125,7 +128,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
-makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX
+makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadThrow m) => AppSettings -> m UniWorX
makeFoundation appSettings'@AppSettings{..} = do
registerGHCMetrics
@@ -168,7 +171,7 @@ makeFoundation appSettings'@AppSettings{..} = do
-- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation.
- let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..}
+ let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..}
-- The UniWorX {..} syntax is an example of record wild cards. For more
-- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -177,7 +180,7 @@ makeFoundation appSettings'@AppSettings{..} = do
(error "smtpPool forced in tempFoundation")
(error "ldapPool forced in tempFoundation")
(error "cryptoIDKey forced in tempFoundation")
- (error "sessionKey forced in tempFoundation")
+ (error "sessionStore forced in tempFoundation")
(error "secretBoxKey forced in tempFoundation")
(error "widgetMemcached forced in tempFoundation")
(error "JSONWebKeySet forced in tempFoundation")
@@ -191,9 +194,9 @@ makeFoundation appSettings'@AppSettings{..} = do
$logDebugS "setup" "SMTP-Pool"
createSmtpPool c
- appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do
+ appWidgetMemcached <- for appWidgetMemcachedConf $ \WidgetMemcachedConf{ widgetMemcachedConf } -> do
$logDebugS "setup" "Widget-Memcached"
- createWidgetMemcached c
+ createMemcached widgetMemcachedConf
-- Create the database connection pool
$logDebugS "setup" "PostgreSQL-Pool"
@@ -215,17 +218,42 @@ makeFoundation appSettings'@AppSettings{..} = do
liftIO . exitWith $ ExitFailure 2
$logDebugS "setup" "Cluster-Config"
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
- appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool
- let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID
+ appSessionStore <- mkSessionStore appSettings' sqlPool `runSqlPool` sqlPool
+
+ let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID
-- Return the foundation
$logDebugS "setup" "Done"
return foundation
+data SessionStoreException
+ = SessionStoreNotAvailable
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+instance Exception SessionStoreException
+
+mkSessionStore :: forall m.
+ ( MonadIO m
+ , MonadLogger m
+ , MonadThrow m
+ , MonadResource m
+ )
+ => AppSettings -> ConnectionPool -> ReaderT SqlBackend m SomeSessionStorage
+mkSessionStore AppSettings{..} mcdSqlConnPool
+ | Just mcdConf@MemcachedConf{..} <- appSessionMemcachedConf = do
+ mcdSqlMemcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterServerSessionKey)
+ $logDebugS "setup" "Session-Memcached"
+ mcdSqlMemcached <- createMemcached mcdConf
+ let mcdSqlMemcachedExpiration = memcachedExpiry
+ return $ _SessionStorageMemcachedSql # MemcachedSqlStorage{..}
+ | appServerSessionAcidFallback = liftIO $
+ review _SessionStorageAcid . Acid.AcidStorage <$> Acid.openMemoryState Acid.emptyState
+ | otherwise = throwM SessionStoreNotAvailable
+
+
clusterSetting :: forall key m p.
( MonadIO m
, ClusterSetting key
@@ -285,8 +313,8 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
return conn
liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
-createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection
-createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close
+createMemcached :: (MonadLogger m, MonadResource m) => MemcachedConf -> m Memcached.Connection
+createMemcached MemcachedConf{memcachedConnectInfo} = snd <$> allocate (Memcached.connect memcachedConnectInfo) Memcached.close
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs
index 10d4c106e..66849e5a5 100644
--- a/src/Data/Aeson/Types/Instances.hs
+++ b/src/Data/Aeson/Types/Instances.hs
@@ -9,11 +9,6 @@ import ClassyPrelude
import Data.Aeson.Types (Parser, Value)
import Control.Monad.Catch
-import Data.Binary (Binary)
-
-import Data.HashMap.Strict.Instances ()
-import Data.Vector.Instances ()
-
import Model.Types.TH.JSON (derivePersistFieldJSON)
import Control.Monad.Fail
@@ -22,7 +17,5 @@ import Control.Monad.Fail
instance MonadThrow Parser where
throwM = fail . show
-instance Binary Value
-
derivePersistFieldJSON ''Value
diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs
index 77f626338..6596fe47e 100644
--- a/src/Data/CaseInsensitive/Instances.hs
+++ b/src/Data/CaseInsensitive/Instances.hs
@@ -26,9 +26,6 @@ import qualified Database.Esqueleto as E
import Web.HttpApiData
-import Data.Binary (Binary)
-import qualified Data.Binary as Binary
-
import qualified Data.Csv as Csv
@@ -99,11 +96,6 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
toPathMultiPiece = toPathMultiPiece . CI.original
-instance (CI.FoldCase s, Binary s) => Binary (CI s) where
- get = CI.mk <$> Binary.get
- put = Binary.put . CI.original
- putList = Binary.putList . map CI.original
-
instance Csv.ToField s => Csv.ToField (CI s) where
toField = Csv.toField . CI.original
diff --git a/src/Data/HashMap/Strict/Instances.hs b/src/Data/HashMap/Strict/Instances.hs
deleted file mode 100644
index daa36c68a..000000000
--- a/src/Data/HashMap/Strict/Instances.hs
+++ /dev/null
@@ -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
diff --git a/src/Data/HashSet/Instances.hs b/src/Data/HashSet/Instances.hs
deleted file mode 100644
index 320ac8940..000000000
--- a/src/Data/HashSet/Instances.hs
+++ /dev/null
@@ -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
diff --git a/src/Data/Time/Calendar/Instances.hs b/src/Data/Time/Calendar/Instances.hs
index d5dd127ed..15c77e94b 100644
--- a/src/Data/Time/Calendar/Instances.hs
+++ b/src/Data/Time/Calendar/Instances.hs
@@ -6,7 +6,6 @@ module Data.Time.Calendar.Instances
) where
import ClassyPrelude
-import Data.Binary (Binary)
import Data.Time.Calendar
@@ -14,7 +13,6 @@ import Data.Universe
deriving newtype instance Hashable Day
-deriving newtype instance Binary Day
deriving instance Ord DayOfWeek
instance Universe DayOfWeek where
diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs
index 4b49cfa1f..2e410080e 100644
--- a/src/Data/Time/Clock/Instances.hs
+++ b/src/Data/Time/Clock/Instances.hs
@@ -9,9 +9,6 @@ import Database.Persist.Sql
import Data.Proxy
-import Data.Binary (Binary)
-import qualified Data.Binary as Binary
-
import Data.Time.Clock
import Data.Time.Calendar.Instances ()
import Web.PathPieces
@@ -44,10 +41,3 @@ instance Csv.ToField UTCTime where
instance Csv.FromField UTCTime where
parseField = iso8601ParseM <=< Csv.parseField
-
-
-instance Binary DiffTime where
- get = fromRational <$> Binary.get
- put = Binary.put . toRational
-
-instance Binary UTCTime
diff --git a/src/Data/Time/LocalTime/Instances.hs b/src/Data/Time/LocalTime/Instances.hs
index 39c0d70f0..210bc7f62 100644
--- a/src/Data/Time/LocalTime/Instances.hs
+++ b/src/Data/Time/LocalTime/Instances.hs
@@ -8,8 +8,6 @@ import ClassyPrelude
import Data.Time.LocalTime
-import Data.Binary (Binary)
-
import qualified Language.Haskell.TH.Syntax as TH
@@ -17,7 +15,6 @@ deriving instance Generic TimeOfDay
deriving instance Typeable TimeOfDay
instance Hashable TimeOfDay
-instance Binary TimeOfDay
deriving instance TH.Lift TimeZone
diff --git a/src/Data/Vector/Instances.hs b/src/Data/Vector/Instances.hs
deleted file mode 100644
index ecb64bd69..000000000
--- a/src/Data/Vector/Instances.hs
+++ /dev/null
@@ -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
diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs
index a44e6071b..4a3a7208c 100644
--- a/src/Database/Persist/Class/Instances.hs
+++ b/src/Database/Persist/Class/Instances.hs
@@ -13,6 +13,7 @@ import Database.Persist.Sql
import Data.Binary (Binary)
import qualified Data.Binary as Binary
+import Data.Binary.Instances ()
import qualified Data.Map as Map
diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs
index 0929a2886..e7309b6cc 100644
--- a/src/Database/Persist/Types/Instances.hs
+++ b/src/Database/Persist/Types/Instances.hs
@@ -11,6 +11,7 @@ import Database.Persist.Types
import Data.Time.Calendar.Instances ()
import Data.Time.LocalTime.Instances ()
import Data.Time.Clock.Instances ()
+import Data.Binary.Instances ()
import Data.Binary (Binary)
diff --git a/src/Foundation.hs b/src/Foundation.hs
index ff2328d83..41fa7917b 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -97,6 +97,9 @@ import qualified Ldap.Client as Ldap
import UnliftIO.Pool
+import qualified Web.ServerSession.Core as ServerSession
+import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
+
-- | Convenient Type Synonyms:
type DB = YesodDB UniWorX
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
@@ -298,7 +301,7 @@ trueAP = APPure . const . const . const $ trueAR <$> ask
falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
-askTokenUnsafe :: forall m.
+askBearerUnsafe :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
@@ -307,23 +310,23 @@ askTokenUnsafe :: forall m.
-- | This performs /no/ meaningful validation of the `BearerToken`
--
-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead
-askTokenUnsafe = $cachedHere $ do
- jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
- catch (decodeToken jwt) $ \case
+askBearerUnsafe = $cachedHere $ do
+ bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer
+ catch (decodeBearer bearer) $ \case
BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
other -> do
$logWarnS "AuthToken" $ tshow other
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
-validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
-validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
+validateBearer :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
+validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token'
where
- validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
- validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
- guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
+ validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
+ validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
+ guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
- tokenAuthority' <- case tokenAuthority of
+ bearerAuthority' <- case bearerAuthority of
Left tVal
| JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
@@ -331,8 +334,8 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
| otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
Right uid -> return uid
- User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority'
- guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
+ User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get bearerAuthority'
+ guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
let
-- Prevent infinite loops
@@ -341,10 +344,10 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
authorityVal <- do
dnf <- either throwM return $ routeAuthTags route
- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority') route isWrite
+ fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just bearerAuthority') route isWrite
guardExceptT (is _Authorized authorityVal) authorityVal
- whenIsJust tokenAddAuth $ \addDNF -> do
+ whenIsJust bearerAddAuth $ \addDNF -> do
$logDebugS "validateToken" $ tshow addDNF
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
guardExceptT (is _Authorized additionalVal) additionalVal
@@ -447,7 +450,7 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
return Authorized
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
- lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
+ lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -1466,11 +1469,31 @@ instance Yesod UniWorX where
Nothing -> getApprootText guessApproot app req
Just root -> root
- -- Store session data on the client in encrypted cookies,
- -- default session idle timeout is 120 minutes
- makeSessionBackend app = do
- (getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout)
- return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate
+ makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = case appSessionStore of
+ SessionStorageMemcachedSql sqlStore
+ -> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore
+ SessionStorageAcid acidStore
+ | appServerSessionAcidFallback
+ -> mkBackend =<< stateSettings <$> ServerSession.createState acidStore
+ _other
+ -> return Nothing
+ where
+ cfg = JwtSession.ServerSessionJwtConfig
+ { sJwtJwkSet = appJSONWebKeySet
+ , sJwtStart = Nothing
+ , sJwtExpiration = appSessionTokenExpiration
+ , sJwtEncoding = appSessionTokenEncoding
+ , sJwtIssueBy = appInstanceID
+ , sJwtIssueFor = appClusterID
+ }
+ mkBackend :: forall sto.
+ ( ServerSession.SessionData sto ~ Map Text ByteString
+ , ServerSession.Storage sto
+ )
+ => ServerSession.State sto -> IO (Maybe SessionBackend)
+ mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
+ stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
+ stateSettings = applyServerSessionSettings appServerSessionConfig
maximumContentLength app _ = app ^. _appMaximumContentLength
@@ -1567,8 +1590,8 @@ instance Yesod UniWorX where
addStaticContent ext _mime content = do
UniWorX{appWidgetMemcached, appSettings'} <- getYesod
- for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
- let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
+ for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
+ let expiry = maybe 0 ceiling memcachedExpiry
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
absoluteLink = unpack widgetMemcachedBaseUrl fileName
diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs
index f6292c4f9..fc8c802ae 100644
--- a/src/Foundation/Type.hs
+++ b/src/Foundation/Type.hs
@@ -1,14 +1,14 @@
module Foundation.Type
( UniWorX(..)
+ , SomeSessionStorage(..)
+ , _SessionStorageMemcachedSql, _SessionStorageAcid
, SMTPPool
- , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionKey, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
+ , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
) where
import Import.NoFoundation
import Database.Persist.Sql (ConnectionPool)
-import qualified Web.ClientSession as ClientSession
-
import Jobs.Types
import Yesod.Core.Types (Logger)
@@ -21,33 +21,41 @@ import qualified Database.Memcached.Binary.IO as Memcached
type SMTPPool = Pool SMTPConnection
+data SomeSessionStorage
+ = SessionStorageMemcachedSql { sessionStorageMemcachedSql :: MemcachedSqlStorage SessionMap }
+ | SessionStorageAcid { sessionStorageAcid :: AcidStorage SessionMap }
+
+makePrisms ''SomeSessionStorage
+
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data UniWorX = UniWorX
- { appSettings' :: AppSettings
- , appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
- , appConnPool :: ConnectionPool -- ^ Database connection pool.
- , appSmtpPool :: Maybe SMTPPool
- , appLdapPool :: Maybe LdapPool
- , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
- , appHttpManager :: Manager
- , appLogger :: (ReleaseKey, TVar Logger)
- , appLogSettings :: TVar LogSettings
- , appCryptoIDKey :: CryptoIDKey
- , appClusterID :: ClusterId
- , appInstanceID :: InstanceId
- , appJobState :: TMVar JobState
- , appSessionKey :: ClientSession.Key
- , appSecretBoxKey :: SecretBox.Key
- , appJSONWebKeySet :: Jose.JwkSet
- , appHealthReport :: TVar (Set (UTCTime, HealthReport))
+ { appSettings' :: AppSettings
+ , appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
+ , appConnPool :: ConnectionPool -- ^ Database connection pool.
+ , appSmtpPool :: Maybe SMTPPool
+ , appLdapPool :: Maybe LdapPool
+ , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
+ , appHttpManager :: Manager
+ , appLogger :: (ReleaseKey, TVar Logger)
+ , appLogSettings :: TVar LogSettings
+ , appCryptoIDKey :: CryptoIDKey
+ , appClusterID :: ClusterId
+ , appInstanceID :: InstanceId
+ , appJobState :: TMVar JobState
+ , appSessionStore :: SomeSessionStorage
+ , appSecretBoxKey :: SecretBox.Key
+ , appJSONWebKeySet :: Jose.JwkSet
+ , appHealthReport :: TVar (Set (UTCTime, HealthReport))
}
makeLenses_ ''UniWorX
instance HasInstanceID UniWorX InstanceId where
instanceID = _appInstanceID
+instance HasClusterID UniWorX ClusterId where
+ clusterID = _appClusterID
instance HasJSONWebKeySet UniWorX Jose.JwkSet where
jsonWebKeySet = _appJSONWebKeySet
instance HasHttpManager UniWorX Manager where
diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs
index b9a7ceb7f..e49a57210 100644
--- a/src/Handler/Metrics.hs
+++ b/src/Handler/Metrics.hs
@@ -23,11 +23,11 @@ getMetricsR = selectRep $ do
metricsHtml = do
samples <- collectMetrics
- metricsToken <- runMaybeT . hoist runDB $ do
+ metricsBearer <- runMaybeT . hoist runDB $ do
uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
- encodeToken =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
+ encodeBearer =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
defaultLayout $ do
setTitleI MsgTitleMetrics
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index b6cce8cf6..2b605d3db 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -766,8 +766,8 @@ postUserNotificationR cID = do
uid <- decrypt cID
User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
- ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
- mJwt <- askJwt
+ ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+ mBearer <- askBearer
isModal <- hasCustomHeader HeaderIsModal
let formWidget = wrapForm nsInnerWdgt def
{ formAction = Just . SomeRoute $ UserNotificationR cID
@@ -775,7 +775,7 @@ postUserNotificationR cID = do
, formAttrs = [ asyncSubmitAttr | isModal ]
}
- formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
+ formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \ns -> do
lift . runDB $ update uid [ UserNotificationSettings =. ns ]
tell . pure =<< messageI Success MsgNotificationSettingsUpdate
@@ -800,12 +800,12 @@ getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html
getSetDisplayEmailR = postSetDisplayEmailR
postSetDisplayEmailR = do
uid <- requireAuthId
- mDisplayEmail <- requireCurrentTokenRestrictions
+ mDisplayEmail <- requireCurrentBearerRestrictions
case mDisplayEmail of
Nothing -> invalidArgs ["Bearer token required"]
Just displayEmail -> do
- ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedJwtPost buttonForm
+ ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedBearerPost buttonForm
let btnView' = wrapForm btnView def
{ formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute SetDisplayEmailR
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 11b6483f7..cec5533b6 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -476,13 +476,13 @@ postUserPasswordR cID = do
[ False <$ guard (isn't _AuthPWHash userAuthentication)
, False <$ guard isAdmin
, do
- authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentTokenRestrictions
+ authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
invalidArgsI [MsgUnauthorizedPasswordResetToken]
return False
]
- ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
+ ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
currentResult <- if
| AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
, requireCurrent
diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs
index 2da19bd90..637aeb25a 100644
--- a/src/Handler/Utils/Invitations.hs
+++ b/src/Handler/Utils/Invitations.hs
@@ -218,9 +218,9 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
route <- mapReaderT liftHandler $ invitationRoute fEnt dat
InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
- let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
- jwt <- encodeToken token
- jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
+ let token = protoToken & bearerRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
+ bearer <- encodeBearer token
+ jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)])
jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat
jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat)
@@ -228,7 +228,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
{ invitationEmail = jInvitee
, invitationFor = invRef @junction fid
, invitationData = toJSON $ dat ^. _invitationDBData
- , invitationExpiresAt = tokenExpiresAt token
+ , invitationExpiresAt = bearerExpiresAt token
}
queueDBJob JobInvitation{..}
@@ -362,7 +362,7 @@ invitationR' :: forall junction m.
-> m Html
-- | Generic handler for incoming invitations
invitationR' InvitationConfig{..} = liftHandler $ do
- InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
+ InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentBearerRestrictions :: Handler (InvitationTokenRestriction junction)
invitee <- requireAuthId
cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute
@@ -379,7 +379,7 @@ invitationR' InvitationConfig{..} = liftHandler $ do
iData :: InvitationData junction
iData = review _InvitationData (dbData, itData)
guardAuthResult =<< hoist lift (invitationRestriction fEnt iData)
- ((dataRes, dataWidget), dataEnctype) <- hoist lift . runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
+ ((dataRes, dataWidget), dataEnctype) <- hoist lift . runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
dataRes <- aFormToWForm $ invitationForm fEnt iData invitee
btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
case btnRes of
diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs
index e7d831cba..83266119f 100644
--- a/src/Handler/Utils/Tokens.hs
+++ b/src/Handler/Utils/Tokens.hs
@@ -1,6 +1,6 @@
module Handler.Utils.Tokens
( maybeBearerToken, requireBearerToken
- , maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions
+ , maybeCurrentBearerRestrictions, requireCurrentBearerRestrictions
) where
import Import
@@ -16,32 +16,32 @@ maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
requireBearerToken = liftHandler $ do
- token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
+ bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
mAuthId <- maybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute
- guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
- return token
+ guardAuthResult <=< runDB $ validateBearer mAuthId currentRoute isWrite bearer
+ return bearer
-requireCurrentTokenRestrictions :: ( MonadHandler m
+requireCurrentBearerRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
-requireCurrentTokenRestrictions = runMaybeT $ do
- token <- requireBearerToken
+requireCurrentBearerRestrictions = runMaybeT $ do
+ bearer <- requireBearerToken
route <- MaybeT getCurrentRoute
- hoistMaybe $ token ^? _tokenRestrictionIx route
+ hoistMaybe $ bearer ^? _bearerRestrictionIx route
-maybeCurrentTokenRestrictions :: ( MonadHandler m
+maybeCurrentBearerRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
-maybeCurrentTokenRestrictions = runMaybeT $ do
- token <- MaybeT maybeBearerToken
+maybeCurrentBearerRestrictions = runMaybeT $ do
+ bearer <- MaybeT maybeBearerToken
route <- MaybeT getCurrentRoute
- hoistMaybe $ token ^? _tokenRestrictionIx route
+ hoistMaybe $ bearer ^? _bearerRestrictionIx route
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index c2f083f37..7212ff285 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -19,3 +19,6 @@ import Settings.WellKnownFiles as Import
import CryptoID as Import
import Audit as Import
+
+import Web.ServerSession.Backend.Persistent.Memcached as Import
+import Web.ServerSession.Backend.Acid as Import (AcidStorage(..))
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 1a2c5eaff..723c699db 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -61,6 +61,7 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Min(..), Max(..))
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..))
import Data.Binary as Import (Binary)
+import Data.Binary.Instances as Import ()
import System.FilePath as Import hiding (joinPath, normalise, isValid, makeValid)
@@ -125,9 +126,6 @@ import Data.Sum.Instances as Import ()
import Data.Fixed.Instances as Import ()
import Data.Scientific.Instances as Import ()
import Data.Set.Instances as Import ()
-import Data.HashMap.Strict.Instances as Import ()
-import Data.HashSet.Instances as Import ()
-import Data.Vector.Instances as Import ()
import Data.Time.Clock.Instances as Import ()
import Data.Time.LocalTime.Instances as Import ()
import Data.Time.Calendar.Instances as Import ()
diff --git a/src/Jobs/Handler/ChangeUserDisplayEmail.hs b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
index 1e2627b84..ff48ed9a2 100644
--- a/src/Jobs/Handler/ChangeUserDisplayEmail.hs
+++ b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
@@ -12,8 +12,8 @@ import Text.Hamlet
dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
- token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
- jwt <- encodeToken token
+ bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
+ jwt <- encodeBearer bearer
let
setDisplayEmailUrl :: SomeRoute UniWorX
setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)])
diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs
index 111b43382..4b894286e 100644
--- a/src/Jobs/Handler/SendNotification/Utils.hs
+++ b/src/Jobs/Handler/SendNotification/Utils.hs
@@ -16,7 +16,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandler $ do
cID <- encrypt uid
- jwt <- encodeToken =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
+ jwt <- encodeBearer =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
let
editNotificationsUrl :: SomeRoute UniWorX
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs
index ed1f10a6b..d61934db6 100644
--- a/src/Jobs/Handler/SendPasswordReset.hs
+++ b/src/Jobs/Handler/SendPasswordReset.hs
@@ -29,11 +29,11 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays 2 $ utctDay now) 0
- resetToken' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
- let resetToken = resetToken'
- & tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
- encodedToken <- encodeToken resetToken
+ resetBearer' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
+ let resetBearer = resetBearer'
+ & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
+ encodedBearer <- encodeBearer resetBearer
- resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedToken)])
+ resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedBearer)])
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/passwordReset.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 97fc6e229..8707ea15a 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -43,10 +43,10 @@ dispatchHealthCheckMatchingClusterConfig
ourSetting <- getsYesod appCryptoIDKey
dbSetting <- clusterSetting @'ClusterCryptoIDKey
return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting
- clusterSettingMatches ClusterClientSessionKey = do
- ourSetting <- getsYesod appSessionKey
- dbSetting <- clusterSetting @'ClusterClientSessionKey
- return $ Just ourSetting == dbSetting
+ clusterSettingMatches ClusterServerSessionKey = do
+ ourSetting <- getsYesod . preview $ _appSessionStore . _SessionStorageMemcachedSql . _mcdSqlMemcachedKey
+ dbSetting <- clusterSetting @'ClusterServerSessionKey
+ return $ maybe True ((== dbSetting) . Just) ourSetting
clusterSettingMatches ClusterSecretBoxKey = do
ourSetting <- getsYesod appSecretBoxKey
dbSetting <- clusterSetting @'ClusterSecretBoxKey
diff --git a/src/Model.hs b/src/Model.hs
index 48c5aa8db..d5a130d34 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -26,7 +26,7 @@ import Text.Blaze (ToMarkup(..))
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
-share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
+share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"]
$(persistDirectoryWith lowerCaseSettings "models")
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index cc4a45502..85aca846e 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -34,6 +34,8 @@ import qualified Net.IPv6 as IPv6
import qualified Data.Char as Char
import qualified Data.CaseInsensitive as CI
+import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
+
-- Database versions must follow https://pvp.haskell.org:
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
@@ -63,6 +65,12 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
deriving Show Eq Ord
|]
+migrateAll' :: Migration
+migrateAll' = sequence_
+ [ migrateUniWorX
+ , migrateMemcachedSqlStorage
+ ]
+
migrateAll :: ( MonadLogger m
, MonadResource m
, MonadUnliftIO m
diff --git a/src/Model/Tokens.hs b/src/Model/Tokens.hs
index 11ed99a4b..3486f9eab 100644
--- a/src/Model/Tokens.hs
+++ b/src/Model/Tokens.hs
@@ -1,150 +1,7 @@
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-{-# LANGUAGE UndecidableInstances #-}
-
module Model.Tokens
- ( BearerToken(..)
- , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
- , tokenRestrict
- , tokenToJSON, tokenParseJSON
+ ( module Model.Tokens
) where
-import ClassyPrelude.Yesod
-import Yesod.Core.Instances ()
-
-import Model
-import Utils (assertM')
-import Utils.Lens hiding ((.=))
-import Data.Aeson.Lens (AsJSON(..))
-
-import Yesod.Auth (AuthId)
-
-import Jose.Jwt (IntDate(..))
-import qualified Jose.Jwt as Jose
-
-import Jose.Jwt.Instances ()
-import Data.Aeson.Types.Instances ()
-
-import qualified Data.HashMap.Strict as HashMap
-import Data.HashMap.Strict.Instances ()
-import Data.HashSet.Instances ()
-import Data.Time.Clock.Instances ()
-
-import Data.Aeson.Types (Parser, (.:?), (.!=))
-import qualified Data.Aeson as JSON
-import qualified Data.Aeson.Types as JSON
-
-import CryptoID
-
-import Data.Time.Clock.POSIX
-
-import Data.Binary (Binary)
-
-import qualified Data.CryptoID.Class.ImplicitNamespace as I
-
-
-
--- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
-data BearerToken site = BearerToken
- { tokenIdentifier :: TokenId
- -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
- , tokenAuthority :: Either Value (AuthId site)
- -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
- , tokenRoutes :: Maybe (HashSet (Route site))
- -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
- , tokenAddAuth :: Maybe AuthDNF
- -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
- , tokenRestrictions :: HashMap (Route site) Value
- -- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
- --
- -- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
- , tokenIssuedAt :: UTCTime
- , tokenIssuedBy :: InstanceId
- , tokenExpiresAt
- , tokenStartsAt :: Maybe UTCTime
- } deriving (Generic, Typeable)
-
-deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
-deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
-deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
-
-instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
-
-makeLenses_ ''BearerToken
-
-_tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
--- ^ Focus a singular restriction (by route) if it exists
---
--- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` or `tokenRestrict` instead
-_tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
-
-_tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
--- ^ Focus a singular restriction (by route) whether it exists, or not
-_tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
-
-tokenRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
--- ^ Add a restriction to a `BearerToken`
---
--- If a restriction already exists for the targeted route, it's silently overwritten
-tokenRestrict route (toJSON -> resVal) = over _tokenRestrictions $ HashMap.insert route resVal
-
-
-
-tokenToJSON :: forall m.
- ( MonadHandler m
- , HasCryptoUUID (AuthId (HandlerSite m)) m
- , RenderRoute (HandlerSite m)
- ) => BearerToken (HandlerSite m) -> m Value
--- ^ Encode a `BearerToken` analogously to `toJSON`
---
--- Monadic context is needed because `AuthId`s are encrypted during encoding
-tokenToJSON BearerToken{..} = do
- cID <- either (return . Left) (fmap Right . I.encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
- let stdPayload = Jose.JwtClaims
- { jwtIss = Just $ toPathPiece tokenIssuedBy
- , jwtSub = Nothing
- , jwtAud = Nothing
- , jwtExp = IntDate . utcTimeToPOSIXSeconds <$> tokenExpiresAt
- , jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> tokenStartsAt
- , jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds tokenIssuedAt
- , jwtJti = Just $ toPathPiece tokenIdentifier
- }
- return . JSON.object $
- catMaybes [ Just $ "authority" .= either id toJSON cID
- , ("routes" .=) <$> tokenRoutes
- , ("add-auth" .=) <$> tokenAddAuth
- , ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
- ]
- ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
-
-tokenParseJSON :: forall site.
- ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
- , ParseRoute site
- , Hashable (Route site)
- )
- => Value
- -> ReaderT CryptoIDKey Parser (BearerToken site)
--- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
---
--- Monadic context is needed because `AuthId`s are encrypted during encoding
---
--- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
-tokenParseJSON v@(Object o) = do
- tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
- tokenAuthority <- either (return . Left) (fmap Right . I.decrypt) tokenAuthority'
-
- tokenRoutes <- lift $ o .:? "routes"
- tokenAddAuth <- lift $ o .:? "add-auth"
- tokenRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
- Jose.JwtClaims{..} <- lift $ parseJSON v
-
- let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
-
- Just tokenIssuedBy <- return $ jwtIss >>= fromPathPiece
- Just tokenIdentifier <- return $ jwtJti >>= fromPathPiece
- Just tokenIssuedAt <- return $ unIntDate <$> jwtIat
- let tokenExpiresAt = unIntDate <$> jwtExp
- tokenStartsAt = unIntDate <$> jwtNbf
-
- return BearerToken{..}
-tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
-
+import Model.Tokens.Lens as Model.Tokens
+import Model.Tokens.Bearer as Model.Tokens
+import Model.Tokens.Session as Model.Tokens
diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs
new file mode 100644
index 000000000..c1c4578fb
--- /dev/null
+++ b/src/Model/Tokens/Bearer.hs
@@ -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
+
diff --git a/src/Model/Tokens/Lens.hs b/src/Model/Tokens/Lens.hs
new file mode 100644
index 000000000..2f2a95571
--- /dev/null
+++ b/src/Model/Tokens/Lens.hs
@@ -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
diff --git a/src/Model/Tokens/Session.hs b/src/Model/Tokens/Session.hs
new file mode 100644
index 000000000..4f0180491
--- /dev/null
+++ b/src/Model/Tokens/Session.hs
@@ -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
diff --git a/src/Settings.hs b/src/Settings.hs
index 63238163b..db800ddd9 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -59,6 +59,10 @@ import Jose.Jwt (JwtEncoding(..))
import System.FilePath.Glob
import Handler.Utils.Submission.TH
+import qualified Web.ServerSession.Core as ServerSession
+
+import Text.Show (showParen, showString)
+
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
@@ -88,6 +92,13 @@ data AppSettings = AppSettings
, appIpFromHeader :: Bool
-- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy.
+
+ , appServerSessionConfig :: ServerSessionSettings
+ , appServerSessionAcidFallback :: Bool
+ , appSessionMemcachedConf :: Maybe MemcachedConf
+ , appSessionTokenExpiration :: Maybe NominalDiffTime
+ , appSessionTokenEncoding :: JwtEncoding
+
, appMailFrom :: Address
, appMailObjectDomain :: Text
, appMailVerp :: VerpMode
@@ -101,8 +112,8 @@ data AppSettings = AppSettings
, appNotificationExpiration :: NominalDiffTime
, appSessionTimeout :: NominalDiffTime
, appMaximumContentLength :: Maybe Word64
- , appJwtExpiration :: Maybe NominalDiffTime
- , appJwtEncoding :: JwtEncoding
+ , appBearerExpiration :: Maybe NominalDiffTime
+ , appBearerEncoding :: JwtEncoding
, appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime
, appHealthCheckDelayNotify :: Bool
@@ -145,7 +156,13 @@ data AppSettings = AppSettings
, appInitialInstanceID :: Maybe (Either FilePath UUID)
, appRibbon :: Maybe Text
- } deriving (Show)
+ } deriving Show
+
+newtype ServerSessionSettings
+ = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
+
+instance Show ServerSessionSettings where
+ showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"
data LogSettings = LogSettings
{ logAll, logDetailed :: Bool
@@ -211,25 +228,34 @@ data SmtpConf = SmtpConf
} deriving (Show)
data WidgetMemcachedConf = WidgetMemcachedConf
- { widgetMemcachedConnectInfo :: Memcached.ConnectInfo
- , widgetMemcachedBaseUrl :: Text
- , widgetMemcachedExpiry :: Maybe NominalDiffTime
+ { widgetMemcachedConf :: MemcachedConf
+ , widgetMemcachedBaseUrl :: Text
+ } deriving (Show)
+
+data MemcachedConf = MemcachedConf
+ { memcachedConnectInfo :: Memcached.ConnectInfo
+ , memcachedExpiry :: Maybe NominalDiffTime
} deriving (Show)
instance FromJSON Memcached.Auth where
parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
-instance FromJSON WidgetMemcachedConf where
- parseJSON = withObject "WidgetMemcachedConf" $ \o -> do
+instance FromJSON MemcachedConf where
+ parseJSON = withObject "MemcachedConf" $ \o -> do
connectHost <- o .:? "host" .!= ""
connectPort <- o .: "port"
connectAuth <- o .: "auth"
numConnection <- o .: "limit"
connectionIdleTime <- o .: "timeout"
- widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
- widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
+ memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
- return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
+ return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
+
+instance FromJSON WidgetMemcachedConf where
+ parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do
+ widgetMemcachedConf <- parseJSON v
+ widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
+ return WidgetMemcachedConf{..}
data ResourcePoolConf = ResourcePoolConf
{ poolStripes :: Int
@@ -343,6 +369,25 @@ instance FromJSON JwtEncoding where
return $ JweEncoding alg enc
]
+instance FromJSON ServerSessionSettings where
+ parseJSON = withObject "ServerSession.State" $ \o -> do
+ cookieName <- o .:? "cookie-name"
+ idleTimeout <- o .:? "idle-timeout"
+ absoluteTimeout <- o .:? "absolute-timeout"
+ timeoutResolution <- o .:? "timeout-resolution"
+ persistentCookies <- o .:? "persistent-cookies"
+ httpOnlyCookies <- o .:? "http-only-cookies"
+ secureCookies <- o .:? "secure-cookies"
+ return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes
+ [ ServerSession.setCookieName <$> cookieName
+ , pure $ ServerSession.setIdleTimeout idleTimeout
+ , pure $ ServerSession.setAbsoluteTimeout absoluteTimeout
+ , pure $ ServerSession.setTimeoutResolution timeoutResolution
+ , ServerSession.setPersistentCookies <$> persistentCookies
+ , ServerSession.setHttpOnlyCookies <$> httpOnlyCookies
+ , ServerSession.setSecureCookies <$> secureCookies
+ ])
+
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
@@ -363,13 +408,17 @@ instance FromJSON AppSettings where
Ldap.Plain host -> not $ null host
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
- let validWidgetMemcachedConf WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
+ let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
[ not $ null connectHost
- , not $ null widgetMemcachedBaseUrl
, numConnection > 0
, connectionIdleTime >= 0
]
+ validWidgetMemcachedConf WidgetMemcachedConf{..} = and
+ [ not $ null widgetMemcachedBaseUrl
+ , validMemcachedConf widgetMemcachedConf
+ ]
appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
+ appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"
@@ -387,8 +436,8 @@ instance FromJSON AppSettings where
appNotificationRateLimit <- o .: "notification-rate-limit"
appNotificationCollateDelay <- o .: "notification-collate-delay"
appNotificationExpiration <- o .: "notification-expiration"
- appJwtExpiration <- o .:? "jwt-expiration"
- appJwtEncoding <- o .: "jwt-encoding"
+ appBearerExpiration <- o .:? "bearer-expiration"
+ appBearerEncoding <- o .: "bearer-encoding"
appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
appHealthCheckDelayNotify <- o .: "health-check-delay-notify"
@@ -417,6 +466,7 @@ instance FromJSON AppSettings where
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev
+ appServerSessionAcidFallback <- o .:? "server-session-acid-fallback" .!= defaultDev
appInitialLogSettings <- o .: "log-settings"
@@ -438,7 +488,11 @@ instance FromJSON AppSettings where
appRibbon <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon"
- return AppSettings {..}
+ appServerSessionConfig <- o .: "server-sessions"
+ appSessionTokenExpiration <- o .:? "session-token-expiration"
+ appSessionTokenEncoding <- o .: "session-token-encoding"
+
+ return AppSettings{..}
makeClassy_ ''AppSettings
diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs
index 6b4d0e836..25cf564bc 100644
--- a/src/Settings/Cluster.hs
+++ b/src/Settings/Cluster.hs
@@ -9,20 +9,18 @@ import ClassyPrelude.Yesod
import Web.HttpApiData
import Utils
-import Control.Lens
import Data.Universe
import qualified Data.Aeson as Aeson
-import qualified Web.ClientSession as ClientSession
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Crypto.Saltine.Core.AEAD as AEAD
import qualified Crypto.Saltine.Class as Saltine
import Data.CryptoID.ByteString (CryptoIDKey)
import qualified Data.CryptoID.ByteString as CryptoID
import qualified Data.Binary as Binary
-import qualified Data.Serialize as Serialize
import qualified Data.ByteString.Base64.URL as Base64
import qualified Jose.Jwa as Jose
@@ -39,7 +37,7 @@ import Model.Types.TH.PathPiece
data ClusterSettingsKey
= ClusterCryptoIDKey
- | ClusterClientSessionKey
+ | ClusterServerSessionKey
| ClusterSecretBoxKey
| ClusterJSONWebKeySet
| ClusterId
@@ -83,18 +81,18 @@ instance FromJSON CryptoIDKey where
| otherwise -> fail $ show (length bs) ++ " extra bytes"
-instance ClusterSetting 'ClusterClientSessionKey where
- type ClusterSettingValue 'ClusterClientSessionKey = ClientSession.Key
- initClusterSetting _ = liftIO $ view _2 <$> ClientSession.randomKey
- knownClusterSetting _ = ClusterClientSessionKey
+instance ClusterSetting 'ClusterServerSessionKey where
+ type ClusterSettingValue 'ClusterServerSessionKey = AEAD.Key
+ initClusterSetting _ = liftIO AEAD.newKey
+ knownClusterSetting _ = ClusterServerSessionKey
+
+instance ToJSON AEAD.Key where
+ toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode
-instance ToJSON ClientSession.Key where
- toJSON = Aeson.String . decodeUtf8 . Base64.encode . Serialize.encode
-
-instance FromJSON ClientSession.Key where
+instance FromJSON AEAD.Key where
parseJSON = Aeson.withText "Key" $ \t -> do
bytes <- either fail return . Base64.decode $ encodeUtf8 t
- either fail return $ Serialize.decode bytes
+ maybe (fail "Could not parse key") return $ Saltine.decode bytes
instance ClusterSetting 'ClusterSecretBoxKey where
diff --git a/src/Utils.hs b/src/Utils.hs
index eae6e88fa..f8879cf98 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -613,6 +613,9 @@ guardMExceptT b err = unless b $ lift err >>= throwE
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT f g = either f g <=< runExceptT
+catchIfExceptT :: (MonadCatch m, Exception e) => (e -> e') -> (e -> Bool) -> m a -> ExceptT e' m a
+catchIfExceptT err p act = catchIf p (lift act) (throwE . err)
+
catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index db0e024d0..8f02a65fb 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -240,6 +240,9 @@ makeLenses_ ''ExternalExamResult
class HasInstanceID s a | s -> a where
instanceID :: Lens' s a
+class HasClusterID s a | s -> a where
+ clusterID :: Lens' s a
+
class HasHttpManager s a | s -> a where
httpManager :: Lens' s a
diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs
index 5ae042c82..e7853f525 100644
--- a/src/Utils/Tokens.hs
+++ b/src/Utils/Tokens.hs
@@ -1,9 +1,9 @@
module Utils.Tokens
( bearerToken
- , encodeToken, BearerTokenException(..), decodeToken
- , tokenParseJSON'
- , askJwt
- , formEmbedJwtPost, formEmbedJwtGet
+ , encodeBearer, BearerTokenException(..), decodeBearer
+ , bearerParseJSON'
+ , askBearer
+ , formEmbedBearerPost, formEmbedBearerGet
) where
import Import.NoModel
@@ -32,7 +32,7 @@ import CryptoID
import Text.Blaze (Markup)
-tokenParseJSON' :: forall m.
+bearerParseJSON' :: forall m.
( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
, ParseRoute (HandlerSite m)
, Hashable (Route (HandlerSite m))
@@ -42,14 +42,15 @@ tokenParseJSON' :: forall m.
)
=> m (Value -> Parser (BearerToken (HandlerSite m)))
-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
-tokenParseJSON' = do
+bearerParseJSON' = do
cidKey <- cryptoIDKey return
- return $ flip runReaderT cidKey . tokenParseJSON
+ return $ flip runReaderT cidKey . bearerParseJSON
bearerToken :: forall m.
( MonadHandler m
, HasInstanceID (HandlerSite m) InstanceId
+ , HasClusterID (HandlerSite m) ClusterId
, HasAppSettings (HandlerSite m)
)
=> Either Value (AuthId (HandlerSite m))
@@ -59,26 +60,27 @@ bearerToken :: forall m.
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
-> m (BearerToken (HandlerSite m))
-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
-bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
- tokenIdentifier <- liftIO getRandom
- tokenIssuedAt <- liftIO getCurrentTime
- tokenIssuedBy <- getsYesod $ view instanceID
+bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do
+ bearerIdentifier <- liftIO getRandom
+ bearerIssuedAt <- liftIO getCurrentTime
+ bearerIssuedBy <- getsYesod $ view instanceID
+ bearerIssuedFor <- getsYesod $ view clusterID
- defaultExpiration <- getsYesod $ view _appJwtExpiration
+ defaultExpiration <- getsYesod $ view _appBearerExpiration
- let tokenExpiresAt
- | Just t <- mTokenExpiresAt
+ let bearerExpiresAt
+ | Just t <- mBearerExpiresAt
= t
| Just tDiff <- defaultExpiration
- = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
+ = Just $ tDiff `addUTCTime` fromMaybe bearerIssuedAt bearerStartsAt
| otherwise
= Nothing
- tokenRestrictions = HashMap.empty
+ bearerRestrictions = HashMap.empty
return BearerToken{..}
-encodeToken :: forall m.
+encodeBearer :: forall m.
( MonadHandler m
, HasJSONWebKeySet (HandlerSite m) JwkSet
, HasAppSettings (HandlerSite m)
@@ -86,11 +88,11 @@ encodeToken :: forall m.
, RenderRoute (HandlerSite m)
)
=> BearerToken (HandlerSite m) -> m Jwt
--- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
-encodeToken token = do
- payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
+-- ^ Call `bearerToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
+encodeBearer token = do
+ payload <- Jose.Claims . toStrict . JSON.encode <$> bearerToJSON token
JwkSet jwks <- getsYesod $ view jsonWebKeySet
- jwtEncoding <- getsYesod $ view _appJwtEncoding
+ jwtEncoding <- getsYesod $ view _appBearerEncoding
either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
@@ -103,7 +105,7 @@ data BearerTokenException
instance Exception BearerTokenException
-decodeToken :: forall m.
+decodeBearer :: forall m.
( MonadHandler m
, HasJSONWebKeySet (HandlerSite m) JwkSet
, HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
@@ -113,50 +115,50 @@ decodeToken :: forall m.
, Hashable (Route (HandlerSite m))
)
=> Jwt -> m (BearerToken (HandlerSite m))
--- ^ Decode a `Jwt` and call `tokenParseJSON`
+-- ^ Decode a `Jwt` and call `bearerParseJSON`
--
-- Throws `bearerTokenException`s
-decodeToken (Jwt bs) = do
+decodeBearer (Jwt bs) = do
JwkSet jwks <- getsYesod $ view jsonWebKeySet
content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
content' <- case content of
Jose.Unsecured _ -> throwM BearerTokenUnsecured
Jose.Jws (_header, payload) -> return payload
Jose.Jwe (_header, payload) -> return payload
- parser <- tokenParseJSON'
- token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
+ parser <- bearerParseJSON'
+ bearer@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
now <- liftIO getCurrentTime
- unless (NTop tokenExpiresAt > NTop (Just now)) $
+ unless (NTop bearerExpiresAt > NTop (Just now)) $
throwM BearerTokenExpired
- unless (tokenStartsAt <= Just now) $
+ unless (bearerStartsAt <= Just now) $
throwM BearerTokenNotStarted
- return token
+ return bearer
-askJwt :: forall m. ( MonadHandler m )
- => m (Maybe Jwt)
+askBearer :: forall m. ( MonadHandler m )
+ => m (Maybe Jwt)
-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
-askJwt = runMaybeT $ asum
+askBearer = runMaybeT $ asum
[ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
, MaybeT $ lookupGlobalPostParam PostBearer
, MaybeT $ lookupGlobalGetParam GetBearer
, fmap Jwt . MaybeT $ lookupSessionBS (toPathPiece SessionBearer)
]
-formEmbedJwtPost, formEmbedJwtGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
-formEmbedJwtPost f fragment = do
- mJwt <- askJwt
+formEmbedBearerPost, formEmbedBearerGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
+formEmbedBearerPost f fragment = do
+ mBearer <- askBearer
f [shamlet|
$newline never
- $maybe jwt <- mJwt
-
+ $maybe bearer <- mBearer
+
#{fragment}
|]
-formEmbedJwtGet f fragment = do
- mJwt <- askJwt
+formEmbedBearerGet f fragment = do
+ mBearer <- askBearer
f [shamlet|
$newline never
- $maybe jwt <- mJwt
-
+ $maybe bearer <- mBearer
+
#{fragment}
|]
diff --git a/src/Web/ServerSession/Backend/Persistent/Memcached.hs b/src/Web/ServerSession/Backend/Persistent/Memcached.hs
new file mode 100644
index 000000000..3945fcd52
--- /dev/null
+++ b/src/Web/ServerSession/Backend/Persistent/Memcached.hs
@@ -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
diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs
new file mode 100644
index 000000000..29c5e081b
--- /dev/null
+++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs
@@ -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. ).
+--
+-- 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 _ = (==)
diff --git a/stack.yaml b/stack.yaml
index 20c318374..07c492062 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -23,6 +23,12 @@ extra-deps:
commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git
commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
+ - git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
+ commit: 1c95b0100471279413485411032d639881012a5e
+ subdirs:
+ - serversession
+ - serversession-backend-acid-state
+
- colonnade-1.2.0.2
- hsass-0.8.0
@@ -92,5 +98,9 @@ extra-deps:
# - skylighting-core-0.8.3.2
# - texmath-0.12.0.1
+ - binary-instances-1
+
+ - acid-state-0.16.0
+
resolver: lts-15.0
allow-newer: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
index ecf90088b..f8e0d7b61 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -88,6 +88,38 @@ packages:
original:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git
commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
+- completed:
+ subdir: serversession
+ cabal-file:
+ size: 2081
+ sha256: a958ff0007e5084e3e4c2a33acc9860c31186105f02f8ab99ecb847a7a8f9497
+ name: serversession
+ version: 1.0.1
+ git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
+ pantry-tree:
+ size: 544
+ sha256: f825236d72f8eb42bb095c08b63e34d4ea7f83b059983543a725ddb5ef808b25
+ commit: 1c95b0100471279413485411032d639881012a5e
+ original:
+ subdir: serversession
+ git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
+ commit: 1c95b0100471279413485411032d639881012a5e
+- completed:
+ subdir: serversession-backend-acid-state
+ cabal-file:
+ size: 1875
+ sha256: 6cc9d29e788334670bc102213a8aae73bc1b8b0a00c416f06d232376750443b7
+ name: serversession-backend-acid-state
+ version: 1.0.3
+ git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
+ pantry-tree:
+ size: 543
+ sha256: 0806157c4bc259f28bcab1cc0dcb58a8becc831e3f4e5e63d28f550acae92842
+ commit: 1c95b0100471279413485411032d639881012a5e
+ original:
+ subdir: serversession-backend-acid-state
+ git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
+ commit: 1c95b0100471279413485411032d639881012a5e
- completed:
hackage: colonnade-1.2.0.2@sha256:c95c2ecff5cfa28c736d8fa662d28b71129f67457068e3f4467b296a621607ab,2099
pantry-tree:
@@ -228,6 +260,20 @@ packages:
sha256: 9d4d8e7a85166ffd951b02f87be540607b55084c04730932346072329adf4913
original:
hackage: doctemplates-0.8.1
+- completed:
+ hackage: binary-instances-1@sha256:b17565598b8df3241f9b46fa8e3a3368ecc8e3f2eb175d7c28f319042a6f5c79,2613
+ pantry-tree:
+ size: 1035
+ sha256: 938ffc6990cac12681c657f7afa93737eecf335e6f0212d8c0b7c1ea3e0f40f4
+ original:
+ hackage: binary-instances-1
+- completed:
+ hackage: acid-state-0.16.0@sha256:a5640fd8d99bdb5f152476a2ae56cc8eb81864b280c8ec7d1387e81296ed844d,6190
+ pantry-tree:
+ size: 13678
+ sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f
+ original:
+ hackage: acid-state-0.16.0
snapshots:
- completed:
size: 488576
diff --git a/start.sh b/start.sh
index 54bfd2d0e..2c3bafbff 100755
--- a/start.sh
+++ b/start.sh
@@ -10,6 +10,8 @@ export DETAILED_LOGGING=${DETAILED_LOGGING:-true}
export LOG_ALL=${LOG_ALL:-false}
export LOGLEVEL=${LOGLEVEL:-info}
export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
+export SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true}
+export SERVER_SESSION_COOKIES_SECURE=${SERVER_SESSION_COOKIES_SECURE:-false}
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
export RIBBON=${RIBBON:-${__HOST:-localhost}}
unset HOST
diff --git a/templates/metrics.hamlet b/templates/metrics.hamlet
index 885a79591..df87f79c0 100644
--- a/templates/metrics.hamlet
+++ b/templates/metrics.hamlet
@@ -1,5 +1,5 @@
$newline never
-$maybe t <- metricsToken
+$maybe t <- metricsBearer