feat(csv): finish implementing csv import
This commit is contained in:
Gregor Kleen
parent
996bc2ac27
commit
e35fed6b85
@ -91,6 +91,7 @@ CourseDeregisterOk: Erfolgreich abgemeldet
|
||||
CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren
|
||||
CourseStudyFeature: Assoziiertes Hauptfach
|
||||
CourseStudyFeatureUpdated: Assoziiertes Hauptfach geändert
|
||||
CourseStudyFeatureNone: Kein assoziiertes Hauptfach
|
||||
CourseTutorial: Tutorium
|
||||
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
@ -1064,7 +1065,7 @@ HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
|
||||
CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer
|
||||
CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
|
||||
CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
|
||||
CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden ohne assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet
|
||||
CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen
|
||||
|
||||
@ -1121,6 +1122,7 @@ ExamRoomMatriculation': Nach Matrikelnummer
|
||||
ExamRoomRandom': Zufällig pro Teilnehmer
|
||||
|
||||
ExamOccurrence: Termin/Raum
|
||||
ExamNoOccurrence: Kein Termin/Raum
|
||||
ExamOccurrences: Prüfungen
|
||||
ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
|
||||
ExamRoomName: Interne Bezeichnung
|
||||
@ -1230,11 +1232,19 @@ CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die de
|
||||
Action: Aktion
|
||||
|
||||
DBCsvDuplicateKey: Zwei Zeilen der CSV-Dateien referenzieren den selben internen Datensatz und können daher nicht verarbeitet werden.
|
||||
DBCsvDuplicateKeyTip: Entfernen Sie ein der unten aufgeführten Zeilen aus Ihren CSV-Dateien und versuchen Sie es erneut.
|
||||
DBCsvDuplicateKeyTip: Entfernen Sie eine der unten aufgeführten Zeilen aus Ihren CSV-Dateien und versuchen Sie es erneut.
|
||||
DBCsvKeyException: Für eine Zeile der CSV-Dateien konnte nicht festgestellt werden, ob sie zu einem bestehenden internen Datensatz korrespondieren.
|
||||
DBCsvException: Bei der Berechnung der auszuführenden Aktionen für einen Datensatz ist ein Fehler aufgetreten.
|
||||
|
||||
ExamUserCsvRegister: Teilnehmer zur Klausur anmelden
|
||||
ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Klausur anmelden
|
||||
ExamUserCsvRegister: Kursteilnehmer zur Klausur anmelden
|
||||
ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
|
||||
ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden
|
||||
ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern
|
||||
|
||||
ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden
|
||||
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden
|
||||
ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden
|
||||
|
||||
TableHeadingFilter: Filter
|
||||
TableHeadingCsvImport: CSV-Import
|
||||
|
||||
@ -108,4 +108,4 @@ instance Csv.ToField s => Csv.ToField (CI s) where
|
||||
toField = Csv.toField . CI.original
|
||||
|
||||
instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where
|
||||
parseField = fmap CI.original . Csv.parseField
|
||||
parseField = fmap CI.mk . Csv.parseField
|
||||
|
||||
@ -4,6 +4,7 @@ module Database.Esqueleto.Utils
|
||||
( true, false
|
||||
, isJust
|
||||
, isInfixOf, hasInfix
|
||||
, or, and
|
||||
, any, all
|
||||
, SqlIn(..)
|
||||
, mkExactFilter, mkExactFilterWith
|
||||
@ -11,15 +12,17 @@ module Database.Esqueleto.Utils
|
||||
, mkExistsFilter
|
||||
, anyFilter, allFilter
|
||||
, orderByOrd, orderByEnum
|
||||
, lower, ciEq
|
||||
) where
|
||||
|
||||
|
||||
import ClassyPrelude.Yesod hiding (isInfixOf, any, all, isJust)
|
||||
import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust)
|
||||
import Data.Universe
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
|
||||
@ -58,6 +61,10 @@ hasInfix :: ( E.Esqueleto query expr backend
|
||||
=> expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool)
|
||||
hasInfix = flip isInfixOf
|
||||
|
||||
and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||
and = F.foldr (\b acc -> acc E.&&. b) true
|
||||
or = F.foldr (\b acc -> acc E.||. b) false
|
||||
|
||||
-- | Given a test and a set of values, check whether anyone succeeds the test
|
||||
-- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated)
|
||||
any :: Foldable f =>
|
||||
@ -164,4 +171,11 @@ orderByOrd = let sortUni = zip [1..] $ List.sort universeF in -- memoize this, m
|
||||
\x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1))
|
||||
|
||||
orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
|
||||
orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1))
|
||||
orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1))
|
||||
|
||||
|
||||
lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
|
||||
lower = E.unsafeSqlFunction "LOWER"
|
||||
|
||||
ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
|
||||
ciEq a b = lower a E.==. lower b
|
||||
|
||||
@ -13,7 +13,7 @@ import Handler.Utils.Csv
|
||||
import Jobs.Queue
|
||||
|
||||
import Utils.Lens hiding (parts)
|
||||
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
@ -32,6 +32,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Control.Arrow (Kleisli(..))
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
@ -887,22 +888,34 @@ data ExamUserActionData = ExamUserDeregisterData
|
||||
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
|
||||
|
||||
data ExamUserCsvActionClass
|
||||
= ExamUserCsvRegister
|
||||
= ExamUserCsvCourseRegister
|
||||
| ExamUserCsvRegister
|
||||
| ExamUserCsvAssignOccurrence
|
||||
| ExamUserCsvSetCourseField
|
||||
| ExamUserCsvDeregister
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
|
||||
|
||||
data ExamUserCsvAction
|
||||
= ExamUserCsvRegisterData
|
||||
{ examUserCsvUser :: UserId
|
||||
= ExamUserCsvCourseRegisterData
|
||||
{ examUserCsvActUser :: UserId
|
||||
, examUserCsvActCourseField :: Maybe StudyFeaturesId
|
||||
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
||||
}
|
||||
| ExamUserCsvRegisterData
|
||||
{ examUserCsvActUser :: UserId
|
||||
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
||||
}
|
||||
| ExamUserCsvAssignOccurrenceData
|
||||
{ examUserCsvRegistration :: ExamRegistrationId
|
||||
, examUserCsvOccurrence :: ExamOccurrenceId
|
||||
{ examUserCsvActRegistration :: ExamRegistrationId
|
||||
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
||||
}
|
||||
| ExamUserCsvSetCourseFieldData
|
||||
{ examUserCsvActCourseParticipant :: CourseParticipantId
|
||||
, examUserCsvActCourseField :: Maybe StudyFeaturesId
|
||||
}
|
||||
| ExamUserCsvDeregisterData
|
||||
{ examUserCsvRegistration :: ExamRegistrationId
|
||||
{ examUserCsvActRegistration :: ExamRegistrationId
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
@ -911,6 +924,16 @@ deriveJSON defaultOptions
|
||||
, sumEncoding = TaggedObject "action" "data"
|
||||
} ''ExamUserCsvAction
|
||||
|
||||
data ExamUserCsvException
|
||||
= ExamUserCsvExceptionNoMatchingUser
|
||||
| ExamUserCsvExceptionNoMatchingStudyFeatures
|
||||
| ExamUserCsvExceptionNoMatchingOccurrence
|
||||
deriving (Show, Generic, Typeable)
|
||||
|
||||
instance Exception ExamUserCsvException
|
||||
|
||||
embedRenderMessage ''UniWorX ''ExamUserCsvException id
|
||||
|
||||
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEUsersR = postEUsersR
|
||||
postEUsersR tid ssh csh examn = do
|
||||
@ -1023,30 +1046,203 @@ 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)
|
||||
dbtCsvDecode = Just DBTCsvDecode
|
||||
{ dbtCsvRowKey = \ExamUserTableCsv{} -> mzero -- FIXME: guess user from csv row and do lookup via UniqueExamRegistration
|
||||
, dbtCsvComputeActions = awaitForever $ \case
|
||||
DBCsvDiffMissing{dbCsvOldKey} -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
|
||||
_other -> return () -- FIXME: compute edit on existing rows & add rows
|
||||
{ dbtCsvRowKey = \csv -> do
|
||||
uid <- lift $ view _2 <$> guessUser csv
|
||||
fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid
|
||||
, dbtCsvComputeActions = \case
|
||||
DBCsvDiffMissing{dbCsvOldKey}
|
||||
-> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
|
||||
DBCsvDiffNew{dbCsvNewKey = Just _}
|
||||
-> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
|
||||
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
|
||||
(isPart, uid) <- lift $ guessUser dbCsvNew
|
||||
if
|
||||
| isPart -> do
|
||||
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
|
||||
when (newFeatures /= oldFeatures) $
|
||||
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
||||
| otherwise ->
|
||||
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
|
||||
DBCsvDiffExisting{..} -> do
|
||||
newOccurrence <- lift $ lookupOccurrence dbCsvNew
|
||||
when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
|
||||
yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence
|
||||
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
|
||||
Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
|
||||
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
||||
, dbtCsvClassifyAction = \case
|
||||
ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister
|
||||
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
|
||||
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
|
||||
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
|
||||
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
|
||||
, dbtCsvCoarsenActionClass = \case
|
||||
ExamUserCsvRegister -> DBCsvActionNew
|
||||
ExamUserCsvDeregister -> DBCsvActionMissing
|
||||
_other -> DBCsvActionExisting
|
||||
ExamUserCsvCourseRegister -> DBCsvActionNew
|
||||
ExamUserCsvRegister -> DBCsvActionNew
|
||||
ExamUserCsvDeregister -> DBCsvActionMissing
|
||||
_other -> DBCsvActionExisting
|
||||
, dbtCsvExecuteActions = do
|
||||
C.mapM_ $ \case
|
||||
ExamUserCsvDeregisterData{..} -> delete examUserCsvRegistration
|
||||
_other -> return () -- FIXME
|
||||
ExamUserCsvCourseRegisterData{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ CourseParticipant
|
||||
{ courseParticipantCourse = examCourse
|
||||
, courseParticipantUser = examUserCsvActUser
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantField = examUserCsvActCourseField
|
||||
}
|
||||
insert_ ExamRegistration
|
||||
{ examRegistrationExam = eid
|
||||
, examRegistrationUser = examUserCsvActUser
|
||||
, examRegistrationOccurrence = examUserCsvActOccurrence
|
||||
, examRegistrationTime = now
|
||||
}
|
||||
ExamUserCsvRegisterData{..} -> do
|
||||
examRegistrationTime <- liftIO getCurrentTime
|
||||
insert_ ExamRegistration
|
||||
{ examRegistrationExam = eid
|
||||
, examRegistrationUser = examUserCsvActUser
|
||||
, examRegistrationOccurrence = examUserCsvActOccurrence
|
||||
, ..
|
||||
}
|
||||
ExamUserCsvAssignOccurrenceData{..} ->
|
||||
update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
|
||||
ExamUserCsvSetCourseFieldData{..} ->
|
||||
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
|
||||
ExamUserCsvDeregisterData{..} -> delete examUserCsvActRegistration
|
||||
return $ CExamR tid ssh csh examn EUsersR
|
||||
, dbtCsvRenderKey = \existing -> \case
|
||||
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
|
||||
ExamUserCsvCourseRegisterData{..} -> do
|
||||
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe features <- examUserCsvActCourseField
|
||||
, ^{studyFeaturesWidget features}
|
||||
$nothing
|
||||
, _{MsgCourseStudyFeatureNone}
|
||||
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
||||
\ (#{examOccurrenceName})
|
||||
$nothing
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvRegisterData{..} -> do
|
||||
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
||||
\ (#{examOccurrenceName})
|
||||
$nothing
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvAssignOccurrenceData{..} -> do
|
||||
occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{registeredUserName' examUserCsvActRegistration}
|
||||
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
||||
\ (#{examOccurrenceName})
|
||||
$nothing
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvSetCourseFieldData{..} -> do
|
||||
User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe features <- examUserCsvActCourseField
|
||||
, ^{studyFeaturesWidget features}
|
||||
$nothing
|
||||
, _{MsgCourseStudyFeatureNone}
|
||||
|]
|
||||
ExamUserCsvDeregisterData{..}
|
||||
-> let Entity _ User{..} = view resultUser $ existing ! E.Value examUserCsvRegistration
|
||||
in nameWidget userDisplayName userSurname
|
||||
_other -> mempty -- FIXME
|
||||
, dbtCsvRenderActionClass = \c -> [whamlet|_{c}|]
|
||||
-> registeredUserName' examUserCsvActRegistration
|
||||
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
||||
, 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
|
||||
Entity _ User{..} = view resultUser $ existing ! registration
|
||||
|
||||
guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
|
||||
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
|
||||
users <- E.select . E.from $ \user -> do
|
||||
E.where_ . E.and $ catMaybes
|
||||
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
|
||||
, (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
|
||||
, (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
|
||||
]
|
||||
let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
|
||||
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
|
||||
E.limit 2
|
||||
return $ (isCourseParticipant, user E.^. UserId)
|
||||
case users of
|
||||
(filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
|
||||
-> return (isPart, uid)
|
||||
[(E.Value isPart, E.Value uid)]
|
||||
-> return (isPart, uid)
|
||||
_other
|
||||
-> throwM ExamUserCsvExceptionNoMatchingUser
|
||||
|
||||
lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
|
||||
lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
|
||||
occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] []
|
||||
case occIds of
|
||||
[occId] -> return occId
|
||||
_other -> throwM ExamUserCsvExceptionNoMatchingOccurrence
|
||||
|
||||
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
|
||||
lookupStudyFeatures csv@ExamUserTableCsv{..} = do
|
||||
uid <- view _2 <$> guessUser csv
|
||||
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> 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 <- csvEUserField
|
||||
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 <- csvEUserDegree
|
||||
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 <$> csvEUserSemester
|
||||
]
|
||||
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
||||
E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary
|
||||
E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
|
||||
E.limit 2
|
||||
return $ studyFeatures E.^. StudyFeaturesId
|
||||
case studyFeatures of
|
||||
[E.Value fid] -> return $ Just fid
|
||||
_other
|
||||
| is _Nothing csvEUserField
|
||||
, is _Nothing csvEUserDegree
|
||||
, is _Nothing csvEUserSemester
|
||||
-> return Nothing
|
||||
_other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
|
||||
|
||||
examUsersDBTableValidator = def
|
||||
|
||||
|
||||
@ -10,9 +10,11 @@ module Handler.Utils.Csv
|
||||
, ToNamedRecord(..), FromNamedRecord(..)
|
||||
, DefaultOrdered(..)
|
||||
, ToField(..), FromField(..)
|
||||
, CsvRendered(..)
|
||||
, toCsvRendered
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Import hiding (Header)
|
||||
|
||||
import Data.Csv
|
||||
import Data.Csv.Conduit
|
||||
@ -21,6 +23,8 @@ import qualified Data.Conduit.List as C
|
||||
import qualified Data.Conduit.Combinators as C (sourceLazy)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
|
||||
deriving instance Typeable CsvParseError
|
||||
@ -69,3 +73,31 @@ fileSourceCsv :: ( FromNamedRecord csv
|
||||
=> FileInfo
|
||||
-> Source m csv
|
||||
fileSourceCsv = (.| decodeCsv) . fileSource
|
||||
|
||||
|
||||
data CsvRendered = CsvRendered
|
||||
{ csvRenderedHeader :: Header
|
||||
, csvRenderedData :: [NamedRecord]
|
||||
} deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
instance ToWidget UniWorX CsvRendered where
|
||||
toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered")
|
||||
where
|
||||
csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row
|
||||
| columnKey <- Vector.toList csvRenderedHeader
|
||||
]
|
||||
| row <- csvRenderedData
|
||||
]
|
||||
|
||||
headers = decodeUtf8 <$> Vector.toList csvRenderedHeader
|
||||
|
||||
toCsvRendered :: forall mono.
|
||||
( ToNamedRecord (Element mono)
|
||||
, DefaultOrdered (Element mono)
|
||||
, MonoFoldable mono
|
||||
)
|
||||
=> mono -> CsvRendered
|
||||
toCsvRendered (otoList -> csvs) = CsvRendered{..}
|
||||
where
|
||||
csvRenderedHeader = headerOrder (error "not forced" :: Element mono)
|
||||
csvRenderedData = map toNamedRecord csvs
|
||||
|
||||
@ -70,7 +70,6 @@ import qualified Data.Set as Set
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Data.Csv (NamedRecord)
|
||||
import qualified Data.Csv as Csv (encodeByName)
|
||||
|
||||
import Colonnade hiding (bool, fromMaybe, singleton)
|
||||
import qualified Colonnade (singleton)
|
||||
@ -342,8 +341,14 @@ data DBCsvException k'
|
||||
{ dbCsvDuplicateKey :: k'
|
||||
, dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB :: NamedRecord
|
||||
}
|
||||
| DBCsvException
|
||||
{ dbCsvExceptionRow :: NamedRecord
|
||||
, dbCsvException :: Text
|
||||
}
|
||||
deriving (Show, Typeable)
|
||||
|
||||
makeLenses_ ''DBCsvException
|
||||
|
||||
instance (Typeable k', Show k') => Exception (DBCsvException k')
|
||||
|
||||
|
||||
@ -486,21 +491,23 @@ instance PathPiece x => PathPiece (WithIdent x) where
|
||||
WithIdent <$> pure ident <*> fromPathPiece rest
|
||||
|
||||
type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv) (Conduit r' (YesodDB UniWorX) csv)
|
||||
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass.
|
||||
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
|
||||
( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv
|
||||
, DBTableKey k'
|
||||
, RedirectUrl UniWorX route
|
||||
, Typeable csv
|
||||
, Ord csvAction, FromJSON csvAction, ToJSON csvAction
|
||||
, Ord csvActionClass
|
||||
, Exception csvException
|
||||
) => DBTCsvDecode
|
||||
{ dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k'
|
||||
, dbtCsvComputeActions :: Conduit (DBCsvDiff r' csv k') (YesodDB UniWorX) csvAction
|
||||
, dbtCsvComputeActions :: DBCsvDiff r' csv k' -> Source (YesodDB UniWorX) csvAction
|
||||
, dbtCsvClassifyAction :: csvAction -> csvActionClass
|
||||
, dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
|
||||
, dbtCsvExecuteActions :: Sink csvAction (YesodDB UniWorX) route
|
||||
, dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
|
||||
, dbtCsvRenderActionClass :: csvActionClass -> Widget
|
||||
, dbtCsvRenderException :: csvException -> YesodDB UniWorX Text
|
||||
}
|
||||
|
||||
data DBTable m x = forall a r r' h i t k k' csv.
|
||||
@ -895,7 +902,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
let
|
||||
toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k')
|
||||
toDiff row = do
|
||||
rowKey <- lift . runMaybeT $ dbtCsvRowKey row
|
||||
rowKey <- lift $
|
||||
handle (throwM . (DBCsvException (toNamedRecord row) :: Text -> DBCsvException k') <=< dbtCsvRenderException) . runMaybeT $ dbtCsvRowKey row
|
||||
seenKeys <- State.get
|
||||
(<* modify (maybe id (flip Map.insert row) rowKey)) $ if
|
||||
| Just rowKey' <- rowKey
|
||||
@ -917,7 +925,18 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
accActionMap acc csvAct = Map.insertWith Set.union (dbtCsvClassifyAction csvAct) (Set.singleton csvAct) acc
|
||||
|
||||
importCsv = do
|
||||
actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions .| C.fold accActionMap Map.empty
|
||||
let
|
||||
dbtCsvComputeActions' :: Sink (DBCsvDiff r' csv k') (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
|
||||
dbtCsvComputeActions' = do
|
||||
let innerAct = awaitForever $ \x
|
||||
-> let doHandle
|
||||
| Just inpCsv <- x ^? _dbCsvNew
|
||||
= handle $ throwM . (DBCsvException (toNamedRecord inpCsv) :: Text -> DBCsvException k') <=< dbtCsvRenderException
|
||||
| otherwise
|
||||
= id
|
||||
in yieldM . doHandle . runConduit $ dbtCsvComputeActions x .| C.fold accActionMap Map.empty
|
||||
innerAct .| C.foldMap id
|
||||
actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions'
|
||||
|
||||
when (Map.null actionMap) $ do
|
||||
addMessageI Info MsgCsvImportUnnecessary
|
||||
@ -957,20 +976,38 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
}
|
||||
|
||||
$(widgetFile "csv-import-confirmation-wrapper")
|
||||
|
||||
let defaultHeaderOrder = headerOrder (error "not to be forced" :: csv)
|
||||
catches importCsv
|
||||
[ Catch.Handler $ \case
|
||||
(DBCsvDuplicateKey{..} :: DBCsvException k')
|
||||
-> liftHandlerT $ sendResponseStatus badRequest400 =<< do
|
||||
let offendingCsv = decodeUtf8 $ Csv.encodeByName (headerOrder (error "not to be forced" :: csv)) [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
|
||||
|
||||
mr <- getMessageRender
|
||||
|
||||
siteLayoutMsg (ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey]) $
|
||||
let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
|
||||
heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey]
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
[whamlet|
|
||||
<p>_{MsgDBCsvDuplicateKey}
|
||||
<p>_{MsgDBCsvDuplicateKeyTip}
|
||||
<pre style="white-space: pre; font-family: monospace">
|
||||
#{offendingCsv}
|
||||
^{offendingCsv}
|
||||
|]
|
||||
(DBCsvException{..} :: DBCsvException k')
|
||||
-> liftHandlerT $ sendResponseStatus badRequest400 =<< do
|
||||
mr <- getMessageRender
|
||||
|
||||
let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvExceptionRow ]
|
||||
heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvException]
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
[whamlet|
|
||||
<p>_{MsgDBCsvException}
|
||||
$if not (Text.null dbCsvException)
|
||||
<p>#{dbCsvException}
|
||||
^{ offendingCsv}
|
||||
|]
|
||||
]
|
||||
_other -> return ()
|
||||
|
||||
14
templates/widgets/csvRendered.hamlet
Normal file
14
templates/widgets/csvRendered.hamlet
Normal file
@ -0,0 +1,14 @@
|
||||
$newline never
|
||||
<table .table .table--striped .table--hover>
|
||||
<thead>
|
||||
<tr .table__row .table__row--head>
|
||||
$forall header <- headers
|
||||
<th .table__th .table__th--csv>
|
||||
#{header}
|
||||
<tbody>
|
||||
$forall row <- csvData
|
||||
<tr .table__row>
|
||||
$forall cell <- row
|
||||
<td .table__td .table__td--csv>
|
||||
$maybe cellText <- cell
|
||||
#{cellText}
|
||||
3
templates/widgets/csvRendered.lucius
Normal file
3
templates/widgets/csvRendered.lucius
Normal file
@ -0,0 +1,3 @@
|
||||
.table__td--csv, .table__th--csv {
|
||||
font-family: monospace;
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user