+ + |] + + +postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html +postLmsResultDirectR sid qsh = do + (_params, files) <- runRequestBody + case files of + [(fhead,file)] -> do + nr <- runDB $ do + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh + runConduit $ fileSource file + .| decodeCsv + .| foldMC (saveResultCsv qid) 0 + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Result mit Header ") <> fhead + [] -> addMessage Error "Es wurde keine Datei übermittelt." + _other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden." + redirect $ LmsResultR sid qsh diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 858559d14..7dbe6c14c 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -2,6 +2,8 @@ module Handler.LMS.Userlist ( getLmsUserlistR, postLmsUserlistR + , getLmsUserlistUploadR, postLmsUserlistUploadR + , postLmsUserlistDirectR ) where @@ -30,8 +32,8 @@ makeLenses_ ''LmsUserlistTableCsv --instance Csv.FromRecord LmsUserlistTableCsv -- csv with headers -lmsUserlistTableCsvHeader :: Csv.Header -lmsUserlistTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsBlocked ] +instance DefaultOrdered LmsUserlistTableCsv where + headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] instance ToNamedRecord LmsUserlistTableCsv where toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord @@ -106,17 +108,17 @@ mkUserlistTable sid qsh qid = do [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed) ] - dbtStyle = def + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "lms-userlist" - dbtCsvEncode = Just DBTCsvEncode {..} + dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample where - dbtCsvExportForm = pure () - dbtCsvNoExportData = Just id - dbtCsvExampleData = Nothing - dbtCsvHeader = const $ return lmsUserlistTableCsvHeader - dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + addExample dce = dce{ dbtCsvExampleData = csvExample } + csvExample = Just + [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} + | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] + ] doEncode' = LmsUserlistTableCsv <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent) <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) @@ -130,11 +132,13 @@ mkUserlistTable sid qsh qid = do { lmsUserlistInsertIdent = csvLULident dbCsvNew , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew } - DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}} -> do - yield $ LmsUserlistUpdateData - { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed & lms2bool - } + DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do + let failedBool = lms2bool csvLULfailed + when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ + yield $ LmsUserlistUpdateData + { lmsUserlistInsertIdent = csvLULident + , lmsUserlistInsertFailed = csvLULfailed & lms2bool + } DBCsvDiffMissing{} -> return () -- no deletion dbtCsvClassifyAction = \case LmsUserlistInsertData{} -> LmsUserlistInsert @@ -193,8 +197,73 @@ getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handl getLmsUserlistR = postLmsUserlistR postLmsUserlistR sid qsh = do lmsTable <- runDB $ do - qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh view _2 <$> mkUserlistTable sid qsh qid siteLayoutMsg MsgMenuLmsUserlist $ do setTitleI MsgMenuLmsUserlist $(widgetFile "lms-userlist") + + +-- Direct File Upload/Download + +--saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend) => +-- Key Qualification -> LmsUserlistTableCsv -> ReaderT backend m () +saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int +saveUserlistCsv qid i LmsUserlistTableCsv{..} = do + now <- liftIO getCurrentTime + void $ upsert + LmsUserlist + { lmsUserlistQualification = qid + , lmsUserlistIdent = csvLULident + , lmsUserlistFailed = csvLULfailed & lms2bool + , lmsUserlistTimestamp = now + } + [ LmsUserlistFailed =. (csvLULfailed & lms2bool) + , LmsUserlistTimestamp =. now + ] + return $ succ i + +makeUserlistUploadForm :: Form FileInfo +makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" + +getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsUserlistUploadR = postLmsUserlistUploadR +postLmsUserlistUploadR sid qsh = do + ((result,widget), enctype) <- runFormPost makeUserlistUploadForm + case result of + FormSuccess file -> do + nr <- runDB $ do + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh + runConduit $ fileSource file + .| decodeCsv + .| foldMC (saveUserlistCsv qid) 0 + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") + redirect $ LmsUserlistR sid qsh + FormFailure errs -> do + forM_ errs $ addMessage Error . toHtml + redirect $ LmsUserlistUploadR sid qsh + FormMissing -> + siteLayoutMsg MsgMenuLmsUserlist $ do + setTitleI MsgMenuLmsUpload + [whamlet|$newline never +
+ + |] + + +postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html +postLmsUserlistDirectR sid qsh = do + (_params, files) <- runRequestBody + case files of + [(fhead,file)] -> do + nr <- runDB $ do + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh + runConduit $ fileSource file + .| decodeCsv + .| foldMC (saveUserlistCsv qid) 0 + addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen für Userlit mit Header ") <> fhead + [] -> addMessage Error "Es wurde keine Datei übermittelt." + _other -> addMessage Error "Es darf nur genau eine Datei übermittelt werden." + redirect $ LmsUserlistR sid qsh \ No newline at end of file diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 6f541f030..f10585b62 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -1,8 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only +{- LANGUAGE TypeApplications -} -- only needed for Database.Esqueleto.Experimental module Handler.LMS.Users - ( getLmsUsersR, postLmsUsersR + ( getLmsUsersR + , getLmsUsersDirectR ) where @@ -17,6 +18,7 @@ import Handler.Utils.LMS import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Conduit.List as C +-- import qualified Database.Esqueleto.Experimental as Ex import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E @@ -28,6 +30,15 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only deriving Generic makeLenses_ ''LmsUserTableCsv +-- | Mundane conversion needed for direct download without dbTable onlu +lmsUser2csv :: LmsUser -> LmsUserTableCsv +lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv + { csvLUTident = lmsUserIdent + , csvLUTpin = lmsUserPin + , csvLUTresetPin = lmsUserResetPin & LmsBool + , csvLUTdelete = lmsUserToDelete lu & LmsBool + , csvLUTstaff = False & LmsBool + } -- csv without headers -- TODO not yet supported -- instance Csv.ToRecord LmsUserTableCsv @@ -77,6 +88,7 @@ mkUserTable _sid qsh qid = do where dbtSQLQuery lmsuser = do E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid + E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) return lmsuser dbtRowKey = (E.^. LmsUserId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? @@ -85,11 +97,13 @@ mkUserTable _sid qsh qid = do , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser - , sortable (Just csvLmsStaff) (i18nCell MsgTableLmsStaff) $ const mempty + , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty ] dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserIdent) - , (csvLmsResetPin , SortColumn $ \lmslist -> lmslist E.^. LmsUserResetPin) + [ (csvLmsIdent , SortColumn (E.^. LmsUserIdent)) + , (csvLmsPin , SortColumn (E.^. LmsUserPin)) + , (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin)) + , (csvLmsDelete , SortColumn lmsUserToDeleteExpr) ] dbtFilter = Map.fromList [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) @@ -99,7 +113,7 @@ mkUserTable _sid qsh qid = do [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin) ] - dbtStyle = def + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "lms-user" @@ -115,8 +129,7 @@ mkUserTable _sid qsh qid = do <*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) - -- <*> const $ LmsBool False - <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) + <*> const (LmsBool False) dbtCsvDecode = Nothing dbtExtraReps = [] @@ -125,12 +138,38 @@ mkUserTable _sid qsh qid = do & defaultSorting [SortAscBy csvLmsIdent] dbTable userDBTableValidator userDBTable -getLmsUsersR, postLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUsersR = postLmsUsersR -postLmsUsersR sid qsh = do +getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsUsersR sid qsh = do lmsTable <- runDB $ do - qid <- getKeyBy404 $ UniqueSchoolShort sid qsh + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh view _2 <$> mkUserTable sid qsh qid siteLayoutMsg MsgMenuLmsUsers $ do setTitleI MsgMenuLmsUsers $(widgetFile "lms-user") + +getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent +getLmsUsersDirectR sid qsh = do + lms_users <- runDB $ do + qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh + selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent] + {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it + Ex.select $ do + lmsuser <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid + Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded) + pure $ LmsUserTableCsv + { csvLUTident = lmsuser Ex.^. LmsUserIdent + , csvLUTpin = lmsuser Ex.^. LmsUserPin + , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin + , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserSuccess) + , csvLUTstaff = LmsBool False + } + -} + let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users + csvRenderedHeader = lmsUserTableCsvHeader + csvSheetName <- csvFilenameLmsUser qsh + addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" + csvRenderedToTypedContent csvSheetName CsvRendered{..} + +-- direct Download see: +-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 1c9775888..43b849e24 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -13,12 +13,14 @@ module Handler.Utils.LMS , csvFilenameLmsUserlist , csvFilenameLmsResult , lmsUserToDelete, _lmsUserToDelete + , lmsUserToDeleteExpr ) where -- general utils for LMS Interface Handlers import Import import Handler.Utils +import qualified Database.Esqueleto.Legacy as E -- generic Column names csvLmsIdent :: IsString a => a @@ -27,7 +29,7 @@ csvLmsIdent = fromString "user" -- "Benutzerkennung" csvLmsTimestamp :: IsString a => a csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" --- for User Table +-- for Users Table csvLmsPin :: IsString a => a csvLmsPin = fromString "pin" -- "PIN" @@ -72,8 +74,12 @@ getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime -- | Deceide whether LMS platform should delete an identifier +lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) +lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserSuccess) + lmsUserToDelete :: LmsUser -> Bool lmsUserToDelete LmsUser{lmsUserEnded, lmsUserSuccess} = isNothing lmsUserEnded && isJust lmsUserSuccess _lmsUserToDelete :: Getter LmsUser Bool -_lmsUserToDelete = to lmsUserToDelete \ No newline at end of file +_lmsUserToDelete = to lmsUserToDelete + diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 50e666ed0..cfb7b1231 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1066,6 +1066,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db <|> piInput psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit + lch <- lookupCustomHeader HeaderDBTableShortcircuit + $logErrorS "DBShortcircuit" $ fromMaybe mempty lch <> " and also " <> tshow psShortcircuit let -- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 59790590c..3a5ae6ea4 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -11,6 +11,8 @@ import Import.NoModel import Database.Persist.Sql import qualified Database.Esqueleto.Legacy as E import qualified Data.Csv as Csv +import qualified Data.Time.Format as Time +import Data.Time.Format.ISO8601 (iso8601ParseM) import Utils.Lens.TH newtype LmsIdent = LmsIdent { getLmsIdent :: Text } @@ -38,32 +40,7 @@ deriveJSON defaultOptions derivePersistFieldJSON ''LmsStatus --- LMS Interface requires Bool to be encoded by 0 or 1 only -{- -data LmsBool = LmsUnset | LmsSet - deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) - -lms2bool :: LmsBool -> Bool -lms2bool LmsUnset = False -lms2bool LmsSet = True -bool2lms :: Bool -> LmsBool -bool2lms False = LmsUnset -bool2lms True = LmsSet - -_lmsBool :: Iso' Bool LmsBool -_lmsBool = iso bool2lms lms2bool - -instance Csv.ToField LmsBool where - toField LmsUnset = "0" - toField LmsSet = "1" - -instance Csv.FromField LmsBool where - parseField i - | i == "0" = pure LmsUnset - | i == "1" = pure LmsSet - | otherwise = empty --} - +-- | LMS interface requires Bool to be encoded by 0 or 1 only newtype LmsBool = LmsBool { lms2bool :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -78,4 +55,27 @@ instance Csv.FromField LmsBool where parseField i | i == "0" = pure $ LmsBool False | i == "1" = pure $ LmsBool True - | otherwise = empty + | otherwise = mempty + +-- | LMS interface requires day format not compliant with iso8601 +newtype LmsDay = LmsDay { lms2day :: Day } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +_lmsDay :: Iso' Day LmsDay +_lmsDay = iso LmsDay lms2day + +-- | Format for day for LMS interface +lmsDayFormat :: String +lmsDayFormat = "%d-%m-%Y" + +instance Csv.ToField LmsDay where + toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter; getTimeLocale requires MonadHandler + +instance Csv.FromField LmsDay where +-- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField +-- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat + parseField i = do + s <- Csv.parseField i + d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s + <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future + return $ LmsDay d diff --git a/templates/lms-result.hamlet b/templates/lms-result.hamlet index 389ec613d..44ca90389 100644 --- a/templates/lms-result.hamlet +++ b/templates/lms-result.hamlet @@ -1,2 +1,5 @@ LMS Result ^{lmsTable} +
+ + _{MsgLmsDirectUpload} diff --git a/testdata/test_results.csv b/testdata/test_results.csv new file mode 100644 index 000000000..beb80f5ae --- /dev/null +++ b/testdata/test_results.csv @@ -0,0 +1,5 @@ +user,success +barfoo,2022-02-01 +huhuuhu,10-12-2011 +pqgrst,2022-03-07 +hootsman,1994-07-08