refactor(qualifications): towards using dbtProj for companies (WIP)
This commit is contained in:
parent
26463c6032
commit
797729a248
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user