|
|
|
|
@ -28,7 +28,7 @@ import qualified Data.CaseInsensitive as CI
|
|
|
|
|
-- import Database.Persist.Sql (updateWhereCount)
|
|
|
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
|
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
|
|
|
-- import qualified Database.Esqueleto.Legacy as EL
|
|
|
|
|
import qualified Database.Esqueleto.Legacy as EL (from, on)
|
|
|
|
|
-- import qualified Database.Esqueleto.PostgreSQL as E
|
|
|
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
@ -77,7 +77,7 @@ postFirmR fsh = do
|
|
|
|
|
<ul>
|
|
|
|
|
$forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper
|
|
|
|
|
<li>#{nr} Employees supervised by ^{nameWidget dn sn} #
|
|
|
|
|
#{icon (bool IconAt IconLetter prefPost)} #
|
|
|
|
|
#{iconLetterOrEmail prefPost} #
|
|
|
|
|
$maybe csh <- mbCsh
|
|
|
|
|
$if csh /= fshId
|
|
|
|
|
from foreign company #{unCompanyKey csh}
|
|
|
|
|
@ -112,8 +112,8 @@ data FirmAllActionData = FirmAllActNotifyData
|
|
|
|
|
|
|
|
|
|
-- just in case for future extensions
|
|
|
|
|
type AllCompanyTableExpr = E.SqlExpr (Entity Company)
|
|
|
|
|
queryCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
|
|
|
|
|
queryCompany = id
|
|
|
|
|
queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
|
|
|
|
|
queryAllCompany = id
|
|
|
|
|
|
|
|
|
|
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)
|
|
|
|
|
resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company)
|
|
|
|
|
@ -255,10 +255,8 @@ mkFirmAllTable isAdmin uid = do
|
|
|
|
|
)
|
|
|
|
|
dbtRowKey = (E.^. CompanyId)
|
|
|
|
|
dbtProj = dbtProjId
|
|
|
|
|
dbtColonnade = formColonnade $
|
|
|
|
|
mconcat
|
|
|
|
|
[ if not isAdmin then mempty else -- guardOnM idAdmin $
|
|
|
|
|
dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
|
|
|
|
|
dbtColonnade = formColonnade $ mconcat
|
|
|
|
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
|
|
|
|
|
, sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
|
|
|
|
|
anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm
|
|
|
|
|
, sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
|
|
|
|
|
@ -276,11 +274,13 @@ mkFirmAllTable isAdmin uid = do
|
|
|
|
|
, sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr
|
|
|
|
|
, sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr
|
|
|
|
|
, sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr
|
|
|
|
|
, sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
|
|
|
|
]
|
|
|
|
|
dbtSorting = mconcat
|
|
|
|
|
[ singletonMap "name" $ SortColumn (E.^. CompanyName)
|
|
|
|
|
, singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
|
|
|
|
|
, singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId)
|
|
|
|
|
, singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal)
|
|
|
|
|
, singletonMap "users" $ SortColumn firmCountUsers
|
|
|
|
|
, singletonMap "supervisors" $ SortColumn firmCountSupervisors
|
|
|
|
|
, singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
|
|
|
|
|
@ -292,12 +292,12 @@ mkFirmAllTable isAdmin uid = do
|
|
|
|
|
, singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
|
|
|
|
|
]
|
|
|
|
|
dbtFilter = mconcat
|
|
|
|
|
[ single $ fltrCompanyNameNr queryCompany
|
|
|
|
|
[ single $ fltrCompanyNameNr queryAllCompany
|
|
|
|
|
, single ("is-supervisor", FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
|
|
|
|
|
(usr :& usrCmp) <- E.from $ E.table @User
|
|
|
|
|
`E.innerJoin` E.table @UserCompany
|
|
|
|
|
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
|
|
|
|
|
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryCompany row E.^. CompanyId
|
|
|
|
|
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
|
|
|
|
|
E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
|
|
|
|
|
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
|
|
|
|
|
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
|
|
|
|
|
@ -374,31 +374,171 @@ data FirmUserActionData = FirmUserActNotifyData
|
|
|
|
|
| FirmUserActMkSuperData
|
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
|
|
|
|
|
|
type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany)
|
|
|
|
|
|
|
|
|
|
queryUserUser :: UserCompanyTableExpr -> E.SqlExpr (Entity User)
|
|
|
|
|
queryUserUser = $(sqlIJproj 2 1)
|
|
|
|
|
|
|
|
|
|
queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
|
|
|
|
|
queryUserUserCompany = $(sqlIJproj 2 2)
|
|
|
|
|
|
|
|
|
|
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64)
|
|
|
|
|
|
|
|
|
|
resultUserUser :: Lens' UserCompanyTableData (Entity User)
|
|
|
|
|
resultUserUser = _dbrOutput . _1
|
|
|
|
|
|
|
|
|
|
resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany)
|
|
|
|
|
resultUserUserCompany = _dbrOutput . _2
|
|
|
|
|
|
|
|
|
|
resultUserCompanySupervisors :: Lens' UserCompanyTableData Word64
|
|
|
|
|
resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
|
|
|
|
|
|
|
|
|
|
resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
|
|
|
|
|
resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
|
|
|
|
|
|
|
|
|
|
instance HasEntity UserCompanyTableData User where
|
|
|
|
|
hasEntity = resultUserUser
|
|
|
|
|
|
|
|
|
|
instance HasUser UserCompanyTableData where
|
|
|
|
|
hasUser = resultUserUser . _entityVal
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
|
|
|
|
|
firmCountUserSupervisors usrCmp = E.subSelectCount $ do
|
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
|
|
|
|
|
|
|
|
|
|
firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64)
|
|
|
|
|
firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do
|
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
|
|
|
|
|
E.&&. usrSpr E.^. UserSupervisorRerouteNotifications
|
|
|
|
|
|
|
|
|
|
mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget)
|
|
|
|
|
mkFirmUserTable isAdmin cid = do
|
|
|
|
|
let
|
|
|
|
|
fsh = unCompanyKey cid
|
|
|
|
|
resultDBTable = DBTable{..}
|
|
|
|
|
where
|
|
|
|
|
dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
|
|
|
|
|
EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
|
|
|
|
|
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
|
|
|
|
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
|
|
|
|
|
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
|
|
|
|
dbtProj = dbtProjId
|
|
|
|
|
dbtColonnade = formColonnade $ mconcat
|
|
|
|
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
|
|
|
|
|
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
|
|
|
|
|
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr
|
|
|
|
|
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
|
|
|
|
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr
|
|
|
|
|
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
|
|
|
|
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
|
|
|
|
, colUserEmail
|
|
|
|
|
]
|
|
|
|
|
dbtSorting = mconcat
|
|
|
|
|
[ single $ sortUserNameLink queryUserUser
|
|
|
|
|
, single $ sortUserEmail queryUserUser
|
|
|
|
|
, singletonMap "postal-pref" $ SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal)
|
|
|
|
|
, singletonMap "matriculation" $ SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer)
|
|
|
|
|
, singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)
|
|
|
|
|
, singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
|
|
|
|
|
, singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
|
|
|
|
|
]
|
|
|
|
|
dbtFilter = mconcat
|
|
|
|
|
[ single $ fltrUserNameEmail queryUserUser
|
|
|
|
|
, singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
|
let checkSuper = do
|
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
|
in case criterion of
|
|
|
|
|
Nothing -> E.true
|
|
|
|
|
Just True -> E.exists checkSuper
|
|
|
|
|
Just False -> E.notExists checkSuper
|
|
|
|
|
, singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) ->
|
|
|
|
|
let checkSuper = do
|
|
|
|
|
usrSpr <- E.from $ E.table @UserSupervisor
|
|
|
|
|
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
|
|
|
|
|
E.&&. E.exists (do
|
|
|
|
|
spr <- E.from $ E.table @UserCompany
|
|
|
|
|
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
|
|
|
|
E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor
|
|
|
|
|
)
|
|
|
|
|
in case criterion of
|
|
|
|
|
Nothing -> E.true
|
|
|
|
|
Just True -> E.exists checkSuper
|
|
|
|
|
Just False -> E.notExists checkSuper
|
|
|
|
|
]
|
|
|
|
|
dbtFilterUI mPrev = mconcat
|
|
|
|
|
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
|
|
|
|
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
|
|
|
|
|
, prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
|
|
|
|
|
]
|
|
|
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
|
|
|
acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
|
|
|
|
|
acts = mconcat
|
|
|
|
|
[ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
|
|
|
|
|
, singletonMap FirmUserActMkSuper $ pure FirmUserActMkSuperData
|
|
|
|
|
]
|
|
|
|
|
dbtParams = DBParamsForm
|
|
|
|
|
{ dbParamsFormMethod = POST
|
|
|
|
|
, dbParamsFormAction = Nothing
|
|
|
|
|
, dbParamsFormAttrs = []
|
|
|
|
|
, dbParamsFormSubmit = FormSubmit
|
|
|
|
|
, dbParamsFormAdditional
|
|
|
|
|
= renderAForm FormStandard $ (, mempty) . First . Just
|
|
|
|
|
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
|
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
|
|
|
, dbParamsFormResult = id
|
|
|
|
|
, dbParamsFormIdent = def
|
|
|
|
|
}
|
|
|
|
|
dbtIdent :: Text
|
|
|
|
|
dbtIdent = "firm-users"
|
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
|
|
|
dbtCsvDecode = Nothing
|
|
|
|
|
dbtExtraReps = []
|
|
|
|
|
|
|
|
|
|
postprocess :: FormResult (First FirmUserActionData, DBFormResult UserId Bool UserCompanyTableData)
|
|
|
|
|
-> FormResult ( FirmUserActionData, Set UserId)
|
|
|
|
|
postprocess inp = do
|
|
|
|
|
(First (Just act), m) <- inp
|
|
|
|
|
let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m
|
|
|
|
|
return (act, s)
|
|
|
|
|
|
|
|
|
|
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
|
|
|
|
|
resultDBTableValidator = def
|
|
|
|
|
& defaultSorting [SortAscBy "user-name"]
|
|
|
|
|
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
|
|
|
|
|
getFirmUsersR = postFirmUsersR
|
|
|
|
|
postFirmUsersR fsh = do
|
|
|
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
|
|
|
let fshId = CompanyKey fsh
|
|
|
|
|
Company{..} <- runDB $ get404 fshId
|
|
|
|
|
(Company{..}, (fusrRes, fusrTable)) <- runDB $ (,)
|
|
|
|
|
<$> get404 fshId
|
|
|
|
|
<*> mkFirmUserTable isAdmin fshId
|
|
|
|
|
formResult fusrRes $ \case
|
|
|
|
|
(FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO"
|
|
|
|
|
(FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO"
|
|
|
|
|
siteLayout (citext2widget companyName) $ do
|
|
|
|
|
setTitle $ citext2Html companyShorthand
|
|
|
|
|
setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")"
|
|
|
|
|
[whamlet|
|
|
|
|
|
<p>
|
|
|
|
|
#{companyPostAddress}
|
|
|
|
|
<p>
|
|
|
|
|
Für neue Firmangehörige ist Benachrichtigungs-Voreinstellung:
|
|
|
|
|
$if companyPrefersPostal
|
|
|
|
|
#{icon IconLetter} Briefversand
|
|
|
|
|
$else
|
|
|
|
|
#{icon IconAt} Email
|
|
|
|
|
<p>
|
|
|
|
|
AVS Nummer #{companyAvsId}
|
|
|
|
|
|
|
|
|
|
<h1>
|
|
|
|
|
!!!STUB!!!TO DO!!!
|
|
|
|
|
<p>
|
|
|
|
|
Table showing all company associated users
|
|
|
|
|
<section>
|
|
|
|
|
<p>
|
|
|
|
|
#{companyPostAddress}
|
|
|
|
|
<p>
|
|
|
|
|
Benachrichtigungs-Voreinstellung für neue Firmangehörige: #
|
|
|
|
|
$if companyPrefersPostal
|
|
|
|
|
#{icon IconLetter} Briefversand
|
|
|
|
|
$else
|
|
|
|
|
#{icon IconAt} Email
|
|
|
|
|
<section>
|
|
|
|
|
<h4>
|
|
|
|
|
Company associated users, excluding foreign supervisors
|
|
|
|
|
<p>
|
|
|
|
|
^{fusrTable}
|
|
|
|
|
|]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -412,513 +552,3 @@ postFirmSupersR fsh = do
|
|
|
|
|
siteLayout (citext2widget fsh) $ do
|
|
|
|
|
setTitle $ citext2Html fsh
|
|
|
|
|
[whamlet|!!!STUB!!!TO DO!!!|]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
|
|
|
|
|
-- { qtcDisplayName :: UserDisplayName
|
|
|
|
|
-- , qtcEmail :: UserEmail
|
|
|
|
|
-- , qtcCompany :: Maybe Text
|
|
|
|
|
-- , qtcCompanyNumbers :: CsvSemicolonList Int
|
|
|
|
|
-- , qtcValidUntil :: Day
|
|
|
|
|
-- , qtcLastRefresh :: Day
|
|
|
|
|
-- , qtcBlockStatus :: Maybe Bool
|
|
|
|
|
-- , qtcBlockFrom :: Maybe UTCTime
|
|
|
|
|
-- , qtcScheduleRenewal:: Bool
|
|
|
|
|
-- , qtcLmsStatusTxt :: Maybe Text
|
|
|
|
|
-- , qtcLmsStatusDay :: Maybe UTCTime
|
|
|
|
|
-- }
|
|
|
|
|
-- deriving Generic
|
|
|
|
|
-- makeLenses_ ''QualificationTableCsv
|
|
|
|
|
|
|
|
|
|
-- qtcExample :: QualificationTableCsv
|
|
|
|
|
-- qtcExample = QualificationTableCsv
|
|
|
|
|
-- { qtcDisplayName = "Max Mustermann"
|
|
|
|
|
-- , qtcEmail = "m.mustermann@example.com"
|
|
|
|
|
-- , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
|
|
|
|
|
-- , qtcCompanyNumbers = CsvSemicolonList [27,69]
|
|
|
|
|
-- , qtcValidUntil = compDay
|
|
|
|
|
-- , qtcLastRefresh = compDay
|
|
|
|
|
-- , qtcBlockStatus = Nothing
|
|
|
|
|
-- , qtcBlockFrom = Nothing
|
|
|
|
|
-- , qtcScheduleRenewal= True
|
|
|
|
|
-- , qtcLmsStatusTxt = Just "Success"
|
|
|
|
|
-- , qtcLmsStatusDay = Just compTime
|
|
|
|
|
-- }
|
|
|
|
|
-- where
|
|
|
|
|
-- compTime :: UTCTime
|
|
|
|
|
-- compTime = $compileTime
|
|
|
|
|
-- compDay :: Day
|
|
|
|
|
-- compDay = utctDay compTime
|
|
|
|
|
|
|
|
|
|
-- qtcOptions :: Csv.Options
|
|
|
|
|
-- qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
|
|
|
|
|
-- where
|
|
|
|
|
-- renameLtc "qtcDisplayName" = "licensee"
|
|
|
|
|
-- renameLtc other = replaceLtc $ camelToPathPiece' 1 other
|
|
|
|
|
-- replaceLtc ('l':'m':'s':'-':t) = prefixLms t
|
|
|
|
|
-- replaceLtc other = other
|
|
|
|
|
-- prefixLms = ("elearn-" <>)
|
|
|
|
|
|
|
|
|
|
-- instance Csv.ToNamedRecord QualificationTableCsv where
|
|
|
|
|
-- toNamedRecord = Csv.genericToNamedRecord qtcOptions
|
|
|
|
|
|
|
|
|
|
-- instance Csv.DefaultOrdered QualificationTableCsv where
|
|
|
|
|
-- headerOrder = Csv.genericHeaderOrder qtcOptions
|
|
|
|
|
|
|
|
|
|
-- instance CsvColumnsExplained QualificationTableCsv where
|
|
|
|
|
-- csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
|
|
|
|
|
-- [ ('qtcDisplayName , SomeMessage MsgLmsUser)
|
|
|
|
|
-- , ('qtcEmail , SomeMessage MsgTableLmsEmail)
|
|
|
|
|
-- , ('qtcCompany , SomeMessage MsgTableCompanies)
|
|
|
|
|
-- , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
|
|
|
|
|
-- , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
|
|
|
|
|
-- , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
|
|
|
|
|
-- , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
|
|
|
|
|
-- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
|
|
|
|
|
-- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
|
|
|
|
|
-- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
|
|
|
|
|
-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
|
|
|
|
|
-- ]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- 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 QualificationUserBlock))
|
|
|
|
|
|
|
|
|
|
-- queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser)
|
|
|
|
|
-- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
|
|
|
|
|
|
|
|
|
-- queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User)
|
|
|
|
|
-- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
|
|
|
|
|
|
|
|
|
-- queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
|
|
|
|
|
-- queryLmsUser = $(sqlLOJproj 3 2)
|
|
|
|
|
|
|
|
|
|
-- queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
|
|
|
|
-- queryQualBlock = $(sqlLOJproj 3 3)
|
|
|
|
|
|
|
|
|
|
-- type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
|
|
|
|
|
|
|
|
|
|
-- resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
|
|
|
|
|
-- resultQualUser = _dbrOutput . _1
|
|
|
|
|
|
|
|
|
|
-- resultUser :: Lens' QualificationTableData (Entity User)
|
|
|
|
|
-- resultUser = _dbrOutput . _2
|
|
|
|
|
|
|
|
|
|
-- resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
|
|
|
|
|
-- resultLmsUser = _dbrOutput . _3 . _Just
|
|
|
|
|
|
|
|
|
|
-- resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
|
|
|
|
|
-- resultQualBlock = _dbrOutput . _4 . _Just
|
|
|
|
|
|
|
|
|
|
-- resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
|
|
|
|
|
-- resultCompanyUser = _dbrOutput . _5
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- instance HasEntity QualificationTableData User where
|
|
|
|
|
-- hasEntity = resultUser
|
|
|
|
|
|
|
|
|
|
-- instance HasUser QualificationTableData where
|
|
|
|
|
-- hasUser = resultUser . _entityVal
|
|
|
|
|
|
|
|
|
|
-- instance HasEntity QualificationTableData QualificationUser where
|
|
|
|
|
-- hasEntity = resultQualUser
|
|
|
|
|
|
|
|
|
|
-- instance HasQualificationUser QualificationTableData where
|
|
|
|
|
-- hasQualificationUser = resultQualUser . _entityVal
|
|
|
|
|
|
|
|
|
|
-- -- instance HasEntity QualificationUserBlock where
|
|
|
|
|
-- -- hasQualificationUserBlock = resultQualBlock
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- data QualificationTableAction
|
|
|
|
|
-- = QualificationActExpire
|
|
|
|
|
-- | QualificationActUnexpire
|
|
|
|
|
-- | QualificationActBlockSupervisor
|
|
|
|
|
-- | QualificationActBlock
|
|
|
|
|
-- | QualificationActUnblock
|
|
|
|
|
-- | QualificationActRenew
|
|
|
|
|
-- | QualificationActGrant
|
|
|
|
|
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
|
|
|
|
|
|
-- instance Universe QualificationTableAction
|
|
|
|
|
-- instance Finite QualificationTableAction
|
|
|
|
|
-- nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
|
|
|
|
|
-- embedRenderMessage ''UniWorX ''QualificationTableAction id
|
|
|
|
|
|
|
|
|
|
-- {-
|
|
|
|
|
-- isAdminAct :: QualificationTableAction -> Bool
|
|
|
|
|
-- isAdminAct QualificationActExpire = False
|
|
|
|
|
-- isAdminAct QualificationActUnexpire = False
|
|
|
|
|
-- isAdminAct QualificationActBlockSupervisor = False
|
|
|
|
|
-- isAdminAct _ = True
|
|
|
|
|
-- -}
|
|
|
|
|
|
|
|
|
|
-- data QualificationTableActionData
|
|
|
|
|
-- = QualificationActExpireData
|
|
|
|
|
-- | QualificationActUnexpireData
|
|
|
|
|
-- | QualificationActBlockSupervisorData
|
|
|
|
|
-- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
|
|
|
|
|
-- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
|
|
|
|
|
-- | QualificationActRenewData
|
|
|
|
|
-- | QualificationActGrantData { qualTableActGrantUntil :: Day }
|
|
|
|
|
-- deriving (Eq, Ord, Show, Generic)
|
|
|
|
|
|
|
|
|
|
-- isExpiryAct :: QualificationTableActionData -> Bool
|
|
|
|
|
-- isExpiryAct QualificationActExpireData = True
|
|
|
|
|
-- isExpiryAct QualificationActUnexpireData = True
|
|
|
|
|
-- isExpiryAct _ = False
|
|
|
|
|
|
|
|
|
|
-- isBlockAct :: QualificationTableActionData -> Bool
|
|
|
|
|
-- isBlockAct QualificationActBlockSupervisorData = True
|
|
|
|
|
-- isBlockAct QualificationActBlockData{} = True
|
|
|
|
|
-- isBlockAct QualificationActUnblockData{} = True
|
|
|
|
|
-- isBlockAct _ = False
|
|
|
|
|
|
|
|
|
|
-- blockActRemoveSupervisors :: QualificationTableActionData -> Bool
|
|
|
|
|
-- blockActRemoveSupervisors QualificationActBlockSupervisorData = True
|
|
|
|
|
-- blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res
|
|
|
|
|
-- blockActRemoveSupervisors _ = False
|
|
|
|
|
|
|
|
|
|
-- -- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
|
|
|
|
|
-- -- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
|
|
|
|
-- -- , E.SqlExpr (Entity User)
|
|
|
|
|
-- -- , E.SqlExpr (Maybe (Entity LmsUser))
|
|
|
|
|
-- -- )
|
|
|
|
|
-- -- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = 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)
|
|
|
|
|
|
|
|
|
|
-- qualificationTableQuery :: UTCTime -> 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 QualificationUserBlock))
|
|
|
|
|
-- )
|
|
|
|
|
-- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
|
|
|
|
-- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
|
|
|
|
|
-- --
|
|
|
|
|
-- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
|
|
|
|
|
-- E.&&. qualBlock `isLatestBlockBefore` E.val now
|
|
|
|
|
-- 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, qualBlock)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- mkQualificationTable ::
|
|
|
|
|
-- ( Functor h, ToSortable h
|
|
|
|
|
-- , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
|
|
|
|
|
-- )
|
|
|
|
|
-- => Bool
|
|
|
|
|
-- -> Entity Qualification
|
|
|
|
|
-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
|
|
|
|
-- -> (Map CompanyId 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
|
|
|
|
|
-- svs <- getSupervisees
|
|
|
|
|
-- now <- liftIO getCurrentTime
|
|
|
|
|
-- -- lookup all companies
|
|
|
|
|
-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
|
|
|
|
|
-- cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
|
|
|
|
-- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
|
|
|
|
-- let
|
|
|
|
|
-- nowaday = utctDay now
|
|
|
|
|
-- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
|
|
|
|
-- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
|
|
|
|
|
-- dbtIdent :: Text
|
|
|
|
|
-- dbtIdent = "qualification"
|
|
|
|
|
-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs
|
|
|
|
|
-- dbtSQLQuery = qualificationTableQuery now qid fltrSvs
|
|
|
|
|
-- dbtRowKey = queryUser >>> (E.^. UserId)
|
|
|
|
|
-- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> 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, qUsrBlock, cmpUsr)
|
|
|
|
|
-- dbtColonnade = cols cmpMap
|
|
|
|
|
-- dbtSorting = mconcat
|
|
|
|
|
-- [ single $ sortUserNameLink queryUser
|
|
|
|
|
-- , single $ sortUserEmail queryUser
|
|
|
|
|
-- , single $ sortUserMatriclenr queryUser
|
|
|
|
|
-- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
|
|
|
|
-- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
|
|
|
|
-- , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
|
|
|
|
|
-- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
|
|
|
|
-- , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
|
|
|
|
-- , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
|
|
|
|
|
-- , E.joinV (queryLmsUser row E.?. LmsUserNotified)
|
|
|
|
|
-- , queryLmsUser row E.?. LmsUserStarted])
|
|
|
|
|
-- , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
|
|
|
|
-- , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
|
|
|
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
|
|
|
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
|
|
|
|
|
-- E.orderBy [E.asc (comp E.^. CompanyName)]
|
|
|
|
|
-- return (comp E.^. CompanyName)
|
|
|
|
|
-- )
|
|
|
|
|
-- -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
|
|
|
|
|
-- ]
|
|
|
|
|
-- dbtFilter = mconcat
|
|
|
|
|
-- [ single $ fltrUserNameEmail queryUser
|
|
|
|
|
-- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
|
|
|
|
|
-- E.from $ \usrAvs -> -- do
|
|
|
|
|
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
|
|
|
|
|
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
|
|
|
|
|
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
|
|
|
|
|
-- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
|
|
|
|
|
-- Nothing -> E.false
|
|
|
|
|
-- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
|
|
|
|
|
-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
|
|
|
|
|
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
|
|
|
|
|
-- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
|
|
|
|
|
-- )
|
|
|
|
|
-- , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
|
|
|
|
|
-- | Set.null criteria -> E.true
|
|
|
|
|
-- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
|
|
|
|
|
-- )
|
|
|
|
|
-- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
|
|
|
|
|
-- E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
|
|
|
|
-- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
|
|
|
|
|
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
|
|
|
|
|
-- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
|
|
|
|
|
-- testcrit = maybe testname testnumber $ readMay $ CI.original criterion
|
|
|
|
|
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
|
|
|
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
|
|
|
|
-- )
|
|
|
|
|
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
|
|
|
|
|
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
|
|
|
|
|
-- if | Just renewal <- mbRenewal
|
|
|
|
|
-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
|
|
|
|
|
-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
|
|
|
|
-- | otherwise -> E.true
|
|
|
|
|
-- )
|
|
|
|
|
-- , single ("tobe-notified", FilterColumn $ \row criterion ->
|
|
|
|
|
-- if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
|
|
|
|
|
-- | otherwise -> E.true
|
|
|
|
|
-- )
|
|
|
|
|
-- , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
|
|
|
|
|
-- ]
|
|
|
|
|
-- dbtFilterUI mPrev = mconcat
|
|
|
|
|
-- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
|
|
|
|
-- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
|
|
|
|
-- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
|
|
|
|
|
-- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
|
|
|
|
|
-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
|
|
|
|
|
-- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
|
|
|
|
-- , if isNothing mbRenewal then mempty
|
|
|
|
|
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
|
|
|
|
-- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
|
|
|
|
|
-- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
|
|
|
|
|
-- ]
|
|
|
|
|
-- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
|
|
|
-- dbtCsvEncode = Just DBTCsvEncode
|
|
|
|
|
-- { dbtCsvExportForm = pure ()
|
|
|
|
|
-- , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
|
|
|
|
-- , dbtCsvName = csvName
|
|
|
|
|
-- , dbtCsvSheetName = csvName
|
|
|
|
|
-- , dbtCsvNoExportData = Just id
|
|
|
|
|
-- , dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample
|
|
|
|
|
-- , dbtCsvExampleData = Just [qtcExample]
|
|
|
|
|
-- }
|
|
|
|
|
-- where
|
|
|
|
|
-- doEncode' :: QualificationTableData -> QualificationTableCsv
|
|
|
|
|
-- doEncode' = QualificationTableCsv
|
|
|
|
|
-- <$> view (resultUser . _entityVal . _userDisplayName)
|
|
|
|
|
-- <*> view (resultUser . _entityVal . _userDisplayEmail)
|
|
|
|
|
-- <*> (view resultCompanyUser >>= getCompanies)
|
|
|
|
|
-- <*> (view resultCompanyUser >>= getCompanyNos)
|
|
|
|
|
-- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
|
|
|
|
-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
|
|
|
|
-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
|
|
|
|
|
-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
|
|
|
|
|
-- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
|
|
|
|
|
-- <*> getStatusPlusTxt
|
|
|
|
|
-- <*> getStatusPlusDay
|
|
|
|
|
-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
|
|
|
|
-- [] -> pure Nothing
|
|
|
|
|
-- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
|
|
|
|
|
-- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
|
|
|
|
|
|
|
|
|
|
-- getStatusPlusTxt =
|
|
|
|
|
-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
|
|
|
|
|
-- Just LmsBlocked{} -> return $ Just "Failed"
|
|
|
|
|
-- Just LmsExpired{} -> return $ Just "Expired"
|
|
|
|
|
-- Just LmsSuccess{} -> return $ Just "Success"
|
|
|
|
|
-- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
|
|
|
|
|
-- preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
|
|
|
|
-- getStatusPlusDay =
|
|
|
|
|
-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
|
|
|
|
|
-- lsd@(Just _) -> return lsd
|
|
|
|
|
-- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
|
|
|
|
|
|
|
|
|
-- dbtCsvDecode = Nothing
|
|
|
|
|
-- dbtExtraReps = []
|
|
|
|
|
-- dbtParams = DBParamsForm
|
|
|
|
|
-- { dbParamsFormMethod = POST
|
|
|
|
|
-- , dbParamsFormAction = Nothing
|
|
|
|
|
-- , dbParamsFormAttrs = []
|
|
|
|
|
-- , dbParamsFormSubmit = FormSubmit
|
|
|
|
|
-- , dbParamsFormAdditional
|
|
|
|
|
-- = renderAForm FormStandard
|
|
|
|
|
-- $ (, mempty) . First . Just
|
|
|
|
|
-- <$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
|
|
|
-- , dbParamsFormEvaluate = liftHandler . runFormPost
|
|
|
|
|
-- , dbParamsFormResult = id
|
|
|
|
|
-- , dbParamsFormIdent = def
|
|
|
|
|
-- }
|
|
|
|
|
|
|
|
|
|
-- postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)
|
|
|
|
|
-- -> FormResult ( QualificationTableActionData, Set UserId)
|
|
|
|
|
-- postprocess inp = do
|
|
|
|
|
-- (First (Just act), usrMap) <- inp
|
|
|
|
|
-- let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
|
|
|
|
-- return (act, usrSet)
|
|
|
|
|
|
|
|
|
|
-- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData))
|
|
|
|
|
-- -- resultDBTableValidator = def
|
|
|
|
|
-- -- & defaultSorting [SortAscBy csvLmsIdent]
|
|
|
|
|
-- over _1 postprocess <$> dbTable psValidator DBTable{..}
|
|
|
|
|
|
|
|
|
|
-- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
|
|
|
-- getQualificationR = postQualificationR
|
|
|
|
|
-- postQualificationR sid qsh = do
|
|
|
|
|
-- isAdmin <- hasReadAccessTo AdminR
|
|
|
|
|
-- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
|
|
|
|
|
-- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
|
|
|
|
|
-- now <- liftIO getCurrentTime
|
|
|
|
|
-- let nowaday = utctDay now
|
|
|
|
|
-- ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
|
|
|
|
|
-- qent@Entity{
|
|
|
|
|
-- entityKey=qid
|
|
|
|
|
-- , entityVal=Qualification{
|
|
|
|
|
-- qualificationAuditDuration=auditMonths
|
|
|
|
|
-- , qualificationValidDuration=validMonths
|
|
|
|
|
-- }} <- getBy404 $ SchoolQualificationShort sid qsh
|
|
|
|
|
|
|
|
|
|
-- -- Block copied to Handler/Qualifications TODO: refactor
|
|
|
|
|
-- let getBlockReasons unblk = E.select $ do
|
|
|
|
|
-- (quser :& qblock) <- E.from $ E.table @QualificationUser
|
|
|
|
|
-- `E.innerJoin` E.table @QualificationUserBlock
|
|
|
|
|
-- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
|
|
|
|
|
-- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
|
|
|
|
-- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
|
|
|
|
|
-- E.groupBy (qblock E.^. QualificationUserBlockReason)
|
|
|
|
|
-- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
|
|
|
|
-- E.orderBy [E.desc countRows']
|
|
|
|
|
-- E.limit 7
|
|
|
|
|
-- pure (qblock E.^. QualificationUserBlockReason)
|
|
|
|
|
-- mkOption :: E.Value Text -> Option Text
|
|
|
|
|
-- mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
|
|
|
|
-- suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
|
|
|
|
|
-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
|
|
|
|
|
-- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
|
|
|
|
|
-- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
|
|
|
|
|
-- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
|
|
|
|
-- acts = mconcat $
|
|
|
|
|
-- [ singletonMap QualificationActExpire $ pure QualificationActExpireData
|
|
|
|
|
-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData
|
|
|
|
|
-- <$ aformMessage msgUnexpire
|
|
|
|
|
-- ] ++ bool
|
|
|
|
|
-- -- nonAdmin actions, ie. Supervisor
|
|
|
|
|
-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
|
|
|
|
|
-- -- Admin-only actions
|
|
|
|
|
-- [ singletonMap QualificationActUnblock $ QualificationActUnblockData
|
|
|
|
|
-- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
|
|
|
|
|
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
|
|
|
|
-- , singletonMap QualificationActBlock $ QualificationActBlockData
|
|
|
|
|
-- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
|
|
|
|
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
|
|
|
|
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
|
|
|
|
|
-- , singletonMap QualificationActRenew $ pure QualificationActRenewData
|
|
|
|
|
-- , singletonMap QualificationActGrant $ QualificationActGrantData
|
|
|
|
|
-- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
|
|
|
|
-- <* aformMessage msgGrantWarning
|
|
|
|
|
-- ] isAdmin
|
|
|
|
|
-- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
|
|
|
|
|
-- linkUserName = bool ForProfileR ForProfileDataR isAdmin
|
|
|
|
|
-- colChoices cmpMap = mconcat
|
|
|
|
|
-- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
|
|
|
-- , colUserNameModalHdr MsgLmsUser linkUserName
|
|
|
|
|
-- , colUserEmail
|
|
|
|
|
-- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
|
|
|
|
-- let icnSuper = text2markup " " <> icon IconSupervisor
|
|
|
|
|
-- cs = [ (cmpName, cmpSpr)
|
|
|
|
|
-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
|
|
|
|
-- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
|
|
|
|
-- ]
|
|
|
|
|
-- companies = intercalate (text2markup ", ") $
|
|
|
|
|
-- (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
|
|
|
|
|
-- in wgtCell companies
|
|
|
|
|
-- , guardMonoid isAdmin colUserMatriclenr
|
|
|
|
|
-- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
|
|
|
|
-- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
|
|
|
|
-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
|
|
|
|
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
|
|
|
|
|
-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
|
|
|
|
|
-- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
|
|
|
|
|
-- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
|
|
|
|
-- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
|
|
|
|
-- , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
|
|
|
|
|
-- $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
|
|
|
|
|
-- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
|
|
|
|
|
-- ]
|
|
|
|
|
-- psValidator = def & defaultSorting [SortDescBy "last-refresh"]
|
|
|
|
|
-- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
|
|
|
|
|
-- return (tbl, qent)
|
|
|
|
|
|
|
|
|
|
-- formResult lmsRes $ \case
|
|
|
|
|
-- (QualificationActRenewData, selectedUsers) | isAdmin -> do
|
|
|
|
|
-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
|
|
|
|
|
-- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
|
|
|
|
-- reloadKeepGetParams $ QualificationR sid qsh
|
|
|
|
|
-- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
|
|
|
|
-- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
|
|
|
|
|
-- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
|
|
|
|
-- reloadKeepGetParams $ QualificationR sid qsh
|
|
|
|
|
-- (action, selectedUsers) | isExpiryAct action -> do
|
|
|
|
|
-- let isUnexpire = action == QualificationActUnexpireData
|
|
|
|
|
-- upd <- runDB $ updateWhereCount
|
|
|
|
|
-- [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
|
|
|
|
|
-- [QualificationUserScheduleRenewal =. isUnexpire]
|
|
|
|
|
-- let msgKind = if upd > 0 then Success else Warning
|
|
|
|
|
-- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
|
|
|
|
|
-- addMessageI msgKind msgVal
|
|
|
|
|
-- reloadKeepGetParams $ QualificationR sid qsh
|
|
|
|
|
-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
|
|
|
|
|
-- let selUserIds = Set.toList selectedUsers
|
|
|
|
|
-- (unblock, reason) = case action of
|
|
|
|
|
-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
|
|
|
|
|
-- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
|
|
|
|
|
-- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
|
|
|
|
|
-- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
|
|
|
|
|
-- notify = case action of
|
|
|
|
|
-- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
|
|
|
|
|
-- _ -> False
|
|
|
|
|
|
|
|
|
|
-- oks <- runDB $ do
|
|
|
|
|
-- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
|
|
|
|
|
-- qualificationUserBlocking qid selUserIds unblock Nothing reason notify
|
|
|
|
|
-- let nrq = length selectedUsers
|
|
|
|
|
-- warnLevel = if
|
|
|
|
|
-- | oks < 0 -> Error
|
|
|
|
|
-- | oks == nrq -> Success
|
|
|
|
|
-- | otherwise -> Warning
|
|
|
|
|
-- fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock
|
|
|
|
|
-- addMessageI warnLevel $ fbmsg qsh oks nrq
|
|
|
|
|
-- reloadKeepGetParams $ QualificationR sid qsh
|
|
|
|
|
-- _ -> addMessageI Error MsgInvalidFormAction
|
|
|
|
|
|
|
|
|
|
-- let heading = citext2widget $ qualificationName quali
|
|
|
|
|
-- siteLayout heading $ do
|
|
|
|
|
-- setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
|
|
|
|
-- $(widgetFile "qualification")
|
|
|
|
|
|
