diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 3f00c0168..76cb76561 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index d6a15dbdb..bd5961c49 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -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 diff --git a/models/lms.model b/models/lms.model index ad78eb6cd..da54d513f 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index ff2fefef5..99f037485 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -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) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 852d3559a..97485ff6b 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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" diff --git a/src/Utils.hs b/src/Utils.hs index db515f22d..5775eead2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 >>) diff --git a/templates/lms-all.hamlet b/templates/lms-all.hamlet new file mode 100644 index 000000000..ecfb928b8 --- /dev/null +++ b/templates/lms-all.hamlet @@ -0,0 +1 @@ +^{lmsTable} \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 90b05a4e9..9c66f5f58 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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