343 lines
15 KiB
Haskell
343 lines
15 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
|
|
( getLmsR , postLmsR
|
|
, getLmsUsersR , postLmsUsersR
|
|
, 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
|
|
|
|
{-
|
|
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 $ UniqueQualificationSchoolShort 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
|
|
|
|
-- 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 -- TODO not yet supported
|
|
lmsResultTableCsvHeader :: Csv.Header
|
|
lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
|
|
|
|
instance ToNamedRecord LmsResultTableCsv where
|
|
toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
|
|
[ csvLmsIdent Csv..= csvLRTident
|
|
, csvLmsSuccess Csv..= csvLRTsuccess
|
|
]
|
|
|
|
instance FromNamedRecord LmsResultTableCsv where
|
|
parseNamedRecord (lsfHeaderTranslate -> csv)
|
|
= LmsResultTableCsv
|
|
<$> csv Csv..: csvLmsIdent
|
|
<*> csv Csv..: csvLmsSuccess
|
|
|
|
instance CsvColumnsExplained LmsResultTableCsv where
|
|
csvColumnsExplanations _ = mconcat
|
|
[ single csvLmsIdent MsgCsvColumnLmsIdent
|
|
, single csvLmsSuccess 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 -- TODO: this is not used anywhere?!
|
|
deriving (Show, Generic, Typeable)
|
|
|
|
instance Exception LmsResultCsvException
|
|
embedRenderMessage ''UniWorX ''LmsResultCsvException id
|
|
|
|
|
|
|
|
mkLmsTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
|
mkLmsTable 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 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
|
|
[ (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
|
|
-- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
|
|
, (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent))
|
|
, (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess))
|
|
]
|
|
dbtFilterUI = \mPrev -> mconcat
|
|
[ 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 = "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
|
|
, 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." -- TODO: how can this ever happen? Check Pagination-Code
|
|
DBCsvDiffMissing{} -> return () -- no deletion
|
|
DBCsvDiffExisting{} -> return () -- no merge TODO!!! ADD MERGE DUE TO Uniqueness!
|
|
, 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 -- TODO: i18n
|
|
[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 csvLmsIdent]
|
|
dbTable resultDBTableValidator resultDBTable
|
|
|
|
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsR = postLmsR
|
|
postLmsR sid qsh = do
|
|
lmsTable <- runDB $ do
|
|
qid <- getKeyBy404 $ UniqueQualificationSchoolShort sid qsh
|
|
view _2 <$> mkLmsTable sid qsh qid
|
|
siteLayoutMsg MsgMenuLmsResult $ do
|
|
setTitleI MsgMenuLmsResult
|
|
$(widgetFile "lms")
|