248 lines
10 KiB
Haskell
248 lines
10 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
|
|
{-# OPTIONS -Wno-unused-imports #-} -- TODO: remove me, for debugging only
|
|
{-# OPTIONS -Wno-redundant-constraints #-} -- TODO: remove me, for debugging only
|
|
|
|
|
|
module Handler.LMS
|
|
( getLmsAllR
|
|
, getLmsSchoolR
|
|
, getLmsR , postLmsR
|
|
, getLmsUsersR , getLmsUsersDirectR
|
|
, getLmsUserlistR , postLmsUserlistR
|
|
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
|
|
, getLmsResultR , postLmsResultR
|
|
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
|
|
)
|
|
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
|
|
|
|
import Handler.LMS.Users as Handler.LMS
|
|
import Handler.LMS.Userlist as Handler.LMS
|
|
import Handler.LMS.Result as Handler.LMS
|
|
|
|
getLmsAllR :: Handler Html
|
|
getLmsAllR = error "TODO"
|
|
|
|
getLmsSchoolR :: SchoolId -> Handler Html
|
|
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-school", toPathPiece ssh)])
|
|
|
|
{- --redirect with filering
|
|
getLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsR ssh qsh = redirect (LmsAllR, [("qualification-school" , toPathPiece ssh)
|
|
,("qualification-shorthand", toPathPiece qsh)
|
|
])
|
|
-}
|
|
|
|
{-
|
|
data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
|
|
{ csvLmsUserIdent :: LmsIdent
|
|
, csvLmsUserPin :: Text
|
|
, csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int
|
|
}
|
|
|
|
data LmsCsvExportData = LmsCsvExportData
|
|
|
|
type LmsUserTableExpr = E.SqlExpr (Entity LmsUser)
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
|
|
|
type LmsUserTableData = DBRow ( Entity LmsUser
|
|
, Maybe (Entity User)
|
|
)
|
|
|
|
queryLmsUser :: Getter LmsUserTableExpr (E.SqlExpr (Entity LmsUser))
|
|
queryLmsUser = to $(E.sqlLOJproj 2 1)
|
|
|
|
queryUser :: Getter LmsUserTableExpr (E.SqlExpr (Maybe (Entity User)))
|
|
queryUser = to $(E.sqlLOJproj 2 2)
|
|
|
|
resultLmsUser :: Lens' LmsUserTableData (Entity LmsUser)
|
|
resultLmsUser = _dbrOutput . _1
|
|
|
|
resultUser :: Lens' LmsUserTableData (Maybe (Entity User))
|
|
resultUser = _dbrOutput . _2
|
|
|
|
|
|
getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsR = postLmsR
|
|
postLmsR sid qsh = do
|
|
_qid <- runDB . getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
-- TODO !!! filter table by qid !!!
|
|
|
|
dbtCsvName <- csvLmsUserFilename
|
|
let dbtIdent = "lmsUsers" :: Text
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtSQLQuery = runReaderT $ do
|
|
lmsUser <- view queryLmsUser
|
|
user <- view queryUser
|
|
lift $ do
|
|
E.on $ E.just (lmsUser E.^. LmsUserUser) E.==. user E.?. UserId
|
|
-- TODO where?
|
|
return (lmsUser, user)
|
|
dbtRowKey = queryLmsUser >>> (E.^. LmsUserId)
|
|
dbtProj = dbtProjSimple $ \(lmsUser, user) -> do
|
|
-- return ("abcdefgh", "12345678", False, False, True)
|
|
return ( lmsUser E.^. LmsUserIdent
|
|
, lmsUser E.^. LmsUserPin
|
|
, lmsUser E.^. LmsUserResetPin
|
|
, lmsUser E.^. LmsUserResetPin
|
|
-- , True) -- works, so we need a simple type here indeed
|
|
, isJust $ E.unValue (user E.?. UserCompanyPersonalNumber))
|
|
dbtColonnade = mempty --TODO
|
|
dbtSorting = mempty
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtParams = def
|
|
-- TODO: wip, for reference, see e.g. Handler.Course.Users or Handler.Exam.
|
|
dbtCsvEncode = do
|
|
return $ DBTCsvEncode
|
|
{ dbtCsvExportForm = def
|
|
, dbtCsvDoEncode = \LmsCsvExportData{} -> C.mapM $ \(_lmsUserTableId, row) -> do
|
|
mitarbeiter <- return 1
|
|
return $ LmsUserTableCsv
|
|
(row ^. resultUser . _entityVal . _lmsUserIdent)
|
|
(row ^. resultUser . _entityVal . _lmsUserPin)
|
|
(row ^. resultUser . _entityVal . _lmsUserResetPin . to fromEnum)
|
|
(row ^. resultUser . _entityVal . _lmsUserDelete . to fromEnum)
|
|
mitarbeiter
|
|
, dbtCsvName
|
|
, dbtCsvNoExportData = Nothing
|
|
, dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def
|
|
, dbtCsvExampleData = Nothing
|
|
}
|
|
-- TODO wip, for reference see e.g. Handler.Exam.Users
|
|
dbtCsvDecode = Nothing -- Just DBTCsvDecode
|
|
-- { dbtCsvRowKey = _1
|
|
-- , dbtCsvComputeActions = _2
|
|
-- , dbtCsvClassifyAction = _3
|
|
-- , dbtCsvCoarsenActionClass = _4
|
|
-- , dbtCsvValidateActions = _5
|
|
-- , dbtCsvExecuteActions = _6 -- <- actions based on sent data here
|
|
-- , dbtCsvRenderKey = _7
|
|
-- , dbtCsvRenderActionClass = _8
|
|
-- , dbtCsvRenderException = _9
|
|
-- }
|
|
psValidator = def
|
|
lmsTable = dbTable psValidator DBTable{..}
|
|
|
|
let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging
|
|
siteLayoutMsg MsgMenuLms $ do
|
|
setTitleI MsgMenuLms
|
|
$(widgetFile "lms")
|
|
-}
|
|
|
|
--- old above, new below
|
|
|
|
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
|
|
|
|
|
|
mkLmsTable :: QualificationId -> DB (Any, Widget)
|
|
mkLmsTable qid = do
|
|
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 "school") (i18nCell MsgTableSchool) $ \(view $ resultQualification . _entityVal . _qualificationSchool -> schoolShorthand) -> wgtCell $ toWgt schoolShorthand
|
|
, sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
|
|
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
|
|
] -- TODO: add more columns for manual debugging view !!!
|
|
dbtSorting = Map.fromList
|
|
[ ("school" , SortColumn $ queryQualification >>> (E.^. QualificationSchool))
|
|
, (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
|
|
-- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
|
|
, (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ ("school" , FilterColumn . E.mkExactFilter $ views (to queryQualification) (E.^. QualificationSchool))
|
|
, (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
|
|
, (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess))
|
|
]
|
|
dbtFilterUI = \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter "school" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool)
|
|
, prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
|
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "qualification"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
resultDBTableValidator = def
|
|
& defaultSorting [SortAscBy csvLmsIdent]
|
|
dbTable resultDBTableValidator resultDBTable
|
|
|
|
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsR = postLmsR
|
|
postLmsR sid qsh = do
|
|
lmsTable <- runDB $ do
|
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
view _2 <$> mkLmsTable qid
|
|
siteLayoutMsg MsgMenuLmsResult $ do
|
|
setTitleI MsgMenuLmsResult
|
|
$(widgetFile "lms")
|