feat(course-applications): csv transport

messages/uniworx/de.msg

@@ -1411,6 +1411,18 @@ CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer
 CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können
 CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
 CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
+CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist
+CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien)
+CsvColumnApplicationsName: Voller Name des Bewerbers
+CsvColumnApplicationsMatriculation: Matrikelnummer des Bewerbers
+CsvColumnApplicationsField: Studienfach, mit dem der Bewerber seine Bewerbung assoziiert hat
+CsvColumnApplicationsDegree: Abschluss, den der Bewerber im assoziierten Studienfach anstrebt
+CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studienfach
+CsvColumnApplicationsText: Text-Bewerbung
+CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)?
+CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer
+CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0"
+CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber
 
 Action: Aktion
 
@@ -1433,6 +1445,15 @@ ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identi
 ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
 ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
 
+CourseApplicationsTableCsvSetField: Bewerbungs-assoziiertes Studienfach ändern
+CourseApplicationsTableCsvSetVeto: Veto setzen/entfernen
+CourseApplicationsTableCsvSetRating: Bewertung eintragen
+CourseApplicationsTableCsvSetComment: Bewertungskommentar eintragen
+
+CourseApplicationsTableCsvExceptionNoMatchingUser: Bewerber konnte nicht eindeutig identifiziert werden
+CourseApplicationsTableCsvExceptionNoMatchingAllocation: Zentralanmeldung konnte nicht eindeutig identifiziert werden
+CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden
+
 TableHeadingFilter: Filter
 TableHeadingCsvImport: CSV-Import
 TableHeadingCsvExport: CSV-Export
@@ -1536,6 +1557,9 @@ CourseApplicationsListTitle: Bewerbungen
 CourseApplicationId: Bewerbungsnummer
 CourseApplicationRatingPoints: Bewertung
 CourseApplicationVeto: Veto
+CourseApplicationNoVeto: Kein Veto
+CourseApplicationNoRatingPoints: Keine Bewertung
+CourseApplicationNoRatingComment: Kein Kommentar
 
 UserDisplayName: Voller Name
 UserMatriculation: Matrikelnummer

src/Data/Bool/Instances.hs

@@ -0,0 +1,28 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Bool.Instances
+  () where
+
+import ClassyPrelude
+
+import qualified Data.Csv as Csv
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive.Instances ()
+
+import qualified Data.Text as Text
+
+
+instance Csv.ToField Bool where
+  toField True = "t"
+  toField False = "f"
+
+instance Csv.FromField Bool where
+  parseField f = do
+    (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
+    (True <$ guard (isTrue t)) <|> (False <$ guard (isFalse t)) <|> fail "Could not decode Bool"
+    where
+      isTrue f' = any (== f')
+        [ "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
+      isFalse f' = any (== f')
+        [ "no", "n", "nein", "falsch", "f", "false", "0" ]

src/Data/CryptoID/Instances.hs

@@ -16,6 +16,8 @@ import qualified Data.CaseInsensitive as CI
 import Web.PathPieces
 import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
 
+import qualified Data.Csv as Csv
+
 
 instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
   toMarkup = toMarkup . CID.ciphertext
