fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(csv): implement csv import

Browse Source
This commit is contained in:
Gregor Kleen 2019-07-19 14:45:44 +02:00
parent f4edec0e9e
commit 996bc2ac27
18 changed files with 497 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
frontend/src/utils/inputs/file-input.js
View File

@ -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';

3
frontend/src/utils/inputs/file-input.scss Normal file
View File

@ -0,0 +1,3 @@
.file-input__list:empty {
display: none;
}

5
frontend/src/utils/inputs/inputs.scss
View File

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

23
messages/uniworx/de.msg
View File

@ -933,6 +933,8 @@ CommTutorialHeading: Tutorium-Mitteilung
RecipientCustom: Weitere Empfänger
RecipientToggleAll: Alle/Keine
DBCsvImportActionToggleAll: Alle/Keine
RGCourseParticipants: Kursteilnehmer
RGCourseLecturers: Kursverwalter
RGCourseCorrectors: Korrektoren
@ -1200,6 +1202,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 +1227,15 @@ 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
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.
ExamUserCsvRegister: Teilnehmer zur Klausur anmelden
ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden
TableHeadingFilter: Filter
TableHeadingCsvImport: CSV-Import
TableHeadingCsvExport: CSV-Export

54
src/Handler/Exam.hs
View File

@ -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)
@ -883,6 +886,31 @@ embedRenderMessage ''UniWorX ''ExamUserAction id
data ExamUserActionData = ExamUserDeregisterData
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
data ExamUserCsvActionClass
= ExamUserCsvRegister
| ExamUserCsvAssignOccurrence
| ExamUserCsvDeregister
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
data ExamUserCsvAction
= ExamUserCsvRegisterData
{ examUserCsvUser :: UserId
}
| ExamUserCsvAssignOccurrenceData
{ examUserCsvRegistration :: ExamRegistrationId
, examUserCsvOccurrence :: ExamOccurrenceId
}
| ExamUserCsvDeregisterData
{ examUserCsvRegistration :: 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
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do
@ -994,7 +1022,31 @@ 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 = \ExamUserTableCsv{} -> mzero -- FIXME: guess user from csv row and do lookup via UniqueExamRegistration
, dbtCsvComputeActions = awaitForever $ \case
DBCsvDiffMissing{dbCsvOldKey} -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
_other -> return () -- FIXME: compute edit on existing rows & add rows
, dbtCsvClassifyAction = \case
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
, dbtCsvCoarsenActionClass = \case
ExamUserCsvRegister -> DBCsvActionNew
ExamUserCsvDeregister -> DBCsvActionMissing
_other -> DBCsvActionExisting
, dbtCsvExecuteActions = do
C.mapM_ $ \case
ExamUserCsvDeregisterData{..} -> delete examUserCsvRegistration
_other -> return () -- FIXME
return $ CExamR tid ssh csh examn EUsersR
, dbtCsvRenderKey = \existing -> \case
ExamUserCsvDeregisterData{..}
-> let Entity _ User{..} = view resultUser $ existing ! E.Value examUserCsvRegistration
in nameWidget userDisplayName userSurname
_other -> mempty -- FIXME
, dbtCsvRenderActionClass = \c -> [whamlet|_{c}|]
}
examUsersDBTableValidator = def

222
src/Handler/Utils/Table/Pagination.hs
View File

@ -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,29 @@ 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 qualified Data.Csv as Csv (encodeByName)
import Colonnade hiding (bool, fromMaybe, singleton)
import qualified Colonnade (singleton)
import Colonnade.Encode
import Colonnade.Encode hiding (row)
import Text.Hamlet (hamletFile)
@ -97,6 +105,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 +281,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 +309,45 @@ instance Button UniWorX ButtonCsvMode where
#{iconCSV}
\ _{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
}
deriving (Show, Typeable)
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 +485,23 @@ 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.
( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv
, DBTableKey k'
, RedirectUrl UniWorX route
, Typeable csv
, Ord csvAction, FromJSON csvAction, ToJSON csvAction
, Ord csvActionClass
) => DBTCsvDecode
{ dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k'
, dbtCsvComputeActions :: Conduit (DBCsvDiff r' csv k') (YesodDB UniWorX) csvAction
, dbtCsvClassifyAction :: csvAction -> csvActionClass
, dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
, dbtCsvExecuteActions :: Sink csvAction (YesodDB UniWorX) route
, dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
, dbtCsvRenderActionClass :: csvActionClass -> Widget
}
data DBTable m x = forall a r r' h i t k k' csv.
( ToSortable h, Functor h
@ -460,7 +519,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 +815,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 +882,97 @@ 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 . 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
actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions .| C.fold accActionMap Map.empty
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
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :defaultChecked (dbtCsvClassifyAction act):checked>
|]
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")
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]) $
[whamlet|
<p>_{MsgDBCsvDuplicateKey}
<p>_{MsgDBCsvDuplicateKeyTip}
<pre style="white-space: pre; font-family: monospace">
#{offendingCsv}
|]
]
_other -> return ()
let
@ -889,7 +1029,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 +1038,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

