diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 5fef09aba..7bd44ebf8 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -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
diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs
index 4fb1bf0a2..937fb2c46 100644
--- a/src/Data/CaseInsensitive/Instances.hs
+++ b/src/Data/CaseInsensitive/Instances.hs
@@ -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
diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs
index 3d4d12510..832a2c5d6 100644
--- a/src/Database/Esqueleto/Utils.hs
+++ b/src/Database/Esqueleto/Utils.hs
@@ -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))
\ No newline at end of file
+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
diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs
index 574f13531..e8c2b8ea4 100644
--- a/src/Handler/Exam.hs
+++ b/src/Handler/Exam.hs
@@ -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
diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs
index 27299f655..4bb875d02 100644
--- a/src/Handler/Utils/Csv.hs
+++ b/src/Handler/Utils/Csv.hs
@@ -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
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 7997741b1..e36c0672b 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -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|
_{MsgDBCsvDuplicateKey}
_{MsgDBCsvDuplicateKeyTip}
-
- #{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|
+ _{MsgDBCsvException}
+ $if not (Text.null dbCsvException)
+
#{dbCsvException}
+ ^{ offendingCsv}
|]
]
_other -> return ()
diff --git a/templates/widgets/csvRendered.hamlet b/templates/widgets/csvRendered.hamlet
new file mode 100644
index 000000000..91ffee919
--- /dev/null
+++ b/templates/widgets/csvRendered.hamlet
@@ -0,0 +1,14 @@
+$newline never
+
+
+
+ $forall header <- headers
+ |
+ #{header}
+ |
+ $forall row <- csvData
+
+ $forall cell <- row
+ |
+ $maybe cellText <- cell
+ #{cellText}
diff --git a/templates/widgets/csvRendered.lucius b/templates/widgets/csvRendered.lucius
new file mode 100644
index 000000000..1187b7160
--- /dev/null
+++ b/templates/widgets/csvRendered.lucius
@@ -0,0 +1,3 @@
+.table__td--csv, .table__th--csv {
+ font-family: monospace;
+}
|