157 lines
6.0 KiB
Haskell
157 lines
6.0 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.Result
|
|
( getLmsResultR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Csv
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Csv as Csv
|
|
import qualified Data.Conduit.List as C
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import qualified Data.Text.Lens as Text
|
|
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 [ "identification", "day-success" ]
|
|
|
|
instance ToNamedRecord LmsResultTableCsv where
|
|
toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
|
|
[ "identification" Csv..= csvLRTident
|
|
, "day-success" Csv..= csvLRTsuccess
|
|
]
|
|
|
|
instance FromNamedRecord LmsResultTableCsv where
|
|
parseNamedRecord (lsfHeaderTranslate -> csv)
|
|
= LmsResultTableCsv
|
|
<$> csv Csv..: "identification"
|
|
<*> csv Csv..: "day-success"
|
|
|
|
|
|
instance CsvColumnsExplained LmsResultTableCsv where
|
|
csvColumnsExplanations _ = mconcat
|
|
[ single "identification" MsgCsvColumnLmsResultIdent
|
|
, single "timestamp-success" MsgCsvColumnLmsResultSuccess
|
|
]
|
|
where
|
|
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
|
single k v = singletonMap k [whamlet|_{v}|]
|
|
|
|
|
|
mkResultTable :: QualificationId -> DB (Any, Widget)
|
|
mkResultTable 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 "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
|
|
, sortable (Just "sucess") (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success
|
|
] -- TODO: add more columns for manual debugging view !!!
|
|
dbtSorting = Map.fromList
|
|
[ ("ident" , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
|
|
, ("success", SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess))
|
|
-- , ("success", SortColumn . views queryLmsResult (E.^. LmsResultSuccess))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ -- ("ident" , FilterColumn $ queryLmsResult >>> (E.^. LmsResultIdent))
|
|
]
|
|
dbtFilterUI = const mempty -- TODO !!! continue here !!! Manual filtering useful to deal with user complaints!
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "lms-userlist"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing -- TODO !!! continue here !!! CSV Import is the purpose of this page! Just save to DB, create Job to deal with it later!
|
|
dbtExtraReps = []
|
|
|
|
resultDBTableValidator = def
|
|
& defaultSorting [SortAscBy "ident"]
|
|
dbTable resultDBTableValidator resultDBTable
|
|
|
|
getLmsResultR :: QualificationId -> Handler Html
|
|
getLmsResultR qid = do
|
|
lmsTable <- runDB $ view _2 <$> mkResultTable qid
|
|
siteLayoutMsg MsgMenuLmsResult $ do
|
|
setTitleI MsgMenuLmsResult
|
|
$(widgetFile "lms-result")
|