Merge branch '234-onboarding-bearer-tokens' into 'master'
Work on "Onboarding / Bearer-Tokens" See merge request !175
This commit is contained in:
Gregor Kleen
commit
74014e994a
@ -27,6 +27,8 @@ notification-rate-limit: 3600
|
||||
notification-collate-delay: 300
|
||||
notification-expiration: 259201
|
||||
session-timeout: 7200
|
||||
jwt-expiration: 604800
|
||||
jwt-encoding: HS256
|
||||
maximum-content-length: 52428800
|
||||
|
||||
log-settings:
|
||||
|
||||
13
haddock.sh
13
haddock.sh
@ -1,3 +1,14 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
|
||||
move-back() {
|
||||
mv -v .stack-work .stack-work-doc
|
||||
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
|
||||
}
|
||||
|
||||
if [[ -d .stack-work-doc ]]; then
|
||||
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
|
||||
mv -v .stack-work-doc .stack-work
|
||||
trap move-back EXIT
|
||||
fi
|
||||
|
||||
stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
|
||||
|
||||
@ -10,6 +10,9 @@ BtnSave: Speichern
|
||||
BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
|
||||
BtnCandidatesDeleteConflicts: Konflikte löschen
|
||||
BtnCandidatesDeleteAll: Alle Beobachtungen löschen
|
||||
BtnResetTokens: Authorisierungs-Tokens invalidieren
|
||||
BtnLecInvAccept: Annehmen
|
||||
BtnLecInvDecline: Ablehnen
|
||||
|
||||
Aborted: Abgebrochen
|
||||
Remarks: Hinweise
|
||||
@ -206,6 +209,13 @@ CorrectorAssignTitle: Korrektor zuweisen
|
||||
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
|
||||
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
|
||||
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
|
||||
UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
|
||||
UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
|
||||
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
|
||||
UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
|
||||
UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
|
||||
UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
|
||||
UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
|
||||
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
|
||||
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
|
||||
UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
|
||||
@ -234,6 +244,7 @@ UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde au
|
||||
UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
|
||||
UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
|
||||
UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen.
|
||||
UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer.
|
||||
|
||||
EMail: E-Mail
|
||||
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
|
||||
@ -275,6 +286,9 @@ ImpressumHeading: Impressum
|
||||
DataProtHeading: Datenschutzerklärung
|
||||
SystemMessageHeading: Uni2work Statusmeldung
|
||||
SystemMessageListHeading: Uni2work Statusmeldungen
|
||||
NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName}
|
||||
TokensLastReset: Tokens zuletzt invalidiert
|
||||
TokensResetSuccess: Authorisierungs-Tokens invalidiert
|
||||
|
||||
HomeOpenCourses: Kurse mit offener Registrierung
|
||||
HomeUpcomingSheets: Anstehende Übungsblätter
|
||||
@ -291,7 +305,8 @@ Plugin: Plugin
|
||||
Ident: Identifikation
|
||||
LastLogin: Letzter Login
|
||||
Settings: Individuelle Benutzereinstellungen
|
||||
SettingsUpdate: Einstellungen wurden gespeichert.
|
||||
SettingsUpdate: Einstellungen erfolgreich gespeichert
|
||||
NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert
|
||||
Never: Nie
|
||||
|
||||
PreviouslyUploadedInfo: Bereits hochgeladene Dateien:
|
||||
@ -515,6 +530,9 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten
|
||||
MailSubjectSupport: Supportanfrage
|
||||
MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
|
||||
|
||||
MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
|
||||
CourseLecturerInvitationAcceptDecline: Einladung annehmen/ablehnen
|
||||
|
||||
SheetGrading: Bewertung
|
||||
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
|
||||
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
|
||||
@ -672,6 +690,7 @@ MenuCourseMembers: Kursteilnehmer
|
||||
MenuTermShow: Semester
|
||||
MenuSubmissionDelete: Abgabe löschen
|
||||
MenuUsers: Benutzer
|
||||
MenuUserNotifications: Benachrichtigungs-Einstellungen
|
||||
MenuAdminTest: Admin-Demo
|
||||
MenuMessageList: Systemnachrichten
|
||||
MenuAdminErrMsg: Fehlermeldung entschlüsseln
|
||||
@ -706,6 +725,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate
|
||||
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
|
||||
AuthTagFree: Seite ist universell zugänglich
|
||||
AuthTagAdmin: Nutzer ist Administrator
|
||||
AuthTagToken: Nutzer präsentiert Authorisierungs-Token
|
||||
AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
|
||||
AuthTagDeprecated: Seite ist nicht überholt
|
||||
AuthTagDevelopment: Seite ist nicht in Entwicklung
|
||||
@ -721,6 +741,7 @@ AuthTagOwner: Nutzer ist Besitzer
|
||||
AuthTagRated: Korrektur ist bewertet
|
||||
AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
|
||||
AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
|
||||
AuthTagSelf: Nutzer greift nur auf eigene Daten zu
|
||||
AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
|
||||
AuthTagRead: Zugriff ist nur lesend
|
||||
AuthTagWrite: Zugriff ist i.A. schreibend
|
||||
@ -735,3 +756,10 @@ MassInputAddDimension: Hinzufügen
|
||||
MassInputDeleteCell: Entfernen
|
||||
|
||||
NavigationFavourites: Favoriten
|
||||
|
||||
EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
|
||||
|
||||
LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen
|
||||
LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt
|
||||
CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
|
||||
CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.
|
||||
|
||||
@ -35,6 +35,12 @@ Lecturer -- course ownership
|
||||
course CourseId
|
||||
type LecturerType default='"lecturer"'
|
||||
UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
|
||||
LecturerInvitation json -- preliminary course ownership for when a token to become `Lecturer` is sent to an email
|
||||
email (CI Text)
|
||||
course CourseId
|
||||
type LecturerType Maybe
|
||||
UniqueLecturerInvitation email course
|
||||
deriving Eq Ord Read Show Generic Typeable
|
||||
CourseParticipant -- course enrolement
|
||||
course CourseId
|
||||
user UserId
|
||||
|
||||
@ -11,6 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
ident (CI Text) -- Case-insensitive user-identifier
|
||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||
lastAuthentication UTCTime Maybe -- last login date
|
||||
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
|
||||
matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
|
||||
email (CI Text) -- Case-insensitive eMail address
|
||||
displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||
|
||||
@ -85,6 +85,7 @@ dependencies:
|
||||
- scientific
|
||||
- tz
|
||||
- system-locale
|
||||
- th-lift
|
||||
- th-lift-instances
|
||||
- gitrev
|
||||
- Glob
|
||||
@ -117,6 +118,9 @@ dependencies:
|
||||
- lattices
|
||||
- hsass
|
||||
- semigroupoids
|
||||
- jose-jwt
|
||||
- mono-traversable
|
||||
- lens-aeson
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
3
routes
3
routes
@ -16,6 +16,7 @@
|
||||
-- !registered -- participant for this course (no effect outside of courses)
|
||||
-- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses)
|
||||
-- !owner -- part of the group of owners of this submission
|
||||
-- !self -- route refers to the currently logged in user themselves
|
||||
-- !capacity -- course this route is associated with has at least one unit of participant capacity
|
||||
-- !empty -- course this route is associated with has no participants whatsoever
|
||||
--
|
||||
@ -39,6 +40,7 @@
|
||||
/users/#CryptoUUIDUser AdminUserR GET POST
|
||||
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
|
||||
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
|
||||
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
|
||||
/admin AdminR GET
|
||||
/admin/features AdminFeaturesR GET POST
|
||||
/admin/test AdminTestR GET POST
|
||||
@ -74,6 +76,7 @@
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
/lecturer-invite/#UserEmail CLecInviteR GET POST
|
||||
/delete CDeleteR GET POST !lecturerANDempty
|
||||
/users CUsersR GET POST
|
||||
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
|
||||
|
||||
@ -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{..}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
22
src/Data/Aeson/Types/Instances.hs
Normal file
22
src/Data/Aeson/Types/Instances.hs
Normal file
@ -0,0 +1,22 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Aeson.Types.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
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 ()
|
||||
|
||||
|
||||
instance MonadThrow Parser where
|
||||
throwM = fail . show
|
||||
|
||||
|
||||
instance Binary Value
|
||||
16
src/Data/HashMap/Strict/Instances.hs
Normal file
16
src/Data/HashMap/Strict/Instances.hs
Normal file
@ -0,0 +1,16 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.HashMap.Strict.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.Binary (Binary(..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
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
|
||||
17
src/Data/HashSet/Instances.hs
Normal file
17
src/Data/HashSet/Instances.hs
Normal file
@ -0,0 +1,17 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.HashSet.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.HashSet (HashSet)
|
||||
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
|
||||
28
src/Data/NonNull/Instances.hs
Normal file
28
src/Data/NonNull/Instances.hs
Normal file
@ -0,0 +1,28 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.NonNull.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.Aeson
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
instance (Binary a, MonoFoldable a) => Binary (NonNull a) where
|
||||
get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable
|
||||
put = Binary.put . toNullable
|
||||
26
src/Data/Time/Clock/Instances.hs
Normal file
26
src/Data/Time/Clock/Instances.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Time.Clock.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.Time.Clock
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
deriving instance Generic UTCTime
|
||||
|
||||
|
||||
instance Binary Day where
|
||||
get = ModifiedJulianDay <$> Binary.get
|
||||
put = Binary.put . toModifiedJulianDay
|
||||
|
||||
instance Binary DiffTime where
|
||||
get = fromRational <$> Binary.get
|
||||
put = Binary.put . toRational
|
||||
|
||||
instance Binary UTCTime
|
||||
18
src/Data/Vector/Instances.hs
Normal file
18
src/Data/Vector/Instances.hs
Normal file
@ -0,0 +1,18 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Vector.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.Vector (Vector)
|
||||
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
|
||||
12
src/Database/Persist/Types/Instances.hs
Normal file
12
src/Database/Persist/Types/Instances.hs
Normal file
@ -0,0 +1,12 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Database.Persist.Types.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Database.Persist.Types
|
||||
|
||||
instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where
|
||||
s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal
|
||||
@ -43,6 +43,7 @@ import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map, (!?))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.List (nubBy)
|
||||
|
||||
@ -55,12 +56,12 @@ import Data.Conduit.List (sourceList)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Monad.Except (MonadError(..), runExceptT)
|
||||
import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Trans.Reader (runReader, mapReaderT)
|
||||
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..))
|
||||
import Control.Monad.Memo.Class (MonadMemo(..), for4)
|
||||
import qualified Control.Monad.Catch as C
|
||||
|
||||
import Handler.Utils.StudyFeatures
|
||||
@ -77,6 +78,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 +98,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 +108,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 +123,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:
|
||||
@ -137,8 +148,10 @@ type SMTPPool = Pool SMTPConnection
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB a = YesodDB UniWorX a
|
||||
type DB = YesodDB UniWorX
|
||||
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
type MailM a = MailT (HandlerT UniWorX IO) a
|
||||
@ -385,25 +398,30 @@ appLanguagesOpts = do
|
||||
|
||||
|
||||
-- Access Control
|
||||
newtype InvalidAuthTag = InvalidAuthTag Text
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
instance Exception InvalidAuthTag
|
||||
|
||||
|
||||
data AccessPredicate
|
||||
= APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Route UniWorX -> Bool -> Handler AuthResult)
|
||||
| APDB (Route UniWorX -> Bool -> DB AuthResult)
|
||||
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
|
||||
| APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> DB AuthResult)
|
||||
|
||||
class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
|
||||
evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult
|
||||
evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
|
||||
|
||||
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
|
||||
evalAccessPred aPred r w = liftHandlerT $ case aPred of
|
||||
(APPure p) -> runReader (p r w) <$> getMsgRenderer
|
||||
(APHandler p) -> p r w
|
||||
(APDB p) -> runDB $ p r w
|
||||
evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
|
||||
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
|
||||
(APHandler p) -> p aid r w
|
||||
(APDB p) -> runDB $ p aid r w
|
||||
|
||||
instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
|
||||
evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of
|
||||
(APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer
|
||||
(APHandler p) -> lift $ p r w
|
||||
(APDB p) -> p r w
|
||||
evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of
|
||||
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
|
||||
(APHandler p) -> lift $ p aid r w
|
||||
(APDB p) -> p aid r w
|
||||
|
||||
|
||||
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
|
||||
@ -424,16 +442,57 @@ trueAR = const Authorized
|
||||
falseAR = Unauthorized . ($ MsgUnauthorized) . render
|
||||
|
||||
trueAP, falseAP :: AccessPredicate
|
||||
trueAP = APPure . const . const $ trueAR <$> ask
|
||||
falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
|
||||
trueAP = APPure . const . const . const $ trueAR <$> ask
|
||||
falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
|
||||
|
||||
|
||||
askTokenUnsafe :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadLogger m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> ExceptT AuthResult m (BearerToken (UniWorX))
|
||||
-- | 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
|
||||
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'
|
||||
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)
|
||||
|
||||
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
|
||||
guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
|
||||
|
||||
authorityVal <- do
|
||||
dnf <- either throwM return $ routeAuthTags route
|
||||
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
|
||||
guardExceptT (is _Authorized authorityVal) authorityVal
|
||||
|
||||
whenIsJust tokenAddAuth $ \addDNF -> do
|
||||
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
|
||||
guardExceptT (is _Authorized additionalVal) additionalVal
|
||||
|
||||
return Authorized
|
||||
|
||||
|
||||
tagAccessPredicate :: AuthTag -> AccessPredicate
|
||||
tagAccessPredicate AuthFree = trueAP
|
||||
tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
|
||||
-- Courses: access only to school admins
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
|
||||
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
|
||||
@ -445,13 +504,15 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
|
||||
return Authorized
|
||||
-- other routes: access to any admin is granted here
|
||||
_other -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
|
||||
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
|
||||
lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
|
||||
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
|
||||
AdminHijackUserR cID -> exceptT return return $ do
|
||||
myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
uid <- decrypt cID
|
||||
otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
|
||||
otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
|
||||
@ -459,21 +520,21 @@ tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
|
||||
guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthNoEscalation r
|
||||
tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
|
||||
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
|
||||
tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
|
||||
$logWarnS "AccessControl" ("route in development: " <> tshow r)
|
||||
#ifdef DEVELOPMENT
|
||||
return Authorized
|
||||
#else
|
||||
return $ Unauthorized "Route under development"
|
||||
#endif
|
||||
tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
@ -485,11 +546,11 @@ tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
|
||||
return Authorized
|
||||
-- lecturer for any school will do
|
||||
_ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
|
||||
return Authorized
|
||||
tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
@ -516,7 +577,7 @@ tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
|
||||
_ -> do
|
||||
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
@ -542,8 +603,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
|
||||
CourseR tid ssh csh CRegisterR -> do
|
||||
now <- liftIO getCurrentTime
|
||||
mbc <- getBy $ TermSchoolCourseShort tid ssh csh
|
||||
mAid <- lift maybeAuthId
|
||||
registered <- case (mbc,mAid) of
|
||||
registered <- case (mbc,mAuthId) of
|
||||
(Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
|
||||
_ -> return False
|
||||
case mbc of
|
||||
@ -565,9 +625,9 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
|
||||
return Authorized
|
||||
|
||||
r -> $unsupportedAuthPredicate AuthTime r
|
||||
tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
|
||||
@ -578,7 +638,7 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthRegistered r
|
||||
tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
||||
let authorizedIfExists f = do
|
||||
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
|
||||
@ -640,14 +700,14 @@ tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
unauthorizedI MsgUnauthorizedParticipant
|
||||
r -> $unsupportedAuthPredicate AuthParticipant r
|
||||
tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
|
||||
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
|
||||
guard $ NTop courseCapacity > NTop (Just registered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCapacity r
|
||||
tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
||||
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -658,73 +718,81 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
|
||||
return E.countRows
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthEmpty r
|
||||
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
guard courseMaterialFree
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthMaterials r
|
||||
tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
|
||||
CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
|
||||
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthOwner r
|
||||
tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
|
||||
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
|
||||
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
sub <- MaybeT $ get sid
|
||||
guard $ submissionRatingDone sub
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthRated r
|
||||
tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
|
||||
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
guard $ sheetSubmissionMode == UserSubmissions
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthUserSubmissions r
|
||||
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
|
||||
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
guard $ sheetSubmissionMode == CorrectorSubmissions
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
|
||||
tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do
|
||||
referencedUser <- case route of
|
||||
AdminUserR cID -> return cID
|
||||
AdminUserDeleteR cID -> return cID
|
||||
AdminHijackUserR cID -> return cID
|
||||
UserNotificationR cID -> return cID
|
||||
CourseR _ _ _ (CUserR cID) -> return cID
|
||||
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
|
||||
referencedUser' <- decrypt referencedUser
|
||||
case mAuthId of
|
||||
Just uid
|
||||
| uid == referencedUser' -> return Authorized
|
||||
Nothing -> return AuthenticationRequired
|
||||
_other -> unauthorizedI MsgUnauthorizedSelf
|
||||
tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
|
||||
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
|
||||
smId <- decrypt cID
|
||||
SystemMessage{..} <- MaybeT $ get smId
|
||||
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
|
||||
let isAuthenticated = isJust mAuthId
|
||||
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthAuthentication r
|
||||
tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
|
||||
tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
|
||||
tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
|
||||
tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
|
||||
|
||||
|
||||
newtype InvalidAuthTag = InvalidAuthTag Text
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
instance Exception InvalidAuthTag
|
||||
defaultAuthDNF :: AuthDNF
|
||||
defaultAuthDNF = PredDNF $ Set.fromList
|
||||
[ impureNonNull . Set.singleton $ PLVariable AuthAdmin
|
||||
, impureNonNull . Set.singleton $ PLVariable AuthToken
|
||||
]
|
||||
|
||||
type DNF a = Set (NonNull (Set a))
|
||||
|
||||
data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
instance Universe SessionAuthTags
|
||||
instance Finite SessionAuthTags
|
||||
nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
|
||||
|
||||
routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
|
||||
routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
|
||||
-- ^ DNF up to entailment:
|
||||
--
|
||||
-- > (A_1 && A_2 && ...) OR' B OR' ...
|
||||
--
|
||||
-- > A OR' B := ((A |- B) ==> A) && (A || B)
|
||||
routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs
|
||||
routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
|
||||
where
|
||||
partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
|
||||
partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
|
||||
partition' prev t
|
||||
| Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
|
||||
= if
|
||||
@ -735,42 +803,63 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p
|
||||
| otherwise
|
||||
= Left $ InvalidAuthTag t
|
||||
|
||||
evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
|
||||
evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
|
||||
-- ^ `tell`s disabled predicates, identified as pivots
|
||||
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite
|
||||
= startEvalMemoT $ do
|
||||
mr <- lift getMsgRenderer
|
||||
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite
|
||||
= do
|
||||
mr <- getMsgRenderer
|
||||
let
|
||||
authTagIsInactive = not . authTagIsActive
|
||||
|
||||
evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
|
||||
evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
|
||||
evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
|
||||
evalAuthTag authTag = lift . (runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
|
||||
where
|
||||
evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do
|
||||
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
|
||||
evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
|
||||
|
||||
evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
|
||||
evalAuthLiteral PLVariable{..} = evalAuthTag plVar
|
||||
evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case
|
||||
Unauthorized _ -> return Authorized
|
||||
AuthenticationRequired -> return AuthenticationRequired
|
||||
Authorized -> unauthorizedI plVar
|
||||
|
||||
orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
|
||||
orAR' = shortCircuitM (is _Authorized) (orAR mr)
|
||||
andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
|
||||
|
||||
evalDNF :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
|
||||
evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
|
||||
evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
|
||||
evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
|
||||
|
||||
lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
|
||||
$logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive . plVar) authDNF
|
||||
|
||||
result <- evalDNF $ filter (all authTagIsActive) authDNF
|
||||
result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF
|
||||
|
||||
unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj ->
|
||||
whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
|
||||
let pivots = filter authTagIsInactive conj
|
||||
whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
|
||||
lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
|
||||
lift . tell $ Set.fromList pivots
|
||||
unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
|
||||
whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
|
||||
let pivots = filter (authTagIsInactive . plVar) conj
|
||||
whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
|
||||
let pivots' = plVar <$> pivots
|
||||
$logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
|
||||
tell $ Set.fromList pivots'
|
||||
|
||||
return result
|
||||
|
||||
evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
|
||||
evalAccessFor mAuthId route isWrite = do
|
||||
dnf <- either throwM return $ routeAuthTags route
|
||||
fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite
|
||||
|
||||
evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
|
||||
evalAccessForDB = evalAccessFor
|
||||
|
||||
evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
|
||||
evalAccess route isWrite = do
|
||||
mAuthId <- liftHandlerT maybeAuthId
|
||||
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
||||
dnf <- either throwM return $ routeAuthTags route
|
||||
(result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf route isWrite
|
||||
(result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite
|
||||
result <$ tellSessionJson SessionInactiveAuthTags deactivated
|
||||
|
||||
evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
|
||||
@ -796,17 +885,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.
|
||||
@ -865,7 +954,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
|
||||
@ -906,8 +995,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
|
||||
@ -958,8 +1047,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
|
||||
|
||||
@ -1414,6 +1502,16 @@ pageActions (AdminR) =
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (AdminUserR cID) = [
|
||||
MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuUserNotifications
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ UserNotificationR cID
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (InfoR) = [
|
||||
MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
@ -2074,7 +2172,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
|
||||
@ -2129,6 +2227,7 @@ instance YesodAuth UniWorX where
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
, userMailLanguages = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, ..
|
||||
}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
@ -2193,7 +2292,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
|
||||
@ -2218,9 +2317,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
|
||||
@ -2228,7 +2327,7 @@ instance YesodMail UniWorX where
|
||||
mailT ctx mail = defMailT ctx $ do
|
||||
void setMailObjectId
|
||||
setDateCurrent
|
||||
replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings)
|
||||
replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
|
||||
|
||||
mail <* setMailSmtpData
|
||||
|
||||
|
||||
@ -286,9 +286,6 @@ instance Button UniWorX ButtonAdminStudyTerms where
|
||||
btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||
-- END Button needed only here
|
||||
|
||||
sessionKeyNewStudyTerms :: Text
|
||||
sessionKeyNewStudyTerms = "key-new-study-terms"
|
||||
|
||||
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
|
||||
getAdminFeaturesR = postAdminFeaturesR
|
||||
postAdminFeaturesR = do
|
||||
@ -304,7 +301,7 @@ postAdminFeaturesR = do
|
||||
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
|
||||
unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
|
||||
let newKeys = map (StudyTermsKey' . fst) infAccepted
|
||||
setSessionJson sessionKeyNewStudyTerms newKeys
|
||||
setSessionJson SessionNewStudyTerms newKeys
|
||||
if | null infAccepted
|
||||
-> addMessageI Info MsgNoCandidatesInferred
|
||||
| otherwise
|
||||
@ -322,7 +319,7 @@ postAdminFeaturesR = do
|
||||
Candidates.conflicts
|
||||
_other -> runDB Candidates.conflicts
|
||||
|
||||
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
|
||||
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
|
||||
( (degreeResult,degreeTable)
|
||||
, (studyTermsResult,studytermsTable)
|
||||
, ((), candidateTable)) <- runDB $ (,,)
|
||||
|
||||
@ -33,6 +33,8 @@ import qualified Database.Esqueleto as E
|
||||
|
||||
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
||||
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
|
||||
|
||||
@ -416,7 +418,7 @@ getCourseNewR = do
|
||||
return course
|
||||
template <- case listToMaybe oldCourses of
|
||||
(Just oldTemplate) ->
|
||||
let newTemplate = courseToForm oldTemplate [] in
|
||||
let newTemplate = courseToForm oldTemplate [] [] in
|
||||
return $ Just $ newTemplate
|
||||
{ cfCourseId = Nothing
|
||||
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
|
||||
@ -445,13 +447,14 @@ postCEditR = pgCEditR
|
||||
|
||||
pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
pgCEditR tid ssh csh = do
|
||||
courseLecs <- runDB $ do
|
||||
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
|
||||
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
||||
return $ (,) <$> mbCourse <*> mbLecs
|
||||
courseData <- runDB $ do
|
||||
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
|
||||
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
||||
mbLecInvites <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerInvitationCourse ==. entityKey course] [Asc LecturerInvitationType]
|
||||
return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
|
||||
-- IMPORTANT: both GET and POST Handler must use the same template,
|
||||
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
|
||||
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ uncurry courseToForm <$> courseLecs
|
||||
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
|
||||
|
||||
|
||||
getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
@ -479,7 +482,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
, cfTerm = tid
|
||||
} -> do -- create new course
|
||||
now <- liftIO getCurrentTime
|
||||
insertOkay <- runDB $ do
|
||||
insertOkay <- runDBJobs $ do
|
||||
insertOkay <- insertUnique Course
|
||||
{ courseName = cfName res
|
||||
, courseDescription = cfDesc res
|
||||
@ -495,7 +498,11 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
, courseDeregisterUntil = cfDeRegUntil res
|
||||
}
|
||||
whenIsJust insertOkay $ \cid -> do
|
||||
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
|
||||
forM_ (cfLecturers res) $ \case
|
||||
Right (lid, lty) -> insert_ $ Lecturer lid cid lty
|
||||
Left (lEmail, mLTy) -> do
|
||||
insert_ $ LecturerInvitation lEmail cid mLTy
|
||||
queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
|
||||
insert_ $ CourseEdit aid now cid
|
||||
return insertOkay
|
||||
case insertOkay of
|
||||
@ -513,7 +520,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
} -> do -- edit existing course
|
||||
now <- liftIO getCurrentTime
|
||||
-- addMessage "debug" [shamlet| #{show res}|]
|
||||
success <- runDB $ do
|
||||
success <- runDBJobs $ do
|
||||
old <- get cid
|
||||
case old of
|
||||
Nothing -> addMessageI Error MsgInvalidInput $> False
|
||||
@ -536,7 +543,15 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
|
||||
Nothing -> do
|
||||
deleteWhere [LecturerCourse ==. cid]
|
||||
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
|
||||
forM_ (cfLecturers res) $ \case
|
||||
Right (lid, lty) -> insert_ $ Lecturer lid cid lty
|
||||
Left (lEmail, mLTy) -> do
|
||||
insertRes <- insertUnique (LecturerInvitation lEmail cid mLTy)
|
||||
case insertRes of
|
||||
Just _ ->
|
||||
queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
|
||||
Nothing ->
|
||||
updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ]
|
||||
insert_ $ CourseEdit aid now cid
|
||||
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
@ -564,11 +579,11 @@ data CourseForm = CourseForm
|
||||
, cfRegFrom :: Maybe UTCTime
|
||||
, cfRegTo :: Maybe UTCTime
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
, cfLecturers :: [(UserId, LecturerType)]
|
||||
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
||||
}
|
||||
|
||||
courseToForm :: Entity Course -> [Lecturer] -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) lecs = CourseForm
|
||||
courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
|
||||
{ cfCourseId = Just cid
|
||||
, cfName = courseName
|
||||
, cfDesc = courseDescription
|
||||
@ -582,7 +597,8 @@ courseToForm (Entity cid Course{..}) lecs = CourseForm
|
||||
, cfRegFrom = courseRegisterFrom
|
||||
, cfRegTo = courseRegisterTo
|
||||
, cfDeRegUntil = courseDeregisterUntil
|
||||
, cfLecturers = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
||||
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
||||
++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ]
|
||||
}
|
||||
|
||||
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
|
||||
@ -609,29 +625,46 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
|
||||
| otherwise -> termsSetField [cfTerm cform]
|
||||
_allOtherCases -> return termsAllowedField
|
||||
|
||||
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId)))
|
||||
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
||||
miAdd _ _ nudge btn = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
|
||||
addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
|
||||
let addRes'' = case (,) <$> addRes <*> addRes' of
|
||||
FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
|
||||
FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
|
||||
| lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
|
||||
| otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
|
||||
FormSuccess (CI.mk -> email, mLid) ->
|
||||
let new = maybe (Left email) Right mLid
|
||||
in FormSuccess $ \prev -> if
|
||||
| new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
|
||||
| otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
|
||||
FormFailure errs -> FormFailure errs
|
||||
FormMissing -> FormMissing
|
||||
addView' = toWidget csrf >> fvInput addView >> fvInput btn
|
||||
return (addRes'', addView')
|
||||
|
||||
miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
|
||||
miCell _ lid defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
||||
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
|
||||
miCell _ (Right lid) defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
|
||||
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
|
||||
let lrwView' = [whamlet|$newline never
|
||||
#{csrf}
|
||||
^{nameEmailWidget userEmail userDisplayName userSurname} #
|
||||
^{fvInput lrwView}
|
||||
|]
|
||||
return (Just <$> lrwRes,lrwView')
|
||||
miCell _ (Left lEmail) defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
||||
let lrwView' = [whamlet|
|
||||
$newline never
|
||||
#{csrf}
|
||||
<span style="font-family:monospace">
|
||||
#{lEmail}
|
||||
#
|
||||
<div .tooltip>
|
||||
<div .tooltip__handle>
|
||||
<div .tooltip__content>
|
||||
_{MsgEmailInvitationWarning}
|
||||
#
|
||||
^{fvInput lrwView}
|
||||
|]
|
||||
return (lrwRes,lrwView')
|
||||
|
||||
miDelete :: ListLength -- ^ Current shape
|
||||
@ -643,13 +676,22 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
|
||||
miAllowAdd _ _ _ = True
|
||||
|
||||
|
||||
lecturerForm :: AForm Handler [(UserId,LecturerType)]
|
||||
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
|
||||
lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
||||
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
|
||||
MassInput{..}
|
||||
(fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
|
||||
True
|
||||
(Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
|
||||
(Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
|
||||
mempty
|
||||
where
|
||||
liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
|
||||
liftEither (Right lid , Just lType) = Right (lid , lType )
|
||||
liftEither (Left lEmail, mLType ) = Left (lEmail, mLType)
|
||||
liftEither _ = error "liftEither: lecturerForm produced output it should not have been able to"
|
||||
|
||||
unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
|
||||
unliftEither (Right (lid , lType )) = (Right lid , Just lType)
|
||||
unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType )
|
||||
|
||||
(newRegFrom,newRegTo,newDeRegUntil) <- case template of
|
||||
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
|
||||
@ -717,7 +759,7 @@ validateCourse CourseForm{..} = do
|
||||
( NTop cfRegFrom <= NTop cfDeRegUntil
|
||||
, MsgCourseDeregistrationEndMustBeAfterStart
|
||||
)
|
||||
, ( maybe (any ((== uid) . fst) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
|
||||
, ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
|
||||
, MsgCourseUserMustBeLecturer
|
||||
)
|
||||
] ]
|
||||
@ -1039,3 +1081,56 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
-- If they are shared, adjust MsgCourseUserNoteTooltip
|
||||
getCNotesR = error "CNotesR: Not implemented"
|
||||
postCNotesR = error "CNotesR: Not implemented"
|
||||
|
||||
|
||||
data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe ButtonLecInvite
|
||||
instance Finite ButtonLecInvite
|
||||
|
||||
nullaryPathPiece ''ButtonLecInvite $ camelToPathPiece' 3
|
||||
embedRenderMessage ''UniWorX ''ButtonLecInvite id
|
||||
|
||||
instance Button UniWorX ButtonLecInvite where
|
||||
btnClasses BtnLecInvAccept = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnLecInvDecline = [BCIsButton, BCDanger]
|
||||
|
||||
getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> UserEmail -> Handler Html
|
||||
getCLecInviteR = postCLecInviteR
|
||||
postCLecInviteR tid ssh csh email = do
|
||||
uid <- requireAuthId
|
||||
(Entity cid Course{..}, Entity liId LecturerInvitation{..}) <- runDB $ do
|
||||
cRes@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
iRes <- getBy404 $ UniqueLecturerInvitation email cid
|
||||
return (cRes, iRes)
|
||||
|
||||
((btnResult, btnInnerWidget), btnEncoding) <- runFormPost . formEmbedJwtPost $ \csrf -> do
|
||||
(ltRes, ltView) <- case lecturerInvitationType of
|
||||
Nothing -> mreq (selectField optionsFinite) "" Nothing
|
||||
Just lType -> mforced (selectField optionsFinite) "" lType
|
||||
(btnRes, btnWdgt) <- buttonForm mempty
|
||||
return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt)
|
||||
|
||||
let btnWidget = wrapForm btnInnerWidget def
|
||||
{ formEncoding = btnEncoding
|
||||
, formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
|
||||
formResult btnResult $ \case
|
||||
(lType, BtnLecInvAccept) -> do
|
||||
runDB $ do
|
||||
delete liId
|
||||
insert_ $ Lecturer uid cid lType
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
addMessageI Success $ MsgLecturerInvitationAccepted (mr lType) csh
|
||||
redirect $ CourseR tid ssh csh CShowR
|
||||
(_, BtnLecInvDecline) -> do
|
||||
runDB $
|
||||
delete liId
|
||||
addMessageI Info $ MsgLecturerInvitationDeclined csh
|
||||
redirect HomeR
|
||||
|
||||
siteLayoutMsg (MsgCourseLecInviteHeading $ CI.original courseName) $ do
|
||||
setTitleI . MsgCourseLecInviteHeading $ CI.original courseName
|
||||
$(widgetFile "courseLecInvite")
|
||||
|
||||
@ -42,11 +42,10 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do
|
||||
& setTooltip MsgDownloadFilesTip
|
||||
) (stgDownloadFiles <$> template)
|
||||
<* aformSection MsgFormNotifications
|
||||
<*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
|
||||
<*> notificationForm (stgNotificationSettings <$> template)
|
||||
return (result, widget) -- no validation required here
|
||||
where
|
||||
themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
|
||||
nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
|
||||
--
|
||||
-- Version with proper grouping:
|
||||
--
|
||||
@ -76,6 +75,31 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do
|
||||
-- <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
|
||||
-- nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
|
||||
|
||||
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
|
||||
notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True
|
||||
where
|
||||
nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template)
|
||||
|
||||
|
||||
data ButtonResetTokens = BtnResetTokens
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonResetTokens
|
||||
instance Finite ButtonResetTokens
|
||||
|
||||
nullaryPathPiece ''ButtonResetTokens $ camelToPathPiece' 1
|
||||
|
||||
embedRenderMessage ''UniWorX ''ButtonResetTokens id
|
||||
instance Button UniWorX ButtonResetTokens where
|
||||
btnClasses BtnResetTokens = [BCIsButton, BCDanger]
|
||||
|
||||
data ProfileAnchor = ProfileSettings | ProfileResetTokens
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ProfileAnchor
|
||||
instance Finite ProfileAnchor
|
||||
|
||||
nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
|
||||
|
||||
|
||||
getProfileR, postProfileR :: Handler Html
|
||||
getProfileR = postProfileR
|
||||
postProfileR = do
|
||||
@ -89,38 +113,60 @@ postProfileR = do
|
||||
, stgDownloadFiles = userDownloadFiles
|
||||
, stgNotificationSettings = userNotificationSettings
|
||||
}
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
|
||||
case res of
|
||||
(FormSuccess SettingsForm{..}) -> do
|
||||
runDB $ do
|
||||
update uid [ UserMaxFavourites =. stgMaxFavourties
|
||||
, UserTheme =. stgTheme
|
||||
, UserDateTimeFormat =. stgDateTime
|
||||
, UserDateFormat =. stgDate
|
||||
, UserTimeFormat =. stgTime
|
||||
, UserDownloadFiles =. stgDownloadFiles
|
||||
, UserNotificationSettings =. stgNotificationSettings
|
||||
]
|
||||
when (stgMaxFavourties < userMaxFavourites) $ do
|
||||
-- prune Favourites to user-defined size
|
||||
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
|
||||
[ Desc CourseFavouriteTime
|
||||
, OffsetBy stgMaxFavourties
|
||||
]
|
||||
mapM_ delete oldFavs
|
||||
addMessageI Info MsgSettingsUpdate
|
||||
redirect ProfileR -- TODO: them change does not happen without redirect
|
||||
((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
|
||||
|
||||
(FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml
|
||||
_ -> return ()
|
||||
formResult res $ \SettingsForm{..} -> do
|
||||
runDB $ do
|
||||
update uid [ UserMaxFavourites =. stgMaxFavourties
|
||||
, UserTheme =. stgTheme
|
||||
, UserDateTimeFormat =. stgDateTime
|
||||
, UserDateFormat =. stgDate
|
||||
, UserTimeFormat =. stgTime
|
||||
, UserDownloadFiles =. stgDownloadFiles
|
||||
, UserNotificationSettings =. stgNotificationSettings
|
||||
]
|
||||
when (stgMaxFavourties < userMaxFavourites) $ do
|
||||
-- prune Favourites to user-defined size
|
||||
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
|
||||
[ Desc CourseFavouriteTime
|
||||
, OffsetBy stgMaxFavourties
|
||||
]
|
||||
mapM_ delete oldFavs
|
||||
addMessageI Info MsgSettingsUpdate
|
||||
redirect $ ProfileR :#: ProfileSettings
|
||||
|
||||
((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm
|
||||
|
||||
formResult tokenRes $ \BtnResetTokens -> do
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ update uid [ UserTokensIssuedAfter =. Just now ]
|
||||
addMessageI Info MsgTokensResetSuccess
|
||||
redirect $ ProfileR :#: ProfileResetTokens
|
||||
|
||||
tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter
|
||||
|
||||
siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do
|
||||
setTitle . toHtml $ "Profil " <> userIdent
|
||||
let settingsForm = wrapForm formWidget def
|
||||
{ formAction = Just $ SomeRoute ProfileR
|
||||
, formEncoding = formEnctype
|
||||
}
|
||||
$(widgetFile "profile")
|
||||
let settingsForm =
|
||||
wrapForm formWidget FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings
|
||||
, formEncoding = formEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just ProfileSettings
|
||||
}
|
||||
tokenForm =
|
||||
wrapForm tokenFormWidget FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens
|
||||
, formEncoding = tokenEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAnchor = Just ProfileResetTokens
|
||||
}
|
||||
tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
|
||||
$(widgetFile "profile/profile")
|
||||
|
||||
|
||||
getProfileDataR :: Handler Html
|
||||
@ -533,3 +579,27 @@ postAuthPredsR = do
|
||||
siteLayoutMsg MsgAuthPredsActive $ do
|
||||
setTitleI MsgAuthPredsActive
|
||||
$(widgetFile "authpreds")
|
||||
|
||||
|
||||
getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html
|
||||
getUserNotificationR = postUserNotificationR
|
||||
postUserNotificationR cID = do
|
||||
uid <- decrypt cID
|
||||
User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
|
||||
|
||||
((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
|
||||
mJwt <- askJwt
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
let formWidget = wrapForm nsInnerWdgt def
|
||||
{ formAction = Just . SomeRoute $ UserNotificationR cID
|
||||
, formEncoding = nsEnc
|
||||
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
|
||||
}
|
||||
|
||||
formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
|
||||
lift . runDB $ update uid [ UserNotificationSettings =. ns ]
|
||||
tell . pure =<< messageI Success MsgNotificationSettingsUpdate
|
||||
|
||||
siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
|
||||
setTitleI $ MsgNotificationSettingsHeading userDisplayName
|
||||
formWidget
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
27
src/Handler/Utils/Tokens.hs
Normal file
27
src/Handler/Utils/Tokens.hs
Normal file
@ -0,0 +1,27 @@
|
||||
module Handler.Utils.Tokens
|
||||
( maybeBearerToken, requireBearerToken
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Control.Monad.Trans.Maybe (runMaybeT)
|
||||
|
||||
|
||||
maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX))
|
||||
maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
|
||||
where
|
||||
cPred err = any ($ err)
|
||||
[ is $ _HCError . _PermissionDenied
|
||||
, is $ _HCError . _NotAuthenticated
|
||||
]
|
||||
|
||||
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
|
||||
requireBearerToken = liftHandlerT $ do
|
||||
token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return $ askTokenUnsafe
|
||||
mAuthId <- maybeAuthId
|
||||
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
|
||||
isWrite <- isWriteRequest currentRoute
|
||||
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
|
||||
return token
|
||||
@ -9,6 +9,7 @@ import Model.Types.JSON as Import
|
||||
import Model.Migration as Import
|
||||
import Model.Rating as Import
|
||||
import Model.Submission as Import
|
||||
import Model.Tokens as Import
|
||||
import Settings as Import
|
||||
import Settings.StaticFiles as Import
|
||||
import Yesod.Auth as Import
|
||||
@ -18,7 +19,11 @@ import Utils as Import
|
||||
import Utils.Frontend.Modal as Import
|
||||
import Utils.Frontend.I18n as Import
|
||||
import Yesod.Core.Json as Import (provideJson)
|
||||
import Yesod.Core.Types.Instances as Import ()
|
||||
import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
|
||||
|
||||
import Language.Haskell.TH.Instances as Import ()
|
||||
|
||||
import Utils.Tokens as Import
|
||||
|
||||
|
||||
import Data.Fixed as Import
|
||||
@ -44,10 +49,15 @@ 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(..))
|
||||
import Data.Monoid.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.Binary as Import (Binary)
|
||||
|
||||
@ -57,17 +67,21 @@ 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
|
||||
|
||||
import Database.Esqueleto.Instances as Import ()
|
||||
import Database.Persist.Sql.Instances as Import ()
|
||||
import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
|
||||
import Database.Persist.Types.Instances as Import ()
|
||||
|
||||
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)
|
||||
|
||||
|
||||
18
src/Jobs.hs
18
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))
|
||||
@ -58,6 +59,7 @@ import Jobs.Handler.QueueNotification
|
||||
import Jobs.Handler.HelpRequest
|
||||
import Jobs.Handler.SetLogSettings
|
||||
import Jobs.Handler.DistributeCorrections
|
||||
import Jobs.Handler.LecturerInvitation
|
||||
|
||||
|
||||
data JobQueueException = JInvalid QueuedJobId QueuedJob
|
||||
@ -77,7 +79,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 +137,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 +159,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 +168,7 @@ execCrontab = evalStateT go HashMap.empty
|
||||
CronLastExec
|
||||
{ cronLastExecJob = toJSON job
|
||||
, cronLastExecTime = now
|
||||
, cronLastExecInstance = instanceID
|
||||
, cronLastExecInstance = instanceID'
|
||||
}
|
||||
[ CronLastExecTime =. now ]
|
||||
lift . lift $ queueDBJob job
|
||||
@ -285,21 +287,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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -21,7 +21,7 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
|
||||
-> Maybe Text -- ^ Referer
|
||||
-> Handler ()
|
||||
dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
|
||||
supportAddress <- getsYesod $ appMailSupport . appSettings
|
||||
supportAddress <- view _appMailSupport
|
||||
userInfo <- bitraverse return (runDB . getEntity) jSender
|
||||
let userAddress = either
|
||||
id
|
||||
|
||||
43
src/Jobs/Handler/LecturerInvitation.hs
Normal file
43
src/Jobs/Handler/LecturerInvitation.hs
Normal file
@ -0,0 +1,43 @@
|
||||
module Jobs.Handler.LecturerInvitation
|
||||
( dispatchJobLecturerInvitation
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
|
||||
dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler ()
|
||||
dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do
|
||||
ctx <- runDB . runMaybeT $ do
|
||||
course <- MaybeT $ get lecturerInvitationCourse
|
||||
void . MaybeT $ getByValue jLecturerInvitation
|
||||
user <- MaybeT $ get jInviter
|
||||
return (course, user)
|
||||
|
||||
case ctx of
|
||||
Just (Course{..}, User{..}) -> do
|
||||
let baseRoute = CourseR courseTerm courseSchool courseShorthand $ CLecInviteR lecturerInvitationEmail
|
||||
jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
|
||||
let
|
||||
invitationUrl :: SomeRoute UniWorX
|
||||
invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
invitationUrl' <- toTextUrl invitationUrl
|
||||
|
||||
mailT def $ do
|
||||
_mailTo .= [Address Nothing (CI.original $ lecturerInvitationEmail)]
|
||||
replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
|
||||
|
||||
addPart ($(ihamletFile "templates/mail/lecturerInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
Nothing -> runDB .
|
||||
deleteBy $ UniqueLecturerInvitation lecturerInvitationEmail lecturerInvitationCourse
|
||||
@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.CorrectionsAssigned
|
||||
|
||||
import Import
|
||||
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
import Handler.Utils.Mail
|
||||
|
||||
import Text.Hamlet
|
||||
@ -28,6 +29,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||
|
||||
addAlternatives $ do
|
||||
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addAlternatives $
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
|
||||
@ -7,6 +7,7 @@ module Jobs.Handler.SendNotification.SheetActive
|
||||
import Import
|
||||
|
||||
import Handler.Utils.Mail
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -27,6 +28,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
addAlternatives $ do
|
||||
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addAlternatives $
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
|
||||
@ -8,6 +8,7 @@ module Jobs.Handler.SendNotification.SheetInactive
|
||||
import Import
|
||||
|
||||
import Handler.Utils.Mail
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
@ -30,8 +31,9 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
addAlternatives $ do
|
||||
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addAlternatives $
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
|
||||
dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
|
||||
@ -56,7 +58,8 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
addAlternatives $ do
|
||||
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addAlternatives $
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
|
||||
|
||||
@ -9,6 +9,7 @@ import Import
|
||||
import Utils.Lens
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Mail
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Data.Aeson as Aeson
|
||||
@ -35,6 +36,8 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
|
||||
csh = courseShorthand
|
||||
shn = sheetName
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
-- TODO: provide convienience template-haskell for `addAlternatives`
|
||||
addAlternatives $ do
|
||||
provideAlternative $ Aeson.object
|
||||
@ -52,5 +55,4 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
|
||||
, "course-school" Aeson..= courseSchool
|
||||
]
|
||||
-- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
|
||||
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
|
||||
@ -8,6 +8,7 @@ import Import
|
||||
|
||||
import Handler.Utils.Database
|
||||
import Handler.Utils.Mail
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
import Text.Hamlet
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
@ -22,7 +23,7 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
|
||||
-- MsgRenderer mr <- getMailMsgRenderer
|
||||
addAlternatives $ do
|
||||
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addAlternatives $
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
|
||||
|
||||
20
src/Jobs/Handler/SendNotification/Utils.hs
Normal file
20
src/Jobs/Handler/SendNotification/Utils.hs
Normal file
@ -0,0 +1,20 @@
|
||||
module Jobs.Handler.SendNotification.Utils
|
||||
( mkEditNotifications
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
mkEditNotifications uid = liftHandlerT $ do
|
||||
cID <- encrypt uid
|
||||
jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
|
||||
let
|
||||
editNotificationsUrl :: SomeRoute UniWorX
|
||||
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
editNotificationsUrl' <- toTextUrl editNotificationsUrl
|
||||
return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
@ -23,6 +23,9 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
|
||||
}
|
||||
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
|
||||
| JobDistributeCorrections { jSheet :: SheetId }
|
||||
| JobLecturerInvitation { jInviter :: UserId
|
||||
, jLecturerInvitation :: LecturerInvitation
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
| NotificationSheetActive { nSheet :: SheetId }
|
||||
|
||||
19
src/Jose/Jwt/Instances.hs
Normal file
19
src/Jose/Jwt/Instances.hs
Normal file
@ -0,0 +1,19 @@
|
||||
{-# 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 Generic JwtError
|
||||
deriving instance Typeable JwtError
|
||||
|
||||
instance Exception JwtError
|
||||
14
src/Language/Haskell/TH/Instances.hs
Normal file
14
src/Language/Haskell/TH/Instances.hs
Normal file
@ -0,0 +1,14 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Language.Haskell.TH.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Lift (deriveLift)
|
||||
import Data.Binary (Binary)
|
||||
|
||||
|
||||
instance Binary Loc
|
||||
|
||||
deriveLift ''Loc
|
||||
@ -27,6 +27,7 @@ module Mail
|
||||
, setSubjectI, setMailObjectId, setMailObjectId'
|
||||
, setDate, setDateCurrent
|
||||
, setMailSmtpData
|
||||
, _addressName, _addressEmail
|
||||
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
|
||||
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
|
||||
) where
|
||||
@ -105,6 +106,7 @@ import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
makeLenses_ ''Address
|
||||
makeLenses_ ''Mail
|
||||
makeLenses_ ''Part
|
||||
|
||||
|
||||
@ -40,5 +40,7 @@ deriving instance Eq (Unique Sheet)
|
||||
-- Automatically generated (i.e. numeric) ids are already taken care of
|
||||
deriving instance Binary (Key Term)
|
||||
|
||||
instance Hashable LecturerInvitation
|
||||
|
||||
submissionRatingDone :: Submission -> Bool
|
||||
submissionRatingDone Submission{..} = isJust submissionRatingTime
|
||||
|
||||
@ -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
|
||||
|
||||
149
src/Model/Tokens.hs
Normal file
149
src/Model/Tokens.hs
Normal file
@ -0,0 +1,149 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model.Tokens
|
||||
( BearerToken(..)
|
||||
, _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
|
||||
, tokenRestrict
|
||||
, tokenToJSON, tokenParseJSON
|
||||
) 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 Data.HashSet (HashSet)
|
||||
|
||||
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)
|
||||
|
||||
|
||||
|
||||
-- | 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 :: 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 <- 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 $
|
||||
catMaybes [ Just $ "authority" .= 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 (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
|
||||
tokenAuthority <- 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
|
||||
|
||||
@ -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,8 @@ import Model.Types.Wordlist
|
||||
import Data.Text.Metrics (damerauLevenshtein)
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = UUID.fromString . unpack
|
||||
@ -712,6 +715,7 @@ pseudonymFragments = folding
|
||||
|
||||
data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
|
||||
= AuthAdmin
|
||||
| AuthToken
|
||||
| AuthLecturer
|
||||
| AuthCorrector
|
||||
| AuthRegistered
|
||||
@ -724,6 +728,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthCorrectorSubmissions
|
||||
| AuthCapacity
|
||||
| AuthEmpty
|
||||
| AuthSelf
|
||||
| AuthAuthentication
|
||||
| AuthNoEscalation
|
||||
| AuthRead
|
||||
@ -731,7 +736,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
|
||||
@ -749,6 +754,8 @@ instance ToJSONKey AuthTag where
|
||||
instance FromJSONKey AuthTag where
|
||||
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
|
||||
|
||||
instance Binary AuthTag
|
||||
|
||||
|
||||
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
|
||||
deriving (Read, Show, Generic)
|
||||
@ -772,6 +779,45 @@ 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
|
||||
|
||||
instance PathPiece a => PathPiece (PredLiteral a) where
|
||||
toPathPiece PLVariable{..} = toPathPiece plVar
|
||||
toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
|
||||
|
||||
fromPathPiece t = PLVariable <$> fromPathPiece t
|
||||
<|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
|
||||
|
||||
instance Binary a => Binary (PredLiteral a)
|
||||
|
||||
|
||||
newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
$(return [])
|
||||
|
||||
instance ToJSON a => ToJSON (PredDNF a) where
|
||||
toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
|
||||
instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
|
||||
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
|
||||
|
||||
instance (Ord a, Binary a) => Binary (PredDNF a) where
|
||||
get = PredDNF <$> Binary.get
|
||||
put = Binary.put . dnfTerms
|
||||
|
||||
type AuthLiteral = PredLiteral AuthTag
|
||||
|
||||
type AuthDNF = PredDNF AuthTag
|
||||
|
||||
|
||||
data LecturerType = CourseLecturer | CourseAssistant
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
@ -785,6 +831,8 @@ deriveJSON defaultOptions
|
||||
} ''LecturerType
|
||||
derivePersistFieldJSON ''LecturerType
|
||||
|
||||
instance Hashable LecturerType
|
||||
|
||||
|
||||
-- Type synonyms
|
||||
|
||||
@ -799,4 +847,5 @@ type UserEmail = CI Email
|
||||
|
||||
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
|
||||
type InstanceId = UUID
|
||||
type TokenId = UUID
|
||||
type TermCandidateIncidence = UUID
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
@ -63,6 +63,9 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
import qualified System.FilePath as FilePath
|
||||
|
||||
import Jose.Jwt (JwtEncoding(..))
|
||||
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
-- theoretically even a database.
|
||||
@ -100,6 +103,8 @@ data AppSettings = AppSettings
|
||||
, appNotificationExpiration :: NominalDiffTime
|
||||
, appSessionTimeout :: NominalDiffTime
|
||||
, appMaximumContentLength :: Maybe Word64
|
||||
, appJwtExpiration :: Maybe NominalDiffTime
|
||||
, appJwtEncoding :: JwtEncoding
|
||||
|
||||
, appInitialLogSettings :: LogSettings
|
||||
|
||||
@ -310,6 +315,18 @@ deriveFromJSON
|
||||
}
|
||||
''SmtpAuthConf
|
||||
|
||||
instance FromJSON JwtEncoding where
|
||||
parseJSON v@(String _) = JwsEncoding <$> parseJSON v
|
||||
parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
|
||||
[ do
|
||||
alg <- obj .: "alg"
|
||||
return $ JwsEncoding alg
|
||||
, do
|
||||
alg <- obj .: "alg"
|
||||
enc <- obj .: "enc"
|
||||
return $ JweEncoding alg enc
|
||||
]
|
||||
|
||||
|
||||
instance FromJSON AppSettings where
|
||||
parseJSON = withObject "AppSettings" $ \o -> do
|
||||
@ -352,6 +369,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"
|
||||
|
||||
appSessionTimeout <- o .: "session-timeout"
|
||||
|
||||
@ -379,6 +398,8 @@ instance FromJSON AppSettings where
|
||||
|
||||
return AppSettings {..}
|
||||
|
||||
makeClassy_ ''AppSettings
|
||||
|
||||
-- | Settings for 'widgetFile', such as which template languages to support and
|
||||
-- default Hamlet settings.
|
||||
--
|
||||
|
||||
@ -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
|
||||
|
||||
27
src/Utils.hs
27
src/Utils.hs
@ -52,6 +52,7 @@ import Control.Monad.Catch hiding (throwM)
|
||||
import qualified Database.Esqueleto as E (Value, unValue)
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Instances ()
|
||||
import Instances.TH.Lift ()
|
||||
|
||||
import Text.Shakespeare.Text (st)
|
||||
@ -69,6 +70,8 @@ import qualified Crypto.Data.PKCS7 as PKCS7
|
||||
import Data.Fixed (Centi)
|
||||
import Data.Ratio ((%))
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
{-# ANN choice ("HLint: ignore Use asum" :: String) #-}
|
||||
|
||||
|
||||
@ -490,6 +493,12 @@ maybeExceptT err act = lift act >>= maybe (throwE err) return
|
||||
maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
|
||||
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
|
||||
|
||||
maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
|
||||
maybeTExceptT err act = maybeExceptT err $ runMaybeT act
|
||||
|
||||
maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
|
||||
maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act
|
||||
|
||||
whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
|
||||
whenExceptT b err = when b $ throwE err
|
||||
|
||||
@ -601,6 +610,15 @@ choice = foldr (<|>) empty
|
||||
-- Sessions --
|
||||
--------------
|
||||
|
||||
data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
|
||||
| SessionNewStudyTerms
|
||||
| SessionBearer
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe SessionKey
|
||||
instance Finite SessionKey
|
||||
|
||||
nullaryPathPiece ''SessionKey $ camelToPathPiece' 1
|
||||
|
||||
setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
|
||||
setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
|
||||
|
||||
@ -725,3 +743,12 @@ encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, Mo
|
||||
encodedSecretBoxOpen ciphertext = do
|
||||
sKey <- secretBoxKey
|
||||
encodedSecretBoxOpen' sKey ciphertext
|
||||
|
||||
-------------
|
||||
-- Caching --
|
||||
-------------
|
||||
|
||||
cachedHere :: Q Exp
|
||||
cachedHere = do
|
||||
loc <- location
|
||||
[e| cachedBy (toStrict $ Binary.encode loc) |]
|
||||
|
||||
@ -35,6 +35,12 @@ existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity r
|
||||
=> Key record -> ReaderT backend m Bool
|
||||
existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
|
||||
|
||||
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
|
||||
=> Unique record -> [Update record] -> ReaderT backend m ()
|
||||
updateBy uniq updates = do
|
||||
key <- getKeyBy uniq
|
||||
for_ key $ flip update updates
|
||||
|
||||
myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway)
|
||||
:: (MonadIO m
|
||||
,Eq (Unique record)
|
||||
|
||||
@ -1,12 +1,16 @@
|
||||
module Utils.Lens ( module Utils.Lens ) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import ClassyPrelude.Yesod hiding ((.=))
|
||||
import Model
|
||||
import Control.Lens as Utils.Lens hiding ((<.>))
|
||||
import Control.Lens.Extras as Utils.Lens (is)
|
||||
import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
|
||||
|
||||
|
||||
_unValue :: Lens' (E.Value a) a
|
||||
_unValue f (E.Value a) = E.Value <$> f a
|
||||
|
||||
@ -90,7 +94,19 @@ makeLenses_ ''StudyTerms
|
||||
|
||||
makeLenses_ ''StudyTermCandidate
|
||||
|
||||
makePrisms ''HandlerContents
|
||||
|
||||
makePrisms ''ErrorResponse
|
||||
|
||||
|
||||
-- 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
|
||||
|
||||
@ -20,7 +20,7 @@ import Data.Universe
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
|
||||
data GlobalGetParam = GetReferer
|
||||
data GlobalGetParam = GetReferer | GetBearer
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe GlobalGetParam
|
||||
@ -51,6 +51,7 @@ globalGetParamField ident Field{fieldParse} = runMaybeT $ do
|
||||
data GlobalPostParam = PostFormIdentifier
|
||||
| PostDeleteTarget
|
||||
| PostMassInputShape
|
||||
| PostBearer
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe GlobalPostParam
|
||||
|
||||
174
src/Utils/Tokens.hs
Normal file
174
src/Utils/Tokens.hs
Normal file
@ -0,0 +1,174 @@
|
||||
module Utils.Tokens
|
||||
( bearerToken
|
||||
, encodeToken, BearerTokenException(..), decodeToken
|
||||
, tokenParseJSON'
|
||||
, askJwt
|
||||
, formEmbedJwtPost, formEmbedJwtGet
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
|
||||
import Yesod.Auth (AuthId)
|
||||
|
||||
import Utils (NTop(..), hoistMaybe, SessionKey(..))
|
||||
import Utils.Parameters
|
||||
import Utils.Lens hiding ((.=))
|
||||
|
||||
import Model
|
||||
import Model.Tokens
|
||||
|
||||
import Jose.Jwk (JwkSet(..))
|
||||
import Jose.Jwt (Jwt(..))
|
||||
import qualified Jose.Jwt as Jose
|
||||
|
||||
import Data.Aeson.Types (Parser)
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Parser as JSON
|
||||
import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
|
||||
import qualified Data.Aeson.Internal as JSON (iparse, formatError)
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Data.Time.Clock
|
||||
|
||||
import Control.Monad.Random (MonadRandom(..))
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
import Settings
|
||||
|
||||
import CryptoID
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
|
||||
|
||||
tokenParseJSON' :: forall m.
|
||||
( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
|
||||
, ParseRoute (HandlerSite m)
|
||||
, Hashable (Route (HandlerSite m))
|
||||
, MonadHandler m
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
)
|
||||
=> m (Value -> Parser (BearerToken (HandlerSite m)))
|
||||
-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
|
||||
tokenParseJSON' = do
|
||||
cidKey <- cryptoIDKey return
|
||||
return $ flip runReaderT cidKey . tokenParseJSON
|
||||
|
||||
|
||||
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)))
|
||||
-> Maybe AuthDNF
|
||||
-> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
|
||||
-> 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
|
||||
|
||||
defaultExpiration <- getsYesod $ view _appJwtExpiration
|
||||
|
||||
let tokenExpiresAt
|
||||
| Just t <- mTokenExpiresAt
|
||||
= t
|
||||
| Just tDiff <- defaultExpiration
|
||||
= Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
|
||||
| otherwise
|
||||
= Nothing
|
||||
tokenRestrictions = HashMap.empty
|
||||
|
||||
return BearerToken{..}
|
||||
|
||||
|
||||
encodeToken :: forall m.
|
||||
( MonadHandler m
|
||||
, HasJSONWebKeySet (HandlerSite m) JwkSet
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
, HasAppSettings (HandlerSite m)
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) 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
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
jwtEncoding <- getsYesod $ view _appJwtEncoding
|
||||
either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
|
||||
|
||||
|
||||
data BearerTokenException
|
||||
= BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
|
||||
| BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
|
||||
| BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
|
||||
| BearerTokenExpired | BearerTokenNotStarted
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
instance Exception BearerTokenException
|
||||
|
||||
decodeToken :: forall m.
|
||||
( MonadHandler m
|
||||
, HasJSONWebKeySet (HandlerSite m) JwkSet
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCrypto m
|
||||
, MonadThrow m
|
||||
, ParseRoute (HandlerSite m)
|
||||
, Hashable (Route (HandlerSite m))
|
||||
)
|
||||
=> Jwt -> m (BearerToken (HandlerSite m))
|
||||
-- ^ Decode a `Jwt` and call `tokenParseJSON`
|
||||
--
|
||||
-- Throws `bearerTokenException`s
|
||||
decodeToken (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'
|
||||
now <- liftIO getCurrentTime
|
||||
unless (NTop tokenExpiresAt > NTop (Just now)) $
|
||||
throwM BearerTokenExpired
|
||||
unless (tokenStartsAt <= Just now) $
|
||||
throwM BearerTokenNotStarted
|
||||
return token
|
||||
|
||||
|
||||
askJwt :: forall m. ( MonadHandler m )
|
||||
=> m (Maybe Jwt)
|
||||
-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
|
||||
askJwt = 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
|
||||
f [shamlet|
|
||||
$newline never
|
||||
$maybe jwt <- mJwt
|
||||
<input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
|
||||
#{fragment}
|
||||
|]
|
||||
formEmbedJwtGet f fragment = do
|
||||
mJwt <- askJwt
|
||||
f [shamlet|
|
||||
$newline never
|
||||
$maybe jwt <- mJwt
|
||||
<input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece jwt}>
|
||||
#{fragment}
|
||||
|]
|
||||
@ -15,37 +15,61 @@ import Data.ByteString.Builder (toLazyByteString)
|
||||
import System.FilePath ((</>))
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.Fail (MonadFail)
|
||||
import qualified Control.Monad.Fail as MonadFail
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
import Data.Functor.Extend
|
||||
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
routeFromPathPiece :: ParseRoute site => Text -> Maybe (Route site)
|
||||
routeFromPathPiece
|
||||
= parseRoute
|
||||
. over (_2.traverse._2) (fromMaybe "")
|
||||
. over _2 queryToQueryText
|
||||
. decodePath
|
||||
. encodeUtf8
|
||||
|
||||
routeToPathPiece :: RenderRoute site => Route site -> Text
|
||||
routeToPathPiece
|
||||
= pack
|
||||
. ("/" </>)
|
||||
. unpack
|
||||
. decodeUtf8
|
||||
. toLazyByteString
|
||||
. uncurry encodePath
|
||||
. over _2 queryTextToQuery
|
||||
. over (_2.traverse._2) (assertM' $ not . null)
|
||||
. renderRoute
|
||||
|
||||
|
||||
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
|
||||
fromPathPiece
|
||||
= parseRoute
|
||||
. over (_2.traverse._2) (fromMaybe "")
|
||||
. over _2 queryToQueryText
|
||||
. decodePath
|
||||
. encodeUtf8
|
||||
toPathPiece
|
||||
= pack
|
||||
. ("/" </>)
|
||||
. unpack
|
||||
. decodeUtf8
|
||||
. toLazyByteString
|
||||
. uncurry encodePath
|
||||
. over _2 queryTextToQuery
|
||||
. over (_2.traverse._2) (assertM' $ not . null)
|
||||
. renderRoute
|
||||
fromPathPiece = routeFromPathPiece
|
||||
toPathPiece = routeToPathPiece
|
||||
|
||||
instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
|
||||
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
|
||||
instance ParseRoute site => FromJSON (Route site) where
|
||||
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece
|
||||
|
||||
instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
|
||||
toJSON = String . toPathPiece
|
||||
instance RenderRoute site => ToJSON (Route site) where
|
||||
toJSON = String . routeToPathPiece
|
||||
|
||||
instance ParseRoute site => FromJSONKey (Route site) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Coulde not parse route") return . routeFromPathPiece
|
||||
|
||||
instance RenderRoute site => ToJSONKey (Route site) where
|
||||
toJSONKey = toJSONKeyText routeToPathPiece
|
||||
|
||||
instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
|
||||
put = Binary.put . toPathPiece
|
||||
get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
|
||||
|
||||
instance RenderRoute site => Hashable (Route site) where
|
||||
hashWithSalt s = hashWithSalt s . routeToPathPiece
|
||||
|
||||
|
||||
instance Monad FormResult where
|
||||
@ -77,3 +101,5 @@ instance Extend FormResult where
|
||||
duplicated (FormSuccess x) = FormSuccess $ FormSuccess x
|
||||
duplicated FormMissing = FormMissing
|
||||
duplicated (FormFailure errs) = FormFailure errs
|
||||
|
||||
|
||||
|
||||
@ -1,16 +1,48 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
|
||||
|
||||
module Yesod.Core.Types.Instances
|
||||
(
|
||||
( CachedMemoT(..)
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import ClassyPrelude.Yesod
|
||||
import Yesod.Core.Types
|
||||
|
||||
import Control.Monad.Fix
|
||||
|
||||
import Control.Monad.Memo
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import Control.Monad.Logger (MonadLoggerIO)
|
||||
|
||||
|
||||
instance MonadFix m => MonadFix (HandlerT site m) where
|
||||
mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
|
||||
|
||||
instance MonadFix m => MonadFix (WidgetT site m) where
|
||||
mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r
|
||||
|
||||
|
||||
-- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
|
||||
newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT :: m a }
|
||||
deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix
|
||||
, MonadIO
|
||||
, MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
|
||||
, MonadResource, MonadHandler, MonadWidget
|
||||
, IsString, Semigroup, Monoid
|
||||
)
|
||||
|
||||
deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m)
|
||||
deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m)
|
||||
|
||||
deriving newtype instance MonadReader r m => MonadReader r (CachedMemoT k v m)
|
||||
|
||||
instance MonadTrans (CachedMemoT k v) where
|
||||
lift = CachedMemoT
|
||||
|
||||
|
||||
-- | Uses `cachedBy` with a `Binary`-encoded @k@
|
||||
instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where
|
||||
memo act key = cachedBy (toStrict $ Binary.encode key) $ act key
|
||||
|
||||
11
start.sh
11
start.sh
@ -1,12 +1,11 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
unset HOST
|
||||
export DETAILED_LOGGING=true
|
||||
export LOG_ALL=false
|
||||
export LOGLEVEL=info
|
||||
export DUMMY_LOGIN=true
|
||||
export ALLOW_DEPRECATED=true
|
||||
export PWFILE=users.yml
|
||||
export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
|
||||
export LOG_ALL=${LOG_ALL:-false}
|
||||
export LOGLEVEL=${LOGLEVEL:-info}
|
||||
export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
|
||||
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
|
||||
|
||||
move-back() {
|
||||
mv -v .stack-work .stack-work-run
|
||||
|
||||
3
templates/courseLecInvite.hamlet
Normal file
3
templates/courseLecInvite.hamlet
Normal file
@ -0,0 +1,3 @@
|
||||
<p>
|
||||
_{MsgCourseLecInviteExplanation}
|
||||
^{btnWidget}
|
||||
@ -1,4 +1,3 @@
|
||||
<p>
|
||||
<a href=@{ProfileR}>
|
||||
_{MsgProfileHeading}
|
||||
\ _{MsgMailEditNotifications}
|
||||
<a href=#{editNotificationsUrl'}>
|
||||
_{MsgMailEditNotifications}
|
||||
|
||||
11
templates/mail/lecturerInvitation.hamlet
Normal file
11
templates/mail/lecturerInvitation.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<body>
|
||||
<p>
|
||||
_{MsgCourseLecInviteExplanation}
|
||||
<p>
|
||||
<a href=#{invitationUrl'}>
|
||||
_{MsgCourseLecturerInvitationAcceptDecline}
|
||||
@ -1,2 +0,0 @@
|
||||
<div .profile>
|
||||
^{settingsForm}
|
||||
13
templates/profile/profile.hamlet
Normal file
13
templates/profile/profile.hamlet
Normal file
@ -0,0 +1,13 @@
|
||||
$newline never
|
||||
<section>
|
||||
^{settingsForm}
|
||||
<section>
|
||||
^{tokenExplanation}
|
||||
<p>
|
||||
_{MsgTokensLastReset}:
|
||||
$maybe tResetTime' <- tResetTime
|
||||
\ #{tResetTime'}
|
||||
$nothing
|
||||
\ _{MsgNever}
|
||||
<br />
|
||||
^{tokenForm}
|
||||
13
templates/profile/tokenExplanation/de.hamlet
Normal file
13
templates/profile/tokenExplanation/de.hamlet
Normal file
@ -0,0 +1,13 @@
|
||||
<p>
|
||||
Das System stellt gelegentlich Benutzer-bezogene <i>Authorisierungs-Tokens</i> aus.
|
||||
Diese Tokens erlauben es jedem, der in Besitz dieses Tokens ist, bestimmte Ihrer Benutzer-Rechte anzunehmen.
|
||||
|
||||
<p>
|
||||
Dies ist insbesondere notwendig um verschickten Emails einen Link beifügen zu können, der das Deabonnieren von Benachrichtigungen erlaubt.
|
||||
|
||||
<p>
|
||||
Mit dem untigen Knopf können Sie alle Authorisierungs-Tokens, die bisher für Sie ausgestellt wurden, als ungültig markieren.
|
||||
Dies ist zum Beispiel dann notwendig, wenn Sie Grund haben zu vermuten, dass Dritte Zugriff auf eines Ihrer Tokens gehabt haben könnten.
|
||||
|
||||
<p>
|
||||
Für die sichere Verwahrung Ihnen ausgehändigter Tokens sind immer Sie selbst verantwortlich.
|
||||
11
test.sh
11
test.sh
@ -1,3 +1,14 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
move-back() {
|
||||
mv -v .stack-work .stack-work-test
|
||||
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
|
||||
}
|
||||
|
||||
if [[ -d .stack-work-test ]]; then
|
||||
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
|
||||
mv -v .stack-work-test .stack-work
|
||||
trap move-back EXIT
|
||||
fi
|
||||
|
||||
exec -- stack build --test --coverage --fast --flag uniworx:dev --flag uniworx:library-only ${@}
|
||||
|
||||
@ -24,7 +24,7 @@ import qualified Data.ByteString as BS
|
||||
|
||||
import Data.Time
|
||||
|
||||
import Utils.Lens (review)
|
||||
import Utils.Lens (review, view)
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
|
||||
|
||||
@ -82,7 +82,7 @@ insertFile fileTitle = do
|
||||
|
||||
fillDb :: DB ()
|
||||
fillDb = do
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
|
||||
now <- liftIO getCurrentTime
|
||||
let
|
||||
insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)
|
||||
@ -94,6 +94,7 @@ fillDb = do
|
||||
{ userIdent = "G.Kleen@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userLastAuthentication = Just now
|
||||
, userTokensIssuedAfter = Just now
|
||||
, userMatrikelnummer = Nothing
|
||||
, userEmail = "G.Kleen@campus.lmu.de"
|
||||
, userDisplayName = "Gregor Kleen"
|
||||
@ -111,6 +112,7 @@ fillDb = do
|
||||
{ userIdent = "felix.hamann@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userLastAuthentication = Nothing
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userMatrikelnummer = Nothing
|
||||
, userEmail = "felix.hamann@campus.lmu.de"
|
||||
, userDisplayName = "Felix Hamann"
|
||||
@ -128,6 +130,7 @@ fillDb = do
|
||||
{ userIdent = "jost@tcs.ifi.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userLastAuthentication = Nothing
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userMatrikelnummer = Nothing
|
||||
, userEmail = "jost@tcs.ifi.lmu.de"
|
||||
, userDisplayName = "Steffen Jost"
|
||||
@ -145,6 +148,7 @@ fillDb = do
|
||||
{ userIdent = "max@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userLastAuthentication = Just now
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userMatrikelnummer = Just "1299"
|
||||
, userEmail = "max@campus.lmu.de"
|
||||
, userDisplayName = "Max Musterstudent"
|
||||
@ -162,6 +166,7 @@ fillDb = do
|
||||
{ userIdent = "tester@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userLastAuthentication = Nothing
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userMatrikelnummer = Just "999"
|
||||
, userEmail = "tester@campus.lmu.de"
|
||||
, userDisplayName = "Tina Tester"
|
||||
|
||||
@ -41,6 +41,7 @@ instance Arbitrary User where
|
||||
]
|
||||
userAuthentication <- arbitrary
|
||||
userLastAuthentication <- arbitrary
|
||||
userTokensIssuedAfter <- arbitrary
|
||||
userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
|
||||
userEmail <- CI.mk . decodeUtf8 . Email.toByteString <$> arbitrary
|
||||
|
||||
|
||||
@ -103,11 +103,12 @@ authenticateAs (Entity _ User{..}) = do
|
||||
-- checking is switched off in wipeDB for those database backends which need it.
|
||||
createUser :: (User -> User) -> YesodExample UniWorX (Entity User)
|
||||
createUser adjUser = do
|
||||
UserDefaultConf{..} <- appUserDefaults . appSettings <$> getTestYesod
|
||||
UserDefaultConf{..} <- appUserDefaults . view appSettings <$> getTestYesod
|
||||
let
|
||||
userMatrikelnummer = Nothing
|
||||
userAuthentication = AuthLDAP
|
||||
userLastAuthentication = Nothing
|
||||
userTokensIssuedAfter = Nothing
|
||||
userIdent = "dummy@example.invalid"
|
||||
userEmail = "dummy@example.invalid"
|
||||
userDisplayName = "Dummy Example"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user