fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): demo subSelect in dbtSQLQuery vs sqlCell

Browse Source
This commit is contained in:
Steffen Jost 2022-03-23 18:08:44 +01:00
parent 89be36e35b
commit 1f4cabc8da
8 changed files with 63 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -124,7 +124,7 @@ MenuCourseEventEdit: Kurstermin bearbeiten
MenuLanguage: Sprache
MenuQualifications: Qualifkationen
MenuLms: Schnittstelle E-Lernen
MenuLms: E-Lernen
MenuLmsEdit: Bearbeiten E-Lernen
MenuLmsUsers: Export E-Lernen Benutzer
MenuLmsUserlist: Melden E-Lernen Benutzer

2
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -125,7 +125,7 @@ MenuCourseEventEdit: Edit course occurrence
MenuLanguage: Language
MenuQualifications: Qualifcations
MenuLms: Interface E-Learning
MenuLms: E-Learning
MenuLmsEdit: Edit E-Learning
MenuLmsUsers: Download E-Learning Users
MenuLmsUserlist: Upload E-Learning Users

4
models/lms.model
View File

@ -38,13 +38,13 @@ QualificationPrecondition
-- TODO: connect Qualification with Exams!
QualificationEdit
user User
user UserId
time UTCTime
qualification QualificationId OnDeleteCascade OnUpdateCascade
deriving Generic
QualificationUser
user User
user UserId
qualification QualificationId OnDeleteCascade OnUpdateCascade
validUntil UTCTime
lastRefresh UTCTime -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False

6
src/Database/Esqueleto/Utils/TH.hs
View File

@ -3,6 +3,7 @@
module Database.Esqueleto.Utils.TH
( SqlIn(..)
, sqlInTuple, sqlInTuples
, _unValue
, unValueN, unValueNIs
, sqlIJproj, sqlLOJproj, sqlFOJproj
) where
@ -19,6 +20,7 @@ import Language.Haskell.TH
import Data.List (foldr1, foldl)
import Utils.TH
import Control.Lens.Iso (Iso', iso)
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
@ -60,6 +62,10 @@ sqlInTuple arity = do
]
]
_unValue :: Iso' (E.Value v) v
_unValue = iso E.unValue E.Value
-- | Generic unValuing of Tuples of Values, i.e.
--
-- > $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)

54
src/Handler/LMS.hs
View File

