Solidify design of BearerToken

config/settings.yml

@@ -27,6 +27,7 @@ notification-rate-limit: 3600
 notification-collate-delay: 300
 notification-expiration: 259201
 session-timeout: 7200
+jwt-expiration: 604800
 maximum-content-length: 52428800
 
 log-settings:

package.yaml

@@ -117,6 +117,8 @@ dependencies:
   - lattices
   - hsass
   - semigroupoids
+  - jose-jwt
+  - mono-traversable
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Application.hs

@@ -101,7 +101,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
 -- the place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
 makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
-makeFoundation appSettings@AppSettings{..} = do
+makeFoundation appSettings'@AppSettings{..} = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
@@ -141,7 +141,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 = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet = 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
@@ -153,13 +153,14 @@ makeFoundation appSettings@AppSettings{..} = do
           (error "sessionKey forced in tempFoundation")
           (error "secretBoxKey forced in tempFoundation")
           (error "widgetMemcached forced in tempFoundation")
+          (error "JSONWebKeySet forced in tempFoundation")
         logFunc loc src lvl str = do
           f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
           f loc src lvl str
 
     flip runLoggingT logFunc $ do
       $logDebugS "InstanceID" $ UUID.toText appInstanceID
-      -- logDebugS "Configuration" $ tshow appSettings
+      -- logDebugS "Configuration" $ tshow appSettings'
 
       smtpPool <- traverse createSmtpPool appSmtpConf
 
@@ -177,8 +178,9 @@ makeFoundation appSettings@AppSettings{..} = do
       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
 
-      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
+      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet
 
       handleJobs foundation
 
