236 lines
10 KiB
Haskell
236 lines
10 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
|
|
|
|
module Handler.LMS.User
|
|
( getLmsUserR, postLmsUserR
|
|
)
|
|
where
|
|
|
|
-- TODO: needs complete refactoring! Old RESULT templates follows
|
|
|
|
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 -- TODO not yet supported
|
|
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 -- TODO: this is not used anywhere?!
|
|
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." -- 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 csvResultIdent]
|
|
dbTable resultDBTableValidator resultDBTable
|
|
|
|
getLmsUserR, postLmsUserR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsUserR = postLmsUserR
|
|
postLmsUserR 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")
|