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

refactor(qualifications): towards using dbtProj for companies (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2023-04-27 16:48:43 +00:00
parent 26463c6032
commit 797729a248
2 changed files with 56 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
src/Handler/Qualification.hs
View File

@ -153,7 +153,7 @@ mkQualificationAllTable = do
data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
{ qtcDisplayName :: UserDisplayName { qtcDisplayName :: UserDisplayName
, qtcEmail :: UserEmail , qtcEmail :: UserEmail
, qtcCompany :: Maybe Text , qtcCompany :: [Text]
, qtcValidUntil :: Day , qtcValidUntil :: Day
, qtcLastRefresh :: Day , qtcLastRefresh :: Day
, qtcBlocked :: Maybe Day , qtcBlocked :: Maybe Day
@ -168,7 +168,7 @@ qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv qtcExample = QualificationTableCsv
{ qtcDisplayName = "Max Mustermann" { qtcDisplayName = "Max Mustermann"
, qtcEmail = "m.mustermann@example.com" , qtcEmail = "m.mustermann@example.com"
, qtcCompany = Just "Example Brothers LLC" , qtcCompany = ["Example Brothers LLC"]
, qtcValidUntil = compDay , qtcValidUntil = compDay
, qtcLastRefresh = compDay , qtcLastRefresh = compDay
, qtcBlocked = Nothing , qtcBlocked = Nothing
@ -213,23 +213,18 @@ instance CsvColumnsExplained QualificationTableCsv where
type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity UserCompany))
`E.InnerJoin` E.SqlExpr (Maybe (Entity Company)))
queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) 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 :: 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 :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 3 2) queryLmsUser = $(sqlLOJproj 2 2)
queryCompany :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity Company))
queryCompany = $(sqlIJproj 2 2) . $(sqlLOJproj 3 3)
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 :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -240,8 +235,8 @@ resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just resultLmsUser = _dbrOutput . _3 . _Just
resultCompany :: Traversal' QualificationTableData (Entity Company) resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
resultCompany = _dbrOutput . _4 . _Just resultCompanyUser = _dbrOutput . _4
instance HasEntity QualificationTableData User where instance HasEntity QualificationTableData User where
@ -287,16 +282,13 @@ qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) ->
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (Maybe (Entity Company))
) )
qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` (usrComp `E.InnerJoin` company)) = do qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
E.on $ usrComp E.?. UserCompanyCompany E.==. company E.?. CompanyId
E.on $ usrComp E.?. UserCompanyUser E.?=. user E.^. UserId
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser 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.&&. 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.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
return (qualUser, user, lmsUser, company) return (qualUser, user, lmsUser)
mkQualificationTable :: mkQualificationTable ::
@ -306,7 +298,7 @@ mkQualificationTable ::
=> Bool => Bool
-> Entity Qualification -> Entity Qualification
-> Map QualificationTableAction (AForm Handler QualificationTableActionData) -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-> cols -> (Map CompanyId (Entity Company) -> cols)
-> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-> DB (FormResult (QualificationTableActionData, Set UserId), Widget) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do 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 now <- liftIO getCurrentTime
let let
nowaday = utctDay now 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 mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text 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 fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtSQLQuery = qualificationTableQuery qid fltrSvs
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjId -- FilteredPostId dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do
dbtColonnade = cols -- 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 dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , single $ sortUserEmail queryUser
@ -341,7 +346,6 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
E.orderBy [E.asc (comp E.^. CompanyName)] E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName) return (comp E.^. CompanyName)
) )
, single ( "company", SortColumn $ queryCompany >>> (E.?. CompanyName))
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ single $ fltrUserNameEmail queryUser
@ -390,7 +394,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
doEncode' = QualificationTableCsv doEncode' = QualificationTableCsv
<$> view (resultUser . _entityVal . _userDisplayName) <$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail) <*> view (resultUser . _entityVal . _userDisplayEmail)
<*> preview (resultCompany . _entityVal . _companyName . _CI) <*> pure ["TODO: companies not yet exported"]
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay)
@ -456,7 +460,7 @@ postQualificationR sid qsh = do
linkLmsUser = toMaybe isAdmin LmsUserR linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin linkUserName = bool ForProfileR ForProfileDataR isAdmin
blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
colChoices = mconcat colChoices cmpMap = mconcat
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdr MsgLmsUser linkUserName , colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail , colUserEmail
@ -470,7 +474,17 @@ postQualificationR sid qsh = do
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies 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 , guardMonoid isAdmin colUserMatriclenr
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , 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 , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d

15
src/Handler/Utils/DateTime.hs
View File

@ -8,7 +8,8 @@ module Handler.Utils.DateTime
( utcToLocalTime, utcToZonedTime ( utcToLocalTime, utcToZonedTime
, localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
, toTimeOfDay , toTimeOfDay
, toMidnight, beforeMidnight, toMidday, toMorning, addHours , toMidnight, beforeMidnight, toMidday, toMorning
, toFullHour, roundDownToMinutes, addHours
, formatDiffDays, formatCalendarDiffDays , formatDiffDays, formatCalendarDiffDays
, formatTime' , formatTime'
, formatTime, formatTimeUser, formatTimeW, formatTimeMail , formatTime, formatTimeUser, formatTimeW, formatTimeMail
@ -68,6 +69,18 @@ toMidnight = toTimeOfDay 0 0 0
toMidday :: Day -> UTCTime toMidday :: Day -> UTCTime
toMidday = toTimeOfDay 12 0 0 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 -- | One second before the end of day
beforeMidnight :: Day -> UTCTime beforeMidnight :: Day -> UTCTime
beforeMidnight = toTimeOfDay 23 59 59 beforeMidnight = toTimeOfDay 23 59 59