@@ -34,3 +36,12 @@ instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c (
 instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where
   toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext
   fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece
+
+instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where
+  parseField = fmap CID.CryptoID . Csv.parseField
+
+instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where
+  toField = Csv.toField . CID.ciphertext
+
+instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where
+  toField = Csv.toField . CI.foldedCase . CID.ciphertext

src/Handler/Course/Application/List.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module Handler.Course.Application.List
   ( getCApplicationsR, postCApplicationsR
   ) where
@@ -8,8 +10,21 @@ import Handler.Utils
 import Handler.Utils.Table.Columns
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
+import qualified Data.Csv as Csv
+
+import qualified Data.Text as Text
+import qualified Data.Text.Lens as Text
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.Map as Map
+
+import qualified Data.Conduit.List as C
+
 
 type CourseApplicationsTableExpr = (              E.SqlExpr (Entity CourseApplication)
                                     `E.InnerJoin` E.SqlExpr (Entity User)
@@ -76,6 +91,122 @@ resultStudyTerms = _dbrOutput . _6 . _Just
 resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
 resultStudyDegree = _dbrOutput . _7 . _Just
 
+
+newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Enum, Bounded)
+makePrisms ''CourseApplicationsTableVeto
+
+instance Csv.ToField CourseApplicationsTableVeto where
+  toField (CourseApplicationsTableVeto True) = "veto"
+  toField (CourseApplicationsTableVeto False) = ""
+
+instance Csv.FromField CourseApplicationsTableVeto where
+  parseField f = do
+    (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
+    return . CourseApplicationsTableVeto $ any (== t)
+      [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
+  
+data CourseApplicationsTableCsv = CourseApplicationsTableCsv
+  { csvCAAllocation :: Maybe AllocationShorthand
+  , csvCAApplication :: Maybe CryptoFileNameCourseApplication
+  , csvCAName :: Maybe Text
+  , csvCAMatriculation :: Maybe Text
+  , csvCAField :: Maybe Text
+  , csvCADegree :: Maybe Text
+  , csvCASemester :: Maybe Int
+  , csvCAText :: Maybe Text
+  , csvCAHasFiles :: Maybe Bool
+  , csvCAVeto :: Maybe CourseApplicationsTableVeto
+  , csvCARating :: Maybe ExamGrade
+  , csvCAComment :: Maybe Text
+  } deriving (Generic)
+makeLenses_ ''CourseApplicationsTableCsv
+
+courseApplicationsTableCsvOptions :: Csv.Options
+courseApplicationsTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }
+
+instance Csv.ToNamedRecord CourseApplicationsTableCsv where
+  toNamedRecord = Csv.genericToNamedRecord courseApplicationsTableCsvOptions
+
+instance Csv.FromNamedRecord CourseApplicationsTableCsv where
+  parseNamedRecord csv
+    = CourseApplicationsTableCsv
+      <$> csv .:?? "allocation"
+      <*> csv .:?? "application"
+      <*> csv .:?? "name"
+      <*> csv .:?? "matriculation"
+      <*> csv .:?? "field"
+      <*> csv .:?? "degree"
+      <*> csv .:?? "semester"
+      <*> csv .:?? "text"
+      <*> csv .:?? "has-files"
+      <*> csv .:?? "veto"
+      <*> csv .:?? "rating"
+      <*> csv .:?? "comment"
+
+instance Csv.DefaultOrdered CourseApplicationsTableCsv where
+  headerOrder = Csv.genericHeaderOrder courseApplicationsTableCsvOptions
+
+instance CsvColumnsExplained CourseApplicationsTableCsv where
+  csvColumnsExplanations = genericCsvColumnsExplanations courseApplicationsTableCsvOptions $ Map.fromList
+    [ ('csvCAAllocation   , MsgCsvColumnApplicationsAllocation   )
+    , ('csvCAApplication  , MsgCsvColumnApplicationsApplication  )
+    , ('csvCAName         , MsgCsvColumnApplicationsName         )
+    , ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
+    , ('csvCAField        , MsgCsvColumnApplicationsField        )
+    , ('csvCADegree       , MsgCsvColumnApplicationsDegree       )
+    , ('csvCASemester     , MsgCsvColumnApplicationsSemester     )
+    , ('csvCAText         , MsgCsvColumnApplicationsText         )
+    , ('csvCAHasFiles     , MsgCsvColumnApplicationsHasFiles     )
+    , ('csvCAVeto         , MsgCsvColumnApplicationsVeto         )
+    , ('csvCARating       , MsgCsvColumnApplicationsRating       )
+    , ('csvCAComment      , MsgCsvColumnApplicationsComment      )
+    ]
+
+data CourseApplicationsTableCsvActionClass
+  = CourseApplicationsTableCsvSetField
+  | CourseApplicationsTableCsvSetVeto
+  | CourseApplicationsTableCsvSetRating
+  | CourseApplicationsTableCsvSetComment
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id
+
+data CourseApplicationsTableCsvAction
+  = CourseApplicationsTableCsvSetFieldData
+    { caCsvActApplication :: CourseApplicationId
+    , caCsvActField :: Maybe StudyFeaturesId
+    }
+  | CourseApplicationsTableCsvSetVetoData
+    { caCsvActApplication :: CourseApplicationId
+    , caCsvActVeto :: Bool
+    }
+  | CourseApplicationsTableCsvSetRatingData
+    { caCsvActApplication :: CourseApplicationId
+    , caCsvActRating :: Maybe ExamGrade
+    }
+  | CourseApplicationsTableCsvSetCommentData
+    { caCsvActApplication :: CourseApplicationId
+    , caCsvActComment :: Maybe Text
+    }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece' 3
+  , sumEncoding = TaggedObject "action" "data"
+  } ''CourseApplicationsTableCsvAction
+
+data CourseApplicationsTableCsvException
+  = CourseApplicationsTableCsvExceptionNoMatchingUser
+  | CourseApplicationsTableCsvExceptionNoMatchingAllocation
+  | CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
+  deriving (Show, Generic, Typeable)
+
+instance Exception CourseApplicationsTableCsvException
+
+embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
+  
+
 getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCApplicationsR = postCApplicationsR
 postCApplicationsR tid ssh csh = do
@@ -184,8 +315,202 @@ postCApplicationsR tid ssh csh = do
         }
       dbtParams = def
 
-      dbtCsvEncode = noCsvEncode
+      dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv
-      dbtCsvDecode = Nothing
+      dbtCsvEncode = DictJust . C.mapM . runReaderT $ CourseApplicationsTableCsv
+        <$> preview (resultAllocation . _entityVal . _allocationShorthand)
+        <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
+        <*> preview (resultUser . _entityVal . _userDisplayName)
+        <*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
+        <*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey)))
+        <*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey)))
+        <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+        <*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just)
+        <*> preview resultHasFiles
+        <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto)
+        <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingPoints . _Just)
+        <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingComment . _Just)
+      dbtCsvDecode = Just DBTCsvDecode
+        { dbtCsvRowKey = \csv -> do
+            appRes <- lift $ guessUser csv
+            case appRes of
+              Right appId -> return $ E.Value appId
+              Left uid -> do
+                alloc <- lift $ guessAllocation csv
+                [appId] <- lift $ selectKeysList [CourseApplicationUser ==. uid, CourseApplicationAllocation ==. alloc] [LimitTo 2]
+                return $ E.Value appId
+        , dbtCsvComputeActions = \case
+            DBCsvDiffMissing{}
+              -> return () -- no deletion
+            DBCsvDiffNew{}
+              -> return () -- no addition
+            DBCsvDiffExisting{..} -> do
+              let appId = dbCsvOld ^. resultCourseApplication . _entityKey
+              
+              newFeatures <- lift $ lookupStudyFeatures dbCsvNew
+              when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
+                yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
+
+              let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
+              whenIsJust mVeto $ \veto -> 
+                when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
+                  yield $ CourseApplicationsTableCsvSetVetoData appId veto
+
+              when (dbCsvNew ^. _csvCARating /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingPoints) $
+                yield $ CourseApplicationsTableCsvSetRatingData appId (dbCsvNew ^. _csvCARating)
+
+              when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $
+                yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment)
+        , dbtCsvClassifyAction = \case
+            CourseApplicationsTableCsvSetFieldData{}   -> CourseApplicationsTableCsvSetField
+            CourseApplicationsTableCsvSetVetoData{}    -> CourseApplicationsTableCsvSetVeto
+            CourseApplicationsTableCsvSetRatingData{}  -> CourseApplicationsTableCsvSetRating
+            CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
+        , dbtCsvCoarsenActionClass = const DBCsvActionExisting
+        , dbtCsvExecuteActions = do
+            C.mapM_ $ \case
+              CourseApplicationsTableCsvSetFieldData{..} -> do
+                CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField ]
+                audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
+              CourseApplicationsTableCsvSetVetoData{..} -> do
+                CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto ]
+                audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
+              CourseApplicationsTableCsvSetRatingData{..} -> do
+                CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating ]
+                audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
+              CourseApplicationsTableCsvSetCommentData{..} -> do
+                CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment ]
+                audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
+            return $ CourseR tid ssh csh CApplicationsR
+        , dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case
+            CourseApplicationsTableCsvSetFieldData{..} ->
+              [whamlet|
+                $newline never
+                ^{existingApplicantName' caCsvActApplication}
+                $maybe features <- caCsvActField
+                  , ^{studyFeaturesWidget features}
+                $nothing
+                  , _{MsgCourseStudyFeatureNone}
+              |]
+            CourseApplicationsTableCsvSetVetoData{..} ->
+              [whamlet|
+                $newline never
+                ^{existingApplicantName' caCsvActApplication}
+                $if caCsvActVeto
+                  , _{MsgCourseApplicationVeto}
+                $else
+                  , _{MsgCourseApplicationNoVeto}
+              |]
+            CourseApplicationsTableCsvSetRatingData{..} ->
+              [whamlet|
+                $newline never
+                ^{existingApplicantName' caCsvActApplication}
+                $maybe newResult <- caCsvActRating
+                  , _{newResult}
+                $nothing
+                  , _{MsgCourseApplicationNoRatingPoints}
+              |]
+            CourseApplicationsTableCsvSetCommentData{..} ->
+              [whamlet|
+                $newline never
+                ^{existingApplicantName' caCsvActApplication}
+                $if is _Nothing caCsvActComment
+                  , _{MsgCourseApplicationNoRatingComment}
+              |]
+        , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
+        , dbtCsvRenderException = ap getMessageRender . pure :: CourseApplicationsTableCsvException -> DB Text
+        }
+        where
+          guessUser :: CourseApplicationsTableCsv -> DB (Either UserId CourseApplicationId)
+          guessUser csv = do
+            mApp <- runMaybeT $ do
+              appId <- squash . catchIfMaybeT (const True :: CryptoIDError -> Bool) . MaybeT . traverse decrypt $ csv ^? _csvCAApplication . _Just
+              CourseApplication{..} <- MaybeT $ get appId
+              guard $ courseApplicationCourse == cid
+              return appId
+
+            maybe (Left <$> guessUser' csv) (return . Right) mApp
+            where
+              guessUser' :: CourseApplicationsTableCsv -> DB UserId
+              guessUser' CourseApplicationsTableCsv{..} = $cachedHereBinary (csvCAMatriculation, csvCAName) $ do
+                users <- E.select . E.from $ \user -> do
+                  E.where_ . E.and $ catMaybes
+                    [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvCAMatriculation
+                    , (user E.^. UserDisplayName E.==.) . E.val <$> csvCAName
+                    ]
+                  return $ user E.^. UserId
+                case users of
+                  [E.Value uid]
+                    -> return uid
+                  _other
+                    -> throwM CourseApplicationsTableCsvExceptionNoMatchingUser
+
+          guessAllocation :: CourseApplicationsTableCsv -> DB (Maybe AllocationId)
+          guessAllocation CourseApplicationsTableCsv{..} = $cachedHereBinary csvCAAllocation . for csvCAAllocation $ \ash -> do
+            mAlloc <- traverse (getJustEntity . allocationCourseAllocation . entityVal) <=< getBy $ UniqueAllocationCourse cid
+            case mAlloc of
+              Just (Entity allocId Allocation{..})
+                | allocationShorthand == ash
+                  -> return allocId
+              _other
+                -> throwM CourseApplicationsTableCsvExceptionNoMatchingAllocation
+
+          existingApplicantName :: Map (E.Value CourseApplicationId) CourseApplicationsTableData -> CourseApplicationId -> Widget
+          existingApplicantName existing (E.Value -> appId) = nameWidget userDisplayName userSurname
+            where
+              Entity _ User{..} = existing ^. singular (ix appId . resultUser)
+
+          lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId)
+          lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do
+            appRes <- guessUser csv
+            (uid, oldFeatures) <- case appRes of
+              Left  uid   -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] []
+              Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId
+            studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
+              E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
+                                  , E.asc (studyFeatures E.^. StudyFeaturesDegree)
+                                  , E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
+                E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
+                E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
+                E.where_ . E.and $ catMaybes
+                  [ do
+                      field <- csvCAField
+                      return . E.or $ catMaybes
+                        [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
+                        , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
+                        , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
+                        ]
+                  , do
+                      degree <- csvCADegree
+                      return . E.or $ catMaybes
+                        [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
+                        , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
+                        , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
+                        ]
+                  , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvCASemester
+                  ]
+                E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
+                let isActiveOrPrevious = E.or
+                      $ (studyFeatures E.^. StudyFeaturesValid)
+                      : [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId
+                        | Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures
+                        ]
+                E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
+                E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
+                return $ studyFeatures E.^. StudyFeaturesId
+            case studyFeatures of
+              [E.Value fid] -> return $ Just fid
+              _other
+                | is _Nothing csvCAField
+                , is _Nothing csvCADegree
+                , is _Nothing csvCASemester
+                -> return Nothing
+              _other
+                | [Entity _ CourseApplication{..}] <- oldFeatures
+                , Just sfid <- courseApplicationField
+                , E.Value sfid `elem` studyFeatures
+                -> return $ Just sfid
+              _other        -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
+
 
       dbtIdent = courseApplicationsIdent
 

src/Handler/Exam/Users.hs

@@ -30,7 +30,6 @@ import qualified Data.Conduit.List as C
 import qualified Data.CaseInsensitive as CI
 
 import Numeric.Lens (integral)
-import Control.Arrow (Kleisli(..))
 
 import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
 
@@ -123,23 +122,20 @@ instance ToNamedRecord ExamUserTableCsv where
 instance FromNamedRecord ExamUserTableCsv where
   parseNamedRecord csv -- Manually defined awaiting issue #427
     = ExamUserTableCsv
-      <$> csv .:? "surname"
+      <$> csv .:?? "surname"
-      <*> csv .:? "first-name"
+      <*> csv .:?? "first-name"
-      <*> csv .:? "name"
+      <*> csv .:?? "name"
-      <*> csv .:? "matriculation"
+      <*> csv .:?? "matriculation"
-      <*> csv .:? "field"
+      <*> csv .:?? "field"
-      <*> csv .:? "degree"
+      <*> csv .:?? "degree"
-      <*> csv .:? "semester"
+      <*> csv .:?? "semester"
-      <*> csv .:? "occurrence"
+      <*> csv .:?? "occurrence"
-      <*> csv .:? "exercise-points"
+      <*> csv .:?? "exercise-points"
-      <*> csv .:? "exercise-num-passes"
+      <*> csv .:?? "exercise-num-passes"
-      <*> csv .:? "exercise-points-max"
+      <*> csv .:?? "exercise-points-max"
-      <*> csv .:? "exercise-num-passes-max"
+      <*> csv .:?? "exercise-num-passes-max"
-      <*> csv .:? "exam-result"
+      <*> csv .:?? "exam-result"
-      <*> csv .:? "course-note"
+      <*> csv .:?? "course-note"
-    where
-      (.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a)
-      m .:? name = Csv.lookup m name <|> return Nothing
 
 instance DefaultOrdered ExamUserTableCsv where
   headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
@@ -567,14 +563,6 @@ postEUsersR tid ssh csh examn = do
             , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
             }
             where
-              studyFeaturesWidget :: StudyFeaturesId -> Widget
-              studyFeaturesWidget featId = do
-                (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
-                [whamlet|
-                  $newline never
-                  _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
-                |]
-
               registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
               registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
                 where
@@ -644,7 +632,6 @@ postEUsersR tid ssh csh examn = do
                           _ -> isActive
                     E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
                     E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
-                    E.limit 2 -- we just need to know whether there is a unique one, none, or more than one
                     return $ studyFeatures E.^. StudyFeaturesId
                 case studyFeatures of
                   [E.Value fid] -> return $ Just fid
@@ -657,7 +644,7 @@ postEUsersR tid ssh csh examn = do
                     | Just (Entity _ CourseParticipant{..}) <- oldFeatures
                     , Just sfid <- courseParticipantField
                     , E.Value sfid `elem` studyFeatures
-                    -> return Nothing
+                    -> return $ Just sfid
                   _other        -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
 
       examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]

src/Handler/Utils.hs

@@ -225,3 +225,11 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
       f <- messageLoggerSource app <$> readTVarIO loggerTVar
       f loc src lvl str
 
+studyFeaturesWidget :: StudyFeaturesId -> Widget
+studyFeaturesWidget featId = do
+  (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
+  [whamlet|
+    $newline never
+    _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
+  |]
+

src/Import/NoModel.hs

@@ -14,6 +14,7 @@ import ClassyPrelude.Yesod    as Import
          , static
          , boolField, identifyForm
          , HasHttpManager(..)
+         , embed
          )
 
 import Model.Types.TH.JSON as Import
@@ -128,6 +129,7 @@ import Net.IP.Instances as Import ()
 import Data.Void.Instances as Import ()
 import Crypto.Hash.Instances as Import ()
 import Colonnade.Instances as Import ()
+import Data.Bool.Instances as Import ()
 
 import Control.Lens as Import
   hiding ( (<.>)
@@ -138,6 +140,10 @@ import Control.Lens as Import
 import Control.Lens.Extras as Import (is)
 import Data.Set.Lens as Import
 
+import Control.Arrow as Import (Kleisli(..))
+
+import Control.Monad.Morph as Import
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Utils/Csv.hs

@@ -1,8 +1,9 @@
 module Utils.Csv
   ( pathPieceCsv
+  , (.:??)
   ) where
 
-import ClassyPrelude
+import ClassyPrelude hiding (lookup)
 import Data.Csv hiding (Name)
   
 import Language.Haskell.TH (Name)
@@ -17,3 +18,7 @@ pathPieceCsv (conT -> t) =
     instance FromField $(t) where
       parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField
   |]
+
+
+(.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a)
+m .:?? name = lookup m name <|> return Nothing