feat(course-applications): csv transport
This commit is contained in:
Gregor Kleen
parent
e816a30b35
commit
cf0ec1aec4
@ -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
|
||||
28
src/Data/Bool/Instances.hs
Normal file
28
src/Data/Bool/Instances.hs
Normal file
@ -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" ]
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
dbtCsvDecode = Nothing
|
||||
dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv
|
||||
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
|
||||
|
||||
|
||||
@ -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 .:? "first-name"
|
||||
<*> csv .:? "name"
|
||||
<*> csv .:? "matriculation"
|
||||
<*> csv .:? "field"
|
||||
<*> csv .:? "degree"
|
||||
<*> csv .:? "semester"
|
||||
<*> csv .:? "occurrence"
|
||||
<*> csv .:? "exercise-points"
|
||||
<*> csv .:? "exercise-num-passes"
|
||||
<*> 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
|
||||
<$> csv .:?? "surname"
|
||||
<*> csv .:?? "first-name"
|
||||
<*> csv .:?? "name"
|
||||
<*> csv .:?? "matriculation"
|
||||
<*> csv .:?? "field"
|
||||
<*> csv .:?? "degree"
|
||||
<*> csv .:?? "semester"
|
||||
<*> csv .:?? "occurrence"
|
||||
<*> csv .:?? "exercise-points"
|
||||
<*> csv .:?? "exercise-num-passes"
|
||||
<*> csv .:?? "exercise-points-max"
|
||||
<*> csv .:?? "exercise-num-passes-max"
|
||||
<*> csv .:?? "exam-result"
|
||||
<*> csv .:?? "course-note"
|
||||
|
||||
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"]
|
||||
|
||||
@ -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}
|
||||
|]
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user