diff --git a/config/settings.yml b/config/settings.yml index 3211d42db..9479d002a 100644 --- a/config/settings.yml +++ b/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: diff --git a/package.yaml b/package.yaml index 339ecff3e..c856a6e95 100644 --- a/package.yaml +++ b/package.yaml @@ -117,6 +117,8 @@ dependencies: - lattices - hsass - semigroupoids + - jose-jwt + - mono-traversable other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index 20824d216..5b130dd50 100644 --- a/src/Application.hs +++ b/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{..} diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 5233faaf3..d65c1ee9b 100644 --- a/src/Auth/LDAP.hs +++ b/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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 899047c3b..22266fc3a 100644 --- a/src/CryptoID.hs +++ b/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 diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs new file mode 100644 index 000000000..f785576f2 --- /dev/null +++ b/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 diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs new file mode 100644 index 000000000..1a11a66d9 --- /dev/null +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 0aca60110..09755de7d 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 46abeddd5..6e250cfd9 100644 --- a/src/Handler/Utils.hs +++ b/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 diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index de2b0705a..15ecfc780 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/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) \ No newline at end of file + | otherwise = loop (succ n) (addOneWeek t) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 21e0b5de5..fd37d73bc 100644 --- a/src/Import/NoFoundation.hs +++ b/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) diff --git a/src/Jobs.hs b/src/Jobs.hs index 2a9a42556..04df2686c 100644 --- a/src/Jobs.hs +++ b/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 diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 41b3441c6..af83ef1c5 100644 --- a/src/Jobs/Crontab.hs +++ b/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 diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index 1ec904e2b..5623be772 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/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 diff --git a/src/Jose/Jwt/Instances.hs b/src/Jose/Jwt/Instances.hs new file mode 100644 index 000000000..f7607168c --- /dev/null +++ b/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 diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 0aed744b0..5ec81cd81 100644 --- a/src/Model/Migration/Types.hs +++ b/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 diff --git a/src/Model/Token.hs b/src/Model/Token.hs new file mode 100644 index 000000000..a57b5244b --- /dev/null +++ b/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" diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 7cf317d0c..5c292d146 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs index e69f8f1b2..66ed78163 100644 --- a/src/Model/Types/JSON.hs +++ b/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 + } + diff --git a/src/Settings.hs b/src/Settings.hs index f717ee378..ae2ce4b30 100644 --- a/src/Settings.hs +++ b/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. -- diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index a6fb11799..872d901b7 100644 --- a/src/Settings/Cluster.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 0abc9a8ee..b6a09e3c3 100644 --- a/src/Utils/Lens.hs +++ b/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