From 2dc6641e68f73f048ee9187e1f6ccd924870577f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Mar 2020 20:38:42 +0100 Subject: [PATCH] fix(csv-import): major usability improvements --- frontend/src/app.sass | 12 +++ messages/uniworx/de-de-formal.msg | 9 +- messages/uniworx/en-eu.msg | 9 +- src/Handler/Utils/Csv.hs | 9 ++ src/Handler/Utils/Table/Pagination.hs | 94 +++++++++++++++---- src/Handler/Utils/Users.hs | 78 ++++++++++----- src/Utils/Form.hs | 34 ++++++- src/Utils/Parameters.hs | 6 ++ .../table/csv-column-explanations.hamlet | 1 + templates/table/csv-reimport.hamlet | 9 ++ 10 files changed, 212 insertions(+), 49 deletions(-) create mode 100644 templates/table/csv-reimport.hamlet diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 3af029a3c..6013ff38e 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -264,6 +264,9 @@ button, .buttongroup > & min-width: 0 + + &.btn-danger + background-color: var(--color-error-dark) .buttongroup display: grid @@ -284,6 +287,9 @@ button:not([disabled]):hover, background-color: var(--color-light) color: white + &.btn-danger + background-color: var(--color-error) + .btn-primary background-color: var(--color-primary) @@ -1220,3 +1226,9 @@ a.breadcrumbs__home .course__registration-status margin-bottom: 12px + +.csv-parse-error + white-space: pre-wrap + font-family: monospace + overflow: auto + max-height: 75vh diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 802f1bc62..cbdda090b 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1756,6 +1756,7 @@ CsvDeleteMissing: Fehlende Einträge entfernen BtnCsvExport: CSV-Datei exportieren BtnCsvImport: CSV-Datei importieren BtnCsvImportConfirm: CSV-Import abschließen +BtnCsvImportAbort: Abbrechen CsvImportNotConfigured: CSV-Import nicht vorgesehen CsvImportConfirmationHeading: CSV-Import Vorschau (noch keine Änderungen importiert) @@ -1830,6 +1831,8 @@ DBCsvDuplicateKey: Zwei Zeilen der CSV-Dateien referenzieren den selben internen 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. +DBCsvParseError: Eine hochgeladene Datei konnte nicht korrekt als CSV-Datei im erwarteten Format interpretiert werden. +DBCsvParseErrorTip: Die Uni2work-Komponente, die für das Interpretieren von CSV-Dateien zuständig ist, hat folgende Fehlermeldung produziert: ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Prüfung anmelden ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden @@ -1846,9 +1849,9 @@ ExamBonusNone: Keine Bonuspunkte ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht -ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden -ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Kursteilnehmers zugeordnet werden -ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden +ExamUserCsvExceptionNoMatchingUser: Benutzer konnte nicht eindeutig identifiziert werden. Alle Identifikatoren des Benutzers (Vorname(n), Nachname, Voller Name, Matrikelnummer, ...) müssen exakt übereinstimmen. Sie können versuchen für diese Zeile manche der Identifikatoren zu entfernen (also z.B. nur eine Matrikelnummer angeben) um dem System zu erlauben nur Anhand der verbleibenden Identifikatoren zu suchen. Sie sollten dann natürlich besonders kontrollieren, dass das System den fraglichen Benutzer korrekt identifiziert hat. +ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Benutzers zugeordnet werden. Sie können versuchen für diese Zeile die Studiengangsdaten zu entfernen um das System automatisch ein Studienfach wählen zu lassen. +ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden. Überprüfen Sie, dass diese Zeile nur interne Raumbezeichnungen enthält, wie sie auch für die Prüfung konfiguriert wurden. ExamUserCsvExceptionMismatchedGradingMode expectedGradingMode@ExamGradingMode actualGradingMode@ExamGradingMode: Es wurde versucht eine Prüfungsleistung einzutragen, die zwar vom System interpretiert werden konnte, aber nicht dem für diese Prüfung erwarteten Modus entspricht. Der erwartete Bewertungsmodus kann unter "Prüfung bearbeiten" angepasst werden ("Bestanden/Nicht Bestanden", "Numerische Noten" oder "Gemischt"). ExamUserCsvExceptionNoOccurrenceTime: Es wurde versucht eine Prüfungsleistung ohne einen zugehörigen Zeitpunkt einzutragen. Sie können entweder einen Zeitpunkt pro Student in der entsprechenden Spalte hinterlegen, oder einen voreingestellten Zeitpunkt unter "Bearbeiten" angeben. diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 984c4ea25..9b7872b1c 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1755,6 +1755,7 @@ CsvDeleteMissing: Delete missing entries BtnCsvExport: Export CSV file BtnCsvImport: Import CSV file BtnCsvImportConfirm: Finalise CSV import +BtnCsvImportAbort: Abort CsvImportNotConfigured: CSV import not configured CsvImportConfirmationHeading: CSV import preview (no changes have been made yet) @@ -1829,6 +1830,8 @@ DBCsvDuplicateKey: Two rows in the CSV file reference the same database entry an DBCsvDuplicateKeyTip: Please remove one of the lines listed below and try again. DBCsvKeyException: For a row in the CSV file it could not be determined whether it references any database entry. DBCsvException: An error occurred hile computing the set of edits this CSV import corresponds to. +DBCsvParseError: An uploaded file could not be interpreted as CSV of the expected format. +DBCsvParseErrorTip: The Uni2work-component that handles CSV decoding has reported the following error: ExamUserCsvCourseRegister: Register users for the exam and enroll them in the course ExamUserCsvRegister: Register users for the exam @@ -1845,9 +1848,9 @@ ExamBonusNone: No bonus points ExamUserCsvCourseNoteDeleted: Course note will be deleted -ExamUserCsvExceptionNoMatchingUser: Course participant could not be identified uniquely -ExamUserCsvExceptionNoMatchingStudyFeatures: The specified field did not match with any of the participant's fields of study -ExamUserCsvExceptionNoMatchingOccurrence: Occurrence/room could not be identified uniquely +ExamUserCsvExceptionNoMatchingUser: Course participant could not be identified uniquely. All identifiers (given name(s), surname, display name, matriculation, ..) must match exactly. You can try to remove some of the identifiers for the given line (i.e. all but matriculation). Uni2work will then search for users using only the remaining identifiers. In this case special care should be taken that Uni2work correctly identifies the intended user. +ExamUserCsvExceptionNoMatchingStudyFeatures: The specified field did not match with any of the participant's fields of study. You can try to remove the field of study for the given line. Uni2work will then automatically choose a field of study. +ExamUserCsvExceptionNoMatchingOccurrence: Occurrence/room could not be identified uniquely. Please ensure that the given line only contains internal room identifiers exactly as they have been configured for this exam. ExamUserCsvExceptionMismatchedGradingMode expectedGradingMode actualGradingMode: The imported data contained an exam achievement which does not match the grading mode for this exam. The expected grading mode can be changed at "Edit exam" ("Passed/Failed", "Numeric grades", or "Mixed"). ExamUserCsvExceptionNoOccurrenceTime: The imported data contained an exam achievement without an associated time. You can either enter a time for each student in the appropriate column or you can set a default time for the entire exam under "Edit". diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 97090b54f..57465d311 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -39,6 +39,8 @@ import qualified Data.Attoparsec.ByteString.Lazy as A import Handler.Utils.DateTime import Data.Time.Format (iso8601DateFormat) +import qualified Data.Char as Char + decodeCsv :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv) => ConduitT ByteString csv m () decodeCsv = decodeCsv' fromNamedCsv @@ -69,6 +71,7 @@ decodeCsv' fromCsv' = do let decodeOptions = defaultDecodeOptions & guessDelimiter testBuffer + & noAlphaNumDelimiters $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|] fromCsv' decodeOptions @@ -104,6 +107,12 @@ decodeCsv' fromCsv' = do | otherwise = id + noAlphaNumDelimiters opts + | Char.isAlphaNum . Char.chr . fromIntegral $ decDelimiter opts + = opts { decDelimiter = decDelimiter defaultDecodeOptions } + | otherwise + = opts + quotedField :: A.Parser () -- We don't care about the return value quotedField = void . Csv.field $ Csv.decDelimiter defaultDecodeOptions -- We can use comma as a separator, because we know that the field we're trying to parse is quoted and so does not rely on the delimiter diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index dd07ad173..816521ec0 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -345,7 +345,7 @@ deriveJSON defaultOptions } ''DBCsvActionMode -data ButtonCsvMode = BtnCsvExport | BtnCsvImport | BtnCsvImportConfirm +data ButtonCsvMode = BtnCsvExport | BtnCsvImport | BtnCsvImportConfirm | BtnCsvImportAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonCsvMode instance Finite ButtonCsvMode @@ -363,6 +363,13 @@ instance Button UniWorX ButtonCsvMode where |] btnLabel x = [whamlet|_{x}|] + btnClasses BtnCsvImportAbort = [BCIsButton, BCDanger] + btnClasses BtnCsvImportConfirm = [BCIsButton, BCPrimary] + btnClasses _ = [BCIsButton] + + btnValidate _ BtnCsvImportAbort = False + btnValidate _ _ = True + data DBCsvMode = DBCsvNormal @@ -373,6 +380,7 @@ data DBCsvMode { dbCsvFiles :: [FileInfo] } | DBCsvExportExample + | DBCsvAbort data DBCsvDiff r' csv k' = DBCsvDiffNew @@ -942,7 +950,15 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> toDyn <$> dbtCsvExportForm Nothing -> pure $ toDyn () - ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport + let importButtons prevRes = do + isReImport <- hasGlobalPostParamForm PostDBCsvReImport + if | is _FormSuccess prevRes || isReImport + -> return [BtnCsvImport, BtnCsvImportAbort] + | otherwise + -> return [BtnCsvImport] + handleBtnAbort _ (FormSuccess BtnCsvImportAbort) = pure DBCsvAbort + handleBtnAbort x btn = x <* btn + ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . withGlobalPostParam PostDBCsvReImport () . withButtonFormCombM' handleBtnAbort importButtons . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport <$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing exportExampleRes <- guardOn <$> hasGlobalGetParam GetCsvExampleData <*> pure DBCsvExportExample @@ -961,12 +977,12 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formSubmit = FormSubmit , formAnchor = Just $ wIdent "csv-export" } - csvImportWdgt' = wrapForm' BtnCsvImport csvImportWdgt FormSettings + csvImportWdgt' = wrapForm csvImportWdgt FormSettings { formMethod = POST , formAction = Just $ tblLink id , formEncoding = csvImportEnctype , formAttrs = [] - , formSubmit = FormSubmit + , formSubmit = FormNoSubmit , formAnchor = Just $ wIdent "csv-import" } csvImportExplanation :: Widget @@ -1049,6 +1065,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db return $(widgetFile "table/csv-example") formResult csvMode $ \case + DBCsvAbort{} -> do + addMessageI Info MsgCsvImportAborted + redirect $ tblLink id DBCsvExportExample{} | Just DBTCsvEncode{..} <- dbtCsvEncode , Just exData <- dbtCsvExampleData -> do @@ -1113,6 +1132,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db addMessageI Info MsgCsvImportUnnecessary redirect $ tblLink id + E.transactionSave -- If dbtCsvComputeActions has side-effects, commit those + liftHandler . (>>= sendResponse) $ siteLayoutMsg MsgCsvImportConfirmationHeading $ do setTitleI MsgCsvImportConfirmationHeading @@ -1136,18 +1157,20 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db |] fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False - (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation")) - let csvImportConfirmForm = wrapForm' BtnCsvImportConfirm csvImportConfirmForm' FormSettings + (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation")) + let csvImportConfirmForm = wrapForm csvImportConfirmForm' FormSettings { formMethod = POST , formAction = Just $ tblLink id , formEncoding = csvImportConfirmEnctype , formAttrs = [] - , formSubmit = FormSubmit + , formSubmit = FormNoSubmit , formAnchor = Nothing :: Maybe Text } $(widgetFile "csv-import-confirmation-wrapper") + csvReImport = $(widgetFile "table/csv-reimport") + hdr <- dbtCsvHeader Nothing catches importCsv [ Catch.Handler $ \case @@ -1161,9 +1184,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db siteLayoutMsg heading $ do setTitleI heading [whamlet| -