34
src/Utils/Form.hs
View File

@ -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|
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|]
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

9
src/Utils/Parameters.hs
View File

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

4
templates/csv-import-confirmation-wrapper.hamlet Normal file
View File

@ -0,0 +1,4 @@
<section>
<p>_{MsgCsvImportConfirmationTip}
<section>
^{csvImportConfirmForm}

21
templates/csv-import-confirmation.hamlet Normal file
View File

@ -0,0 +1,21 @@
$newline never
#{csrf}
<div .actions>
$forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap)
<div .action>
<input type=checkbox id=#{actionClassIdent actionClass} .action__checkbox :defaultChecked actionClass:checked>
<label .action__label for=#{actionClassIdent actionClass}>
^{dbtCsvRenderActionClass actionClass}
<fieldset .action__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{actionClassIdent actionClass}>
<div .action__checked-counter>
<div .action__toggle-all>
<input type=checkbox id=#{actionClassIdent actionClass}-toggle-all>
<label for=#{actionClassIdent actionClass}-toggle-all .action__option-label>
_{MsgDBCsvImportActionToggleAll}
<div .action__options>
$forall action <- Set.toList (actionMap ! actionClass)
<div .action__option>
^{csvActionCheckBox [] action}
<label .action__option-label for=#{actionIdent action}>
^{dbtCsvRenderKey existing action}

81
templates/csv-import-confirmation.julius Normal file
View File

@ -0,0 +1,81 @@
(function() {
var IMPORT_ACTIONS_SELECTOR = '.actions';
var IMPORT_ACTION_SELECTOR = '.action';
var IMPORT_ACTION_CHECKBOX_SELECTOR = '.action__checkbox ';
var IMPORT_ACTION_OPTIONS_SELECTOR = '.action__options';
var IMPORT_ACTION_TOGGLE_ALL_SELECTOR = '.action__toggle-all [type="checkbox"]';
var IMPORT_ACTION_CHECKED_COUNTER_SELECTOR = '.action__checked-counter';
var importActionsElement;
document.addEventListener('DOMContentLoaded', function() {
importActionsElement = document.querySelector(IMPORT_ACTIONS_SELECTOR);
setupActions();
});
function setupActions() {
var actionElements = Array.from(importActionsElement.querySelectorAll(IMPORT_ACTION_SELECTOR));
actionElements.forEach(function(element) {
setupAction(element);
});
}
function setupAction(actionElement) {
var actionCheckbox = actionElement.querySelector(IMPORT_ACTION_CHECKBOX_SELECTOR);
var actionOptions = actionElement.querySelector(IMPORT_ACTION_OPTIONS_SELECTOR);
if (actionOptions) {
var actionCheckboxes = Array.from(actionOptions.querySelectorAll('[type="checkbox"]'));
var toggleAllCheckbox = actionElement.querySelector(IMPORT_ACTION_TOGGLE_ALL_SELECTOR);
// setup action checkbox to toggle all child checkboxes if changed
actionCheckbox.addEventListener('change', function() {
actionCheckboxes.forEach(function(checkbox) {
checkbox.checked = actionCheckbox.checked;
});
updateCheckedCounter(actionElement, actionCheckboxes);
updateToggleAllCheckbox(toggleAllCheckbox, actionCheckboxes);
});
// update counter and toggle checkbox initially
updateCheckedCounter(actionElement, actionCheckboxes);
updateToggleAllCheckbox(toggleAllCheckbox, actionCheckboxes);
// register change listener for individual checkboxes
actionCheckboxes.forEach(function(checkbox) {
checkbox.addEventListener('change', function() {
updateCheckedCounter(actionElement, actionCheckboxes);
updateToggleAllCheckbox(toggleAllCheckbox, actionCheckboxes);
});
});
// register change listener for toggle all checkbox
if (toggleAllCheckbox) {
toggleAllCheckbox.addEventListener('change', function() {
actionCheckboxes.forEach(function(checkbox) {
checkbox.checked = toggleAllCheckbox.checked;
});
updateCheckedCounter(actionElement, actionCheckboxes);
});
}
}
}
// update checked state of toggle all checkbox based on all other checkboxes
function updateToggleAllCheckbox(toggleAllCheckbox, actionCheckboxes) {
var allChecked = actionCheckboxes.reduce(function(acc, checkbox) {
return acc && checkbox.checked;
}, true);
toggleAllCheckbox.checked = allChecked;
}
// update value of checked counter
function updateCheckedCounter(actionElement, actionCheckboxes) {
var checkedCounter = actionElement.querySelector(IMPORT_ACTION_CHECKED_COUNTER_SELECTOR);
var checkedCheckboxes = actionCheckboxes.reduce(function(acc, checkbox) { return checkbox.checked ? acc + 1 : acc; }, 0);
checkedCounter.innerHTML = checkedCheckboxes + '/' + actionCheckboxes.length;
}
})();

