Merge branch 'master' into 155-zentralanmeldungen
This commit is contained in:
Gregor Kleen
commit
7d7bb844f5
26
CHANGELOG.md
26
CHANGELOG.md
@ -2,6 +2,32 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [4.8.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.7.0...v4.8.0) (2019-07-31)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **exam add users:** correctly differentiate and fix messages ([a473599](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a473599))
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **exams:** better explain "enlist directly" ([f07eb3d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f07eb3d))
|
||||
|
||||
|
||||
|
||||
## [4.7.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.6.0...v4.7.0) (2019-07-30)
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **exam users:** course notes ([1e756be](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/1e756be))
|
||||
* **notification triggers:** redesign interface ([84c12b5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/84c12b5)), closes [#410](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/410)
|
||||
* **users:** lecturer invitations ([e6c3be4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e6c3be4))
|
||||
* **users:** switching between AuthModes & password changing ([0d610cc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0d610cc))
|
||||
|
||||
|
||||
|
||||
## [4.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.5.0...v4.6.0) (2019-07-26)
|
||||
|
||||
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
argumentPackages@{ ... }:
|
||||
|
||||
let
|
||||
defaultPackages = (import <nixpkgs> {}).haskellPackages;
|
||||
defaultPackages = (import ./stackage.nix {});
|
||||
haskellPackages = defaultPackages // argumentPackages;
|
||||
in import ./uniworx.nix { inherit (haskellPackages) callPackage; }
|
||||
|
||||
@ -553,6 +553,16 @@ PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team sp
|
||||
DummyLoginTitle: Development-Login
|
||||
LoginNecessary: Bitte melden Sie sich dazu vorher an!
|
||||
|
||||
InternalLdapError: Interner Fehler beim Campus-Login
|
||||
|
||||
CampusUserInvalidEmail: Konnte anhand des Campus-Logins keine EMail-Addresse ermitteln
|
||||
CampusUserInvalidDisplayName: Konnte anhand des Campus-Logins keinen vollen Namen ermitteln
|
||||
CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermitteln
|
||||
CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln
|
||||
CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln
|
||||
CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln
|
||||
CampusUserInvalidFeaturesOfStudy parseErr@String: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln: #{parseErr}
|
||||
|
||||
CorrectorNormal: Normal
|
||||
CorrectorMissing: Abwesend
|
||||
CorrectorExcused: Entschuldigt
|
||||
@ -1110,6 +1120,7 @@ ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurd
|
||||
ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Klausur angemeldet
|
||||
ExamRegistrationInviteDeadline: Einladung nur gültig bis
|
||||
ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen
|
||||
ExamRegistrationEnlistDirectlyTip: Sollen, wenn manche der E-Mail Addressen bereits in Uni2work mit Nutzern assoziiert sind, jene Nutzer direkt zur Klausur hinzugefügt werden? Ansonsten werden Einladung an alle E-Mail Addressen (nicht nur unbekannte) versandt, die die Nutzer zunächst akzeptieren müssen um Klausurteilnehmer zu werden.
|
||||
ExamRegistrationRegisterCourse: Nutzer auch zum Kurs anmelden
|
||||
ExamRegistrationRegisterCourseTip: Nutzer, die keine Kursteilnehmer sind, werden sonst nicht zur Klausur angemeldet.
|
||||
ExamRegistrationInviteField: Einzuladende EMail Addressen
|
||||
@ -1278,6 +1289,7 @@ CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilneh
|
||||
CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat
|
||||
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können
|
||||
CsvColumnExamUserResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
|
||||
CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
|
||||
|
||||
Action: Aktion
|
||||
|
||||
@ -1292,6 +1304,9 @@ ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
|
||||
ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden
|
||||
ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern
|
||||
ExamUserCsvSetResult: Ergebnis eintragen
|
||||
ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
|
||||
|
||||
ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht
|
||||
|
||||
ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden
|
||||
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden
|
||||
|
||||
9
nixpkgs.nix
Normal file
9
nixpkgs.nix
Normal file
@ -0,0 +1,9 @@
|
||||
{ nixpkgs ? import <nixpkgs>
|
||||
}:
|
||||
|
||||
import ((nixpkgs {}).fetchFromGitHub {
|
||||
owner = "NixOS";
|
||||
repo = "nixpkgs";
|
||||
rev = "19.03";
|
||||
sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy";
|
||||
})
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "4.6.0",
|
||||
"version": "4.8.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "4.6.0",
|
||||
"version": "4.8.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 4.6.0
|
||||
version: 4.8.0
|
||||
|
||||
dependencies:
|
||||
# Due to a bug in GHC 8.0.1, we block its usage
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{ nixpkgs ? import <nixpkgs> }:
|
||||
{ nixpkgs ? import ./nixpkgs.nix {} }:
|
||||
|
||||
let
|
||||
inherit (nixpkgs {}) pkgs;
|
||||
|
||||
131
src/Auth/LDAP.hs
131
src/Auth/LDAP.hs
@ -1,9 +1,12 @@
|
||||
module Auth.LDAP
|
||||
( campusLogin
|
||||
( apLdap
|
||||
, campusLogin
|
||||
, CampusUserException(..)
|
||||
, campusUser
|
||||
, CampusMessage(..)
|
||||
, Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
|
||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
||||
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (userEmail, userDisplayName)
|
||||
@ -42,12 +45,12 @@ findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||
findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters
|
||||
where
|
||||
userFilters =
|
||||
[ userPrincipalName Ldap.:= Text.encodeUtf8 ident
|
||||
, userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
||||
, userEmail Ldap.:= Text.encodeUtf8 ident
|
||||
, userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
|
||||
, userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
||||
, userDisplayName Ldap.:= Text.encodeUtf8 ident
|
||||
[ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
|
||||
, ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
||||
, ldapUserEmail Ldap.:= Text.encodeUtf8 ident
|
||||
, ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
|
||||
, ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
||||
, ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
|
||||
]
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope ldapScope
|
||||
@ -56,10 +59,53 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
|
||||
userPrincipalName, userEmail, userDisplayName :: Ldap.Attr
|
||||
userPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
userEmail = Ldap.Attr "mail"
|
||||
userDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr
|
||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
ldapUserEmail = Ldap.Attr "mail"
|
||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
||||
ldapUserFirstName = Ldap.Attr "givenName"
|
||||
ldapUserSurname = Ldap.Attr "sn"
|
||||
ldapUserTitle = Ldap.Attr "title"
|
||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||
ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString"
|
||||
|
||||
|
||||
data CampusUserException = CampusUserLdapError LdapPoolError
|
||||
| CampusUserHostNotResolved String
|
||||
| CampusUserLineTooLong
|
||||
| CampusUserHostCannotConnect String [IOException]
|
||||
| CampusUserNoResult
|
||||
| CampusUserAmbiguous
|
||||
deriving (Show, Eq, Generic, Typeable)
|
||||
|
||||
instance Exception CampusUserException
|
||||
|
||||
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
let userFilter = Ldap.Present ldapUserPrincipalName
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope Ldap.BaseObject
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapSearchTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
|
||||
Nothing -> do
|
||||
findUser conf ldap credsIdent []
|
||||
case results of
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
where
|
||||
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
|
||||
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
|
||||
campusForm :: ( RenderMessage site FormMessage
|
||||
, RenderMessage site CampusMessage
|
||||
@ -69,6 +115,9 @@ campusForm = CampusLogin
|
||||
<$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing
|
||||
<*> areq passwordField (fslI MsgCampusPassword) Nothing
|
||||
|
||||
apLdap :: Text
|
||||
apLdap = "LDAP"
|
||||
|
||||
campusLogin :: forall site.
|
||||
( YesodAuth site
|
||||
, RenderMessage site FormMessage
|
||||
@ -78,7 +127,7 @@ campusLogin :: forall site.
|
||||
) => LdapConf -> LdapPool -> AuthPlugin site
|
||||
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
where
|
||||
apName = "LDAP"
|
||||
apName = apLdap
|
||||
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
||||
apDispatch "POST" [] = do
|
||||
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
|
||||
@ -90,10 +139,10 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
||||
ldapResult <- withLdap pool $ \ldap -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
searchResults <- findUser conf ldap campusIdent [userPrincipalName]
|
||||
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
|
||||
case searchResults of
|
||||
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
|
||||
| Just [principalName] <- lookup userPrincipalName userAttrs
|
||||
| [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
|
||||
, Right credsIdent <- Text.decodeUtf8' principalName
|
||||
-> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
||||
other -> return $ Left other
|
||||
@ -123,55 +172,3 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
, formAnchor = Just "login--campus" :: Maybe Text
|
||||
}
|
||||
$(widgetFile "widgets/campus-login/campus-login-form")
|
||||
|
||||
data CampusUserException = CampusUserLdapError LdapPoolError
|
||||
| CampusUserHostNotResolved String
|
||||
| CampusUserLineTooLong
|
||||
| CampusUserHostCannotConnect String [IOException]
|
||||
| CampusUserNoResult
|
||||
| CampusUserAmbiguous
|
||||
deriving (Show, Eq, Generic, Typeable)
|
||||
|
||||
instance Exception CampusUserException
|
||||
|
||||
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
let userFilter = Ldap.Present userPrincipalName
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope Ldap.BaseObject
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapSearchTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
|
||||
Nothing -> do
|
||||
findUser conf ldap credsIdent []
|
||||
case results of
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
where
|
||||
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
|
||||
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
-- ldapConfig :: UniWorX -> LDAPConfig
|
||||
-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
|
||||
-- { usernameFilter = \u -> principalName <> "=" <> u
|
||||
-- , identifierModifier
|
||||
-- , ldapUri = appLDAPURI settings
|
||||
-- , initDN = appLDAPDN settings
|
||||
-- , initPass = appLDAPPw settings
|
||||
-- , baseDN = appLDAPBaseName settings
|
||||
-- , ldapScope = LdapScopeSubtree
|
||||
-- }
|
||||
-- where
|
||||
-- principalName :: IsString a => a
|
||||
-- principalName = "userPrincipalName"
|
||||
-- identifierModifier _ entry = case lookup principalName $ leattrs entry of
|
||||
-- Just [n] -> Text.pack n
|
||||
-- _ -> error "Could not determine user principal name"
|
||||
|
||||
@ -55,7 +55,7 @@ import Data.Conduit.List (sourceList)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
|
||||
import Control.Monad.Except (MonadError(..), ExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Trans.Reader (runReader, mapReaderT)
|
||||
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
|
||||
@ -88,6 +88,8 @@ import qualified Data.Aeson as JSON
|
||||
|
||||
import Data.FileEmbed (embedFile)
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
|
||||
type SMTPPool = Pool SMTPConnection
|
||||
|
||||
@ -2732,6 +2734,155 @@ instance YesodPersist UniWorX where
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = defaultGetDBRunner appConnPool
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidEmail
|
||||
| CampusUserInvalidDisplayName
|
||||
| CampusUserInvalidGivenName
|
||||
| CampusUserInvalidSurname
|
||||
| CampusUserInvalidTitle
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidFeaturesOfStudy String
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception CampusUserConversionException
|
||||
|
||||
embedRenderMessage ''UniWorX ''CampusUserConversionException id
|
||||
|
||||
upsertCampusUser :: Ldap.AttrList [] -> Creds UniWorX -> DB (Entity User)
|
||||
upsertCampusUser ldapData Creds{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
|
||||
let
|
||||
userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
|
||||
userEmail' = fold [ v | (k, v) <- ldapData, k == ldapUserEmail ]
|
||||
userDisplayName' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ]
|
||||
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
||||
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
||||
userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ]
|
||||
|
||||
userAuthentication
|
||||
| isPWHash = error "PWHash should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = now <$ guard (not isDummy)
|
||||
|
||||
userEmail <- if
|
||||
| [bs] <- userEmail'
|
||||
, Right userEmail <- Text.decodeUtf8' bs
|
||||
-> return $ mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
userDisplayName <- if
|
||||
| [bs] <- userDisplayName'
|
||||
, Right userDisplayName <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidDisplayName
|
||||
userFirstName <- if
|
||||
| [bs] <- userFirstName'
|
||||
, Right userFirstName <- Text.decodeUtf8' bs
|
||||
-> return userFirstName
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidGivenName
|
||||
userSurname <- if
|
||||
| [bs] <- userSurname'
|
||||
, Right userSurname <- Text.decodeUtf8' bs
|
||||
-> return userSurname
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidSurname
|
||||
userTitle <- if
|
||||
| all ByteString.null userTitle'
|
||||
-> return Nothing
|
||||
| [bs] <- userTitle'
|
||||
, Right userTitle <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTitle
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidTitle
|
||||
userMatrikelnummer <- if
|
||||
| [bs] <- userMatrikelnummer'
|
||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMatrikelnummer
|
||||
| [] <- userMatrikelnummer'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidMatriculation
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userIdent = mk credsIdent
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
, userMailLanguages = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, ..
|
||||
}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
, UserDisplayName =. userDisplayName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | not isDummy ]
|
||||
|
||||
user@(Entity userId _) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate
|
||||
|
||||
let
|
||||
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
|
||||
userStudyFeatures' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserStudyFeatures
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
termNames = nubBy ((==) `on` mk) $ do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserFieldName
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures
|
||||
|
||||
let
|
||||
studyTermCandidates = Set.fromList $ do
|
||||
name <- termNames
|
||||
StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
|
||||
return (key, name)
|
||||
studyTermCandidateIncidence
|
||||
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
|
||||
. UUID.fromByteString
|
||||
. fromStrict
|
||||
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
||||
. runIdentity
|
||||
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
|
||||
|
||||
[E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate ->
|
||||
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
|
||||
|
||||
unless candidatesRecorded $ do
|
||||
let
|
||||
studyTermCandidates' = do
|
||||
(studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
|
||||
return StudyTermCandidate{..}
|
||||
insertMany_ studyTermCandidates'
|
||||
|
||||
E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
||||
forM_ fs $ \f@StudyFeatures{..} -> do
|
||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
|
||||
|
||||
return user
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
isDummy = credsPlugin == "dummy"
|
||||
isPWHash = credsPlugin == "PWHash"
|
||||
|
||||
|
||||
instance YesodAuth UniWorX where
|
||||
type AuthId UniWorX = UserId
|
||||
|
||||
@ -2761,25 +2912,34 @@ instance YesodAuth UniWorX where
|
||||
isDummy = credsPlugin == "dummy"
|
||||
isPWHash = credsPlugin == "PWHash"
|
||||
|
||||
excHandlers
|
||||
excRecovery res
|
||||
| isDummy || isPWHash
|
||||
= [ C.Handler $ \err -> do
|
||||
addMessage Error (toHtml $ tshow (err :: CampusUserException))
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
acceptExisting
|
||||
]
|
||||
= do
|
||||
case res of
|
||||
UserError err -> addMessageI Error err
|
||||
ServerError err -> addMessage Error $ toHtml err
|
||||
_other -> return ()
|
||||
acceptExisting
|
||||
| otherwise
|
||||
= [ C.Handler $ \case
|
||||
CampusUserNoResult -> do
|
||||
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
|
||||
return . UserError $ IdentifierNotFound credsIdent
|
||||
CampusUserAmbiguous -> do
|
||||
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
|
||||
return . UserError $ IdentifierNotFound credsIdent
|
||||
err -> do
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
return $ ServerError "LDAP lookup failed"
|
||||
]
|
||||
= return res
|
||||
|
||||
excHandlers =
|
||||
[ C.Handler $ \case
|
||||
CampusUserNoResult -> do
|
||||
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
CampusUserAmbiguous -> do
|
||||
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
err -> do
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr MsgInternalLdapError
|
||||
, C.Handler $ \(cExc :: CampusUserConversionException) -> do
|
||||
$logErrorS "LDAP" $ tshow cExc
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr cExc
|
||||
]
|
||||
|
||||
acceptExisting = do
|
||||
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
@ -2792,138 +2952,13 @@ instance YesodAuth UniWorX where
|
||||
UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
|
||||
|
||||
flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
|
||||
Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
|
||||
ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra
|
||||
Just (ldapConf, ldapPool) -> do
|
||||
let userCreds = Creds credsPlugin (original userIdent) credsExtra
|
||||
ldapData <- campusUser ldapConf ldapPool userCreds
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
|
||||
let
|
||||
userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
|
||||
userEmail' = lookup (Attr "mail") ldapData
|
||||
userDisplayName' = lookup (Attr "displayName") ldapData
|
||||
userFirstName' = lookup (Attr "givenName") ldapData
|
||||
userSurname' = lookup (Attr "sn") ldapData
|
||||
userTitle' = lookup (Attr "title") ldapData
|
||||
|
||||
userAuthentication
|
||||
| isPWHash = error "PWHash should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = now <$ guard (not isDummy)
|
||||
|
||||
userEmail <- if
|
||||
| Just [bs] <- userEmail'
|
||||
, Right userEmail <- Text.decodeUtf8' bs
|
||||
-> return $ mk userEmail
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user email"
|
||||
userDisplayName <- if
|
||||
| Just [bs] <- userDisplayName'
|
||||
, Right userDisplayName <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user name"
|
||||
userFirstName <- if
|
||||
| Just [bs] <- userFirstName'
|
||||
, Right userFirstName <- Text.decodeUtf8' bs
|
||||
-> return userFirstName
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user given name"
|
||||
userSurname <- if
|
||||
| Just [bs] <- userSurname'
|
||||
, Right userSurname <- Text.decodeUtf8' bs
|
||||
-> return userSurname
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user surname"
|
||||
userTitle <- if
|
||||
| maybe True (all ByteString.null) userTitle'
|
||||
-> return Nothing
|
||||
| Just [bs] <- userTitle'
|
||||
, Right userTitle <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTitle
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user title"
|
||||
userMatrikelnummer <- if
|
||||
| Just [bs] <- userMatrikelnummer'
|
||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMatrikelnummer
|
||||
| Nothing <- userMatrikelnummer'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not decode user matriculation"
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
, userMailLanguages = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, ..
|
||||
}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
, UserDisplayName =. userDisplayName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | not isDummy ]
|
||||
|
||||
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
|
||||
|
||||
let
|
||||
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
|
||||
userStudyFeatures' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
termNames = nubBy ((==) `on` mk) $ do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == Attr "dfnEduPersonFieldOfStudyString"
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
|
||||
|
||||
let
|
||||
studyTermCandidates = Set.fromList $ do
|
||||
name <- termNames
|
||||
StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
|
||||
return (key, name)
|
||||
studyTermCandidateIncidence
|
||||
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID")
|
||||
. UUID.fromByteString
|
||||
. fromStrict
|
||||
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
||||
. runIdentity
|
||||
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
|
||||
|
||||
[E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate ->
|
||||
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
|
||||
|
||||
unless candidatesRecorded $ do
|
||||
let
|
||||
studyTermCandidates' = do
|
||||
(studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
|
||||
return StudyTermCandidate{..}
|
||||
lift $ insertMany_ studyTermCandidates'
|
||||
|
||||
lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
||||
forM_ fs $ \f@StudyFeatures{..} -> do
|
||||
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
|
||||
|
||||
return $ Authenticated userId
|
||||
Nothing -> acceptExisting
|
||||
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
Authenticated . entityKey <$> upsertCampusUser ldapData userCreds
|
||||
Nothing
|
||||
-> acceptExisting
|
||||
|
||||
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
||||
[ campusLogin <$> appLdapConf <*> appLdapPool
|
||||
|
||||
@ -25,5 +25,4 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
-- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared?
|
||||
-- If they are shared, adjust MsgCourseUserNoteTooltip
|
||||
getCNotesR = postCNotesR
|
||||
postCNotesR _ _ _ = do
|
||||
defaultLayout $ [whamlet|You have corrector access to this course.|]
|
||||
postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|]
|
||||
|
||||
@ -128,20 +128,20 @@ postCAddUserR tid ssh csh = do
|
||||
-- register known users
|
||||
execWriterT $ mapM (registerUser cid) uids
|
||||
|
||||
when (not $ null emails) $
|
||||
unless (null emails) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
||||
|
||||
when (not $ null aurAlreadyRegistered) $ do
|
||||
unless (null aurAlreadyRegistered) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null aurNoUniquePrimaryField) $ do
|
||||
unless (null aurNoUniquePrimaryField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null aurSuccess) $
|
||||
unless (null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
||||
|
||||
registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
||||
|
||||
@ -27,7 +27,8 @@ data AddRecipientsResult = AddRecipientsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurNoUniquePrimaryField
|
||||
, aurNoCourseRegistration
|
||||
, aurSuccess :: [UserEmail]
|
||||
, aurSuccess
|
||||
, aurSuccessCourse :: [UserEmail]
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Monoid AddRecipientsResult where
|
||||
@ -66,7 +67,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
= tomorrowEndOfDay
|
||||
|
||||
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
|
||||
enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly) (Just False)
|
||||
enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False)
|
||||
registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
|
||||
occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing
|
||||
users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
|
||||
@ -87,7 +88,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler ()
|
||||
processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do
|
||||
let (emails,uids) = partitionEithers $ Set.toList users
|
||||
AddRecipientsResult alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- lift . runDBJobs $ do
|
||||
AddRecipientsResult{..} <- lift . runDBJobs $ do
|
||||
-- send Invitation eMails to unkown users
|
||||
sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails]
|
||||
-- register known users
|
||||
@ -96,21 +97,21 @@ postEAddUserR tid ssh csh examn = do
|
||||
unless (null emails) $
|
||||
tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails
|
||||
|
||||
unless (null alreadyRegistered) $
|
||||
tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField
|
||||
unless (null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length aurSuccess
|
||||
|
||||
unless (null registeredNoField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|]
|
||||
unless (null aurNoUniquePrimaryField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
|
||||
modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
unless (null noCourseRegistration) $ do
|
||||
let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|]
|
||||
unless (null aurNoCourseRegistration) $ do
|
||||
let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}|]
|
||||
modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse")
|
||||
tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
unless (null registeredOneField) $
|
||||
tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField
|
||||
unless (null aurSuccessCourse) $
|
||||
tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length aurSuccessCourse
|
||||
|
||||
registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
||||
registerUser cid eid registerCourse occId uid = exceptT tell tell $ do
|
||||
@ -149,6 +150,6 @@ postEAddUserR tid ssh csh examn = do
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
||||
Just _ -> mempty { aurSuccess = pure userEmail }
|
||||
Just _ -> mempty { aurSuccessCourse = pure userEmail }
|
||||
|
||||
|
||||
|
||||
@ -36,8 +36,8 @@ import Control.Arrow (Kleisli(..))
|
||||
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
||||
|
||||
|
||||
type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
|
||||
type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult))
|
||||
type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
|
||||
type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote))
|
||||
|
||||
instance HasEntity ExamUserTableData User where
|
||||
hasEntity = _dbrOutput . _2
|
||||
@ -49,25 +49,28 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
|
||||
_userTableOccurrence = _dbrOutput . _3
|
||||
|
||||
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
|
||||
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
|
||||
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1)
|
||||
|
||||
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
|
||||
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
|
||||
|
||||
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
|
||||
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
|
||||
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1)
|
||||
|
||||
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
|
||||
queryExamOccurrence = $(sqlLOJproj 4 2)
|
||||
queryExamOccurrence = $(sqlLOJproj 5 2)
|
||||
|
||||
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
|
||||
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
|
||||
|
||||
queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
|
||||
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
|
||||
|
||||
queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
|
||||
queryExamResult = $(sqlLOJproj 4 4)
|
||||
queryExamResult = $(sqlLOJproj 5 4)
|
||||
|
||||
queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
|
||||
queryCourseNote = $(sqlLOJproj 5 5)
|
||||
|
||||
resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
|
||||
resultExamRegistration = _dbrOutput . _1
|
||||
@ -90,6 +93,9 @@ resultExamOccurrence = _dbrOutput . _3 . _Just
|
||||
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
|
||||
resultExamResult = _dbrOutput . _7 . _Just
|
||||
|
||||
resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
|
||||
resultCourseNote = _dbrOutput . _8 . _Just
|
||||
|
||||
data ExamUserTableCsv = ExamUserTableCsv
|
||||
{ csvEUserSurname :: Maybe Text
|
||||
, csvEUserFirstName :: Maybe Text
|
||||
@ -104,6 +110,7 @@ data ExamUserTableCsv = ExamUserTableCsv
|
||||
, csvEUserExercisePointsMax :: Maybe Points
|
||||
, csvEUserExerciseNumPassesMax :: Maybe Int
|
||||
, csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
|
||||
, csvEUserCourseNote :: Maybe Html
|
||||
}
|
||||
deriving (Generic)
|
||||
makeLenses_ ''ExamUserTableCsv
|
||||
@ -130,6 +137,7 @@ instance FromNamedRecord ExamUserTableCsv where
|
||||
<*> csv .:? "exercise-points-max"
|
||||
<*> csv .:? "exercise-num-passes-max"
|
||||
<*> csv .:? "exam-result"
|
||||
<*> csv .:? "course-note"
|
||||
where
|
||||
(.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a)
|
||||
m .:? name = Csv.lookup m name <|> return Nothing
|
||||
@ -152,6 +160,7 @@ instance CsvColumnsExplained ExamUserTableCsv where
|
||||
, ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax )
|
||||
, ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
|
||||
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
|
||||
, ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote )
|
||||
]
|
||||
|
||||
data ExamUserAction = ExamUserDeregister
|
||||
@ -171,8 +180,9 @@ data ExamUserCsvActionClass
|
||||
| ExamUserCsvRegister
|
||||
| ExamUserCsvAssignOccurrence
|
||||
| ExamUserCsvSetCourseField
|
||||
| ExamUserCsvDeregister
|
||||
| ExamUserCsvSetResult
|
||||
| ExamUserCsvSetCourseNote
|
||||
| ExamUserCsvDeregister
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
|
||||
|
||||
@ -201,6 +211,10 @@ data ExamUserCsvAction
|
||||
{ examUserCsvActUser :: UserId
|
||||
, examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
|
||||
}
|
||||
| ExamUserCsvSetCourseNoteData
|
||||
{ examUserCsvActUser :: UserId
|
||||
, examUserCsvActCourseNote :: Maybe Html
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel
|
||||
@ -236,7 +250,9 @@ postEUsersR tid ssh csh examn = do
|
||||
let
|
||||
examUsersDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult) = do
|
||||
dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do
|
||||
E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
|
||||
E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
|
||||
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
@ -248,7 +264,7 @@ postEUsersR tid ssh csh examn = do
|
||||
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
|
||||
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
|
||||
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult)
|
||||
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote)
|
||||
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
|
||||
dbtProj = return
|
||||
dbtColonnade = mconcat $ catMaybes
|
||||
@ -269,6 +285,8 @@ postEUsersR tid ssh csh examn = do
|
||||
return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
|
||||
, guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
|
||||
, guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
|
||||
, pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
|
||||
-> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ sortUserNameLink queryUser
|
||||
@ -279,6 +297,11 @@ postEUsersR tid ssh csh examn = do
|
||||
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
||||
, ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
|
||||
, ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
|
||||
, ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
|
||||
E.sub_select . E.from $ \edit -> do
|
||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||
)
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameEmail queryUser
|
||||
@ -354,6 +377,7 @@ postEUsersR tid ssh csh examn = do
|
||||
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
|
||||
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
|
||||
<*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
|
||||
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
|
||||
dbtCsvDecode = Just DBTCsvDecode
|
||||
{ dbtCsvRowKey = \csv -> do
|
||||
uid <- lift $ view _2 <$> guessUser csv
|
||||
@ -376,6 +400,10 @@ postEUsersR tid ssh csh examn = do
|
||||
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
|
||||
when (is _Just $ csvEUserExamResult dbCsvNew) $
|
||||
yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew
|
||||
|
||||
note <- lift . getBy $ UniqueCourseUserNote uid examCourse
|
||||
when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $
|
||||
yield . ExamUserCsvSetCourseNoteData uid $ csvEUserCourseNote dbCsvNew
|
||||
DBCsvDiffExisting{..} -> do
|
||||
newOccurrence <- lift $ lookupOccurrence dbCsvNew
|
||||
when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
|
||||
@ -388,6 +416,9 @@ postEUsersR tid ssh csh examn = do
|
||||
|
||||
when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
|
||||
yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
|
||||
|
||||
when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $
|
||||
yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew
|
||||
, dbtCsvClassifyAction = \case
|
||||
ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister
|
||||
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
|
||||
@ -395,6 +426,7 @@ postEUsersR tid ssh csh examn = do
|
||||
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
|
||||
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
|
||||
ExamUserCsvSetResultData{} -> ExamUserCsvSetResult
|
||||
ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote
|
||||
, dbtCsvCoarsenActionClass = \case
|
||||
ExamUserCsvCourseRegister -> DBCsvActionNew
|
||||
ExamUserCsvRegister -> DBCsvActionNew
|
||||
@ -442,6 +474,16 @@ postEUsersR tid ssh csh examn = do
|
||||
User{userIdent} <- getJust examRegistrationUser
|
||||
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||||
delete examUserCsvActRegistration
|
||||
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do
|
||||
noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse
|
||||
whenIsJust noteId $ \nid -> do
|
||||
deleteWhere [CourseUserNoteEditNote ==. nid]
|
||||
delete nid
|
||||
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- liftHandlerT requireAuthId
|
||||
Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ]
|
||||
insert_ $ CourseUserNoteEdit uid now nid
|
||||
return $ CExamR tid ssh csh examn EUsersR
|
||||
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
|
||||
ExamUserCsvCourseRegisterData{..} -> do
|
||||
@ -502,7 +544,14 @@ postEUsersR tid ssh csh examn = do
|
||||
$nothing
|
||||
, _{MsgExamResultNone}
|
||||
|]
|
||||
|
||||
ExamUserCsvSetCourseNoteData{..} -> do
|
||||
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$if isn't _Just examUserCsvActCourseNote
|
||||
\ (_{MsgExamUserCsvCourseNoteDeleted})
|
||||
|]
|
||||
ExamUserCsvDeregisterData{..}
|
||||
-> registeredUserName' examUserCsvActRegistration
|
||||
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
||||
|
||||
@ -260,10 +260,7 @@ postAdminUserR uuid = do
|
||||
campusHandler _ = mzero
|
||||
campusResult <- runMaybeT . handle campusHandler $ do
|
||||
(Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
|
||||
let
|
||||
campusLogin :: AuthPlugin UniWorX
|
||||
campusLogin = Auth.campusLogin conf pool
|
||||
void . Auth.campusUser conf pool $ Creds (apName campusLogin) (CI.original userIdent) []
|
||||
void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
|
||||
case campusResult of
|
||||
Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
|
||||
_other
|
||||
|
||||
@ -31,8 +31,9 @@ deriving instance Typeable CsvParseError
|
||||
instance Exception CsvParseError
|
||||
|
||||
|
||||
typeCsv :: ContentType
|
||||
typeCsv, typeCsv' :: ContentType
|
||||
typeCsv = "text/csv"
|
||||
typeCsv' = "text/csv; charset=UTF-8; header=present"
|
||||
|
||||
extensionCsv :: Extension
|
||||
extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
|
||||
@ -57,7 +58,7 @@ respondCsv :: ( ToNamedRecord csv
|
||||
)
|
||||
=> Source (HandlerT site IO) csv
|
||||
-> HandlerT site IO TypedContent
|
||||
respondCsv src = respondSource typeCsv $ src .| encodeCsv .| awaitForever sendChunk
|
||||
respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
|
||||
|
||||
respondCsvDB :: ( ToNamedRecord csv
|
||||
, DefaultOrdered csv
|
||||
@ -65,7 +66,7 @@ respondCsvDB :: ( ToNamedRecord csv
|
||||
)
|
||||
=> Source (YesodDB site) csv
|
||||
-> HandlerT site IO TypedContent
|
||||
respondCsvDB src = respondSourceDB typeCsv $ src .| encodeCsv .| awaitForever sendChunk
|
||||
respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
|
||||
|
||||
fileSourceCsv :: ( FromNamedRecord csv
|
||||
, MonadResource m
|
||||
|
||||
@ -14,6 +14,8 @@ import Data.Hashable (Hashable(..))
|
||||
import Data.Aeson (ToJSON(..), FromJSON(..))
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
|
||||
instance Eq Markup where
|
||||
(==) = (==) `on` Text.renderMarkup
|
||||
@ -35,3 +37,9 @@ instance ToJSON Markup where
|
||||
|
||||
instance FromJSON Markup where
|
||||
parseJSON = Aeson.withText "Html" $ return . preEscapedText
|
||||
|
||||
instance Csv.ToField Markup where
|
||||
toField = Csv.toField . Text.renderMarkup
|
||||
|
||||
instance Csv.FromField Markup where
|
||||
parseField = fmap preEscapedText . Csv.parseField
|
||||
|
||||
@ -148,6 +148,8 @@ makeLenses_ ''ExamOccurrence
|
||||
|
||||
makePrisms ''AuthenticationMode
|
||||
|
||||
makeLenses_ ''CourseUserNote
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{ ghc, nixpkgs ? import <nixpkgs> }:
|
||||
{ ghc, nixpkgs ? import ./nixpkgs.nix {} }:
|
||||
|
||||
let
|
||||
haskellPackages = import ./stackage.nix { inherit nixpkgs; };
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{ nixpkgs ? import <nixpkgs>
|
||||
{ nixpkgs ? import ./nixpkgs.nix {}
|
||||
, snapshot ? "lts-10.5"
|
||||
}:
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
<h2>
|
||||
_{MsgExamRegistrationNotRegisteredWithoutCourse (length registeredNoField)}
|
||||
_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}
|
||||
<ul>
|
||||
$forall email <- noCourseRegistration
|
||||
$forall email <- aurNoCourseRegistration
|
||||
<li style="font-family: monospace">#{email}
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
<h2>
|
||||
_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}
|
||||
_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}
|
||||
<ul>
|
||||
$forall email <- registeredNoField
|
||||
$forall email <- aurNoUniquePrimaryField
|
||||
<li style="font-family: monospace">#{email}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user