feat(csv): finish implementing csv import

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

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

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

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
+  = ExamUserCsvCourseRegisterData
-    { examUserCsvUser :: UserId
+    { examUserCsvActUser :: UserId
+    , examUserCsvActCourseField :: Maybe StudyFeaturesId
+    , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
+    }
+  | ExamUserCsvRegisterData
+    { examUserCsvActUser :: UserId
+    , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
     }
   | ExamUserCsvAssignOccurrenceData
-    { examUserCsvRegistration :: ExamRegistrationId
+    { examUserCsvActRegistration :: ExamRegistrationId
-    , examUserCsvOccurrence :: ExamOccurrenceId
+    , 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
+            { dbtCsvRowKey = \csv -> do
-            , dbtCsvComputeActions = awaitForever $ \case
+                uid <- lift $ view _2 <$> guessUser csv
-                DBCsvDiffMissing{dbCsvOldKey} -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
+                fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid
-                _other -> return () -- FIXME: compute edit on existing rows & add rows
+            , 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
+                ExamUserCsvCourseRegister -> DBCsvActionNew
-                ExamUserCsvDeregister -> DBCsvActionMissing
+                ExamUserCsvRegister       -> DBCsvActionNew
-                _other                -> DBCsvActionExisting 
+                ExamUserCsvDeregister     -> DBCsvActionMissing
+                _other                    -> DBCsvActionExisting 
             , dbtCsvExecuteActions = do
                 C.mapM_ $ \case
-                  ExamUserCsvDeregisterData{..} -> delete examUserCsvRegistration
+                  ExamUserCsvCourseRegisterData{..} -> do
-                  _other -> return () -- FIXME
+                    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
+                  -> registeredUserName' examUserCsvActRegistration
-                      in nameWidget userDisplayName userSurname
+            , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
-                _other -> mempty -- FIXME
+            , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
-            , dbtCsvRenderActionClass = \c -> [whamlet|_{c}|]
             }
+            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
 

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

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

templates/widgets/csvRendered.hamlet

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

templates/widgets/csvRendered.lucius

@@ -0,0 +1,3 @@
+.table__td--csv, .table__th--csv {
+  font-family: monospace;
+}