From 797729a248e681d0af6aaf4d3809a0a38883673a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 27 Apr 2023 16:48:43 +0000 Subject: [PATCH] refactor(qualifications): towards using dbtProj for companies (WIP) --- src/Handler/Qualification.hs | 70 +++++++++++++++++++++-------------- src/Handler/Utils/DateTime.hs | 15 +++++++- 2 files changed, 56 insertions(+), 29 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index cfc4ae0da..e3d83f076 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -153,7 +153,7 @@ mkQualificationAllTable = do data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail - , qtcCompany :: Maybe Text + , qtcCompany :: [Text] , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlocked :: Maybe Day @@ -168,7 +168,7 @@ qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" - , qtcCompany = Just "Example Brothers LLC" + , qtcCompany = ["Example Brothers LLC"] , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlocked = Nothing @@ -212,24 +212,19 @@ instance CsvColumnsExplained QualificationTableCsv where type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) `E.InnerJoin` E.SqlExpr (Entity User) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) - `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity UserCompany)) - `E.InnerJoin` E.SqlExpr (Maybe (Entity Company))) + ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 3 2) - -queryCompany :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity Company)) -queryCompany = $(sqlIJproj 2 2) . $(sqlLOJproj 3 3) +queryLmsUser = $(sqlLOJproj 2 2) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity Company)) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany]) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -240,8 +235,8 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just -resultCompany :: Traversal' QualificationTableData (Entity Company) -resultCompany = _dbrOutput . _4 . _Just +resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] +resultCompanyUser = _dbrOutput . _4 instance HasEntity QualificationTableData User where @@ -286,17 +281,14 @@ isBlockAct _ = False qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) - , E.SqlExpr (Maybe (Entity LmsUser)) - , E.SqlExpr (Maybe (Entity Company)) + , E.SqlExpr (Maybe (Entity LmsUser)) ) -qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` (usrComp `E.InnerJoin` company)) = do - E.on $ usrComp E.?. UserCompanyCompany E.==. company E.?. CompanyId - E.on $ usrComp E.?. UserCompanyUser E.?=. user E.^. UserId +qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) - return (qualUser, user, lmsUser, company) + return (qualUser, user, lmsUser) mkQualificationTable :: @@ -306,7 +298,7 @@ mkQualificationTable :: => Bool -> Entity Qualification -> Map QualificationTableAction (AForm Handler QualificationTableActionData) - -> cols + -> (Map CompanyId (Entity Company) -> cols) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do @@ -314,6 +306,12 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime let nowaday = utctDay now + companyStamp = "CompanyMap" <> tshow (roundDownToMinutes 5 now) + -- lookup all companies + cmpMap <- $cachedHereBinary companyStamp $ do + cmps <- selectList [] [Asc CompanyId] + return $ Map.fromAscList $ fmap (\c -> (entityKey c, c)) cmps + let mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text @@ -321,8 +319,15 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjId -- FilteredPostId - dbtColonnade = cols + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do + -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do + -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) + -- E.orderBy [E.asc (comp E.^. CompanyName)] + -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) + cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] + return (qualUsr, usr, lmsUsr, cmpUsr) + dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser @@ -340,8 +345,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) - ) - , single ( "company", SortColumn $ queryCompany >>> (E.?. CompanyName)) + ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -390,7 +394,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) - <*> preview (resultCompany . _entityVal . _companyName . _CI) + <*> pure ["TODO: companies not yet exported"] <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) @@ -456,7 +460,7 @@ postQualificationR sid qsh = do linkLmsUser = toMaybe isAdmin LmsUserR linkUserName = bool ForProfileR ForProfileDataR isAdmin blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin - colChoices = mconcat + colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail @@ -470,7 +474,17 @@ postQualificationR sid qsh = do (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies - , sortable (Just "company") (i18nCell MsgTableCompany) $ \( preview $ resultCompany . _entityVal . _companyName . _CI -> cn) -> cellMaybe textCell cn + , sortable (Just "company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> do + let icnSuper = text2markup " " <> icon IconSupervisor + cs = [ (cmpName, cmpSpr) + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpEnt = Map.lookup cmpId cmpMap + , isJust cmpEnt + , let Just (Entity _ Company{companyName = cmpName}) = cmpEnt + ] + companies = intersperse (text2markup ", ") $ + (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs + pure $ toWgt $ mconcat companies , guardMonoid isAdmin colUserMatriclenr , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index a29ff5f6b..80669b061 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -8,7 +8,8 @@ module Handler.Utils.DateTime ( utcToLocalTime, utcToZonedTime , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple , toTimeOfDay - , toMidnight, beforeMidnight, toMidday, toMorning, addHours + , toMidnight, beforeMidnight, toMidday, toMorning + , toFullHour, roundDownToMinutes, addHours , formatDiffDays, formatCalendarDiffDays , formatTime' , formatTime, formatTimeUser, formatTimeW, formatTimeMail @@ -68,6 +69,18 @@ toMidnight = toTimeOfDay 0 0 0 toMidday :: Day -> UTCTime toMidday = toTimeOfDay 12 0 0 +-- | Round up to next full hour +toFullHour :: UTCTime -> UTCTime +toFullHour t = t{utctDayTime=rounded} + where + rounded = fromInteger $ 3600 * (1 + (truncate (utctDayTime t) `div` 3600)) + +roundDownToMinutes :: Integer -> UTCTime -> UTCTime +roundDownToMinutes f t = t{utctDayTime=rounded} + where + rounded = fromInteger $ factor * (truncate (utctDayTime t) `div` factor) + factor = 60 * f + -- | One second before the end of day beforeMidnight :: Day -> UTCTime beforeMidnight = toTimeOfDay 23 59 59