{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only module Handler.LMS.Result ( getLmsResultR, postLmsResultR ) where import Import import Handler.Utils import Handler.Utils.Csv 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.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity LmsResult) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification) queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult) queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) queryLmsUser = $(sqlLOJproj 3 2) queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User)) queryUser = $(sqlLOJproj 3 3) type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User)) instance HasEntity LmsResultTableData LmsResult where hasEntity = _dbrOutput . _2 {- MaybeHasUser only! instance HasUser LmsResultTableData where hasUser = _dbrOutput . _4 . _entityVal -} resultQualification :: Lens' LmsResultTableData (Entity Qualification) resultQualification = _dbrOutput . _1 resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult) resultLmsResult = _dbrOutput . _2 resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just resultUser :: Traversal' LmsResultTableData (Entity User) resultUser = _dbrOutput . _4 . _Just -- required for import only data LmsResultTableCsv = LmsResultTableCsv { csvLRTident :: LmsIdent , csvLRTsuccess :: Day } deriving Generic makeLenses_ ''LmsResultTableCsv -- csv without headers instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices -- csv with headers lmsResultTableCsvHeader :: Csv.Header lmsResultTableCsvHeader = Csv.header [ csvResultIdent, csvResultSuccess ] instance ToNamedRecord LmsResultTableCsv where toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord [ csvResultIdent Csv..= csvLRTident , csvResultSuccess Csv..= csvLRTsuccess ] instance FromNamedRecord LmsResultTableCsv where parseNamedRecord (lsfHeaderTranslate -> csv) = LmsResultTableCsv <$> csv Csv..: csvResultIdent <*> csv Csv..: csvResultSuccess instance CsvColumnsExplained LmsResultTableCsv where csvColumnsExplanations _ = mconcat [ single csvResultIdent MsgCsvColumnLmsIdent , single csvResultSuccess MsgCsvColumnLmsSuccess ] where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single k v = singletonMap k [whamlet|_{v}|] data LmsResultCsvActionClass = LmsResultInsert deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id -- By coincidence the action type is identical to LmsResultTableCsv data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success , sumEncoding = TaggedObject "action" "data" } ''LmsResultCsvAction data LmsResultCsvException = LmsResultCsvExceptionDuplicatedKey deriving (Show, Generic, Typeable) instance Exception LmsResultCsvException embedRenderMessage ''UniWorX ''LmsResultCsvException id mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable sid qsh qid = do dbtCsvName <- csvFilenameLmsResult qsh let dbtCsvSheetName = dbtCsvName let resultDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do qualification <- asks queryQualification lmsResult <- asks queryLmsResult lmsUser <- asks queryLmsUser user <- asks queryUser lift $ do E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent) E.on $ lmsUser E.?. LmsUserUser E.==. user E.?. UserId E.where_ $ qualification E.^. QualificationId E.==. E.val qid return (qualification, lmsResult, lmsUser, user) dbtRowKey = queryLmsResult >>> (E.^. LmsResultId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvResultIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvResultSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success ] -- TODO: add more columns for manual debugging view !!! dbtSorting = Map.fromList [ (csvResultIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) -- , (csvResultSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) , (csvResultSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilter = Map.fromList [ (csvResultIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) , (csvResultSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter csvResultIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter csvResultSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess) ] dbtStyle = def dbtParams = def dbtIdent :: Text dbtIdent = "lms-result" dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvName , dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsResultTableCsvHeader , dbtCsvExampleData = Nothing } where doEncode' = LmsResultTableCsv <$> view (resultLmsResult . _entityVal . _lmsResultIdent) <*> view (resultLmsResult . _entityVal . _lmsResultSuccess) dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later { dbtCsvRowKey = \LmsResultTableCsv{..} -> fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident csvLRTsuccess , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do yield $ LmsResultInsertData { lmsResultInsertIdent = csvLRTident dbCsvNew , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew } DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffExisting{} -> return () -- no merge , dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert , dbtCsvCoarsenActionClass = \LmsResultInsert -> DBCsvActionNew -- there is only one action: insert into table , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvExecuteActions = do C.mapM_ $ \LmsResultInsertData{..} -> do now <- liftIO getCurrentTime void $ upsert LmsResult { lmsResultQualification = qid , lmsResultIdent = lmsResultInsertIdent , lmsResultSuccess = lmsResultInsertSuccess , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? } [ LmsResultSuccess =. lmsResultInsertSuccess , LmsResultTimestamp =. now ] -- queueDBJob?? -- todo -- audit return $ LmsResultR sid qsh , dbtCsvRenderKey = \_ LmsResultInsertData{..} -> do [whamlet| $newline never Ident #{getLmsIdent lmsResultInsertIdent} # had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} |] , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text } dbtExtraReps = [] resultDBTableValidator = def & defaultSorting [SortAscBy "ident"] dbTable resultDBTableValidator resultDBTable getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html getLmsResultR = postLmsResultR postLmsResultR sid qsh = do lmsTable <- runDB $ do qid <- getKeyBy404 $ UniqueSchoolShort sid qsh view _2 <$> mkResultTable sid qsh qid siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult $(widgetFile "lms-result")