@@ -265,7 +267,7 @@ makeLogWare app = do
       logger <- readTVarIO . snd $ appLogger app
       logWare <- mkRequestLogger def
         { outputFormat = bool
-            (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
+            (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader)
             (Detailed True)
             logDetailed
         , destination = Logger $ loggerSet logger
@@ -287,8 +289,8 @@ makeLogWare app = do
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
 warpSettings foundation = defaultSettings
-    & setPort (appPort $ appSettings foundation)
-    & setHost (appHost $ appSettings foundation)
+    & setPort (foundation ^. _appPort)
+    & setHost (foundation ^. _appHost)
     & setOnException (\_req e ->
         when (defaultShouldDisplayException e) $ do
           logger <- readTVarIO . snd $ appLogger foundation
@@ -384,6 +386,6 @@ addPWEntry :: User
            -> Text {-^ Password -}
            -> IO ()
 addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
-  PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
+  PWHashConf{..} <- getsYesod $ view _appAuthPWHash
   (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
   void $ insert User{..}

src/Auth/LDAP.hs

@@ -159,7 +159,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
                   ]
 
 -- ldapConfig :: UniWorX -> LDAPConfig
--- ldapConfig _app@(appSettings -> settings) = LDAPConfig
+-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
 --   { usernameFilter = \u -> principalName <> "=" <> u
 --   , identifierModifier
 --   , ldapUri = appLDAPURI settings

src/CryptoID.hs

@@ -29,6 +29,11 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..
 import Data.Aeson.Encoding (text)
 
 
+instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
+  type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey
+  cryptoIDKey f = ask >>= f
+
+
 -- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
              , ''FileId

src/Data/Aeson/Types/Instances.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Aeson.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson.Types (Parser)
+import Control.Monad.Catch
+
+
+instance MonadThrow Parser where
+  throwM = fail . show

src/Data/NonNull/Instances.hs

@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.NonNull.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson
+
+
+instance ToJSON a => ToJSON (NonNull a) where
+  toJSON = toJSON . toNullable
+
+instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
+  parseJSON = parseJSON >=> maybe (fail "Expected non-empty structure") return . fromNullable
+
+
+instance Hashable a => Hashable (NonNull a) where
+  hashWithSalt s = hashWithSalt s . toNullable

src/Foundation.hs

@@ -77,6 +77,7 @@ import qualified Yesod.Auth.Message as Auth
 import qualified Data.Conduit.List as C
 
 import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Jose.Jwk as Jose
 
 import qualified Database.Memcached.Binary.IO as Memcached
 import Data.Bits (Bits(zeroBits))
@@ -96,6 +97,8 @@ instance DisplayAble TermId where
 instance DisplayAble SchoolId where
   display = CI.original . unSchoolKey
 
+type SMTPPool = Pool SMTPConnection
+
 -- infixl 9 :$:
 -- pattern a :$: b = a b
 
@@ -104,7 +107,7 @@ instance DisplayAble SchoolId where
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data UniWorX = UniWorX
-    { appSettings        :: AppSettings
+    { appSettings'       :: AppSettings
     , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
     , appConnPool        :: ConnectionPool -- ^ Database connection pool.
     , appSmtpPool        :: Maybe SMTPPool
@@ -119,9 +122,16 @@ data UniWorX = UniWorX
     , appCronThread      :: TMVar (ReleaseKey, ThreadId)
     , appSessionKey      :: ClientSession.Key
     , appSecretBoxKey    :: SecretBox.Key
+    , appJSONWebKeySet   :: Jose.JwkSet
     }
 
-type SMTPPool = Pool SMTPConnection
+makeLenses_ ''UniWorX
+instance HasInstanceID UniWorX InstanceId where
+  instanceID = _appInstanceID
+instance HasJSONWebKeySet UniWorX Jose.JwkSet where
+  jsonWebKeySet = _appJSONWebKeySet
+instance HasAppSettings UniWorX where
+  appSettings = _appSettings'
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
@@ -463,7 +473,7 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
 tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
   addMessageI Error MsgDeprecatedRoute
-  allow <- appAllowDeprecated . appSettings <$> getYesod
+  allow <- view _appAllowDeprecated
   return $ bool (Unauthorized "Deprecated Route") Authorized allow
 tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
   $logWarnS "AccessControl" ("route in development: " <> tshow r)
@@ -809,17 +819,17 @@ instance Yesod UniWorX where
     -- Controls the base of generated URLs. For more information on modifying,
     -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
     approot = ApprootRequest $ \app req ->
-        case appRoot $ appSettings app of
+        case app ^. _appRoot of
             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 UniWorX{appSessionKey,appSettings=AppSettings{appSessionTimeout}} = do
-      (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout
-      return . Just $ clientSessionBackend appSessionKey getCachedDate
+    makeSessionBackend app = do
+      (getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout)
+      return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate
 
-    maximumContentLength UniWorX{appSettings=AppSettings{appMaximumContentLength}} _ = appMaximumContentLength
+    maximumContentLength app _ = app ^. _appMaximumContentLength
 
     -- Yesod Middleware allows you to run code before and after each handler function.
     -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
@@ -878,7 +888,7 @@ instance Yesod UniWorX where
         encrypted :: ToJSON a => a -> Widget -> Widget
         encrypted plaintextJson plaintext = do
           canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
-          shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings
+          shouldEncrypt <- view _appEncryptErrors
           if
             | shouldEncrypt
             , not canDecrypt -> do
@@ -919,8 +929,8 @@ instance Yesod UniWorX where
     isAuthorized = evalAccess
 
     addStaticContent ext _mime content = do
-      UniWorX{appWidgetMemcached, appSettings} <- getYesod
-      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
+      UniWorX{appWidgetMemcached, appSettings'} <- getYesod
+      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
             touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
             add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
@@ -971,8 +981,7 @@ siteLayout = siteLayout' . Just
 siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
            -> Widget -> Handler Html
 siteLayout' headingOverride widget = do
-  master <- getYesod
-  let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
+  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings
 
   isModal <- hasCustomHeader HeaderIsModal
 
@@ -2081,7 +2090,7 @@ instance YesodAuth UniWorX where
             _other -> return res
 
       $logDebugS "auth" $ tshow Creds{..}
-      UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
+      UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
 
       flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
         Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
@@ -2200,7 +2209,7 @@ instance YesodAuth UniWorX where
       where
         insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
 
-    authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes
+    authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
       [ campusLogin <$> appLdapConf <*> appLdapPool
       , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
       , dummyLogin <$ guard appAuthDummyLogin
@@ -2225,9 +2234,9 @@ unsafeHandler f h = do
 
 
 instance YesodMail UniWorX where
-  defaultFromAddress = getsYesod $ appMailFrom . appSettings
-  mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
-  mailVerp = getsYesod $ appMailVerp . appSettings
+  defaultFromAddress = getsYesod $ view _appMailFrom
+  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
+  mailVerp = getsYesod $ view _appMailVerp
   mailDateTZ = return appTZ
   mailSmtp act = do
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool

src/Handler/Utils.hs

@@ -4,6 +4,8 @@ module Handler.Utils
 
 import Import
 
+import Utils.Lens
+
 import qualified Data.Text as T
 -- import qualified Data.Set (Set)
 import qualified Data.Set as Set
@@ -40,7 +42,7 @@ downloadFiles = do
   case mauth of
     Just (Entity _ User{..}) -> return userDownloadFiles
     Nothing -> do
-      AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
+      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
       return userDefaultDownloadFiles
 
 tidFromText :: Text -> Maybe TermId

src/Handler/Utils/DateTime.hs

@@ -13,6 +13,8 @@ module Handler.Utils.DateTime
 
 import Import
 
+import Utils.Lens
+
 import Data.Time.Zones
 import qualified Data.Time.Zones as TZ
 
@@ -83,7 +85,7 @@ getTimeLocale = getTimeLocale' <$> languages
 getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
 getDateTimeFormat sel = do
   mauth <- liftHandlerT maybeAuth
-  AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
   let
     fmt
       | Just (Entity _ User{..}) <- mauth
@@ -182,4 +184,4 @@ weeksToAdd old new = loop 0 old
   where
     loop n t
       | t > new   = n
-      | otherwise = loop (succ n) (addOneWeek t)
+      | otherwise = loop (succ n) (addOneWeek t)

src/Import/NoFoundation.hs

@@ -43,6 +43,7 @@ import GHC.Exts               as Import (IsList)
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
 import Data.List.NonEmpty.Instances as Import ()
+import Data.NonNull.Instances as Import ()
 import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
 import Data.Monoid            as Import (Last(..), First(..))
@@ -56,6 +57,7 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey)
 
 import Network.Mail.Mime.Instances as Import ()
 import Yesod.Core.Instances as Import ()
+import Data.Aeson.Types.Instances as Import ()
 
 import Ldap.Client.Pool as Import
 
@@ -67,6 +69,8 @@ import Numeric.Natural.Instances as Import ()
 import System.Random as Import (Random)
 import Control.Monad.Random.Class as Import (MonadRandom(..))
 
+import Jose.Jwt.Instances as Import ()
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs.hs

@@ -6,6 +6,7 @@ module Jobs
   ) where
 
 import Import
+import Utils.Lens
 
 import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
 import Jobs.Types (JobCtl(JobCtlQueue))
@@ -77,7 +78,7 @@ handleJobs :: ( MonadResource m
 -- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
 -- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
 handleJobs foundation@UniWorX{..} = do
-  let num = appJobWorkers appSettings
+  let num = foundation ^. _appJobWorkers
 
   jobCrontab <- liftIO $ newTMVarIO HashMap.empty
   jobConfirm <- liftIO $ newTVarIO HashMap.empty
@@ -135,7 +136,7 @@ execCrontab = evalStateT go HashMap.empty
         runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
 
       refT <- liftIO getCurrentTime
-      settings <- getsYesod appSettings
+      settings <- getsYesod appSettings'
       currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
         crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
         case crontab' of
@@ -157,7 +158,7 @@ execCrontab = evalStateT go HashMap.empty
                     | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
                       -> do
                         now <- liftIO $ getCurrentTime
-                        instanceID <- getsYesod appInstanceID
+                        instanceID' <- getsYesod appInstanceID
                         State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
                         case jobCtl of
                           JobCtlQueue job -> do
@@ -166,7 +167,7 @@ execCrontab = evalStateT go HashMap.empty
                               CronLastExec
                                 { cronLastExecJob = toJSON job
                                 , cronLastExecTime = now
-                                , cronLastExecInstance = instanceID
+                                , cronLastExecInstance = instanceID'
                                 }
                               [ CronLastExecTime =. now ]
                             lift . lift $ queueDBJob job
@@ -285,21 +286,21 @@ jLocked jId act = do
   let
     lock = runDB . setSerializable $ do
       qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
-      instanceID <- getsYesod appInstanceID
-      threshold <- getsYesod $ appJobStaleThreshold . appSettings
+      instanceID' <- getsYesod $ view instanceID
+      threshold <- getsYesod $ view _appJobStaleThreshold
       now <- liftIO getCurrentTime
       hadStale <- maybeT (return False) $ do
         lockTime <- MaybeT $ return queuedJobLockTime
         lockInstance <- MaybeT $ return queuedJobLockInstance
         if
-          | lockInstance == instanceID
+          | lockInstance == instanceID'
           , diffUTCTime now lockTime >= threshold
             -> return True
           | otherwise
             -> throwM $ JLocked jId lockInstance lockTime
       when hadStale .
         $logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
-      val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
+      val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID'
                            , QueuedJobLockTime =. Just now
                            ]
       liftIO . atomically $ writeTVar hasLock True

src/Jobs/Crontab.hs

@@ -23,7 +23,7 @@ import qualified Data.Conduit.List as C
 determineCrontab :: DB (Crontab JobCtl)
 -- ^ Extract all future jobs from the database (sheet deadlines, ...)
 determineCrontab = execWriterT $ do
-  AppSettings{..} <- getsYesod appSettings
+  AppSettings{..} <- getsYesod appSettings'
 
   case appJobFlushInterval of
     Just interval -> tell $ HashMap.singleton

src/Jobs/Handler/HelpRequest.hs

@@ -20,7 +20,7 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
                        -> Maybe Text -- ^ Referer
                        -> Handler ()
 dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
-  supportAddress <- getsYesod $ appMailSupport . appSettings
+  supportAddress <- view _appMailSupport
   userInfo <- bitraverse return (runDB . getEntity) jSender
   let userAddress = either
         id

src/Jose/Jwt/Instances.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Jose.Jwt.Instances
+  (
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Jose.Jwt
+
+
+instance PathPiece Jwt where
+  toPathPiece (Jwt bytes) = decodeUtf8 bytes
+  fromPathPiece = Just . Jwt . encodeUtf8
+
+deriving instance Typeable JwtError
+
+instance Exception JwtError

src/Model/Migration/Types.hs

@@ -2,7 +2,6 @@ module Model.Migration.Types where
 
 import ClassyPrelude.Yesod
 import Data.Aeson.TH (deriveJSON, defaultOptions)
-import Database.Persist.Sql
 
 import qualified Model as Current
 import qualified Model.Types.JSON as Current

src/Model/Token.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Model.Token
+  ( BearerToken(..)
+  , bearerToken
+  , encodeToken, decodeToken
+  , tokenToJSON, tokenParseJSON
+  ) where
+
+import ClassyPrelude.Yesod
+import Model
+import Settings
+import Utils.Lens hiding ((.=))
+
+import Yesod.Auth (AuthId)
+
+-- import qualified Jose.Jwa as Jose
+import Jose.Jwk (JwkSet)
+-- import qualified Jose.Jwk as Jose
+import Jose.Jwt (Jwt, JwtError, IntDate(..))
+import qualified Jose.Jwt as Jose
+
+import Jose.Jwt.Instances ()
+import Data.Aeson.Types.Instances ()
+
+import qualified Crypto.Random as Crypto (MonadRandom)
+
+import Data.HashSet (HashSet)
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Data.Aeson.Types (Parser, (.:?), (.:))
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Types as JSON
+
+import CryptoID
+
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+
+import Control.Monad.Random (MonadRandom(..))
+
+
+data BearerToken site = BearerToken
+  { tokenIdentifier :: TokenId
+  , tokenAuthority  :: AuthId site
+  , tokenRoutes     :: Maybe (HashSet (Route site))
+  , tokenAddAuth    :: AuthCNF
+  , 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)
+
+tokenToJSON :: forall m.
+               ( MonadHandler m
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , RenderRoute (HandlerSite m)
+               ) => BearerToken (HandlerSite m) -> m Value
+tokenToJSON BearerToken{..} = do
+  cID <- encrypt tokenAuthority :: m (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 $
+    [ "authority" .= cID
+    , "routes"    .= tokenRoutes
+    , "add-auth"  .= tokenAddAuth
+    ] ++ 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)
+tokenParseJSON v@(Object o) = do
+  tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
+  tokenAuthority <- decrypt tokenAuthority'
+
+  tokenRoutes    <- lift $ o .:? "routes"
+  tokenAddAuth   <- lift $ o .:  "add-auth"
+  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
+
+
+bearerToken :: forall m.
+               ( MonadHandler m
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , HasAppSettings (HandlerSite m)
+               )
+            => AuthId (HandlerSite m)
+            -> Maybe (HashSet (Route (HandlerSite m)))
+            -> AuthCNF
+            -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
+            -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
+            -> m (BearerToken (HandlerSite m))
+bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
+  tokenIdentifier <- liftIO $ getRandom
+  tokenIssuedAt <- liftIO $ getCurrentTime
+  tokenIssuedBy <- getsYesod $ view instanceID
+
+  defaultExpiration <- getsYesod $ view _appJWTExpiration
+  
+  let tokenExpiresAt
+        | Just t <- mTokenExpiresAt
+        = t
+        | Just tDiff <- defaultExpiration
+        = Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
+        | otherwise
+        = Nothing
+
+  return BearerToken{..}
+
+
+encodeToken :: forall m.
+               ( Crypto.MonadRandom m
+               , MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasInstanceID (HandlerSite m) InstanceId
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , RenderRoute (HandlerSite m)
+               )
+            => BearerToken (HandlerSite m) -> m Jwt
+encodeToken token = do
+  _payload <- tokenToJSON token
+  error "Not implemented"
+
+decodeToken :: forall m.
+               ( Crypto.MonadRandom m
+               , MonadHandler m
+               , HasJSONWebKeySet (HandlerSite m) JwkSet
+               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               )
+            => Jwt -> m (Either JwtError (BearerToken (HandlerSite m)))
+decodeToken = error "Not implemented"

src/Model/Types.hs

@@ -27,6 +27,8 @@ import Data.Universe.Helpers
 import Data.UUID.Types (UUID)
 import qualified Data.UUID.Types as UUID
 
+import Data.NonNull.Instances ()
+
 import Data.Default
 
 import Text.Read (readMaybe)
@@ -54,7 +56,7 @@ import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
 import Data.Aeson.Types (toJSONKeyText)
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
 
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@@ -79,7 +81,7 @@ import Model.Types.Wordlist
 import Data.Text.Metrics (damerauLevenshtein)
 
 import Data.Binary (Binary)
-
+  
 
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack
@@ -731,7 +733,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthDeprecated
   | AuthDevelopment
   | AuthFree
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe AuthTag
 instance Finite AuthTag
@@ -774,6 +776,40 @@ instance FromJSON AuthTagActive where
 derivePersistFieldJSON ''AuthTagActive
 
 
+data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable a => Hashable (PredLiteral a)
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = ObjectWithSingleField
+  , unwrapUnaryRecords = True
+  } ''PredLiteral
+
+
+newtype PredCNF a = PredCNF (Set (NonNull (Set (PredLiteral a))))
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Semigroup, Monoid)
+
+newtype PredDNF a = PredDNF (Set (NonNull (Set (PredLiteral a))))
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Semigroup, Monoid)
+
+$(return [])
+
+instance (Ord a, ToJSON a) => ToJSON (PredCNF a) where
+  toJSON = $(mkToJSON predNFAesonOptions ''PredCNF)
+instance (Ord a, FromJSON a) => FromJSON (PredCNF a) where
+  parseJSON = $(mkParseJSON predNFAesonOptions ''PredCNF)
+ 
+instance (Ord a, ToJSON a) => ToJSON (PredDNF a) where
+  toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
+instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
+  parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
+
+type AuthCNF = PredCNF AuthTag
+type AuthDNF = PredDNF AuthTag
+
 
 data LecturerType = CourseLecturer | CourseAssistant
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -801,4 +837,5 @@ type UserEmail       = CI Email
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
 type InstanceId      = UUID
+type TokenId         = UUID
 type TermCandidateIncidence = UUID

src/Model/Types/JSON.hs

@@ -1,5 +1,6 @@
 module Model.Types.JSON
   ( derivePersistFieldJSON
+  , predNFAesonOptions
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@@ -9,11 +10,13 @@ import Database.Persist.Sql
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text.Encoding as Text
 
-import qualified Data.Aeson as JSON
+import Data.Aeson as JSON
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Datatype
 
+import Utils.PathPiece
+
 
 derivePersistFieldJSON :: Name -> DecsQ
 derivePersistFieldJSON tName = do
@@ -28,10 +31,10 @@ derivePersistFieldJSON tName = do
         | otherwise = cxt [[t|PersistField|] `appT` t]
   sequence
     [ instanceD iCxt ([t|PersistField|] `appT` t)
-      [ funD (mkName "toPersistValue")
+      [ funD 'toPersistValue
         [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
         ]
-      , funD (mkName "fromPersistValue")
+      , funD 'fromPersistValue
         [ do
             bs <- newName "bs"
             clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
@@ -45,8 +48,20 @@ derivePersistFieldJSON tName = do
         ]
       ]
     , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
-      [ funD (mkName "sqlType")
+      [ funD 'sqlType
         [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
         ]
       ]
     ]
+
+
+predNFAesonOptions :: Options
+-- ^ Needed for JSON instances of `predCNF` and `predDNF`
+--
+-- Moved to this module due to stage restriction
+predNFAesonOptions = defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = ObjectWithSingleField
+  , tagSingleConstructors = True
+  }
+  

src/Settings.hs

@@ -100,6 +100,7 @@ data AppSettings = AppSettings
     , appNotificationExpiration :: NominalDiffTime
     , appSessionTimeout         :: NominalDiffTime
     , appMaximumContentLength   :: Maybe Word64
+    , appJWTExpiration          :: Maybe NominalDiffTime
 
     , appInitialLogSettings     :: LogSettings
 
@@ -352,6 +353,7 @@ instance FromJSON AppSettings where
         appNotificationRateLimit  <- o .:  "notification-rate-limit"
         appNotificationCollateDelay <- o .: "notification-collate-delay"
         appNotificationExpiration <- o .: "notification-expiration"
+        appJWTExpiration          <- o .:? "jwt-expiration"
 
         appSessionTimeout         <- o .: "session-timeout"
 
@@ -379,6 +381,8 @@ instance FromJSON AppSettings where
 
         return AppSettings {..}
 
+makeClassy_ ''AppSettings
+
 -- | Settings for 'widgetFile', such as which template languages to support and
 -- default Hamlet settings.
 --

src/Settings/Cluster.hs

@@ -32,11 +32,16 @@ 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
+import qualified Jose.Jwk as Jose
+import qualified Jose.Jwt as Jose
+
 
 data ClusterSettingsKey
   = ClusterCryptoIDKey
   | ClusterClientSessionKey
   | ClusterSecretBoxKey
+  | ClusterJSONWebKeySet
   deriving (Eq, Ord, Enum, Bounded, Show, Read)
 
 instance Universe ClusterSettingsKey
@@ -120,3 +125,12 @@ instance FromJSON SecretBox.Key where
   parseJSON = Aeson.withText "Key" $ \t -> do
     bytes <- either fail return . Base64.decode $ encodeUtf8 t
     maybe (fail "Could not parse key") return $ Saltine.decode bytes
+
+
+instance ClusterSetting 'ClusterJSONWebKeySet where
+  type ClusterSettingValue 'ClusterJSONWebKeySet = Jose.JwkSet
+  initClusterSetting _ = liftIO $ do
+    now <- getCurrentTime
+    jwkSig <- Jose.generateSymmetricKey 32 (Jose.UTCKeyId now) Jose.Sig (Just $ Jose.Signed Jose.HS256)
+    return $ Jose.JwkSet [jwkSig]
+  knownClusterSetting _ = ClusterJSONWebKeySet

src/Utils/Lens.hs

@@ -93,4 +93,12 @@ makeLenses_ ''StudyTermCandidate
 
 -- makeClassy_ ''Load
 
+--------------------------
+-- Fields for `UniWorX` --
+--------------------------
 
+class HasInstanceID s a | s -> a where
+  instanceID :: Lens' s a
+  
+class HasJSONWebKeySet s a | s -> a where
+  jsonWebKeySet :: Lens' s a