diff --git a/frontend/src/utils/inputs/file-input.js b/frontend/src/utils/inputs/file-input.js
index 676d6ff2c..568e1baf4 100644
--- a/frontend/src/utils/inputs/file-input.js
+++ b/frontend/src/utils/inputs/file-input.js
@@ -1,4 +1,5 @@
import { Utility } from '../../core/utility';
+import './file-input.scss';
const FILE_INPUT_CLASS = 'file-input';
const FILE_INPUT_INITIALIZED_CLASS = 'file-input--initialized';
diff --git a/frontend/src/utils/inputs/file-input.scss b/frontend/src/utils/inputs/file-input.scss
new file mode 100644
index 000000000..7bf23248d
--- /dev/null
+++ b/frontend/src/utils/inputs/file-input.scss
@@ -0,0 +1,3 @@
+.file-input__list:empty {
+ display: none;
+}
diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss
index 7bd86c059..643902d08 100644
--- a/frontend/src/utils/inputs/inputs.scss
+++ b/frontend/src/utils/inputs/inputs.scss
@@ -25,6 +25,11 @@
color: var(--color-fontsec);
}
+.form-section-legend {
+ color: var(--color-fontsec);
+ margin: 7px 0;
+}
+
.form-group-label {
font-weight: 600;
padding-top: 6px;
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 92bcd7821..99ed87ddf 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
@@ -933,6 +934,8 @@ CommTutorialHeading: Tutorium-Mitteilung
RecipientCustom: Weitere Empfänger
RecipientToggleAll: Alle/Keine
+DBCsvImportActionToggleAll: Alle/Keine
+
RGCourseParticipants: Kursteilnehmer
RGCourseLecturers: Kursverwalter
RGCourseCorrectors: Korrektoren
@@ -1062,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
@@ -1119,7 +1122,9 @@ ExamRoomMatriculation': Nach Matrikelnummer
ExamRoomRandom': Zufällig pro Teilnehmer
ExamOccurrence: Termin/Raum
+ExamNoOccurrence: Kein Termin/Raum
ExamOccurrences: Prüfungen
+ExamRooms: Räume
ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
ExamRoomName: Interne Bezeichnung
ExamRoom: Raum
@@ -1200,6 +1205,14 @@ CsvAddNew: Neue Einträge einfügen
CsvDeleteMissing: Fehlende Einträge entfernen
BtnCsvExport: CSV-Datei exportieren
BtnCsvImport: CSV-Datei importieren
+BtnCsvImportConfirm: CSV-Import abschließen
+
+CsvImportNotConfigured: CSV-Import nicht vorgesehen
+CsvImportConfirmationHeading: CSV-Import abschließen
+CsvImportConfirmationTip: Durch den CSV-Import würden die unten aufgeführten Änderungen vorgenommen. Bitte überprüfen Sie diese zunächst sorgfältig.
+CsvImportUnnecessary: Durch den CSV-Import würden keine Änderungen vorgenommen werden
+CsvImportSuccessful n@Int: CSV-Import erfolgreich, es #{pluralDE n "wurde eine Aktion" (mappend (mappend "wurden " (toMessage n)) " Aktionen")} durchgeführt
+CsvImportAborted: CSV-Import abgebrochen
Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%)
@@ -1217,4 +1230,23 @@ CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilneh
CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können
-Action: Aktion
\ No newline at end of file
+Action: Aktion
+
+DBCsvDuplicateKey: Zwei Zeilen der CSV-Dateien referenzieren den selben internen Datensatz und können daher nicht verarbeitet werden.
+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.
+
+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
+TableHeadingCsvExport: CSV-Export
\ No newline at end of file
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..6ddf7edd3 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,17 +61,19 @@ 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 (E.&&.) true
+or = F.foldr (E.||.) 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 =>
- (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
-any test = F.foldr (\needle acc -> acc E.||. test needle) false
+any :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool)
+any test = or . map test . otoList
-- | Given a test and a set of values, check whether all succeeds the test
-- WARNING: SQL leaves it explicitely unspecified whether `&&` is short curcuited (i.e. lazily evaluated)
-all :: Foldable f =>
- (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
-all test = F.foldr (\needle acc -> acc E.&&. test needle) true
+all :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool)
+all test = and . map test . otoList
-- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
@@ -164,4 +169,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 dec5b8998..4531aa395 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
@@ -22,6 +22,9 @@ import Data.Map ((!), (!?))
import qualified Data.Map as Map
import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Data.Text.Lens as Text
+
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
import Text.Blaze.Html.Renderer.String (renderHtml)
@@ -29,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
@@ -883,6 +887,53 @@ embedRenderMessage ''UniWorX ''ExamUserAction id
data ExamUserActionData = ExamUserDeregisterData
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
+data ExamUserCsvActionClass
+ = ExamUserCsvCourseRegister
+ | ExamUserCsvRegister
+ | ExamUserCsvAssignOccurrence
+ | ExamUserCsvSetCourseField
+ | ExamUserCsvDeregister
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
+
+data ExamUserCsvAction
+ = ExamUserCsvCourseRegisterData
+ { examUserCsvActUser :: UserId
+ , examUserCsvActCourseField :: Maybe StudyFeaturesId
+ , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
+ }
+ | ExamUserCsvRegisterData
+ { examUserCsvActUser :: UserId
+ , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
+ }
+ | ExamUserCsvAssignOccurrenceData
+ { examUserCsvActRegistration :: ExamRegistrationId
+ , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
+ }
+ | ExamUserCsvSetCourseFieldData
+ { examUserCsvActCourseParticipant :: CourseParticipantId
+ , examUserCsvActCourseField :: Maybe StudyFeaturesId
+ }
+ | ExamUserCsvDeregisterData
+ { examUserCsvActRegistration :: ExamRegistrationId
+ }
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+ { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel
+ , fieldLabelModifier = camelToPathPiece' 3
+ , 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
@@ -994,7 +1045,204 @@ postEUsersR tid ssh csh examn = do
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
- dbtCsvDecode = Nothing
+ dbtCsvDecode = Just DBTCsvDecode
+ { 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
+ ExamUserCsvCourseRegister -> DBCsvActionNew
+ ExamUserCsvRegister -> DBCsvActionNew
+ ExamUserCsvDeregister -> DBCsvActionMissing
+ _other -> DBCsvActionExisting
+ , dbtCsvExecuteActions = do
+ C.mapM_ $ \case
+ 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 = \(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{..}
+ -> 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 ad436a996..27f476312 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -7,7 +7,9 @@ module Handler.Utils.Table.Pagination
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
, DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
, module Handler.Utils.Table.Pagination.CsvColumnExplanations
- , DBTCsvEncode, DBTCsvDecode
+ , DBCsvActionMode(..)
+ , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
+ , DBTCsvEncode, DBTCsvDecode(..)
, DBTable(..), noCsvEncode, IsDBTable(..), DBCell(..)
, singletonFilter
, DBParams(..)
@@ -50,23 +52,28 @@ import qualified Database.Esqueleto.Internal.Language as E (From)
import qualified Network.Wai as Wai
-import Control.Monad.RWS hiding ((<>), mapM_)
-import Control.Monad.Writer hiding ((<>), mapM_)
+import Control.Monad.RWS (RWST(..), execRWS)
+import Control.Monad.Writer (WriterT(..))
import Control.Monad.Reader (ReaderT(..), mapReaderT)
+import Control.Monad.State (StateT(..), evalStateT)
import Control.Monad.Trans.Maybe
+import Control.Monad.State.Class (modify)
+import qualified Control.Monad.State.Class as State
import Data.Foldable (Foldable(foldMap))
-import Data.Map (Map)
+import Data.Map (Map, (!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
+import Data.Csv (NamedRecord)
+
import Colonnade hiding (bool, fromMaybe, singleton)
import qualified Colonnade (singleton)
-import Colonnade.Encode
+import Colonnade.Encode hiding (row)
import Text.Hamlet (hamletFile)
@@ -97,6 +104,8 @@ import Data.Semigroup as Sem (Semigroup(..))
import qualified Data.Conduit.List as C
+import qualified Control.Monad.Catch as Catch
+
#if MIN_VERSION_base(4,11,0)
type Monoid' = Monoid
@@ -271,8 +280,19 @@ piIsUnset PaginationInput{..} = and
, isNothing piPage
]
+
+data DBCsvActionMode = DBCsvActionNew | DBCsvActionExisting | DBCsvActionMissing
+ deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable)
+instance Universe DBCsvActionMode
+instance Finite DBCsvActionMode
-data ButtonCsvMode = BtnCsvExport | BtnCsvImport
+nullaryPathPiece ''DBCsvActionMode $ camelToPathPiece' 3
+deriveJSON defaultOptions
+ { constructorTagModifier = camelToPathPiece' 3
+ } ''DBCsvActionMode
+
+
+data ButtonCsvMode = BtnCsvExport | BtnCsvImport | BtnCsvImportConfirm
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCsvMode
instance Finite ButtonCsvMode
@@ -288,21 +308,51 @@ instance Button UniWorX ButtonCsvMode where
#{iconFileCSV}
\ _{BtnCsvExport}
|]
- btnLabel BtnCsvImport
- = [whamlet|
- $newline never
- _{BtnCsvImport}
- |]
-
-data DBCsvMode = DBCsvNormal
- | DBCsvExport
- | DBCsvImport
- { _dbCsvFiles :: [FileInfo]
- , _dbCsvModifyExisting, _dbCsvAddNew, _dbCsvDeleteMissing :: Bool
- }
+ btnLabel x = [whamlet|_{x}|]
-type DBTableKey k' = (ToJSON k', FromJSON k', Ord k', Binary k')
+data DBCsvMode
+ = DBCsvNormal
+ | DBCsvExport
+ | DBCsvImport
+ { dbCsvFiles :: [FileInfo]
+ }
+
+data DBCsvDiff r' csv k'
+ = DBCsvDiffNew
+ { dbCsvNewKey :: Maybe k'
+ , dbCsvNew :: csv
+ }
+ | DBCsvDiffExisting
+ { dbCsvOldKey :: k'
+ , dbCsvOld :: r'
+ , dbCsvNew :: csv
+ }
+ | DBCsvDiffMissing
+ { dbCsvOldKey :: k'
+ , dbCsvOld :: r'
+ }
+
+makeLenses_ ''DBCsvDiff
+makePrisms ''DBCsvDiff
+
+data DBCsvException k'
+ = DBCsvDuplicateKey
+ { dbCsvDuplicateKey :: k'
+ , dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB :: NamedRecord
+ }
+ | DBCsvException
+ { dbCsvExceptionRow :: NamedRecord
+ , dbCsvException :: Text
+ }
+ deriving (Show, Typeable)
+
+makeLenses_ ''DBCsvException
+
+instance (Typeable k', Show k') => Exception (DBCsvException k')
+
+
+type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k')
data DBRow r = forall k'. DBTableKey k' => DBRow
{ dbrKey :: k'
, dbrOutput :: r
@@ -440,9 +490,25 @@ instance PathPiece x => PathPiece (WithIdent x) where
(ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
WithIdent <$> pure ident <*> fromPathPiece rest
-
type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv) (Conduit r' (YesodDB UniWorX) csv)
-type DBTCsvDecode csv = DictMaybe (FromNamedRecord csv) (Sink csv (YesodDB UniWorX) ())
+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 :: 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.
( ToSortable h, Functor h
@@ -460,7 +526,7 @@ data DBTable m x = forall a r r' h i t k k' csv.
, dbtStyle :: DBStyle
, dbtParams :: DBParams m x
, dbtCsvEncode :: DBTCsvEncode r' csv
- , dbtCsvDecode :: DBTCsvDecode csv
+ , dbtCsvDecode :: Maybe (DBTCsvDecode r' k' csv)
, dbtIdent :: i
}
@@ -756,9 +822,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
((csvExportRes, csvExportWdgt), csvExportEnctype) <- lift . runFormGet . identifyForm FIDDBTableCsvExport . set (mapped . mapped . _1 . mapped) DBCsvExport $ buttonForm' [BtnCsvExport]
((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport
<$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing
- <*> apopt checkBoxField (fslI MsgCsvModifyExisting) (Just True)
- <*> apopt checkBoxField (fslI MsgCsvAddNew) (Just True)
- <*> apopt checkBoxField (fslI MsgCsvDeleteMissing) (Just False)
let
csvMode = asum
@@ -826,13 +889,127 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
formResult csvMode $ \case
DBCsvExport
- | Just (Dict, dbtCsvEncode') <- dbtCsvEncode
- -> do
- setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv
- sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode'
- DBCsvImport{}
- | Just (Dict, _dbtCsvDecode) <- dbtCsvDecode
- -> error "dbCsvImport"
+ | Just (Dict, dbtCsvEncode') <- dbtCsvEncode -> do
+ setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv
+ sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode'
+ DBCsvImport{..}
+ | Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
+ , ..
+ } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
+ let existing = Map.fromList $ zip currentKeys rows
+ sourceDiff :: Source (StateT (Map k' csv) (YesodDB UniWorX)) (DBCsvDiff r' csv k')
+ sourceDiff = do
+ let
+ toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k')
+ toDiff row = do
+ 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
+ , Just oldRow <- Map.lookup rowKey' seenKeys
+ -> throwM $ DBCsvDuplicateKey rowKey' (toNamedRecord oldRow) (toNamedRecord row)
+ | Just rowKey' <- rowKey
+ , Just oldRow <- Map.lookup rowKey' existing
+ -> return $ DBCsvDiffExisting rowKey' oldRow row
+ | otherwise
+ -> return $ DBCsvDiffNew rowKey row
+ mapM_ fileSourceCsv dbCsvFiles .| C.mapM toDiff
+
+ seen <- State.get
+ forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if
+ | Map.member rowKey seen -> return ()
+ | otherwise -> yield $ DBCsvDiffMissing rowKey oldRow
+
+ accActionMap :: Map csvActionClass (Set csvAction) -> csvAction -> Map csvActionClass (Set csvAction)
+ accActionMap acc csvAct = Map.insertWith Set.union (dbtCsvClassifyAction csvAct) (Set.singleton csvAct) acc
+
+ importCsv = do
+ 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
+ redirect $ tblLink id
+
+ liftHandlerT . (>>= sendResponse) $
+ siteLayoutMsg MsgCsvImportConfirmationHeading $ do
+ setTitleI MsgCsvImportConfirmationHeading
+
+ let
+ precomputeIdents :: forall f m'. (Eq (Element f), MonoFoldable f, MonadHandler m') => f -> m' (Element f -> Text)
+ precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed")
+ actionClassIdent <- precomputeIdents $ Map.keys actionMap
+ actionIdent <- precomputeIdents . Set.unions $ Map.elems actionMap
+
+ let defaultChecked actClass = case dbtCsvCoarsenActionClass actClass of
+ DBCsvActionMissing -> False
+ _other -> True
+ csvActionCheckBox :: [(Text, Text)] -> csvAction -> Widget
+ csvActionCheckBox vAttrs act = do
+ let
+ sJsonField :: Field (HandlerT UniWorX IO) csvAction
+ sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
+ [whamlet|
+ $newline never
+
+ |]
+ fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False
+ (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandlerT . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
+ let csvImportConfirmForm = wrapForm' BtnCsvImportConfirm csvImportConfirmForm' FormSettings
+ { formMethod = POST
+ , formAction = Just $ tblLink id
+ , formEncoding = csvImportConfirmEnctype
+ , formAttrs = []
+ , formSubmit = FormSubmit
+ , formAnchor = Nothing :: Maybe Text
+ }
+
+ $(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
+ mr <- getMessageRender
+
+ let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
+ heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey]
+
+ siteLayoutMsg heading $ do
+ setTitleI heading
+ [whamlet|
+ _{MsgDBCsvDuplicateKey}
+
_{MsgDBCsvDuplicateKeyTip}
+ ^{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 ()
let
@@ -889,7 +1066,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
csvWdgt = $(widgetFile "table/csv-transcode")
- uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")
+ uiLayout table = csvWdgt <> dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")
dbInvalidateResult' = foldr (<=<) return . catMaybes $
[ do
@@ -898,6 +1075,22 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
return . dbInvalidateResult dbtParams . DBTIRowsMissing $ length previousKeys - length currentKeys
]
+ ((csvImportConfirmRes, ()), _enctype) <- case dbtCsvDecode of
+ Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do
+ lift . runFormPost . identifyForm FIDDBTableCsvImportConfirm $ \_csrf -> do
+ acts <- globalPostParamFields PostDBCsvImportAction secretJsonField
+ return . (, ()) $ if
+ | null acts -> FormSuccess $ do
+ addMessageI Info MsgCsvImportAborted
+ redirect $ tblLink id
+ | otherwise -> FormSuccess $ do
+ finalDest <- runConduit $ C.sourceList acts .| dbtCsvExecuteActions
+ addMessageI Success . MsgCsvImportSuccessful $ length acts
+ E.transactionSave
+ redirect finalDest
+ _other -> return ((FormMissing, ()), mempty)
+ formResult csvImportConfirmRes id
+
dbInvalidateResult' <=< bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
where
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index e7ae3b654..e1a2a24b4 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -199,6 +199,7 @@ data FormIdentifier
| FIDDBTable
| FIDDBTableCsvExport
| FIDDBTableCsvImport
+ | FIDDBTableCsvImportConfirm
| FIDDelete
| FIDCourseRegister
| FIDuserRights
@@ -567,7 +568,26 @@ data SecretJSONFieldException = SecretJSONFieldDecryptFailure
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Exception SecretJSONFieldException
-secretJsonField :: ( ToJSON a, FromJSON a
+secretJsonField' :: ( ToJSON a, FromJSON a
+ , MonadHandler m
+ , MonadSecretBox (ExceptT EncodedSecretBoxException m)
+ , MonadSecretBox (WidgetT (HandlerSite m) IO)
+ , RenderMessage (HandlerSite m) FormMessage
+ , RenderMessage (HandlerSite m) SecretJSONFieldException
+ )
+ => FieldViewFunc m Text -> Field m a
+secretJsonField' fieldView' = Field{..}
+ where
+ fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
+ fieldParse [] [] = return $ Right Nothing
+ fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+ fieldView theId name attrs val isReq = do
+ val' <- traverse (encodedSecretBox SecretBoxShort) val
+ fieldView' theId name attrs val' isReq
+ fieldEnctype = UrlEncoded
+
+secretJsonField :: forall m a.
+ ( ToJSON a, FromJSON a
, MonadHandler m
, MonadSecretBox (ExceptT EncodedSecretBoxException m)
, MonadSecretBox (WidgetT (HandlerSite m) IO)
@@ -575,17 +595,7 @@ secretJsonField :: ( ToJSON a, FromJSON a
, RenderMessage (HandlerSite m) SecretJSONFieldException
)
=> Field m a
-secretJsonField = Field{..}
- where
- fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
- fieldParse [] [] = return $ Right Nothing
- fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
- fieldView theId name attrs val _isReq = do
- val' <- traverse (encodedSecretBox SecretBoxShort) val
- [whamlet|
-
- |]
- fieldEnctype = UrlEncoded
+secretJsonField = secretJsonField' $ fieldView (hiddenField :: Field m Text)
htmlFieldSmall :: forall m. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Html
htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField
diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs
index 57d1a0cff..6a66df6e1 100644
--- a/src/Utils/Parameters.hs
+++ b/src/Utils/Parameters.hs
@@ -6,7 +6,7 @@ module Utils.Parameters
, GlobalPostParam(..)
, lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams
, lookupGlobalPostParamForm, hasGlobalPostParamForm
- , globalPostParamField
+ , globalPostParamField, globalPostParamFields
) where
import ClassyPrelude.Yesod
@@ -55,6 +55,7 @@ data GlobalPostParam = PostFormIdentifier
| PostDeleteTarget
| PostMassInputShape
| PostBearer
+ | PostDBCsvImportAction
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalPostParam
@@ -84,3 +85,9 @@ globalPostParamField ident Field{fieldParse} = runMaybeT $ do
ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs)
+
+globalPostParamFields :: Monad m => GlobalPostParam -> Field m a -> MForm m [a]
+globalPostParamFields ident Field{fieldParse} = fmap (fromMaybe []) . runMaybeT $ do
+ ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
+ fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
+ forM ((Left <$> fs) ++ (Right <$> ts)) $ \inp -> MaybeT $ either (const Nothing) id <$> lift (either (\f -> fieldParse [] [f]) (\t -> fieldParse [t] []) inp)
diff --git a/templates/csv-import-confirmation-wrapper.hamlet b/templates/csv-import-confirmation-wrapper.hamlet
new file mode 100644
index 000000000..b5459079b
--- /dev/null
+++ b/templates/csv-import-confirmation-wrapper.hamlet
@@ -0,0 +1,4 @@
+
+ _{MsgCsvImportConfirmationTip}
+
+ ^{csvImportConfirmForm}
diff --git a/templates/csv-import-confirmation.hamlet b/templates/csv-import-confirmation.hamlet
new file mode 100644
index 000000000..473a2c101
--- /dev/null
+++ b/templates/csv-import-confirmation.hamlet
@@ -0,0 +1,21 @@
+$newline never
+#{csrf}
+
+ $forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap)
+
+
+