@ -1,8 +1,6 @@
{-# 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
{-# LANGUAGE TypeApplications #-}
module Handler.LMS
( getLmsAllR
@ -20,12 +18,13 @@ module Handler.LMS
import Import
import Handler.Utils
import Handler.Utils.Csv
-- 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 Data.Csv as Csv
-- import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
@ -34,6 +33,10 @@ import Handler.LMS.Users as Handler.LMS
import Handler.LMS.Userlist as Handler.LMS
import Handler.LMS.Result as Handler.LMS
getLmsSchoolR :: SchoolId -> Handler Html
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)])
getLmsAllR :: Handler Html
getLmsAllR = do
lmsTable <- runDB $ do
@ -42,10 +45,7 @@ getLmsAllR = do
setTitleI MsgMenuQualifications
$(widgetFile "lms-all")
x :: Int64
x = 42
type AllQualificationTableData = DBRow (Entity Qualification, E.Value Int64)
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64)
queryAllQualification :: Lens' AllQualificationTableData Qualification
queryAllQualification = _dbrOutput . _1 . _entityVal
@ -54,22 +54,37 @@ mkLmsAllTable = do
let
resultDBTable = DBTable{..}
where
dbtSQLQuery = runReaderT $ do
quali <- view id
--count
return (quali, E.val x)
dbtSQLQuery quali = do
-- let x = E.val (42::Word64)
--
-- x <- pure . E.subSelectCount . E.from $ \quser ->
-- E.where_ $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
--
x <- pure . Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
return (quali, x)
dbtRowKey = (E.^. QualificationId)
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = dbColonnade $ mconcat
[ colSchool $ queryAllQualification . _qualificationSchool
, sortable (Just "qualification-shorthand") (i18nCell MsgTableLmsIdent) $ \(view queryAllQualification -> quali) ->
, sortable (Just "qualification-short") (i18nCell MsgTableLmsIdent) $ \(view queryAllQualification -> quali) ->
let qsh = qualificationShorthand quali in
anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
, sortable Nothing (i18nCell MsgTableLmsUser) $ \(view $ _dbrOutput . _1 . _entityKey -> qualid) -> sqlCell $ do
num <- fmap (maybe 0 (max 0 . Ex.unValue) . listToMaybe) .
Ex.select $ do
quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qualid
pure Ex.countRows
return $ word2widget num
, sortable Nothing (i18nCell MsgMenuAdminTest) $ \(view $ _dbrOutput . _2 . _unValue -> n) -> wgtCell $ word2widget n
] -- TODO: add more columns for manual debugging view !!!
dbtSorting = mconcat
[
sortSchool $ to (E.^. QualificationSchool)
, singletonMap "qualification-shorthand" $ SortColumn (E.^. QualificationShorthand)
, singletonMap "qualification-short" $ SortColumn (E.^. QualificationShorthand)
]
dbtFilter = mconcat
[
@ -88,16 +103,11 @@ mkLmsAllTable = do
dbtExtraReps = []
resultDBTableValidator = def
& defaultSorting [SortAscBy "school", SortAscBy "qualification-shorthand"]
& defaultSorting [SortAscBy "school", SortAscBy "qualification-short"]
dbTable resultDBTableValidator resultDBTable
getLmsSchoolR :: SchoolId -> Handler Html
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-school", toPathPiece ssh)])
getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsEditR = postLmsEditR
postLmsEditR = error "TODO"

7
src/Utils.hs
View File

@ -301,6 +301,13 @@ citext2widget t = [whamlet|#{CI.original t}|]
str2widget :: String -> WidgetFor site ()
str2widget s = [whamlet|#{s}|]
int2widget :: Int64 -> WidgetFor site ()
int2widget i = [whamlet|#{tshow i}|]
word2widget :: Word64 -> WidgetFor site ()
word2widget i = [whamlet|#{tshow i}|]
withFragment :: Monad m => MForm m (a, WidgetFor site ()) -> Markup -> MForm m (a, WidgetFor site ())
withFragment form html = flip fmap form $ over _2 (toWidget html >>)

1
templates/lms-all.hamlet Normal file
View File

@ -0,0 +1 @@
^{lmsTable}

15
test/Database/Fill.hs
View File

@ -457,8 +457,18 @@ fillDb = do
for_ [jost] $ \uid ->
void . insert' $ UserSchool uid avn False
qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing True
_qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False
qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing True
qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" Nothing (Just 24) (Just $ 5 * 12) Nothing False
qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" Nothing Nothing (Just $ 5 * 12) Nothing False
void . insert' $ QualificationUser jost qid_f now now now -- TODO: better dates!
void . insert' $ QualificationUser gkleen qid_f now now now
void . insert' $ QualificationUser maxMuster qid_f now now now
void . insert' $ QualificationUser svaupel qid_f now now now
void . insert' $ QualificationUser gkleen qid_r now now now
void . insert' $ QualificationUser maxMuster qid_r now now now
void . insert' $ QualificationUser fhamann qid_r now now now
void . insert' $ QualificationUser svaupel qid_l now now now
void . insert' $ QualificationUser gkleen qid_l now now now
void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (addBDays (-1) $ utctDay now) now
void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (addBDays (-2) $ utctDay now) now
void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (addBDays (-3) $ utctDay now) now
@ -468,6 +478,7 @@ fillDb = do
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False Nothing now Nothing Nothing
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False (Just True) now (Just now) Nothing
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True (Just False) now (Just now) Nothing
let
sdBsc = StudyDegreeKey' 82
sdMst = StudyDegreeKey' 88