Merge branch 'master' into 155-zentralanmeldungen

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)
 
 

default.nix

@@ -1,6 +1,6 @@
 argumentPackages@{ ... }:
 
 let
-  defaultPackages = (import <nixpkgs> {}).haskellPackages;
+  defaultPackages = (import ./stackage.nix {});
   haskellPackages = defaultPackages // argumentPackages;
 in import ./uniworx.nix { inherit (haskellPackages) callPackage; }

messages/uniworx/de.msg

@@ -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

nixpkgs.nix

@@ -0,0 +1,9 @@
+{ nixpkgs ? import <nixpkgs>
+}:
+
+import ((nixpkgs {}).fetchFromGitHub {
+  owner = "NixOS";
+  repo = "nixpkgs";
+  rev = "19.03";
+  sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy";
+})

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "4.6.0",
+  "version": "4.8.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "4.6.0",
+  "version": "4.8.0",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -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

shell.nix

@@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs> }:
+{ nixpkgs ? import ./nixpkgs.nix {} }:
 
 let
   inherit (nixpkgs {}) pkgs;

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
+      [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
-      , userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+      , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
-      , userEmail         Ldap.:= Text.encodeUtf8 ident
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 ident
-      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
-      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
-      , userDisplayName   Ldap.:= Text.encodeUtf8 ident
+      , 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
+ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr
-userPrincipalName = Ldap.Attr "userPrincipalName"
+ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
-userEmail         = Ldap.Attr "mail"
+ldapUserEmail         = Ldap.Attr "mail"
-userDisplayName   = Ldap.Attr "displayName"
+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"

src/Foundation.hs

@@ -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
+          = do
-                addMessage Error (toHtml $ tshow (err :: CampusUserException))
+              case res of
-                $logErrorS "LDAP" $ tshow err
+                UserError   err -> addMessageI Error   err
-                acceptExisting
+                ServerError err -> addMessage  Error $ toHtml err
-            ]
+                _other          -> return ()
+              acceptExisting
           | otherwise
-          = [ C.Handler $ \case
+          = return res
-                CampusUserNoResult -> do
+          
-                  $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
+        excHandlers =
-                  return . UserError $ IdentifierNotFound credsIdent
+          [ C.Handler $ \case
-                CampusUserAmbiguous -> do
+              CampusUserNoResult -> do
-                  $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
+                $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
-                  return . UserError $ IdentifierNotFound credsIdent
+                excRecovery . UserError $ IdentifierNotFound credsIdent
-                err -> do
+              CampusUserAmbiguous -> do
-                  $logErrorS "LDAP" $ tshow err
+                $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
-                  return $ ServerError "LDAP lookup failed"
+                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
+        Just (ldapConf, ldapPool) -> do
-          ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra
+          let userCreds = Creds credsPlugin (original userIdent) credsExtra
+          ldapData <- campusUser ldapConf ldapPool userCreds
           $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-
+          Authenticated . entityKey <$> upsertCampusUser ldapData userCreds
-          let
+        Nothing
-            userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
+          -> acceptExisting
-            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 ())
 
     authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
       [ campusLogin <$> appLdapConf <*> appLdapPool

src/Handler/Course.hs

@@ -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
+postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|]
-  defaultLayout $ [whamlet|You have corrector access to this course.|]

src/Handler/Course/ParticipantInvite.hs

@@ -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) ()

src/Handler/Exam/AddUser.hs

@@ -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) $
+      unless (null aurSuccess) $
-        tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField
+        tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length aurSuccess
 
-      unless (null registeredNoField) $ do
+      unless (null aurNoUniquePrimaryField) $ do
-        let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|]
+        let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
             modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
         tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
 
-      unless (null noCourseRegistration) $ do
+      unless (null aurNoCourseRegistration) $ do
-        let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|]
+        let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}|]
             modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse")
         tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
 
-      unless (null registeredOneField) $
+      unless (null aurSuccessCourse) $
-        tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField
+        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 }
 
 

src/Handler/Exam/Users.hs

@@ -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 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))
+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

src/Handler/Users.hs

@@ -260,10 +260,7 @@ postAdminUserR uuid = do
               campusHandler _ = mzero
             campusResult <- runMaybeT . handle campusHandler $ do
                 (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
-                let
+                void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
-                  campusLogin :: AuthPlugin UniWorX
-                  campusLogin = Auth.campusLogin conf pool
-                void . Auth.campusUser conf pool $ Creds (apName campusLogin) (CI.original userIdent) []
             case campusResult of
               Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
               _other

src/Handler/Utils/Csv.hs

@@ -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

src/Text/Blaze/Instances.hs

@@ -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

src/Utils/Lens.hs

@@ -148,6 +148,8 @@ makeLenses_ ''ExamOccurrence
 
 makePrisms ''AuthenticationMode
 
+makeLenses_ ''CourseUserNote
+
 
 -- makeClassy_ ''Load
 

stack.nix

@@ -1,4 +1,4 @@
-{ ghc, nixpkgs ? import <nixpkgs> }:
+{ ghc, nixpkgs ? import ./nixpkgs.nix {} }:
 
 let
   haskellPackages = import ./stackage.nix { inherit nixpkgs; };

stackage.nix

@@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs>
+{ nixpkgs ? import ./nixpkgs.nix {}
 , snapshot ? "lts-10.5"
 }:
 

templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet

@@ -1,5 +1,5 @@
 <h2>
-  _{MsgExamRegistrationNotRegisteredWithoutCourse (length registeredNoField)}
+  _{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}
 <ul>
-  $forall email <- noCourseRegistration
+  $forall email <- aurNoCourseRegistration
     <li style="font-family: monospace">#{email}

templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet

@@ -1,5 +1,5 @@
 <h2>
-  _{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}
+  _{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}
 <ul>
-  $forall email <- registeredNoField
+  $forall email <- aurNoUniquePrimaryField
     <li style="font-family: monospace">#{email}