52
templates/csv-import-confirmation.lucius Normal file
View File

@ -0,0 +1,52 @@
.action {
max-width: 800px;
padding: 3px 0;
&:not(:last-child) {
margin-bottom: 7px;
}
&:not(:first-child) {
margin-top: 7px;
}
}
.action__options {
max-height: 450px;
overflow-y: auto;
}
.action__option {
display: flex;
&:not(:last-child) {
margin-bottom: 10px;
}
}
.action__label,
.action__option-label {
margin-left: 15px;
vertical-align: top;
}
.action__fieldset {
margin: 7px 0 5px 9px;
padding: 5px 0 10px;
border-left: 1px solid #bcbcbc;
padding-left: 16px;
position: relative;
}
.action__toggle-all {
display: flex;
border-bottom: 1px solid #bcbcbc;
padding-bottom: 8px;
margin-bottom: 8px;
}
.action__checked-counter {
position: absolute;
right: 5px;
top: 5px;
}

16
templates/default-layout.lucius
View File

@ -331,22 +331,6 @@ input[type="button"].btn-info:hover,
box-shadow: 0 0 1px 1px var(--color-grey-light);
}
.csv-export, .csv-import {
box-shadow: 0 0 1px 1px var(--color-grey);
* {
margin-right: 10px;
}
*:last-child {
margin-right: 0;
&.modal__trigger {
margin-right: 10px;
}
}
}
@media (max-width: 425px) {
.scrolltable {

12
templates/table/csv-transcode.hamlet
View File

@ -1,8 +1,14 @@
$newline never
$if is _Just dbtCsvDecode
<div .csv-import>
^{csvImportWdgt'}
<h3 .csv-import__toggle uw-show-hide data-show-hide-id=table-csv-import data-show-hide-collapsed>
_{MsgTableHeadingCsvImport}
<div .csv-import__content>
^{csvImportWdgt'}
$if is _Just dbtCsvEncode
<div .csv-export>
^{csvExportWdgt'}
^{csvColExplanations'}
<h3 .csv-import__toggle uw-show-hide data-show-hide-id=table-csv-export>
_{MsgTableHeadingCsvExport}
<div .csv-export__content>
^{csvExportWdgt'}
^{csvColExplanations'}

21
templates/table/csv-transcode.lucius Normal file
View File

@ -0,0 +1,21 @@
.csv-export {
margin-bottom: 13px;
.csv-export__content {
display: flex;
align-content: space-between;
align-items: center;
& > * {
margin-right: 10px;
&:last-child {
margin-right: 0;
}
}
}
}
.csv-import {
margin-bottom: 13px;
}

3
templates/table/layout-filter-default.hamlet
View File

@ -1,6 +1,7 @@
$newline never
<div .table-filter>
<h3 .table-filter__toggle uw-show-hide data-show-hide-id=table-filter data-show-hide-collapsed>Filter
<h3 .table-filter__toggle uw-show-hide data-show-hide-id=table-filter data-show-hide-collapsed>
_{MsgTableHeadingFilter}
<div>
^{filterForm}
^{scrolltable}

1
templates/table/layout.hamlet
View File

@ -5,7 +5,6 @@ $else
<div .table-header>
<div .table__row-count>
_{MsgRowCount rowCount}
^{csvWdgt}
^{table}

7
templates/widgets/aform/aform.hamlet
View File

@ -3,8 +3,9 @@ $newline never
$case formLayout
$of FormDBTablePagesize
$forall view <- fieldViews
<label .form-group-label.label-pagesize for=#{fvId view}>#{fvLabel view}
^{fvInput view}
<div>
<label .form-group-label.label-pagesize for=#{fvId view}>#{fvLabel view}
^{fvInput view}
$of _
$forall view <- fieldViews
$if fvId view == idFormSectionNoinput
@ -23,6 +24,6 @@ $case formLayout
$maybe err <- fvErrors view
<div .form-error>#{err}
$if formHasRequiredFields
<div .form-section-title>
<div .form-section-legend>
<span .form-group__required-marker>
_{MsgAFormFieldRequiredTip}