_{MsgDBCsvDuplicateKey} -

_{MsgDBCsvDuplicateKeyTip} - ^{offendingCsv} + $newline never +

+

_{MsgDBCsvDuplicateKey} +

_{MsgDBCsvDuplicateKeyTip} + ^{offendingCsv} +

+ ^{csvReImport} |] (DBCsvException{..} :: DBCsvException k') -> liftHandler $ sendResponseStatus badRequest400 =<< do @@ -1175,11 +1202,36 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db siteLayoutMsg heading $ do setTitleI heading [whamlet| -

_{MsgDBCsvException} - $if not (Text.null dbCsvException) -

#{dbCsvException} - ^{ offendingCsv} + $newline never +

+

_{MsgDBCsvException} + $if not (Text.null dbCsvException) +

#{dbCsvException} + ^{offendingCsv} +

+ ^{csvReImport} |] + , Catch.Handler $ \(csvParseError :: CsvParseError) + -> liftHandler $ sendResponseStatus badRequest400 =<< do + mr <- getMessageRender + + let heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvParseError] + + siteLayoutMsg heading $ do + setTitleI heading + [whamlet| + $newline never +
+

_{MsgDBCsvParseErrorTip} +

+                           $case csvParseError
+                             $of CsvParseError _ errMsg
+                               #{errMsg}
+                             $of IncrementalError errMsg
+                               #{errMsg}
+                       
+ ^{csvReImport} + |] ] _other -> return () @@ -1260,11 +1312,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db return . dbInvalidateResult dbtParams . DBTIRowsMissing $ length previousKeys - length currentKeys ] - ((csvImportConfirmRes, ()), _enctype) <- case dbtCsvDecode of + ((csvImportConfirmRes, _confirmView), _enctype) <- case dbtCsvDecode of Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do - lift . runFormPost . identifyForm FIDDBTableCsvImportConfirm $ \_csrf -> do + lift . runFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm FIDDBTableCsvImportConfirm $ \_csrf -> do acts <- globalPostParamFields PostDBCsvImportAction secretJsonField - return . (, ()) $ if + return . (, mempty) $ if | null acts -> FormSuccess $ do addMessageI Info MsgCsvImportAborted redirect $ tblLink id @@ -1273,8 +1325,12 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db addMessageI Success . MsgCsvImportSuccessful $ length acts E.transactionSave redirect finalDest - _other -> return ((FormMissing, ()), mempty) - formResult csvImportConfirmRes id + _other -> return ((FormMissing, mempty), mempty) + formResult csvImportConfirmRes $ \case + (_, BtnCsvImportAbort) -> do + addMessageI Info MsgCsvImportAborted + redirect $ tblLink id + (act, _) -> act 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 diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index dc23e8739..bd95b8be3 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -2,6 +2,8 @@ module Handler.Utils.Users ( computeUserAuthenticationDigest , Digest, SHA3_256 , constEq + , NameMatchQuality(..) + , matchesName , GuessUserInfo(..) , guessUser ) where @@ -21,6 +23,10 @@ import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E +import qualified Data.MultiSet as MultiSet +import qualified Data.Map as Map +import qualified Data.Text as Text + computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode @@ -36,14 +42,44 @@ instance Binary GuessUserInfo makeLenses_ ''GuessUserInfo +data NameMatchQuality + = NameMatchSuffix + | NameMatchPrefix + | NameMatchPermutation + | NameMatchEqual + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +matchesName :: Textual t + => t -- ^ haystack + -> t -- ^ needle + -> Maybe NameMatchQuality +matchesName (repack -> haystack) (repack -> needle) + = fmap (view _1) . Map.lookupMax $ Map.filter id tests + where + asWords :: Text -> [CI Text] + asWords = map CI.mk . filter (not . Text.null) . Text.words . Text.strip + + tests :: Map NameMatchQuality Bool + tests = mconcat + [ singletonMap NameMatchEqual $ asWords needle == asWords haystack + , singletonMap NameMatchPrefix $ asWords needle `isPrefixOf` asWords haystack + , singletonMap NameMatchSuffix $ asWords needle `isSuffixOf` asWords haystack + , singletonMap NameMatchPermutation $ ((==) `on` MultiSet.fromList) (asWords needle) (asWords haystack) + ] + guessUser :: Set GuessUserInfo -> DB (Maybe UserId) guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False where + asWords :: Text -> [Text] + asWords = filter (not . Text.null) . Text.words . Text.strip + + containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y + toSql user = \case - GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') - GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `E.hasInfix` E.val userDisplayName' - GuessUserSurname userSurname' -> user E.^. UserSurname `E.hasInfix` E.val userSurname' - GuessUserFirstName userFirstName' -> user E.^. UserFirstName `E.hasInfix` E.val userFirstName' + GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') + GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' + GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname' + GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' go didLdap = do let retrieveUsers = E.select . E.from $ \user -> do @@ -58,9 +94,9 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False closeness :: Entity User -> Entity User -> Ordering closeness = mconcat $ concat [ pure $ comparing (fmap Down . matchesMatriculation) - , (criteria ^.. folded . _guessUserSurname) <&> \surn -> comparing (preview $ _entityVal . _userSurname . to CI.mk . only (CI.mk surn)) - , (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (preview $ _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn)) - , (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (preview $ _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn)) + , (criteria ^.. folded . _guessUserSurname) <&> \surn -> comparing (view $ _entityVal . _userSurname . to (`matchesName` surn)) + , (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (view $ _entityVal . _userFirstName . to (`matchesName` firstn)) + , (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (view $ _entityVal . _userDisplayName . to (`matchesName` dispn)) ] doLdap userMatr = do @@ -70,19 +106,17 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False ldapData <- campusUserMatr' ldapConf ldapPool userMatr for ldapData $ upsertCampusUser UpsertCampusUser - - case users' of - x@(Entity pid _) : xs - | [] <- xs - , fromMaybe False (matchesMatriculation x) || didLdap - -> return $ Just pid - | x' : _ <- xs - , fromMaybe False (matchesMatriculation x) || didLdap - , GT <- x `closeness` x' - -> return $ Just pid - | not didLdap - , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer - , all (== userMatr) userMatrs' - -> doLdap userMatr >>= maybe (go True) (return . Just) - _other + if + | x@(Entity pid _) : [] <- users' + , fromMaybe False (matchesMatriculation x) || didLdap + -> return $ Just pid + | x@(Entity pid _) : x' : _ <- users' + , fromMaybe False (matchesMatriculation x) || didLdap + , GT <- x `closeness` x' + -> return $ Just pid + | not didLdap + , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer + , all (== userMatr) userMatrs' + -> doLdap userMatr >>= maybe (go True) (return . Just) + | otherwise -> return Nothing diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 4ca0e17e9..61fbcad7b 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -393,11 +393,11 @@ buttonView btn = do -- | generate a form that only shows a finite amount of buttons -buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ()) +buttonForm :: (MonadHandler m, Button (HandlerSite m) a, Finite a) => Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) buttonForm = buttonForm' universeF -- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass -buttonForm' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ()) +buttonForm' :: (MonadHandler m, Button (HandlerSite m) a) => [a] -> Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) buttonForm' btns csrf = do (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns "" return (res, [whamlet| @@ -407,6 +407,36 @@ buttonForm' btns csrf = do ^{fvInput bView} |]) +withButtonForm' :: (MonadHandler m, Button (HandlerSite m) btn) + => [btn] + -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) + -> (Html -> MForm m (FormResult (a, btn), WidgetT (HandlerSite m) IO ())) +withButtonForm' = withButtonFormM' . const . return + +withButtonFormComb' :: (MonadHandler m, Button (HandlerSite m) btn) + => (FormResult a -> FormResult btn -> FormResult b) + -> [btn] + -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) + -> (Html -> MForm m (FormResult b, WidgetT (HandlerSite m) IO ())) +withButtonFormComb' f = withButtonFormCombM' f . const . return + +withButtonFormM' :: (MonadHandler m, Button (HandlerSite m) btn) + => (FormResult a -> MForm m [btn]) + -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) + -> (Html -> MForm m (FormResult (a, btn), WidgetT (HandlerSite m) IO ())) +withButtonFormM' = withButtonFormCombM' (\x btn -> (,) <$> x <*> btn) + +withButtonFormCombM' :: (MonadHandler m, Button (HandlerSite m) btn) + => (FormResult a -> FormResult btn -> FormResult b) + -> (FormResult a -> MForm m [btn]) + -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) + -> (Html -> MForm m (FormResult b, WidgetT (HandlerSite m) IO ())) +withButtonFormCombM' combF mkBtns innerForm csrf = do + (innerRes, innerView) <- innerForm csrf + btns <- mkBtns innerRes + (buttonRes, btnView) <- buttonForm' btns mempty + return (combF innerRes buttonRes, innerView <> btnView) + -- | buttons-only form complete with widget-generation and evaluation; return type determines buttons shown. runButtonForm ::(PathPiece ident, Eq ident, RenderMessage site FormMessage, Button site ButtonSubmit, Button site a, Finite a) diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index dbbd78070..b92d2431f 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -7,6 +7,7 @@ module Utils.Parameters , lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams , lookupGlobalPostParamForm, hasGlobalPostParamForm , globalPostParamField, globalPostParamFields + , withGlobalPostParam ) where import ClassyPrelude.Yesod @@ -56,6 +57,7 @@ data GlobalPostParam = PostFormIdentifier | PostMassInputShape | PostBearer | PostDBCsvImportAction + | PostDBCsvReImport | PostLoginDummy | PostExamAutoOccurrencePrevious | PostLanguage @@ -94,3 +96,7 @@ globalPostParamFields ident Field{fieldParse} = fmap (fromMaybe []) . runMaybeT 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) + +withGlobalPostParam :: PathPiece result => GlobalPostParam -> result -> (Html -> MForm m a) -> (Html -> MForm m a) +withGlobalPostParam (toPathPiece -> ident) (toPathPiece -> res) f csrf + = f $ csrf <> [shamlet||] diff --git a/templates/table/csv-column-explanations.hamlet b/templates/table/csv-column-explanations.hamlet index bc72a43f9..a94338dde 100644 --- a/templates/table/csv-column-explanations.hamlet +++ b/templates/table/csv-column-explanations.hamlet @@ -1,3 +1,4 @@ +$newline never

_{MsgCsvColumnsExplanationsTip}
$forall (colName, colExplanation) <- csvColExplanations'' diff --git a/templates/table/csv-reimport.hamlet b/templates/table/csv-reimport.hamlet new file mode 100644 index 000000000..0de054b07 --- /dev/null +++ b/templates/table/csv-reimport.hamlet @@ -0,0 +1,9 @@ +$newline never +

^{csvImportExplanation} +

^{csvColExplanations'} +$maybe wgt <- csvExample +

+ ^{modal (i18n MsgCsvExampleData) (Right wgt)} +

+ ^{modal (i18n MsgCsvChangeOptionsLabel) (Left (SomeRoute CsvOptionsR))} +^{csvImportWdgt'}