Merge branch 'fradrive/newletter'
This commit is contained in:
commit
9e2a964ef7
@ -4,7 +4,9 @@
|
||||
AvsPersonInfo: AVS Personendaten
|
||||
AvsPersonId: AVS Personen Id
|
||||
AvsPersonNo: AVS Personennummer
|
||||
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
|
||||
AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert
|
||||
AvsPersonNoDiffers: Es sind derzeit zwei verschiedene AVS Personennummern zugeordnet. Bitte einen Administrator kontaktieren.
|
||||
AvsCardNo: Ausweiskartennummer
|
||||
AvsFirstName: Vorname
|
||||
AvsLastName: Nachname
|
||||
@ -15,7 +17,6 @@ AvsQueryNeeded: Benötigt Verbindung zum AVS.
|
||||
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
|
||||
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
|
||||
AvsLicence: Fahrberechtigung
|
||||
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
|
||||
AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive
|
||||
BtnAvsRevokeUnknown: Fahrberechtigungen im AVS sofort entziehen
|
||||
BtnAvsImportUnknown: AVS Daten unbekannter Personen importieren
|
||||
@ -45,6 +46,7 @@ AvsCardColorBlue: Blau
|
||||
AvsCardColorRed: Rot
|
||||
AvsCardColorYellow: Gelb
|
||||
LastAvsSynchronisation: Letzte AVS-Synchronisation
|
||||
LastAvsSyncedBefore: Letzte AVS-Synchronisation vor
|
||||
LastAvsSynchError: Letzte AVS-Fehlermeldung
|
||||
|
||||
AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht
|
||||
|
||||
@ -4,7 +4,9 @@
|
||||
AvsPersonInfo: AVS person info
|
||||
AvsPersonId: AVS person id
|
||||
AvsPersonNo: AVS person number
|
||||
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
|
||||
AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive
|
||||
AvsPersonNoDiffers: There are currently two differing AVS person numbers associated with this user. Please contact an administrator to resolve this.
|
||||
AvsCardNo: Card number
|
||||
AvsFirstName: First name
|
||||
AvsLastName: Last name
|
||||
@ -15,7 +17,7 @@ AvsQueryNeeded: AVS connection required.
|
||||
AvsQueryEmpty: At least one query field must be filled!
|
||||
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
|
||||
AvsLicence: Driving Licence
|
||||
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
|
||||
|
||||
AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
|
||||
BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately
|
||||
BtnAvsImportUnknown: Import AVS data for unknown persons
|
||||
@ -45,6 +47,7 @@ AvsCardColorBlue: Blue
|
||||
AvsCardColorRed: Red
|
||||
AvsCardColorYellow: Yellow
|
||||
LastAvsSynchronisation: Last AVS synchronisation
|
||||
LastAvsSyncedBefore: Last AVS synchronisation before
|
||||
LastAvsSynchError: Last AVS Error
|
||||
|
||||
AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond
|
||||
|
||||
@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: Die Anzeige von Kurse, zu denen Sie angemeldet sind wi
|
||||
ProfileGroupSubmissionDates: Bei Gruppenabgaben wird kein Datum angezeigt, wenn Sie die Gruppenabgabe nie selbst hochgeladen haben.
|
||||
ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt. Auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier dann nicht aufgeführt werden.
|
||||
ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
|
||||
Remarks: Hinweise
|
||||
Remarks: Hinweis:
|
||||
|
||||
ProfileSupervisor: Übergeordnete Ansprechpartner
|
||||
ProfileSupervisee: Ist Ansprechpartner für
|
||||
ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden
|
||||
ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
|
||||
ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
|
||||
ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand
|
||||
ProfileSupervisee n@Int m@Int: Ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
|
||||
ProfileSuperviseeRemark n@Int m@Int: Dieser Nutzer ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
|
||||
|
||||
UserTelephone: Telefon
|
||||
UserMobile: Mobiltelefon
|
||||
|
||||
@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: The feature to display courses you have registered for
|
||||
ProfileGroupSubmissionDates: No date is shown for group submissions if you have never uploaded the submission yourself.
|
||||
ProfileCorrectorRemark: The table above only shows registration as a corrector in principle. Even without registration corrections can be assigned individually and are not listed.
|
||||
ProfileCorrections: List of all assigned corrections
|
||||
Remarks: Remarks
|
||||
Remarks: Remark:
|
||||
|
||||
ProfileSupervisor: Supervised by
|
||||
ProfileSupervisee: Supervises
|
||||
ProfileNoSupervisor: Is not supervised by anynone
|
||||
ProfileSupervisor n m: #{pluralENsN n "supervisor"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
|
||||
ProfileSupervisorRemark n@Int m@Int l@Int: #{m}/#{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")}
|
||||
ProfileNoSupervisee: Does not supervise anynone
|
||||
ProfileSupervisee n m: Supervises #{pluralENsN n "person"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
|
||||
ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{noneMoreEN m "" (" with " <> tshow m <> " having active notifications rerouting to this user")}
|
||||
|
||||
UserTelephone: Phone
|
||||
UserMobile: Mobile
|
||||
|
||||
@ -39,7 +39,7 @@ module Foundation.I18n
|
||||
, StudyDegreeTerm(..)
|
||||
, ShortStudyFieldType(..)
|
||||
, StudyDegreeTermType(..)
|
||||
, ErrorResponseTitle(..)
|
||||
, ErrorResponseTitle(..)
|
||||
, UniWorXMessages(..)
|
||||
, uniworxMessages
|
||||
, unRenderMessage, unRenderMessage', unRenderMessageLenient
|
||||
@ -88,15 +88,14 @@ pluralDE num singularForm pluralForm
|
||||
| otherwise = pluralForm
|
||||
|
||||
pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
|
||||
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
|
||||
pluralDEx c n t = pluralDE n t $ t `snoc` c
|
||||
|
||||
-- | like `pluralDEe` but also prefixes with the number
|
||||
-- | like `pluralDEx` but also prefixes with the number
|
||||
pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
|
||||
pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
|
||||
|
||||
pluralDEe :: (Eq a, Num a) => a -> Text -> Text
|
||||
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
|
||||
-- ^ @pluralDEe n "Monat" = pluralDEe n "Monat" "Monate"@
|
||||
pluralDEe = pluralDEx 'e'
|
||||
|
||||
-- | like `pluralDEe` but also prefixes with the number
|
||||
@ -105,7 +104,7 @@ pluralDEeN = pluralDExN 'e'
|
||||
|
||||
-- | postfix plural with an 'n'
|
||||
pluralDEn :: (Eq a, Num a) => a -> Text -> Text
|
||||
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
|
||||
-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
|
||||
pluralDEn = pluralDEx 'n'
|
||||
|
||||
-- | like `pluralDEn` but also prefixes with the number
|
||||
@ -124,14 +123,14 @@ noneOneMoreDE num noneText singularForm pluralForm
|
||||
| num == 1 = singularForm
|
||||
| otherwise = pluralForm
|
||||
|
||||
-- noneMoreDE :: (Eq a, Num a)
|
||||
-- => a -- ^ Count
|
||||
-- -> Text -- ^ None
|
||||
-- -> Text -- ^ Some
|
||||
-- -> Text
|
||||
-- noneMoreDE num noneText someText
|
||||
-- | num == 0 = noneText
|
||||
-- | otherwise = someText
|
||||
noneMoreDE :: (Eq a, Num a)
|
||||
=> a -- ^ Count
|
||||
-> Text -- ^ None
|
||||
-> Text -- ^ Some
|
||||
-> Text
|
||||
noneMoreDE num noneText someText
|
||||
| num == 0 = noneText
|
||||
| otherwise = someText
|
||||
|
||||
pluralEN :: (Eq a, Num a)
|
||||
=> a -- ^ Count
|
||||
@ -146,7 +145,7 @@ pluralENs :: (Eq a, Num a)
|
||||
=> a -- ^ Count
|
||||
-> Text -- ^ Singular
|
||||
-> Text
|
||||
-- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@
|
||||
-- ^ @pluralENs n "foo" = pluralEN n "foo" "foos"@
|
||||
pluralENs n t = pluralEN n t $ t `snoc` 's'
|
||||
|
||||
-- | like `pluralENs` but also prefixes with the number
|
||||
@ -164,14 +163,14 @@ noneOneMoreEN num noneText singularForm pluralForm
|
||||
| num == 1 = singularForm
|
||||
| otherwise = pluralForm
|
||||
|
||||
-- noneMoreEN :: (Eq a, Num a)
|
||||
-- => a -- ^ Count
|
||||
-- -> Text -- ^ None
|
||||
-- -> Text -- ^ Some
|
||||
-- -> Text
|
||||
-- noneMoreEN num noneText someText
|
||||
-- | num == 0 = noneText
|
||||
-- | otherwise = someText
|
||||
noneMoreEN :: (Eq a, Num a)
|
||||
=> a -- ^ Count
|
||||
-> Text -- ^ None
|
||||
-> Text -- ^ Some
|
||||
-> Text
|
||||
noneMoreEN num noneText someText
|
||||
| num == 0 = noneText
|
||||
| otherwise = someText
|
||||
|
||||
_ordinalEN :: ToMessage a
|
||||
=> a
|
||||
@ -191,20 +190,20 @@ notEN :: Bool -> Text
|
||||
notEN = bool "not" ""
|
||||
|
||||
{- -- TODO: use this is message eventually
|
||||
-- Commonly used plurals
|
||||
-- Commonly used plurals
|
||||
data Thing = Person | Examinee
|
||||
deriving (Eq)
|
||||
|
||||
thingDE :: Int -> Thing -> Text
|
||||
thingDE :: Int -> Thing -> Text
|
||||
thingDE num = (tshow num <>) . Text.cons ' ' . thing
|
||||
where
|
||||
where
|
||||
thing :: Thing -> Text
|
||||
thing Person = pluralDE num "Person" "Personen"
|
||||
thing Examinee = pluralDE num "Prüfling" "Prüflinge"
|
||||
|
||||
thingEN :: Int -> Thing -> Text
|
||||
|
||||
thingEN :: Int -> Thing -> Text
|
||||
thingEN num t = tshow num <> Text.cons ' ' (thing t)
|
||||
where
|
||||
where
|
||||
thing :: Thing -> Text
|
||||
thing Person = pluralENs num "person"
|
||||
thing Examinee = pluralENs num "examinee"
|
||||
@ -282,7 +281,7 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma
|
||||
embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3)
|
||||
|
||||
|
||||
newtype SomeMessages master = SomeMessages [SomeMessage master]
|
||||
newtype SomeMessages master = SomeMessages [SomeMessage master]
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
instance master ~ master' => RenderMessage master (SomeMessages master') where
|
||||
@ -621,6 +620,6 @@ unRenderMessageLenient = unRenderMessage' cmp
|
||||
instance Default DateTimeFormatter where
|
||||
def = mkDateTimeFormatter (getTimeLocale' []) def appTZ
|
||||
|
||||
instance RenderMessage UniWorX Address where
|
||||
instance RenderMessage UniWorX Address where
|
||||
renderMessage s l a@Address{addressName = Just aname} = aname <> cons ' ' (renderMessage s l a{addressName=Nothing})
|
||||
renderMessage _ _ Address{addressEmail = mail} = "<" <> mail <> ">"
|
||||
|
||||
@ -159,7 +159,7 @@ postAdminAvsR = do
|
||||
$nothing
|
||||
AVS nicht konfiguriert!
|
||||
|]
|
||||
|
||||
|
||||
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
|
||||
|
||||
let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId))
|
||||
@ -168,7 +168,7 @@ postAdminAvsR = do
|
||||
try (avsQuery fr) >>= \case
|
||||
Left err -> return $ Just (Just $ exceptionWgt err, Nothing)
|
||||
Right (AvsResponsePerson pns) -> do
|
||||
let mapid = case Set.toList pns of
|
||||
let mapid = case Set.toList pns of
|
||||
[AvsDataPerson{avsPersonPersonID=apid}] -> Just apid
|
||||
_ -> Nothing
|
||||
wgt = [whamlet|
|
||||
@ -178,12 +178,12 @@ postAdminAvsR = do
|
||||
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|
||||
return $ Just (toMaybe (notNull pns) wgt, mapid)
|
||||
(mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson
|
||||
|
||||
|
||||
((sresult', swidget), senctype) <- runFormPost $ makeAvsStatusForm mapid
|
||||
let sresult = sresult' <|> maybe FormMissing (FormSuccess . AvsQueryStatus . Set.singleton) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
|
||||
procFormStatus fr = do
|
||||
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
|
||||
tryShow $ do
|
||||
tryShow $ do
|
||||
AvsResponseStatus pns <- avsQuery fr
|
||||
return [whamlet|
|
||||
<ul>
|
||||
@ -203,9 +203,9 @@ postAdminAvsR = do
|
||||
$forall AvsDataContact{..} <- pns
|
||||
<li>
|
||||
<ul>
|
||||
<li>AvsId: #{tshow avsContactPersonID}
|
||||
<li>AvsId: #{tshow avsContactPersonID}
|
||||
<li>^{jsonWidget avsContactPersonInfo}
|
||||
<li>^{jsonWidget avsContactFirmInfo}
|
||||
<li>^{jsonWidget avsContactFirmInfo}
|
||||
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
|
||||
mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
|
||||
|
||||
@ -560,15 +560,15 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
|
||||
-- , colUserCompany
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
||||
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
companies' <- liftHandler . runDBRead . 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 uid
|
||||
E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
||||
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
||||
companies =
|
||||
companies =
|
||||
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||
|
||||
|
||||
pure $ intercalate (text2widget "; ") companies
|
||||
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
|
||||
@ -639,8 +639,8 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
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)
|
||||
suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not_)
|
||||
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
|
||||
|
||||
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
|
||||
acts = mconcat
|
||||
@ -697,22 +697,22 @@ instance Button UniWorX UserAvsAction where
|
||||
|
||||
|
||||
getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
|
||||
getAdminAvsUserR = postAdminAvsUserR
|
||||
postAdminAvsUserR uuid = do
|
||||
getAdminAvsUserR = postAdminAvsUserR
|
||||
postAdminAvsUserR uuid = do
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
|
||||
|
||||
uid <- decrypt uuid
|
||||
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
||||
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
||||
-- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
|
||||
let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
|
||||
-- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
|
||||
-- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
|
||||
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
||||
-- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
|
||||
mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
|
||||
let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
|
||||
compDict <- if 1 >= length compsUsed
|
||||
compDict <- if 1 >= length compsUsed
|
||||
then return mempty -- switch company only sensible if there is more than one company to choose
|
||||
else do
|
||||
else do
|
||||
let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
|
||||
switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
|
||||
switchCompFormHandler availComps mbPrime = do
|
||||
@ -722,20 +722,20 @@ postAdminAvsUserR uuid = do
|
||||
<*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime
|
||||
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
|
||||
switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
|
||||
switchCompValidate = do
|
||||
switchCompValidate = do
|
||||
(uuid_rcvd,_) <- State.get
|
||||
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
|
||||
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
|
||||
((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
|
||||
formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
|
||||
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
|
||||
problems <- liftHandler . runDB $ do
|
||||
problems <- liftHandler . runDB $ do
|
||||
(usrUp, problems) <- switchAvsUserCompany True False uid cid
|
||||
update uid usrUp
|
||||
forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
|
||||
forM_ problems (\p -> do
|
||||
forM_ problems (\p -> do
|
||||
-- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
|
||||
tell . pure =<< messageI Warning p
|
||||
)
|
||||
)
|
||||
let ok = if null problems then Success else Error
|
||||
tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
|
||||
)
|
||||
@ -758,10 +758,10 @@ postAdminAvsUserR uuid = do
|
||||
setTitle $ toHtml $ show userAvsNoPerson
|
||||
let contactWgt = case mbContact of
|
||||
Left err -> exceptionWgt err
|
||||
Right (AvsResponseContact adcs) ->
|
||||
Right (AvsResponseContact adcs) ->
|
||||
if null adcs
|
||||
then [whamlet|_{MsgAvsPersonSearchEmpty}|]
|
||||
else
|
||||
else
|
||||
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
|
||||
in mconcat cs
|
||||
cardsWgt = case mbStatus of
|
||||
@ -779,14 +779,14 @@ postAdminAvsUserR uuid = do
|
||||
^{cardsWgt}
|
||||
<p>
|
||||
_{MsgAvsCurrentData}
|
||||
|]
|
||||
where
|
||||
|]
|
||||
where
|
||||
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
|
||||
mkContactWgt warnBolt reqAvsNo AvsDataContact
|
||||
{ -- avsContactPersonID = _api
|
||||
avsContactPersonInfo = AvsPersonInfo{..}
|
||||
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
|
||||
} =
|
||||
} =
|
||||
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
|
||||
[whamlet|
|
||||
<section .profile>
|
||||
@ -794,8 +794,8 @@ postAdminAvsUserR uuid = do
|
||||
$if avsNoOk
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsPersonNo}
|
||||
<dd .deflist__dd>
|
||||
#{avsInfoPersonNo}
|
||||
<dd .deflist__dd>
|
||||
#{avsInfoPersonNo}
|
||||
^{warnBolt}
|
||||
_{MsgAvsPersonNoMismatch}
|
||||
<dt .deflist__dt>
|
||||
@ -826,7 +826,7 @@ postAdminAvsUserR uuid = do
|
||||
|
||||
-- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
|
||||
mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
|
||||
mkCardsWgt (mbPrimName, swForm) crds
|
||||
mkCardsWgt (mbPrimName, swForm) crds
|
||||
| null crds = [whamlet|_{MsgAvsCardsEmpty}|]
|
||||
| otherwise = do
|
||||
let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
|
||||
@ -844,7 +844,7 @@ postAdminAvsUserR uuid = do
|
||||
$if hasIssueDate
|
||||
<th .table__th>_{MsgTableAvsCardIssueDate}
|
||||
$if hasValidToDate
|
||||
<th .table__th>_{MsgTableAvsCardValidTo}
|
||||
<th .table__th>_{MsgTableAvsCardValidTo}
|
||||
$if hasCompany
|
||||
<th .table__th>_{MsgTableCompany}
|
||||
<th .table__th>_{MsgAvsPrimaryCompany}
|
||||
@ -865,7 +865,7 @@ postAdminAvsUserR uuid = do
|
||||
<td .table__td>
|
||||
$maybe d <- avsDataIssueDate
|
||||
^{formatTimeW SelFormatDate d}
|
||||
$if hasValidToDate
|
||||
$if hasValidToDate
|
||||
<td .table__td>
|
||||
$maybe d <- avsDataValidTo
|
||||
^{formatTimeW SelFormatDate d}
|
||||
@ -903,13 +903,13 @@ getProblemAvsErrorR = do
|
||||
E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
|
||||
return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
|
||||
qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
|
||||
qerryUsrAvs = $(E.sqlIJproj 2 1)
|
||||
qerryUsrAvs = $(E.sqlIJproj 2 1)
|
||||
qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
|
||||
qerryUser = $(E.sqlIJproj 2 2)
|
||||
reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
|
||||
reserrUsrAvs = _dbrOutput . _1
|
||||
-- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
|
||||
-- reserrUser = _dbrOutput . _2
|
||||
-- reserrUser = _dbrOutput . _2
|
||||
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
@ -949,4 +949,3 @@ getProblemAvsErrorR = do
|
||||
siteLayoutMsg MsgMenuAvsSynchError $ do
|
||||
setTitleI MsgMenuAvsSynchError
|
||||
[whamlet|^{avsSyncErrTbl}|]
|
||||
|
||||
@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
| otherwise
|
||||
-> return $ FormSuccess ()
|
||||
|
||||
mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> do
|
||||
mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
|
||||
E.where_ $ course E.^. CourseId E.==. E.val cid
|
||||
E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool)
|
||||
E.||. mayEditCourse muid ata course
|
||||
@ -92,7 +92,7 @@ courseMayReRegister :: Entity Course -> DB Bool
|
||||
courseMayReRegister (Entity cid Course{..}) = do
|
||||
registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ]
|
||||
let capacity = maybe True (>= registrations) courseCapacity
|
||||
|
||||
|
||||
wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR
|
||||
|
||||
|
||||
|
||||
@ -119,7 +119,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
|
||||
|
||||
faHandler (FirmActNotifyData, Set.toList -> fids) = do
|
||||
usrs <- runDB $ E.select $ E.distinct $ do
|
||||
usrs <- runDBRead $ E.select $ E.distinct $ do
|
||||
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
||||
E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
|
||||
return $ usr E.^. UserId
|
||||
@ -325,34 +325,33 @@ addDefaultSupervisorsAll mutualSupervision cids = do
|
||||
------------------------------
|
||||
-- repeatedly useful queries
|
||||
|
||||
usrSuperiorCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
|
||||
-- usrSuperiorCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
|
||||
usrSuperiorCompanies cmp usr = do
|
||||
othr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
|
||||
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
|
||||
E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
|
||||
-- return othr
|
||||
|
||||
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
|
||||
fromUserCompany mbFltr cmpy = do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
||||
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
|
||||
|
||||
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
|
||||
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
|
||||
|
||||
firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
|
||||
firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
|
||||
where
|
||||
primFltr usr = E.notExists (do
|
||||
othr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
|
||||
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
|
||||
E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
|
||||
)
|
||||
primFltr = E.notExists . usrSuperiorCompanies cmp
|
||||
|
||||
firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
|
||||
where
|
||||
primFltr usr = E.exists (do
|
||||
othr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
|
||||
E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
|
||||
E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
|
||||
)
|
||||
primFltr = E.exists . usrSuperiorCompanies cmp
|
||||
|
||||
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
|
||||
@ -1375,14 +1374,14 @@ handleFirmCommR ultDest cs = do
|
||||
csKeys = CompanyKey <$> cs
|
||||
mbUser <- maybeAuthId
|
||||
-- get employees of chosen companies
|
||||
empys <- mkCompanyUsrList <$> runDB (E.select $ do
|
||||
empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
|
||||
(emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
|
||||
E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
|
||||
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
|
||||
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
|
||||
)
|
||||
-- get supervisors of employees
|
||||
sprs <- mkCompanyUsrList <$> runDB (E.select $ do
|
||||
sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
|
||||
(spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
|
||||
E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
|
||||
E.||. (spr E.^. UserId E.=?. E.val mbUser)
|
||||
|
||||
@ -19,7 +19,7 @@ module Handler.LMS
|
||||
, getLmsFakeR , postLmsFakeR
|
||||
, getLmsUserR
|
||||
, getLmsUserSchoolR
|
||||
, getLmsUserAllR
|
||||
, getLmsUserAllR
|
||||
)
|
||||
where
|
||||
|
||||
@ -81,11 +81,11 @@ postLmsAllR = do
|
||||
mbBtnForm <- if not isAdmin then return Nothing else do
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
|
||||
case btnResult of
|
||||
(FormSuccess BtnLmsEnqueue) ->
|
||||
queueJob' JobLmsQualificationsEnqueue
|
||||
(FormSuccess BtnLmsEnqueue) ->
|
||||
queueJob' JobLmsQualificationsEnqueue
|
||||
>> addMessage Info "Einreihung ablaufender Qualifikationen zum LMS wird nun im Hintergund durchgeführt."
|
||||
(FormSuccess BtnLmsDequeue) ->
|
||||
queueJob' JobLmsQualificationsDequeue
|
||||
(FormSuccess BtnLmsDequeue) ->
|
||||
queueJob' JobLmsQualificationsDequeue
|
||||
>> addMessage Info "Benachrichtigung abgelaufener Qualifikationen und Aufräumen beendeter LMS Nutzer wird im Hintergund ausgeführt."
|
||||
FormMissing -> return ()
|
||||
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
|
||||
@ -112,20 +112,20 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
|
||||
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
|
||||
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
||||
|
||||
|
||||
|
||||
mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
|
||||
mkLmsAllTable isAdmin lmsDeletionDays = do
|
||||
svs <- getSupervisees
|
||||
svs <- getSupervisees
|
||||
let
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery quali = do
|
||||
let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
|
||||
let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
|
||||
Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs)
|
||||
cusers = Ex.subSelectCount $ do
|
||||
cusers = Ex.subSelectCount $ do
|
||||
luser <- Ex.from $ Ex.table @LmsUser
|
||||
Ex.where_ $ filterSvs luser
|
||||
cactive = Ex.subSelectCount $ do
|
||||
Ex.where_ $ filterSvs luser
|
||||
cactive = Ex.subSelectCount $ do
|
||||
luser <- Ex.from $ Ex.table @LmsUser
|
||||
Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
|
||||
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
|
||||
@ -155,15 +155,15 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
|
||||
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
|
||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
||||
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
|
||||
, sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
|
||||
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
|
||||
, sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
|
||||
$ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
|
||||
let icn = IconOK -- change icon here, if desired
|
||||
in case mbSapId of
|
||||
in case mbSapId of
|
||||
Nothing -> mempty
|
||||
Just sapId | isAdmin -> cellTooltipIcon (Just icn) (text2message sapId) mempty
|
||||
Just _ -> iconCell icn
|
||||
Just _ -> iconCell icn
|
||||
, adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
|
||||
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
|
||||
, adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
|
||||
@ -342,7 +342,7 @@ instance HasEntity LmsTableData QualificationUser where
|
||||
hasEntity = resultQualUser
|
||||
|
||||
instance HasQualificationUser LmsTableData where
|
||||
hasQualificationUser = resultQualUser . _entityVal
|
||||
hasQualificationUser = resultQualUser . _entityVal
|
||||
|
||||
data LmsTableAction = LmsActNotify
|
||||
| LmsActRenewNotify
|
||||
@ -351,7 +351,7 @@ data LmsTableAction = LmsActNotify
|
||||
| LmsActRestart
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
|
||||
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''LmsTableAction id
|
||||
|
||||
@ -360,12 +360,12 @@ data LmsTableActionData = LmsActNotifyData
|
||||
| LmsActRenewPinData -- no longer used
|
||||
| LmsActResetData
|
||||
{ lmsActRestartExtend :: Maybe Integer
|
||||
, lmsActRestartUnblock :: Maybe Bool
|
||||
, lmsActRestartUnblock :: Maybe Bool
|
||||
, lmsActRestartNotify :: Maybe Bool
|
||||
}
|
||||
| LmsActRestartData
|
||||
| LmsActRestartData
|
||||
{ lmsActRestartExtend :: Maybe Integer
|
||||
, lmsActRestartUnblock :: Maybe Bool
|
||||
, lmsActRestartUnblock :: Maybe Bool
|
||||
, lmsActRestartNotify :: Maybe Bool
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -407,14 +407,14 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
|
||||
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_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
||||
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
||||
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
|
||||
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
|
||||
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
||||
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
|
||||
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
||||
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
|
||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
|
||||
|
||||
|
||||
@ -423,17 +423,17 @@ mkLmsTable :: ( Functor h, ToSortable h
|
||||
)
|
||||
=> Bool
|
||||
-> Entity Qualification
|
||||
-> Map LmsTableAction (AForm Handler LmsTableActionData)
|
||||
-> Map LmsTableAction (AForm Handler LmsTableActionData)
|
||||
-> (Map CompanyId Company -> cols)
|
||||
-> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
|
||||
-> DB (FormResult (LmsTableActionData, Set UserId), Widget)
|
||||
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
now <- liftIO getCurrentTime
|
||||
-- lookup all companies
|
||||
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
|
||||
-- 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
|
||||
let
|
||||
csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "lms"
|
||||
@ -486,19 +486,19 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
-- )
|
||||
, single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
|
||||
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \usrAvs -> -- do
|
||||
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 ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
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 $ ciOriginal criterion
|
||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
||||
)
|
||||
)
|
||||
, fltrAVSCardNos queryUser
|
||||
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
|
||||
| Set.null criteria -> E.true
|
||||
@ -506,7 +506,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
)
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
||||
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
|
||||
, fltrAVSCardNosUI mPrev
|
||||
@ -516,7 +516,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
, prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
|
||||
, prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
|
||||
-- , if isNothing mbRenewal then mempty
|
||||
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
||||
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtCsvEncode = Just DBTCsvEncode
|
||||
@ -548,14 +548,14 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
|
||||
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
|
||||
getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
||||
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))
|
||||
|
||||
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
|
||||
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
|
||||
DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
|
||||
@ -603,18 +603,18 @@ postLmsR sid qsh = do
|
||||
[ singletonMap LmsActNotify $ pure LmsActNotifyData
|
||||
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
|
||||
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
|
||||
, singletonMap LmsActReset $ LmsActResetData
|
||||
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
|
||||
, singletonMap LmsActReset $ LmsActResetData
|
||||
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
|
||||
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
|
||||
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
|
||||
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
|
||||
<* aformMessage msgResetInfo
|
||||
, singletonMap LmsActRestart $ LmsActRestartData
|
||||
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
|
||||
, singletonMap LmsActRestart $ LmsActRestartData
|
||||
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
|
||||
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
|
||||
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
|
||||
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
|
||||
<* aformMessage msgRestartWarning
|
||||
]
|
||||
<* aformMessage msgRestartWarning
|
||||
]
|
||||
colChoices cmpMap = mconcat
|
||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
|
||||
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR
|
||||
@ -622,11 +622,11 @@ postLmsR sid qsh = do
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
|
||||
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||
]
|
||||
in intercalate spacerCell cs
|
||||
, colUserMatriclenr isAdmin
|
||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||
-- , 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) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
|
||||
@ -653,8 +653,8 @@ postLmsR sid qsh = do
|
||||
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
|
||||
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
|
||||
let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified
|
||||
lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
|
||||
recipient = row ^. hasUser
|
||||
lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
|
||||
recipient = row ^. hasUser
|
||||
letterDates = row ^? resultPrintAck
|
||||
lastLetterDate = headDef Nothing =<< letterDates
|
||||
letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
|
||||
@ -675,7 +675,7 @@ postLmsR sid qsh = do
|
||||
$maybe ackdate <- mbackdate
|
||||
^{formatTimeW SelFormatDateTime ackdate}
|
||||
$nothing
|
||||
_{MsgPrintJobUnacknowledged}
|
||||
_{MsgPrintJobUnacknowledged}
|
||||
<p>
|
||||
<a href=@{lprLink}>
|
||||
_{MsgPrintJobs}
|
||||
@ -700,25 +700,25 @@ postLmsR sid qsh = do
|
||||
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
|
||||
|
||||
(action, selectedUsers) | isResetRestartAct action -> do
|
||||
let usersList = Set.toList selectedUsers
|
||||
let usersList = Set.toList selectedUsers
|
||||
numUsers = Set.size selectedUsers
|
||||
isReset = isResetAct action
|
||||
actRestartExtend = action & lmsActRestartExtend
|
||||
actRestartUnblock = action & lmsActRestartUnblock
|
||||
actRestartNotify = action & lmsActRestartNotify
|
||||
actRestartExtend = action & lmsActRestartExtend
|
||||
actRestartUnblock = action & lmsActRestartUnblock
|
||||
actRestartNotify = action & lmsActRestartNotify
|
||||
|
||||
chgUsers <- runDB $ do
|
||||
chgUsers <- runDB $ do
|
||||
when (actRestartUnblock == Just True) $ do
|
||||
oks <- qualificationUserBlocking qid usersList True Nothing (Left $ bool "Manueller LMS Neustart" "Manuelle LMS Zurücksetzung" isReset) (fromMaybe True actRestartNotify)
|
||||
addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
|
||||
|
||||
whenIsJust actRestartExtend $ \extDays -> do
|
||||
let cutoff = addDays extDays nowaday
|
||||
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
|
||||
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
|
||||
[ QualificationUserQualification ==. qid
|
||||
, QualificationUserUser <-. usersList
|
||||
, QualificationUserUser <-. usersList
|
||||
, QualificationUserValidUntil <. cutoff
|
||||
] []
|
||||
] []
|
||||
forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
|
||||
|
||||
fromIntegral <$> (if isReset
|
||||
@ -727,25 +727,25 @@ postLmsR sid qsh = do
|
||||
else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
|
||||
)
|
||||
|
||||
unless isReset $
|
||||
unless isReset $
|
||||
forM_ selectedUsers $ \uid ->
|
||||
queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
|
||||
runDB $ forM_ selectedUsers $ \uid ->
|
||||
audit $ TransactionLmsReset
|
||||
{ transactionQualification = qid
|
||||
runDB $ forM_ selectedUsers $ \uid ->
|
||||
audit $ TransactionLmsReset
|
||||
{ transactionQualification = qid
|
||||
, transactionLmsUser = uid
|
||||
, transactionLmsReset = isReset
|
||||
, transactionLmsResetExtend = actRestartExtend
|
||||
, transactionLmsResetExtend = actRestartExtend
|
||||
, transactionLmsResetUnblock = actRestartUnblock
|
||||
, transactionLmsResetNotify = actRestartNotify
|
||||
, transactionLmsResetNotify = actRestartNotify
|
||||
}
|
||||
|
||||
let mStatus = bool Success Warning $ chgUsers < numUsers
|
||||
addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers
|
||||
reloadKeepGetParams $ LmsR sid qsh
|
||||
|
||||
(action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
|
||||
(action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
|
||||
numExaminees <- runDB $ do
|
||||
okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification
|
||||
, LmsUserEnded ==. Nothing -- not yet deleted
|
||||
@ -761,7 +761,7 @@ postLmsR sid qsh = do
|
||||
return $ length okUsers
|
||||
let numSelected = length selectedUsers
|
||||
diffSelected = numSelected - numExaminees
|
||||
mstat = bool Success Warning $ diffSelected /= 0
|
||||
mstat = bool Success Warning $ diffSelected /= 0
|
||||
when (isRenewPinAct action) $ addMessageI mstat $ MsgLmsPinRenewal numExaminees
|
||||
when (isNotifyAct action) $ addMessageI mstat $ MsgLmsNotificationSend numExaminees
|
||||
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
|
||||
@ -791,22 +791,22 @@ getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh)
|
||||
viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html
|
||||
viewLmsUserR msid mqsh uuid = do
|
||||
uid <- decrypt uuid
|
||||
now <- liftIO getCurrentTime
|
||||
(user@User{userDisplayName}, quals, qblocks) <- runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
(user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
|
||||
usr <- get404 uid
|
||||
qs <- Ex.select $ do
|
||||
(qual :& qualUsr :& lmsUsr) <-
|
||||
qs <- Ex.select $ do
|
||||
(qual :& qualUsr :& lmsUsr) <-
|
||||
Ex.from $ Ex.table @Qualification
|
||||
`Ex.leftJoin` Ex.table @QualificationUser
|
||||
`Ex.on` (\(qual :& qualUsr) -> qualUsr E.?. QualificationUserUser E.?=. Ex.val uid
|
||||
E.&&. qualUsr E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId
|
||||
)
|
||||
)
|
||||
`Ex.leftJoin` Ex.table @LmsUser
|
||||
`Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid
|
||||
E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
|
||||
E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
|
||||
)
|
||||
Ex.where_ $ E.and $
|
||||
(E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
|
||||
(E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
|
||||
[ (qual E.^. QualificationSchool E.==.) . E.val <$> msid
|
||||
, (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh
|
||||
]
|
||||
@ -816,7 +816,7 @@ viewLmsUserR msid mqsh uuid = do
|
||||
<- foldMapM (\(_, mbqu, _, _) -> case mbqu of
|
||||
Nothing -> pure mempty
|
||||
Just (Entity quid _) -> do
|
||||
blocks <- Ex.select $ do
|
||||
blocks <- Ex.select $ do
|
||||
(qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock
|
||||
`Ex.leftJoin` Ex.table @User
|
||||
`Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId)
|
||||
@ -826,7 +826,7 @@ viewLmsUserR msid mqsh uuid = do
|
||||
return $ Map.singleton quid blocks
|
||||
) qs
|
||||
return (usr, qs, Map.filter notNull bs)
|
||||
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
|
||||
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
|
||||
siteLayout heading $ do
|
||||
setTitle $ toHtml userDisplayName
|
||||
$(widgetFile "lms-user")
|
||||
$(widgetFile "lms-user")
|
||||
|
||||
@ -13,7 +13,7 @@ import Handler.SystemMessage
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
import Database.Esqueleto.Utils.TH
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
@ -315,16 +315,16 @@ newsUpcomingExams uid = do
|
||||
| otherwise -> mempty
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
|
||||
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
|
||||
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
|
||||
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
|
||||
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
|
||||
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
|
||||
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
|
||||
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
|
||||
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
|
||||
, ("registered", SortColumn $ queryExam >>> (\exam ->
|
||||
[ ("demo-both", SortColumns $ queryCourse &&& queryExam >>> (\(course,exam)-> [SomeExprValue $ course E.^. CourseShorthand, SomeExprValue $ exam E.^. ExamName]))
|
||||
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
|
||||
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
|
||||
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
|
||||
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
|
||||
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
|
||||
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
|
||||
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
|
||||
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
|
||||
, ("registered", SortColumn $ queryExam >>> (\exam ->
|
||||
E.exists $ E.from $ \registration -> do
|
||||
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
|
||||
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
module Handler.Profile
|
||||
( getProfileR, postProfileR
|
||||
, getForProfileR, postForProfileR
|
||||
, getProfileDataR, makeProfileData
|
||||
, getProfileDataR, makeProfileData
|
||||
, getForProfileDataR
|
||||
, getAuthPredsR, postAuthPredsR
|
||||
, getUserNotificationR, postUserNotificationR
|
||||
@ -70,11 +70,11 @@ data SettingsForm = SettingsForm
|
||||
, stgDownloadFiles :: Bool
|
||||
, stgWarningDays :: NominalDiffTime
|
||||
, stgShowSex :: Bool
|
||||
|
||||
|
||||
, stgPinPassword :: Maybe Text
|
||||
, stgPrefersPostal :: Bool
|
||||
, stgPostAddress :: Maybe StoredMarkup
|
||||
|
||||
|
||||
, stgTelephone :: Maybe Text
|
||||
, stgMobile :: Maybe Text
|
||||
|
||||
@ -142,9 +142,9 @@ makeSettingForm template html = do
|
||||
<*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template)
|
||||
|
||||
<*> aopt (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template)
|
||||
<*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template)
|
||||
<*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template)
|
||||
|
||||
<*> examOfficeForm (stgExamOfficeSettings <$> template)
|
||||
<*> examOfficeForm (stgExamOfficeSettings <$> template)
|
||||
<*> schoolsForm (stgSchools <$> template)
|
||||
<*> notificationForm (stgNotificationSettings <$> template)
|
||||
return (result, widget) -- no validation here, done later by validateSettings
|
||||
@ -156,7 +156,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
|
||||
where
|
||||
schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
|
||||
schoolsForm' = do
|
||||
allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
|
||||
allSchools <- liftHandler . runDBRead $ selectList [] [Asc SchoolName]
|
||||
|
||||
let
|
||||
schoolForm (Entity ssh School{schoolName})
|
||||
@ -226,7 +226,7 @@ notificationForm template = wFormToAForm $ do
|
||||
let
|
||||
ntfs nt = fslI nt & case nt of
|
||||
_other -> id
|
||||
|
||||
|
||||
nsForm nt
|
||||
| maybe False ntHidden $ ntSection nt
|
||||
= pure $ notificationAllowed def nt
|
||||
@ -297,7 +297,7 @@ examOfficeForm template = wFormToAForm $ do
|
||||
| otherwise
|
||||
-> FormSuccess $ Map.singleton kStart (Left nLabel)
|
||||
return (addRes', $(widgetFile "profile/exam-office-labels/add"))
|
||||
|
||||
|
||||
miCell :: ListPosition
|
||||
-> Either ExamOfficeLabelName ExamOfficeLabelId
|
||||
-> Maybe EOLabelData
|
||||
@ -366,7 +366,7 @@ validateSettings User{..} = do
|
||||
userDisplayName' <- use _stgDisplayName
|
||||
guardValidation MsgUserDisplayNameInvalid $
|
||||
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
|
||||
validDisplayName userTitle userFirstName userSurname userDisplayName'
|
||||
validDisplayName userTitle userFirstName userSurname userDisplayName'
|
||||
|
||||
userDisplayEmail' <- use _stgDisplayEmail
|
||||
guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
|
||||
@ -412,7 +412,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
|
||||
|
||||
getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
|
||||
getForProfileR = postForProfileR
|
||||
postForProfileR cID = do
|
||||
postForProfileR cID = do
|
||||
uid <- decrypt cID
|
||||
user <- runDB $ get404 uid
|
||||
serveProfileR (uid, user)
|
||||
@ -449,7 +449,7 @@ serveProfileR (uid, user@User{..}) = do
|
||||
, stgShowSex = userShowSex
|
||||
, stgPinPassword = userPinPassword
|
||||
, stgPostAddress = userPostAddress
|
||||
, stgPrefersPostal = userPrefersPostal
|
||||
, stgPrefersPostal = userPrefersPostal
|
||||
, stgTelephone = userTelephone
|
||||
, stgMobile = userMobile
|
||||
, stgExamOfficeSettings = ExamOfficeSettings
|
||||
@ -580,14 +580,49 @@ getProfileDataR = do
|
||||
getForProfileDataR :: CryptoUUIDUser -> Handler Html
|
||||
getForProfileDataR cID = do
|
||||
uid <- decrypt cID
|
||||
(user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
|
||||
(user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgHeadingForProfileData $ userDisplayName user
|
||||
dataWidget
|
||||
|
||||
-- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget}
|
||||
-- a poor man's record subsitute
|
||||
|
||||
{-
|
||||
type TableHasData = (Bool, Widget)
|
||||
tableHasRows :: TableHasData -> Bool
|
||||
tableHasRows = fst
|
||||
tableWidget :: TableHasData -> Widget
|
||||
tableWidget = snd
|
||||
-}
|
||||
|
||||
maybeTable :: (RenderMessage UniWorX a)
|
||||
=> a -> (Bool, Widget) -> Widget
|
||||
maybeTable m = maybeTable' m Nothing Nothing
|
||||
|
||||
maybeTable' :: (RenderMessage UniWorX a)
|
||||
=> a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
|
||||
maybeTable' _ Nothing _ (False, _ ) = mempty
|
||||
maybeTable' _ (Just nodata) _ (False, _ ) =
|
||||
[whamlet|
|
||||
<div .container>
|
||||
_{nodata}
|
||||
|]
|
||||
maybeTable' hdr _ mbRemark (True ,tbl) =
|
||||
[whamlet|
|
||||
<div .container>
|
||||
<h2> _{hdr}
|
||||
<div .container>
|
||||
^{tbl}
|
||||
$maybe remark <- mbRemark
|
||||
<em>_{MsgProfileRemark}
|
||||
\ ^{remark}
|
||||
|]
|
||||
|
||||
|
||||
makeProfileData :: Entity User -> DB Widget
|
||||
makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
|
||||
now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
|
||||
let usrAutomatic :: CU_UserAvs_User -> Widget
|
||||
usrAutomatic = updateAutomatic . mayUpdate usrVal avsId . mkCheckUpdate
|
||||
@ -599,48 +634,57 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
|
||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
|
||||
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
|
||||
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
||||
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
||||
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
||||
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
||||
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
||||
return (studyfeat, studydegree, studyterms)
|
||||
companies <- wgtCompanies uid
|
||||
supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
|
||||
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
|
||||
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
|
||||
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
||||
let numSupervisors = length supervisors'
|
||||
supervisors = intersperse (text2widget ", ") $
|
||||
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
|
||||
icnReroute = text2widget " " <> toWgt (icon IconLetter)
|
||||
supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
|
||||
E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
||||
let numSupervisees = length supervisees'
|
||||
supervisees = intersperse (text2widget ", ") $
|
||||
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
|
||||
-- icnReroute = text2widget " " <> toWgt (icon IconLetter)
|
||||
-- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
-- E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
|
||||
-- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
|
||||
-- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
|
||||
-- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
||||
-- let numSupervisors = length supervisors'
|
||||
-- supervisors = intersperse (text2widget ", ") $
|
||||
-- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
|
||||
-- icnReroute = text2widget " " <> toWgt (icon IconReroute)
|
||||
-- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
-- E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
|
||||
-- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
-- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
||||
-- let numSupervisees = length supervisees'
|
||||
-- supervisees = intersperse (text2widget ", ") $
|
||||
-- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
|
||||
-- -- icnReroute = text2widget " " <> toWgt (icon IconReroute)
|
||||
--Tables
|
||||
(hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
|
||||
ownedCoursesTable <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
|
||||
enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
|
||||
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
|
||||
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
|
||||
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
|
||||
qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen
|
||||
supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors
|
||||
superviseesTable <- mkSuperviseesTable uid -- Tabelle mit allen Supervisees
|
||||
let examTable, ownTutorialTable, tutorialTable :: Widget
|
||||
examTable = i18n MsgPersonalInfoExamAchievementsWip
|
||||
ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
|
||||
tutorialTable = i18n MsgPersonalInfoTutorialsWip
|
||||
superviseesTable <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees
|
||||
let supervisorsWgt :: Widget =
|
||||
let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable
|
||||
in maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor)
|
||||
(toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt)
|
||||
superviseesWgt :: Widget =
|
||||
let ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable
|
||||
in maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee)
|
||||
(toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt)
|
||||
-- let examTable, ownTutorialTable, tutorialTable :: Widget
|
||||
-- examTable = i18n MsgPersonalInfoExamAchievementsWip
|
||||
-- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
|
||||
-- tutorialTable = i18n MsgPersonalInfoTutorialsWip
|
||||
|
||||
cID <- encrypt uid
|
||||
mCRoute <- getCurrentRoute
|
||||
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
|
||||
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
|
||||
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
|
||||
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
|
||||
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
|
||||
tooltipAvsPersNoDiffers <- messageI Error MsgAvsPersonNoDiffers
|
||||
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
|
||||
let profileRemarks = $(i18nWidgetFile "profile-remarks")
|
||||
return $(widgetFile "profileData")
|
||||
|
||||
@ -698,7 +742,7 @@ mkOwnedCoursesTable =
|
||||
|
||||
|
||||
-- | Table listing all courses that the given user is enrolled in
|
||||
mkEnrolledCoursesTable :: UserId -> DB Widget
|
||||
mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
|
||||
mkEnrolledCoursesTable =
|
||||
let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
||||
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
||||
@ -706,7 +750,7 @@ mkEnrolledCoursesTable =
|
||||
|
||||
validator = def & defaultSorting [SortDescBy "time"]
|
||||
|
||||
in \uid -> dbTableWidget' validator
|
||||
in \uid -> (_1 %~ getAny) <$> dbTableWidget validator
|
||||
DBTable
|
||||
{ dbtIdent = "courseMembership" :: Text
|
||||
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
|
||||
@ -717,7 +761,7 @@ mkEnrolledCoursesTable =
|
||||
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
||||
, dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
|
||||
, dbtColonnade = mconcat
|
||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
|
||||
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
|
||||
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
|
||||
schoolCell <$> view _courseTerm
|
||||
@ -750,7 +794,7 @@ mkEnrolledCoursesTable =
|
||||
|
||||
|
||||
-- | Table listing all submissions for the given user
|
||||
mkSubmissionTable :: UserId -> DB Widget
|
||||
mkSubmissionTable :: UserId -> DB (Bool, Widget)
|
||||
mkSubmissionTable =
|
||||
let dbtIdent = "submissions" :: Text
|
||||
dbtStyle = def
|
||||
@ -784,7 +828,7 @@ mkSubmissionTable =
|
||||
<&> _dbrOutput . _4 %~ E.unValue
|
||||
|
||||
dbtColonnade = mconcat
|
||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
|
||||
termCell <$> view (_dbrOutput . _1 . _1)
|
||||
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
|
||||
schoolCell <$> view _1
|
||||
@ -828,14 +872,10 @@ mkSubmissionTable =
|
||||
dbtExtraReps = []
|
||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||
dbtSorting = dbtSorting' uid
|
||||
in dbTableWidget' validator DBTable{..}
|
||||
-- in do dbtSQLQuery <- dbtSQLQuery'
|
||||
-- dbtSorting <- dbtSorting'
|
||||
-- return $ dbTableWidget' validator $ DBTable {..}
|
||||
|
||||
in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
|
||||
|
||||
-- | Table listing all submissions for the given user
|
||||
mkSubmissionGroupTable :: UserId -> DB Widget
|
||||
mkSubmissionGroupTable :: UserId -> DB (Bool, Widget)
|
||||
mkSubmissionGroupTable =
|
||||
let dbtIdent = "subGroups" :: Text
|
||||
dbtStyle = def
|
||||
@ -858,7 +898,7 @@ mkSubmissionGroupTable =
|
||||
<&> _dbrOutput . _1 %~ $(E.unValueN 3)
|
||||
|
||||
dbtColonnade = mconcat
|
||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
|
||||
termCell <$> view (_dbrOutput . _1 . _1)
|
||||
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
|
||||
schoolCell <$> view _1
|
||||
@ -887,10 +927,10 @@ mkSubmissionGroupTable =
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||
in dbTableWidget' validator DBTable{..}
|
||||
in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
|
||||
|
||||
|
||||
mkCorrectionsTable :: UserId -> DB Widget
|
||||
mkCorrectionsTable :: UserId -> DB (Bool, Widget)
|
||||
mkCorrectionsTable =
|
||||
let dbtIdent = "corrections" :: Text
|
||||
dbtStyle = def
|
||||
@ -923,7 +963,7 @@ mkCorrectionsTable =
|
||||
<&> _dbrOutput . _2 %~ E.unValue
|
||||
|
||||
dbtColonnade = mconcat
|
||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $
|
||||
[ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
|
||||
termCellCL <$> view (_dbrOutput . _1)
|
||||
, sortable (Just "school") (i18nCell MsgTableCourseSchool) $
|
||||
schoolCellCL <$> view (_dbrOutput . _1)
|
||||
@ -960,7 +1000,7 @@ mkCorrectionsTable =
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||
in dbTableWidget' validator DBTable{..}
|
||||
in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
|
||||
|
||||
|
||||
-- | Table listing all qualifications that the given user is enrolled in
|
||||
@ -977,26 +1017,26 @@ mkQualificationsTable =
|
||||
E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
|
||||
E.&&. qblock `isLatestBlockBefore` E.val now
|
||||
E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
|
||||
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
|
||||
E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
|
||||
return (quali, quser, qblock)
|
||||
, dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
|
||||
, dbtProj = dbtProjId
|
||||
, dbtProj = dbtProjId
|
||||
, dbtColonnade = mconcat
|
||||
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
|
||||
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
|
||||
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
|
||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
|
||||
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
|
||||
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
|
||||
qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
|
||||
qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
|
||||
]
|
||||
, dbtSorting = mconcat
|
||||
[ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool)
|
||||
, singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName
|
||||
, singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName
|
||||
, singletonMap "blocked" $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom
|
||||
, singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserValidUntil
|
||||
, singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserLastRefresh
|
||||
, singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld
|
||||
, singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld
|
||||
]
|
||||
, dbtFilter = mempty
|
||||
, dbtFilterUI = mempty
|
||||
@ -1027,9 +1067,9 @@ instance HasUser TblSupervisorData where
|
||||
hasUser = _dbrOutput . _1 . _entityVal
|
||||
|
||||
-- | Table listing all supervisor of the given user
|
||||
mkSupervisorsTable :: UserId -> DB Widget
|
||||
mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
|
||||
where
|
||||
mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget)
|
||||
mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
|
||||
where
|
||||
dbtIdent = "userSupervisedBy" :: Text
|
||||
dbtStyle = def
|
||||
|
||||
@ -1043,10 +1083,17 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
|
||||
dbtColonnade = mconcat
|
||||
[ colUserNameModalHdr MsgTableSupervisor ForProfileDataR
|
||||
, colUserEmail
|
||||
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
|
||||
-- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> indicatorCell <> ifIconCell b IconReroute
|
||||
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
|
||||
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
|
||||
isLetter = row ^. resultUser . _userPrefersPostal
|
||||
in tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $
|
||||
if isReroute
|
||||
then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter)
|
||||
else mempty
|
||||
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
|
||||
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
|
||||
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
|
||||
]
|
||||
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
|
||||
dbtSorting = mconcat
|
||||
@ -1054,8 +1101,13 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
|
||||
, singletonMap & uncurry $ sortUserEmail queryUser
|
||||
, singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
|
||||
, singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
|
||||
-- , singletonMap "reroute" $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) -> mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal))
|
||||
, singletonMap "reroute" $ SortColumns $ \row ->
|
||||
[ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
|
||||
, SomeExprValue $ queryUser row E.^. UserPrefersPostal
|
||||
]
|
||||
, singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany)
|
||||
, singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
|
||||
, singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ singletonMap & uncurry $ fltrUserNameEmail queryUser
|
||||
@ -1068,9 +1120,9 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
|
||||
|
||||
|
||||
-- | Table listing all persons supervised by the given user
|
||||
mkSuperviseesTable :: UserId -> DB Widget
|
||||
mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
|
||||
where
|
||||
mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget)
|
||||
mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
|
||||
where
|
||||
dbtIdent = "userSupervisedBy" :: Text
|
||||
dbtStyle = def
|
||||
|
||||
@ -1081,22 +1133,30 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
|
||||
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
|
||||
dbtProj = dbtProjId
|
||||
|
||||
iconCellLetterOrEmail = spacerCell <> iconFixedCell (iconLetterOrEmail userPrefersPostal) -- only notification type of supervisor matters here
|
||||
dbtColonnade = mconcat
|
||||
[ colUserNameModalHdr MsgTableSupervisee ForProfileDataR
|
||||
-- , colUserEmail
|
||||
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
|
||||
, colUserEmail
|
||||
-- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
|
||||
-- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
|
||||
let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
|
||||
in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
|
||||
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
|
||||
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
|
||||
, sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
|
||||
]
|
||||
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap & uncurry $ sortUserNameLink queryUser
|
||||
, singletonMap & uncurry $ sortUserEmail queryUser
|
||||
, singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
|
||||
, singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
|
||||
-- , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
|
||||
-- , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
|
||||
, singletonMap "reroute" $ SortColumns $ \row ->
|
||||
[ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
|
||||
, SomeExprValue $ queryUser row E.^. UserPrefersPostal
|
||||
]
|
||||
, singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany)
|
||||
, singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
|
||||
, singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ singletonMap & uncurry $ fltrUserNameEmail queryUser
|
||||
|
||||
@ -27,10 +27,10 @@ import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
|
||||
data SapUserTableCsv = SapUserTableCsv -- for csv export only
|
||||
{ csvSUTpersonalNummer :: Text
|
||||
{ csvSUTpersonalNummer :: Text
|
||||
, csvSUTqualifikation :: Text
|
||||
, csvSUTgültigVon :: Day
|
||||
, csvSUTgültigBis :: Day
|
||||
, csvSUTgültigBis :: Day
|
||||
-- , csvSUTsupendiertBis :: Maybe Day
|
||||
, csvSUTausprägung :: Text
|
||||
}
|
||||
@ -38,7 +38,7 @@ data SapUserTableCsv = SapUserTableCsv -- for csv export only
|
||||
makeLenses_ ''SapUserTableCsv
|
||||
|
||||
sapUserTableCsvHeader :: Csv.Header
|
||||
sapUserTableCsvHeader = Csv.header
|
||||
sapUserTableCsvHeader = Csv.header
|
||||
[ "PersonalNummer"
|
||||
, "Qualifikation"
|
||||
, "GültigVon"
|
||||
@ -51,40 +51,40 @@ instance ToNamedRecord SapUserTableCsv where
|
||||
toNamedRecord SapUserTableCsv{..} = Csv.namedRecord
|
||||
[ "PersonalNummer" Csv..= csvSUTpersonalNummer
|
||||
, "Qualifikation" Csv..= csvSUTqualifikation
|
||||
, "GültigVon" Csv..= csvSUTgültigVon
|
||||
, "GültigBis" Csv..= csvSUTgültigBis
|
||||
, "GültigVon" Csv..= csvSUTgültigVon
|
||||
, "GültigBis" Csv..= csvSUTgültigBis
|
||||
-- , "SupendiertBis" Csv..= csvSUTsupendiertBis
|
||||
, "Ausprägung" Csv..= csvSUTausprägung
|
||||
, "Ausprägung" Csv..= csvSUTausprägung
|
||||
]
|
||||
|
||||
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
|
||||
-- temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo
|
||||
sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv]
|
||||
sapRes2csv = concatMap procRes
|
||||
where
|
||||
where
|
||||
procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks))
|
||||
| validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber
|
||||
= let mkSap (dfrom,duntil) = SapUserTableCsv
|
||||
{ csvSUTpersonalNummer = persNo
|
||||
, csvSUTqualifikation = sapId
|
||||
, csvSUTgültigVon = dfrom
|
||||
, csvSUTgültigBis = duntil
|
||||
, csvSUTgültigBis = duntil
|
||||
, csvSUTausprägung = "J"
|
||||
}
|
||||
in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks
|
||||
procRes _ = []
|
||||
|
||||
-- | compute a series of valid periods, assume that lists is already sorted by Day
|
||||
-- the lists encodes qualification_user_blocks with block=False/unblock=True
|
||||
-- the lists encodes qualification_user_blocks with block=False/unblock=True
|
||||
compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
|
||||
compileBlocks dStart dEnd = go (dStart, True)
|
||||
where
|
||||
compileBlocks dStart dEnd = go (dStart, True)
|
||||
where
|
||||
go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
|
||||
go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
|
||||
| s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change
|
||||
| d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
|
||||
| s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change
|
||||
| d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
|
||||
go (d,s) ((d1,s1):r1)
|
||||
| dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity
|
||||
| dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity
|
||||
| s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found
|
||||
| s == s1 = go (d ,s ) r1 -- no change
|
||||
| otherwise = go (d1,s1) r1 -- ignore invalid interval
|
||||
@ -95,18 +95,18 @@ compileBlocks dStart dEnd = go (dStart, True)
|
||||
-- | Deliver all employess with a successful LDAP synch within the last 3 months
|
||||
getQualificationSAPDirectR :: Handler TypedContent
|
||||
getQualificationSAPDirectR = do
|
||||
now <- liftIO getCurrentTime
|
||||
fdate <- formatTime' "%Y%m%d_%H-%M" now
|
||||
now <- liftIO getCurrentTime
|
||||
fdate <- formatTime' "%Y%m%d_%H-%M" now
|
||||
let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
|
||||
qualUsers <- runDB $ E.select $ do
|
||||
(qual :& qualUser :& user :& qualBlock) <-
|
||||
E.from $ E.table @Qualification
|
||||
qualUsers <- runDBRead $ E.select $ do
|
||||
(qual :& qualUser :& user :& qualBlock) <-
|
||||
E.from $ E.table @Qualification
|
||||
`E.innerJoin` E.table @QualificationUser
|
||||
`E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
|
||||
`E.innerJoin` E.table @User
|
||||
`E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId)
|
||||
`E.leftJoin` E.table @QualificationUserBlock
|
||||
`E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
|
||||
`E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
|
||||
qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
||||
E.&&. E.val now E.>~. qualBlock E.?. QualificationUserBlockFrom
|
||||
)
|
||||
@ -116,19 +116,19 @@ getQualificationSAPDirectR = do
|
||||
E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
|
||||
E.groupBy ( user E.^. UserCompanyPersonalNumber
|
||||
, qualUser E.^. QualificationUserFirstHeld
|
||||
, qualUser E.^. QualificationUserValidUntil
|
||||
, qualUser E.^. QualificationUserValidUntil
|
||||
, qual E.^. QualificationSapId
|
||||
)
|
||||
let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId]
|
||||
-- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder
|
||||
return
|
||||
return
|
||||
( user E.^. UserCompanyPersonalNumber
|
||||
, qual E.^. QualificationSapId
|
||||
, qualUser E.^. QualificationUserFirstHeld
|
||||
, qualUser E.^. QualificationUserValidUntil
|
||||
, E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom ) blockOrder
|
||||
, E.arrayAggWith E.AggModeAll ( qualBlock E.?. QualificationUserBlockUnblock) blockOrder
|
||||
)
|
||||
)
|
||||
let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
|
||||
fmtOpts = (review csvPreset CsvPresetRFC)
|
||||
{ csvIncludeHeader = True
|
||||
@ -144,7 +144,7 @@ getQualificationSAPDirectR = do
|
||||
let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
|
||||
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
||||
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
|
||||
|
||||
|
||||
|
||||
-- direct Download see:
|
||||
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
|
||||
|
||||
@ -70,15 +70,15 @@ nullaryPathPiece ''UserAction $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''UserAction id
|
||||
|
||||
data UserActionData = UserAvsSyncData
|
||||
| UserLdapSyncData
|
||||
| UserLdapSyncData
|
||||
| UserHijack
|
||||
| UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
|
||||
| UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
|
||||
| UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
|
||||
| UserRemoveSupervisorData
|
||||
| UserRemoveSubordinatesData
|
||||
|
||||
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
|
||||
isNotSetSupervisor :: UserActionData -> Bool
|
||||
isNotSetSupervisor UserSetSupervisorData{} = False
|
||||
isNotSetSupervisor _ = True
|
||||
@ -121,21 +121,21 @@ postUsersR = do
|
||||
-- (AdminUserR <$> encrypt uid)
|
||||
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
|
||||
, sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
supervisors' <- liftHandler . runDBRead . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
|
||||
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
|
||||
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
|
||||
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
|
||||
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
|
||||
let supervisors = intersperse (text2widget ", ") $
|
||||
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
|
||||
icnReroute = text2widget " " <> toWgt (icon IconLetter)
|
||||
icnReroute = text2widget " " <> toWgt (icon IconReroute)
|
||||
pure $ mconcat supervisors
|
||||
, sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
|
||||
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
|
||||
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
|
||||
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
|
||||
, flip foldMap universeF $ \function ->
|
||||
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
|
||||
schools <- liftHandler . runDBRead . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
|
||||
E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
|
||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
|
||||
@ -148,7 +148,7 @@ postUsersR = do
|
||||
<li>#{sh}
|
||||
|]
|
||||
, sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
|
||||
let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
|
||||
let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDBRead $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
|
||||
in listCell' getFunctions i18nCell
|
||||
, sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
|
||||
{ formCellAttrs = []
|
||||
@ -187,14 +187,14 @@ postUsersR = do
|
||||
return (act, usrSet)
|
||||
|
||||
acts :: Map UserAction (AForm Handler UserActionData)
|
||||
acts = mconcat
|
||||
acts = mconcat
|
||||
[ singletonMap UserLdapSync $ pure UserLdapSyncData
|
||||
, singletonMap UserAvsSync $ pure UserAvsSyncData
|
||||
, singletonMap UserAddSupervisor $ UserAddSupervisorData
|
||||
, singletonMap UserAddSupervisor $ UserAddSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
|
||||
<*> aopt textField (fslI MsgSupervisorReason) Nothing
|
||||
, singletonMap UserSetSupervisor $ UserSetSupervisorData
|
||||
, singletonMap UserSetSupervisor $ UserSetSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
|
||||
<*> aopt textField (fslI MsgSupervisorReason) Nothing
|
||||
@ -209,7 +209,7 @@ postUsersR = do
|
||||
, dbtProj = dbtProjId
|
||||
, dbtSorting = Map.fromList $
|
||||
[ ( SortingKey $ CI.mk $ toPathPiece function
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
|
||||
E.where_ $ uf E.^. UserFunctionUser E.==. user E.^. UserId
|
||||
E.&&. uf E.^. UserFunctionFunction E.==. E.val function
|
||||
return (uf E.^. UserFunctionSchool)
|
||||
@ -254,9 +254,9 @@ postUsersR = do
|
||||
return (usrSpvr E.^. UserDisplayName)
|
||||
)
|
||||
, ( "system-function"
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
|
||||
E.where_ $ usf E.^. UserSystemFunctionUser E.==. user E.^. UserId
|
||||
return $ usf E.^. UserSystemFunctionFunction
|
||||
return $ usf E.^. UserSystemFunctionFunction
|
||||
)
|
||||
]
|
||||
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
|
||||
@ -265,7 +265,7 @@ postUsersR = do
|
||||
-- if Set.null criteria then E.true else -- TODO: why is this condition not needed?
|
||||
-- -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
|
||||
-- E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
|
||||
-- )
|
||||
-- )
|
||||
-- , ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
|
||||
-- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
-- Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
|
||||
@ -299,8 +299,14 @@ postUsersR = do
|
||||
in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
|
||||
| otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
)
|
||||
, ( "avs-sync", FilterColumn . E.mkExistsFilter $ \user criterion ->
|
||||
E.from $ \usrAvs -> do
|
||||
let minTime = (E.val criterion :: E.SqlExpr (E.Value UTCTime))
|
||||
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
|
||||
E.&&. usrAvs E.^. UserAvsLastSynch E.<=. minTime
|
||||
)
|
||||
, ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
|
||||
E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
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
|
||||
@ -317,12 +323,12 @@ postUsersR = do
|
||||
E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
|
||||
)
|
||||
-- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
|
||||
-- E.from $ \usrAvs -> -- do
|
||||
-- E.from $ \usrAvs -> -- do
|
||||
-- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
|
||||
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
|
||||
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
|
||||
-- )
|
||||
, ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
|
||||
, ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
|
||||
Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
|
||||
Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
|
||||
_ -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
@ -341,8 +347,9 @@ postUsersR = do
|
||||
, prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
|
||||
, prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
|
||||
, prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
|
||||
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
|
||||
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
|
||||
, prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
|
||||
, prismAForm (singletonFilter "avs-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLastAvsSyncedBefore)
|
||||
]
|
||||
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
, dbtParams = DBParamsForm
|
||||
@ -368,10 +375,10 @@ postUsersR = do
|
||||
formResult usersRes $ \case
|
||||
(act, usersSet)
|
||||
| Set.null usersSet && isNotSetSupervisor act ->
|
||||
addMessageI Info MsgActionNoUsersSelected
|
||||
addMessageI Info MsgActionNoUsersSelected
|
||||
(UserLdapSyncData, userSet) -> do
|
||||
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid
|
||||
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
|
||||
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
(UserAvsSyncData, userSet) -> do
|
||||
n <- runDB $ queueAvsUpdateByUID userSet Nothing
|
||||
@ -379,7 +386,7 @@ postUsersR = do
|
||||
redirectKeepGetParams UsersR
|
||||
(UserHijack, Set.lookupMin -> Just uid) ->
|
||||
hijackUser uid >>= sendResponse
|
||||
(UserRemoveSupervisorData, userSet) -> do
|
||||
(UserRemoveSupervisorData, userSet) -> do
|
||||
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
|
||||
addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
@ -388,11 +395,11 @@ postUsersR = do
|
||||
addMessageI Success $ MsgUsersRemoveSubordinates $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
(act, usersSet)
|
||||
| isActionSupervisor act -> do
|
||||
| isActionSupervisor act -> do
|
||||
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
|
||||
let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
||||
users = Set.toList usersSet
|
||||
nrSuperNotFound = length supersNotFound
|
||||
nrSuperNotFound = length supersNotFound
|
||||
runDB $ do
|
||||
unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users]
|
||||
putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act)
|
||||
@ -413,7 +420,7 @@ postUsersR = do
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
||||
addMessageI Success MsgSynchroniseLdapAllUsersQueued
|
||||
redirect UsersR
|
||||
AllUsersAvsSync -> do
|
||||
AllUsersAvsSync -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser
|
||||
@ -425,7 +432,7 @@ postUsersR = do
|
||||
-- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
|
||||
Ex.<&> E.justVal nowaday
|
||||
)
|
||||
) (\current excluded ->
|
||||
) (\current excluded ->
|
||||
[ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
|
||||
, AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause)
|
||||
]
|
||||
@ -450,7 +457,7 @@ hijackUser uid = do
|
||||
setCredsRedirect $ Creds apDummy (CI.original userIdent) []
|
||||
|
||||
getAdminHijackUserR :: CryptoUUIDUser -> Handler Html
|
||||
getAdminHijackUserR cID = do
|
||||
getAdminHijackUserR cID = do
|
||||
(hijackWgt, hijackEnctype) <- generateFormPost hijackUserForm
|
||||
let hjForm = wrapForm hijackWgt def{ formSubmit = FormNoSubmit, formEncoding = hijackEnctype, formAction = Just . SomeRoute $ AdminHijackUserR cID }
|
||||
uid :: UserId <- decrypt cID
|
||||
@ -463,7 +470,7 @@ getAdminHijackUserR cID = do
|
||||
|]
|
||||
|
||||
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
|
||||
postAdminHijackUserR cID = do
|
||||
postAdminHijackUserR cID = do
|
||||
((hijackRes, _), _) <- runFormPost hijackUserForm
|
||||
$logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes
|
||||
uid <- decrypt cID
|
||||
@ -517,13 +524,13 @@ postAdminUserR uuid = do
|
||||
queueJob' $ JobSynchroniseLdapUser uid
|
||||
addMessageI Success $ MsgSynchroniseLdapUserQueued 1
|
||||
redirectKeepGetParams $ AdminUserR uuid
|
||||
ThisUserAvsSync -> do
|
||||
ThisUserAvsSync -> do
|
||||
n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing
|
||||
addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n
|
||||
redirectKeepGetParams $ AdminUserR uuid
|
||||
-- ThisUserHijack -> do
|
||||
-- redirect $ AdminHijackUserR uuid
|
||||
let thisUserActWgt = wrapForm thisUserActWgt' def
|
||||
let thisUserActWgt = wrapForm thisUserActWgt' def
|
||||
{ formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute $ AdminUserR uuid
|
||||
, formEncoding = thisUserActEnctype
|
||||
|
||||
@ -171,11 +171,11 @@ lookupAvsUsers apis = do
|
||||
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
|
||||
updateReceivers uid = do
|
||||
-- First perform AVS update for receiver
|
||||
runDB (getBy (UniqueUserAvsUser uid)) >>= \case
|
||||
runDBRead (getBy (UniqueUserAvsUser uid)) >>= \case
|
||||
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
|
||||
Nothing -> return ()
|
||||
-- Retrieve updated user and supervisors now
|
||||
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
|
||||
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDBRead $ (,)
|
||||
<$> getJustEntity uid
|
||||
<*> (E.select $ do
|
||||
(usrSuper :& usrAvs) <-
|
||||
@ -194,7 +194,7 @@ updateReceivers uid = do
|
||||
if null receiverIDs
|
||||
then directResult
|
||||
else do
|
||||
receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
|
||||
receivers <- runDBRead $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
|
||||
if null receivers
|
||||
then directResult
|
||||
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
|
||||
@ -450,7 +450,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
|
||||
|
||||
linktoAvsUserByUIDs :: Set UserId -> Handler ()
|
||||
linktoAvsUserByUIDs uids = do
|
||||
ips <- runDB $ E.select $ do
|
||||
ips <- runDBRead $ E.select $ do
|
||||
usr <- E.from $ E.table @User
|
||||
let uid = usr E.^. UserId
|
||||
ipn = usr E.^. UserCompanyPersonalNumber
|
||||
@ -484,18 +484,18 @@ createAvsUserById muid api = do
|
||||
case Set.toList contactRes of
|
||||
[] -> throwM $ AvsUserUnknownByAvs api
|
||||
(_:_:_) -> throwM $ AvsUserAmbiguous api
|
||||
[AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
|
||||
[adc@AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
|
||||
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
|
||||
| otherwise -> do
|
||||
-- check for matching existing user
|
||||
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
|
||||
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
|
||||
oldUsr <- runDB $ do
|
||||
-- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
|
||||
oldUsr <- runDBRead $ do
|
||||
mbUid <- if isJust muid
|
||||
then return muid
|
||||
else firstJustM $ catMaybes
|
||||
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
|
||||
, persMail <&> guessUserByEmail
|
||||
-- , persMail <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail!
|
||||
]
|
||||
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
|
||||
return (mbUid, mbUAvs)
|
||||
@ -533,11 +533,11 @@ createAvsUserById muid api = do
|
||||
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
|
||||
, audSurname = cpi ^. _avsInfoLastName & Text.strip
|
||||
, audDisplayName = cpi ^. _avsInfoDisplayName
|
||||
, audDisplayEmail = persMail & fromMaybe mempty
|
||||
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
|
||||
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
|
||||
, audDisplayEmail = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI
|
||||
, audEmail = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI
|
||||
, audIdent = "AVSID:" <> ciShow api
|
||||
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
|
||||
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
|
||||
, audMatriculation = cpi ^. _avsInfoPersonNo & Just
|
||||
, audSex = Nothing
|
||||
, audBirthday = cpi ^. _avsInfoDateOfBirth
|
||||
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
|
||||
@ -676,9 +676,14 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
|
||||
oldSup = snd <$> oldChanges
|
||||
unless (supChange == Just False) $ do
|
||||
-- upsert new superior company supervisor
|
||||
mbMaxPrio <- E.selectOne $ do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
|
||||
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
||||
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
||||
suprEnt <- upsertBy (UniqueUserCompany supid cid)
|
||||
(UserCompany supid cid True False 1 True)
|
||||
[UserCompanySupervisor =. True]
|
||||
(UserCompany supid cid True False maxPrio True)
|
||||
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio]
|
||||
E.insertSelectWithConflict UniqueUserSupervisor
|
||||
(do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
@ -736,15 +741,15 @@ guessAvsUser :: Text -> Handler (Maybe UserId)
|
||||
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
|
||||
| prefix=="AVSID:" =
|
||||
let avsid = AvsPersonId nr in
|
||||
runDB (getBy $ UniqueUserAvsId avsid) >>= \case
|
||||
runDBRead (getBy $ UniqueUserAvsId avsid) >>= \case
|
||||
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
|
||||
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
|
||||
| prefix=="AVSNO:" =
|
||||
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
|
||||
runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
|
||||
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
|
||||
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
|
||||
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
|
||||
runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
|
||||
runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
|
||||
other -> return other
|
||||
guessAvsUser someid = do
|
||||
try (runDB $ ldapLookupAndUpsert someid) >>= \case
|
||||
|
||||
@ -109,7 +109,7 @@ data CU_UserAvs_User
|
||||
| CU_UA_UserMatrikelnummer
|
||||
| CU_UA_UserCompanyPersonalNumber
|
||||
| CU_UA_UserLdapPrimaryKey
|
||||
-- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
|
||||
-- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmail instead
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance MkCheckUpdate CU_UserAvs_User where
|
||||
|
||||
@ -40,16 +40,16 @@ wgtCompanies = \uid -> do
|
||||
^{c}
|
||||
$forall c <- otherCmp
|
||||
<p>
|
||||
#{c}
|
||||
^{c}
|
||||
|]
|
||||
return $ toMaybe (notNull topCmp) resWgt
|
||||
where
|
||||
procCmp _ [] = (0, [],[])
|
||||
procCmp _ [] = (0, [], [])
|
||||
procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
|
||||
let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
|
||||
isTop = cmpPrio >= maxPri
|
||||
let isTop = cmpPrio >= maxPri
|
||||
cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
|
||||
(accPri,accTop,accRem) = procCmp maxPri cs
|
||||
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpName : accRem) accRem isTop) -- lazy evaluation after repmin example
|
||||
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
|
||||
|
||||
-- TODO: use this function in company view Handler.Firm #157
|
||||
-- | add all company supervisors for a given users
|
||||
|
||||
@ -112,12 +112,14 @@ validQualification' cutoff qualUser =
|
||||
E.&&. quserBlock' False cutoff qualUser
|
||||
|
||||
-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
|
||||
selectValidQualifications ::
|
||||
( MonadIO m
|
||||
, BackendCompatible SqlBackend backend
|
||||
, PersistQueryRead backend
|
||||
, PersistUniqueRead backend
|
||||
) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
|
||||
-- selectValidQualifications ::
|
||||
-- ( MonadIO m
|
||||
-- , BackendCompatible SqlBackend backend
|
||||
-- , PersistQueryRead backend
|
||||
-- , PersistUniqueRead backend
|
||||
-- ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
|
||||
selectValidQualifications :: (MonadIO m, E.SqlBackendCanRead backend)
|
||||
=> QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
|
||||
selectValidQualifications qid uids cutoff =
|
||||
-- cutoff <- utctDay <$> liftIO getCurrentTime
|
||||
E.select $ do
|
||||
|
||||
@ -14,7 +14,7 @@ import Handler.Utils.DateTime
|
||||
import Handler.Utils.Widgets
|
||||
import Handler.Utils.Occurrences
|
||||
import Handler.Utils.LMS (lmsUserStatusWidget)
|
||||
import Handler.Utils.Qualification (isValidQualification)
|
||||
import Handler.Utils.Qualification (isValidQualification)
|
||||
|
||||
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
|
||||
|
||||
@ -41,16 +41,23 @@ cellTell = flip tellCell
|
||||
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
|
||||
indicatorCell = writerCell . tell $ Any True
|
||||
|
||||
addIndicatorCell :: IsDBTable m Any => DBCell m Any -> DBCell m Any
|
||||
addIndicatorCell = tellCell $ Any True
|
||||
|
||||
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
|
||||
writerCell act = mempty & cellContents %~ (<* act)
|
||||
|
||||
-- for documentation purposes
|
||||
-- for documentation purposes
|
||||
cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
|
||||
cellMaybe = foldMap
|
||||
|
||||
maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
|
||||
maybeCell = flip foldMap
|
||||
|
||||
boolCell :: IsDBTable m b => Bool -> DBCell m b -> DBCell m b
|
||||
boolCell True c = c
|
||||
boolCell False _ = mempty
|
||||
|
||||
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
|
||||
htmlCell = cell . toWidget . toMarkup
|
||||
|
||||
@ -62,7 +69,7 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
|
||||
sqlCell act = mempty & cellContents .~ lift act
|
||||
|
||||
-- TODO: Formulate variant of sqlCell that types for tables having actions, i.e. MForm istead of YesodDB?
|
||||
-- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a
|
||||
-- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a
|
||||
-- sqlCell' = flip (set' cellContents) mempty
|
||||
|
||||
-- | Highlight table cells with warning: Is not yet implemented in frontend.
|
||||
@ -158,14 +165,14 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget
|
||||
|
||||
-- | Show Text if it is small, create modal otherwise
|
||||
modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a
|
||||
modalCellLarge content
|
||||
modalCellLarge content
|
||||
| length content > 32 = modalCell content
|
||||
| otherwise = stringCell content
|
||||
|
||||
markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a
|
||||
markupCellLargeModal mup
|
||||
| markupIsSmallish mup = cell $ toWidget mup
|
||||
| otherwise = modalCell mup
|
||||
| otherwise = modalCell mup
|
||||
|
||||
-----------------
|
||||
-- Datatype cells
|
||||
@ -221,44 +228,44 @@ cellHasUserLink toLink user =
|
||||
|
||||
-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights
|
||||
cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
|
||||
cellHasUserModal toLink user =
|
||||
cellHasUserModal toLink user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
||||
lWdgt = do
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modalAccess nWdgt nWdgt False $ toLink uuid
|
||||
modalAccess nWdgt nWdgt False $ toLink uuid
|
||||
in cell lWdgt
|
||||
|
||||
-- | like `cellHasUserModal` but but always display link without prior access rights checks
|
||||
cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
|
||||
cellHasUserModalAdmin toLink user =
|
||||
cellHasUserModalAdmin toLink user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
||||
lWdgt = do
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modal nWdgt $ Left $ SomeRoute $ toLink uuid
|
||||
modal nWdgt $ Left $ SomeRoute $ toLink uuid
|
||||
in cell lWdgt
|
||||
|
||||
-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights
|
||||
cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
|
||||
cellEditUserModal user =
|
||||
cellEditUserModal user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modalAccess mempty nWdgt True $ ForProfileR uuid
|
||||
in cell lWdgt
|
||||
|
||||
-- | like `cellEditUserModal` but always displays the link without prior access rights checks
|
||||
cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
|
||||
cellEditUserModalAdmin user =
|
||||
cellEditUserModalAdmin user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
|
||||
in cell lWdgt
|
||||
@ -267,23 +274,23 @@ cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
|
||||
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
|
||||
|
||||
cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a
|
||||
cellHasMatrikelnummerLinked isAdmin usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
cellHasMatrikelnummerLinked isAdmin usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
|
||||
if isAdmin
|
||||
then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid)
|
||||
| otherwise = mempty
|
||||
where
|
||||
where
|
||||
usrEntity = usr ^. hasEntityUser
|
||||
|
||||
cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
|
||||
cellHasMatrikelnummerLinkedAdmin usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
cellHasMatrikelnummerLinkedAdmin usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
|
||||
modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
| otherwise = mempty
|
||||
where
|
||||
where
|
||||
usrEntity = usr ^. hasEntityUser
|
||||
|
||||
|
||||
@ -393,7 +400,7 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific
|
||||
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
|
||||
qualificationValidIconCell d qb qu = do
|
||||
blockIcon $ isValidQualification d qu qb
|
||||
where
|
||||
where
|
||||
blockIcon = cell . toWidget . iconQualificationBlock
|
||||
|
||||
qualificationValidUntilCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
|
||||
@ -402,11 +409,11 @@ qualificationValidUntilCell = qualificationValidUntilCell' (Just LmsUserAllR)
|
||||
qualificationValidUntilCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Day -> Maybe b -> a -> DBCell m c
|
||||
qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
|
||||
Nothing -> headWgt <> dateWgt
|
||||
Just toLink -> do
|
||||
Just toLink -> do
|
||||
uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
|
||||
let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid
|
||||
headWgt <> modalWgt
|
||||
where
|
||||
where
|
||||
dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
|
||||
iconWgt = toWidget $ iconQualificationBlock $ isValidQualification d qu qb
|
||||
headWgt = iconWgt <> [whamlet| |]
|
||||
@ -416,18 +423,18 @@ qualificationValidReasonCell = qualificationValidReasonCell' (Just LmsUserAllR)
|
||||
|
||||
qualificationValidReasonCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c
|
||||
qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
|
||||
where
|
||||
where
|
||||
ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb
|
||||
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
|
||||
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
| qualificationUserBlockUnblock = mempty
|
||||
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom
|
||||
dc tstamp
|
||||
dc tstamp
|
||||
| Just toLink <- mbToLink = cell $ do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
let dWgt = formatTimeW SelFormatDate tstamp
|
||||
modalAccess dWgt dWgt False $ toLink uuid
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
| otherwise = dateCell tstamp
|
||||
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
||||
|
||||
@ -438,15 +445,15 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
|
||||
icErr = cell . toWidget . isBad $ quValid /= extValid
|
||||
ic = cell . toWidget $ iconQualificationBlock quValid
|
||||
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
|
||||
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
| showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
|
||||
| qualificationUserBlockUnblock = mempty
|
||||
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom
|
||||
dc tstamp
|
||||
dc tstamp
|
||||
| Just toLink <- mbToLink = cell $ do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
let dWgt = formatTimeW SelFormatDate tstamp
|
||||
modalAccess dWgt dWgt False $ toLink uuid
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
| otherwise = dateCell tstamp
|
||||
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
||||
|
||||
@ -496,7 +503,7 @@ lmsStatusCell extendedInfo mkLink = wgtCell . lmsUserStatusWidget extendedInfo m
|
||||
|
||||
lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
|
||||
lmsStateCell LmsFailed = iconBoolCell False
|
||||
lmsStateCell LmsOpen = iconSpacerCell
|
||||
lmsStateCell LmsOpen = iconSpacerCell
|
||||
lmsStateCell LmsPassed = iconBoolCell True
|
||||
|
||||
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
|
||||
@ -515,7 +522,7 @@ avsPersonNoLinkedCellAdmin a = cell $ do
|
||||
modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
|
||||
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
|
||||
avsPersonCardCell cards = wgtCell
|
||||
avsPersonCardCell cards = wgtCell
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul .list--iconless .list--inline .list--comma-separated>
|
||||
@ -523,6 +530,6 @@ avsPersonCardCell cards = wgtCell
|
||||
<li>
|
||||
_{c}
|
||||
|]
|
||||
where
|
||||
where
|
||||
validCards = Set.filter avsDataValid cards
|
||||
validColors = Set.toDescList $ Set.map avsDataCardColor validCards
|
||||
@ -84,7 +84,7 @@ import Data.Ratio ((%))
|
||||
import qualified Data.Foldable as Foldable
|
||||
|
||||
import qualified Yesod.Form.Functions as Yesod
|
||||
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect,unsafeSqlValue)
|
||||
@ -170,7 +170,7 @@ dbFilterKey ident = toPathPiece . WithIdent ident
|
||||
|
||||
|
||||
data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
|
||||
|
||||
|
||||
data SortColumn t r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
| forall a. PersistField a => SortColumnNullsInv { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
| forall a. PersistField a => SortColumnNeverNull { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
@ -264,7 +264,7 @@ instance Monoid (DBTProjFilterPost r') where
|
||||
data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a
|
||||
| forall a. IsFilterColumnHandler t a => FilterColumnHandler a
|
||||
| forall a. IsFilterProjected fs a => FilterProjected a
|
||||
|
||||
|
||||
|
||||
filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
|
||||
filterColumn (FilterColumn f) = Just $ filterColumn' f
|
||||
@ -292,9 +292,9 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
|
||||
filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
|
||||
|
||||
class IsFilterColumnHandler t a where
|
||||
filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool))
|
||||
|
||||
class IsFilterColumnHandler t a where
|
||||
filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool))
|
||||
|
||||
instance IsFilterColumnHandler t ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) where
|
||||
filterColumnHandler' fin args = fin args
|
||||
@ -482,7 +482,7 @@ data DBCsvMode
|
||||
| DBCsvAbort
|
||||
|
||||
makePrisms ''DBCsvMode
|
||||
|
||||
|
||||
data DBCsvDiff r' csv k'
|
||||
= DBCsvDiffNew
|
||||
{ dbCsvNewKey :: Maybe k'
|
||||
@ -519,7 +519,7 @@ makeLenses_ ''DBCsvException
|
||||
|
||||
instance (Typeable k', Show k') => Exception (DBCsvException k')
|
||||
|
||||
|
||||
|
||||
data DBTProjCtx fs r = DBTProjCtx
|
||||
{ dbtProjFilter :: fs
|
||||
, dbtProjRow :: DBRow r
|
||||
@ -613,7 +613,7 @@ data DBStyle r = DBStyle
|
||||
}
|
||||
|
||||
data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool }
|
||||
| DBSTCourse
|
||||
| DBSTCourse
|
||||
(Lens' r (Entity Course)) -- course
|
||||
(Traversal' r (Entity User)) -- lecturers
|
||||
(Lens' r Bool) -- isRegistered
|
||||
@ -666,7 +666,7 @@ multiFilter key = prism' fromInner fromOuter
|
||||
-- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v])
|
||||
fromInner = maybe Map.empty (Map.singleton key)
|
||||
fromOuter = Just . Map.lookup key
|
||||
|
||||
|
||||
data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
|
||||
( ToNamedRecord csv, CsvColumnsExplained csv
|
||||
, DBTableKey k'
|
||||
@ -750,7 +750,7 @@ dbtProjId :: forall fs r r'.
|
||||
( fs ~ (), DBRow r ~ r' )
|
||||
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
|
||||
dbtProjId = dbtProjId'
|
||||
|
||||
|
||||
dbtProjSimple' :: forall fs r r' r''.
|
||||
DBRow r'' ~ r'
|
||||
=> (r -> DB r'')
|
||||
@ -1059,7 +1059,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
doSorting <- or2M
|
||||
(getsYesod . views _appBotMitigations $ Set.notMember SettingBotMitigationOnlyLoggedInTableSorting)
|
||||
(is _Just <$> maybeAuthId)
|
||||
|
||||
|
||||
let
|
||||
sortingOptions = mkOptionList
|
||||
[ Option t' (SortingSetting t d) t'
|
||||
@ -1112,7 +1112,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
<|> piInput
|
||||
|
||||
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
|
||||
|
||||
|
||||
let
|
||||
-- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now
|
||||
((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
|
||||
@ -1217,8 +1217,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
-- && all (is _Just) filterSql
|
||||
|
||||
-- psLimit' = bool PagesizeAll psLimit selectPagesize
|
||||
|
||||
filterHandler <- case csvMode of
|
||||
|
||||
filterHandler <- case csvMode of
|
||||
FormSuccess DBCsvImport{} -> return mempty -- don't execute Handler actions for unneeded filters upon csv _import_
|
||||
_other -> liftHandler $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnHandler fc
|
||||
|
||||
@ -1240,7 +1240,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps -- Note that multiple where_ are indeed concatenated
|
||||
_other -> return ()
|
||||
let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) []
|
||||
sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both
|
||||
sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both
|
||||
unless (null sqlFilters) $ E.where_ $ E.and sqlFilters
|
||||
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
|
||||
|
||||
@ -1279,7 +1279,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
exData <- hoistMaybe dbtCsvExampleData
|
||||
hdr <- lift $ dbtCsvHeader Nothing
|
||||
exportUrl <- toTextUrl (currentRoute, [(toPathPiece GetCsvExampleData, "")])
|
||||
return $(widgetFile "table/csv-example")
|
||||
return $(widgetFile "table/csv-example")
|
||||
|
||||
formResult csvMode $ \case
|
||||
DBCsvAbort{} -> do
|
||||
@ -1470,7 +1470,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
guardM doAltRep
|
||||
|
||||
cts <- reqAccept <$> getRequest
|
||||
|
||||
|
||||
altRep <- hoistMaybe <=< asum $ do
|
||||
mRep <- hoistMaybe . selectRep' extraReps' =<< cts
|
||||
return . return $ mRep <&> \case
|
||||
@ -1520,7 +1520,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
-> State.modify $ (:) (n, beforeSize, cellSize)
|
||||
| otherwise -> return ()
|
||||
let rowspanAcc'' = rowspanAcc'
|
||||
& traverse . _1 %~ pred
|
||||
& traverse . _1 %~ pred
|
||||
whenIsJust (flattenAnnotated v) $ go rowspanAcc''
|
||||
|
||||
compCellSize :: forall h' c. [(Int, Int, Int)] -> [Sized (Maybe Int) h' c] -> Sized (Maybe Int) h' c -> (Int, Maybe Int)
|
||||
@ -1634,7 +1634,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
addMessageI Success . MsgCsvImportSuccessful $ length acts'
|
||||
E.transactionSave
|
||||
redirect finalDest
|
||||
|
||||
|
||||
_other -> return ((FormMissing, mempty), mempty)
|
||||
formResult csvImportConfirmRes $ \case
|
||||
(_, BtnCsvImportAbort) -> do
|
||||
@ -1661,7 +1661,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
||||
setParam key = setParams key . maybeToList
|
||||
|
||||
|
||||
|
||||
dbTableWidget :: Monoid x
|
||||
=> PSValidator (HandlerFor UniWorX) x
|
||||
@ -1784,7 +1784,7 @@ anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget)
|
||||
|
||||
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
|
||||
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
|
||||
|
||||
|
||||
anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
|
||||
anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)
|
||||
|
||||
@ -1855,7 +1855,7 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $
|
||||
|
||||
listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
|
||||
listCell = listCell' . return
|
||||
|
||||
|
||||
listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
|
||||
listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell
|
||||
|
||||
@ -1926,7 +1926,7 @@ dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
|
||||
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
|
||||
-- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
|
||||
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ pure ("uw-hide-columns--no-hide","")) $ formCell resLens genIndex genForm
|
||||
where
|
||||
where
|
||||
genForm _ mkUnique = do
|
||||
(selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
|
||||
return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
|
||||
@ -1936,7 +1936,7 @@ dbSelectIf :: forall x h r i a. (Headedness h, Monoid' x)
|
||||
=> Lens' x (FormResult (DBFormResult i a (DBRow r)))
|
||||
-> Setter' a Bool
|
||||
-> (DBRow r -> MForm (HandlerFor UniWorX) i)
|
||||
-> (DBRow r -> Bool)
|
||||
-> (DBRow r -> Bool)
|
||||
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
|
||||
dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ [("uw-hide-columns--no-hide", mempty)] ) fCell
|
||||
where
|
||||
@ -1945,9 +1945,9 @@ dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessP
|
||||
(selResult, selWidget) <- mreq checkBoxField ((bool inputDisabled id $ condition row) $ fsUniq mkUnique "select") (Just False) -- produces disabled field, but still checked by master checkbox from header
|
||||
--(selResult, selWidget) <- mreq (bool noField checkBoxField $ condition row) (fsUniq mkUnique "select") (Just False) -- omits field entirely, but also removes master checkbox from header
|
||||
{- Similar to previous: omits field entirely, but also removes master checkbox from header
|
||||
(selResult, selWidget) <- if condition row
|
||||
(selResult, selWidget) <- if condition row
|
||||
then mreq checkBoxField (fsUniq mkUnique "select") (Just False)
|
||||
else return (FormMissing, FieldView "" Nothing "" mempty Nothing False)
|
||||
else return (FormMissing, FieldView "" Nothing "" mempty Nothing False)
|
||||
-}
|
||||
return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
|
||||
|
||||
|
||||
@ -62,7 +62,7 @@ userWidget :: HasUser c => c -> Widget
|
||||
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
|
||||
|
||||
userIdWidget :: UserId -> Widget
|
||||
userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDB $ get uid)
|
||||
userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)
|
||||
|
||||
linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
|
||||
linkUserWidget lnk (Entity uid usr) = do
|
||||
@ -71,7 +71,7 @@ linkUserWidget lnk (Entity uid usr) = do
|
||||
|
||||
-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
|
||||
linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
|
||||
linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDB $ get uid)
|
||||
linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)
|
||||
|
||||
userEmailWidget :: HasUser c => c -> Widget
|
||||
userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
|
||||
@ -141,15 +141,20 @@ modalAccess wdgtNo wdgtYes writeAccess route = do
|
||||
else wdgtNo
|
||||
|
||||
-- also see Handler.Utils.Table.Cells.companyCell
|
||||
companyWidget :: (CompanyShorthand, CompanyName, Bool) -> Widget
|
||||
companyWidget (csh, cname, isSupervisor) = simpleLink (toWgt name) curl
|
||||
companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
|
||||
companyWidget isPrimary (csh, cname, isSupervisor)
|
||||
| isPrimary, isSupervisor = simpleLink (toWgt $ name <> iconSupervisor) curl
|
||||
| isPrimary = simpleLink (toWgt name ) curl
|
||||
| isSupervisor = toWgt name <> simpleLink (toWgt iconSupervisor) curl
|
||||
| otherwise = toWgt name
|
||||
where
|
||||
curl = FirmUsersR csh
|
||||
corg = ciOriginal cname
|
||||
name
|
||||
| isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
|
||||
| isSupervisor = text2markup (corg <> " ")
|
||||
| otherwise = text2markup corg
|
||||
|
||||
|
||||
----------
|
||||
-- HEAT --
|
||||
----------
|
||||
|
||||
@ -3,9 +3,9 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Jobs.Handler.SynchroniseAvs
|
||||
( dispatchJobSynchroniseAvs
|
||||
( dispatchJobSynchroniseAvs
|
||||
-- , dispatchJobSynchroniseAvsId
|
||||
-- , dispatchJobSynchroniseAvsUser
|
||||
-- , dispatchJobSynchroniseAvsUser
|
||||
, dispatchJobSynchroniseAvsQueue
|
||||
) where
|
||||
|
||||
@ -26,7 +26,7 @@ import Handler.Utils.Avs
|
||||
|
||||
-- pause is a date in the past; don't synch again if the last synch was after pause
|
||||
dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
|
||||
dispatchJobSynchroniseAvs numIterations epoch iteration pause
|
||||
dispatchJobSynchroniseAvs numIterations epoch iteration pause
|
||||
= JobHandlerException . runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
todos <- runConduit $ readUsers .| filterIteration now .| sinkList
|
||||
@ -44,13 +44,13 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
|
||||
userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
|
||||
currentIteration = toInteger iteration `mod` toInteger numIterations
|
||||
$logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
|
||||
guard $ userIteration == currentIteration
|
||||
return $ AvsSync userId now pause
|
||||
guard $ userIteration == currentIteration
|
||||
return $ AvsSync userId now pause
|
||||
|
||||
-- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
|
||||
-- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
|
||||
-- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
|
||||
-- where
|
||||
-- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
|
||||
-- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
|
||||
-- where
|
||||
-- processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause
|
||||
-- insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid
|
||||
|
||||
@ -66,7 +66,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
|
||||
-- -- , avsSyncPause = pause
|
||||
-- -- }
|
||||
-- -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308
|
||||
-- runDB $ maybeM
|
||||
-- runDB $ maybeM
|
||||
-- (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause})
|
||||
-- (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} ->
|
||||
-- update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now])
|
||||
@ -78,10 +78,10 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
|
||||
-- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
|
||||
-- (unlinked,linked) <- runDB $ do
|
||||
-- jobs <- E.select (do
|
||||
-- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
|
||||
-- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
|
||||
-- `E.leftJoin` E.table @UserAvs
|
||||
-- `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
|
||||
-- let pause = avsSync E.^. AvsSyncPause
|
||||
-- let pause = avsSync E.^. AvsSyncPause
|
||||
-- lastSync = usrAvs E.?. UserAvsLastSynch
|
||||
-- E.where_ $ E.isNothing pause
|
||||
-- E.||. E.isNothing lastSync
|
||||
@ -91,22 +91,22 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
|
||||
-- let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
|
||||
-- E.deleteWhere [AvsSyncId <-. syncIds]
|
||||
-- return (unlinked, linked)
|
||||
|
||||
|
||||
-- void $ updateAvsUserByIds linked
|
||||
-- void $ linktoAvsUserByUIDs unlinked
|
||||
-- -- we do not reschedule failed synchs here in order to avoid a loop
|
||||
-- where
|
||||
-- where
|
||||
-- discernJob (accSync, accUid, accApi) (E.Value k, _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi)
|
||||
-- discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value Nothing ) = (k:accSync, Set.insert uid accUid, accApi)
|
||||
|
||||
|
||||
dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
|
||||
dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
|
||||
jobs <- runDB $ do
|
||||
dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
|
||||
jobs <- runDBRead $ do
|
||||
E.select (do
|
||||
(avsSync :& usrAvs) <- E.from $ E.table @AvsSync
|
||||
(avsSync :& usrAvs) <- E.from $ E.table @AvsSync
|
||||
`E.leftJoin` E.table @UserAvs
|
||||
`E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
|
||||
let pause = avsSync E.^. AvsSyncPause
|
||||
let pause = avsSync E.^. AvsSyncPause
|
||||
lastSync = usrAvs E.?. UserAvsLastSynch
|
||||
proceed = E.isNothing pause
|
||||
E.||. E.isNothing lastSync
|
||||
@ -124,7 +124,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
|
||||
runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
|
||||
$logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||
-- we do not reschedule failed synchs here in order to avoid a loop
|
||||
where
|
||||
where
|
||||
discernJob accs ( _ , E.Value (Just api), E.Value True ) = accs & over _2 (Set.insert api)
|
||||
discernJob accs (E.Value uid, E.Value Nothing , E.Value True ) = accs & over _1 (Set.insert uid)
|
||||
discernJob accs ( _ , _ , E.Value False ) = accs
|
||||
|
||||
@ -412,6 +412,10 @@ citext2widget t = [whamlet|#{CI.original t}|]
|
||||
str2widget :: String -> WidgetFor site ()
|
||||
str2widget s = [whamlet|#{s}|]
|
||||
|
||||
-- | hamlet does not like quotes
|
||||
spaceWidget :: WidgetFor site ()
|
||||
spaceWidget = str2widget " "
|
||||
|
||||
int2widget :: Int64 -> WidgetFor site ()
|
||||
int2widget i = [whamlet|#{tshow i}|]
|
||||
|
||||
|
||||
@ -106,19 +106,21 @@ data Icon
|
||||
| IconBlocked
|
||||
| IconCertificate
|
||||
| IconPrintCenter
|
||||
| IconLetter
|
||||
| IconLetter -- only to be used for postal matters
|
||||
| IconAt
|
||||
| IconSupervisor
|
||||
| IconSupervisorForeign
|
||||
| IconSuperior -- supervisor and head of department
|
||||
-- IconWaitingForUser
|
||||
| IconExpired
|
||||
| IconLocked
|
||||
| IconUnlocked
|
||||
| IconResetTries -- also see IconReset
|
||||
| IconResetTries -- also see IconReset
|
||||
| IconCompany
|
||||
| IconEdit
|
||||
| IconUserEdit
|
||||
-- IconMagic -- indicates automatic updates
|
||||
-- IconMagic -- indicates automatic updates
|
||||
| IconReroute -- for notification rerouting
|
||||
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||
deriving anyclass (Universe, Finite, NFData)
|
||||
@ -158,7 +160,7 @@ iconText = \case
|
||||
IconSFTHint -> "life-ring" -- for SheetFileType only
|
||||
IconSFTSolution -> "exclamation-circle" -- for SheetFileType only
|
||||
IconSFTMarking -> "check-circle" -- for SheetFileType only
|
||||
IconEmail -> "envelope" -- envelope is no longer unamibuous, use IconAt or IconLetter if email and postal need to be distinguished
|
||||
IconEmail -> "envelope" -- envelope is no longer unambiguous, use IconAt or IconLetter if email and postal need to be distinguished
|
||||
IconRegisterTemplate -> "file-alt"
|
||||
IconNoCorrectors -> "user-slash"
|
||||
IconRemoveUser -> "user-slash"
|
||||
@ -207,6 +209,7 @@ iconText = \case
|
||||
IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter
|
||||
IconSupervisor -> "head-side" -- must be notably different to user
|
||||
IconSupervisorForeign -> "alien"
|
||||
IconSuperior -> "user-tie" -- user-crown
|
||||
-- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
|
||||
IconExpired -> "hourglass-end"
|
||||
IconLocked -> "lock"
|
||||
@ -216,7 +219,7 @@ iconText = \case
|
||||
IconEdit -> "edit"
|
||||
IconUserEdit -> "user-edit"
|
||||
-- IconMagic -> "wand-magic"
|
||||
|
||||
IconReroute -> "directions"
|
||||
nullaryPathPiece ''Icon $ camelToPathPiece' 1
|
||||
deriveLift ''Icon
|
||||
|
||||
@ -316,6 +319,8 @@ iconExamRegister :: Bool -> Markup
|
||||
iconExamRegister True = icon IconExamRegisterTrue
|
||||
iconExamRegister False = icon IconExamRegisterFalse
|
||||
|
||||
-- | indicator whether notifications are sent by letter or email
|
||||
-- use iconReroute if type of rerouting is unclear
|
||||
iconLetterOrEmail :: Bool -> Markup
|
||||
iconLetterOrEmail True = icon IconLetter
|
||||
iconLetterOrEmail False = icon IconAt
|
||||
|
||||
@ -11,15 +11,22 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dd .deflist__dd .email>
|
||||
#{userIdent}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAuthModeSet}
|
||||
<dd .deflist__dd>
|
||||
_{MsgAuthModeSet}
|
||||
<dd .deflist__dd>
|
||||
_{userAuthentication}
|
||||
$maybe avs <- avsId
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsPersonNo}
|
||||
^{messageTooltip tooltipAvsPersNo}
|
||||
<dd .deflist__dd .ldap-primary-key>
|
||||
#{view _userAvsNoPerson avs}
|
||||
$with avsNoPers <- tshow (view _userAvsNoPerson avs)
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsPersonNo}
|
||||
^{messageTooltip tooltipAvsPersNo}
|
||||
$maybe matnr <- userMatrikelnummer
|
||||
$if matnr /= avsNoPers
|
||||
^{messageTooltip tooltipAvsPersNoDiffers}
|
||||
<dd .deflist__dd .ldap-primary-key>
|
||||
^{modalAccess (text2widget avsNoPers) (text2widget avsNoPers) False (AdminAvsUserR cID)}
|
||||
$maybe matnr <- userMatrikelnummer
|
||||
$if matnr /= avsNoPers
|
||||
/ #{matnr}
|
||||
$maybe avsError <- view _userAvsLastSynchError avs
|
||||
<dt .deflist__dt>
|
||||
_{MsgLastAvsSynchError}
|
||||
@ -29,15 +36,18 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
_{MsgLastAvsSynchronisation}
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
|
||||
$nothing
|
||||
$maybe matnr <- userMatrikelnummer
|
||||
<dt .deflist__dt>
|
||||
_{MsgTableMatrikelNr}
|
||||
^{messageTooltip tooltipAvsPersNo}
|
||||
^{usrAutomatic CU_UA_UserMatrikelnummer}
|
||||
<dd .deflist__dd>
|
||||
^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)}
|
||||
<dt .deflist__dt>
|
||||
_{MsgNameSet} ^{usrAutomatic CU_UA_UserDisplayName}
|
||||
<dd .deflist__dd>
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe matnr <- userMatrikelnummer
|
||||
<dt .deflist__dt>
|
||||
_{MsgTableMatrikelNr} ^{usrAutomatic CU_UA_UserMatrikelnummer}
|
||||
<dd .deflist__dd>
|
||||
^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)}
|
||||
$maybe sex <- userSex
|
||||
<dt .deflist__dt>
|
||||
_{MsgTableSex}
|
||||
@ -58,7 +68,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dt .deflist__dt>
|
||||
_{MsgAdminUserPostAddress} #
|
||||
^{updateAutomatic postalAutomatic}
|
||||
<dd .deflist__dd>
|
||||
<dd .deflist__dd>
|
||||
#{addr}
|
||||
$if (not postalAutomatic)
|
||||
$maybe postUpdate <- userPostLastUpdate
|
||||
@ -84,6 +94,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
#{userEmail}
|
||||
<dt .deflist__dt>
|
||||
_{MsgAdminUserPinPassword}
|
||||
^{usrAutomatic CU_UA_UserPinPassword}
|
||||
<dd .deflist__dd>
|
||||
$maybe pass <- userPinPassword
|
||||
#{pass}
|
||||
@ -108,24 +119,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dt .deflist__dt>
|
||||
_{MsgCompanyPersonalNumber} ^{usrAutomatic CU_UA_UserCompanyPersonalNumber}
|
||||
<dd .deflist__dd>
|
||||
#{companyPersonalNumber}
|
||||
#{companyPersonalNumber}
|
||||
$maybe compWgt <- companies
|
||||
<dt .deflist__dt>
|
||||
_{MsgCompany}
|
||||
<dd .deflist__dd>
|
||||
^{compWgt}
|
||||
$if numSupervisors > 0
|
||||
<dt .deflist__dt>_{MsgProfileSupervisor}
|
||||
$if numSupervisors > 3
|
||||
\ #{numSupervisors}
|
||||
<dd .deflist__dd>
|
||||
^{mconcat supervisors}
|
||||
$if numSupervisees > 0
|
||||
<dt .deflist__dt>_{MsgProfileSupervisee}
|
||||
$if length supervisees > 3
|
||||
\ #{numSupervisees}
|
||||
<dd .deflist__dd>
|
||||
^{mconcat supervisees}
|
||||
$if showAdminInfo
|
||||
<dt .deflist__dt>
|
||||
_{MsgUserCreated}
|
||||
@ -147,7 +146,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
_{MsgNeverSet}
|
||||
$maybe pKey <- userLdapPrimaryKey
|
||||
<dt .deflist__dt>
|
||||
_{MsgProfileLdapPrimaryKey}
|
||||
_{MsgProfileLdapPrimaryKey}
|
||||
<dd .deflist__dd .ldap-primary-key>
|
||||
#{pKey}
|
||||
<dt .deflist__dt>
|
||||
@ -197,67 +196,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
$nothing
|
||||
^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
|
||||
<section>
|
||||
<div .container>
|
||||
$if hasRowsOwnedCourses
|
||||
<div .container>
|
||||
<h2>_{MsgProfileCourses}
|
||||
<div .container>
|
||||
^{ownedCoursesTable}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileCourseParticipations}
|
||||
<div .container>
|
||||
^{enrolledCoursesTable}
|
||||
^{supervisorsWgt}
|
||||
|
||||
^{superviseesWgt}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileQualifications}
|
||||
<div .container>
|
||||
^{qualificationsTable}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileCourseExamResults}
|
||||
<div .container>
|
||||
^{examTable}
|
||||
^{maybeTable MsgProfileCourses ownedCoursesTable}
|
||||
|
||||
^{maybeTable MsgProfileCourseParticipations enrolledCoursesTable}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileTutorials}
|
||||
<div .container>
|
||||
^{ownTutorialTable}
|
||||
^{maybeTable MsgProfileSubmissionGroups submissionGroupTable}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileTutorialParticipations}
|
||||
<div .container>
|
||||
^{tutorialTable}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileSubmissionGroups}
|
||||
<div .container>
|
||||
^{submissionGroupTable}
|
||||
|
||||
<div .container>
|
||||
<h2>_{MsgProfileSubmissions}
|
||||
<div .container>
|
||||
^{submissionTable}
|
||||
<em>_{MsgProfileRemark}
|
||||
\ _{MsgProfileGroupSubmissionDates}
|
||||
|
||||
<div .container>
|
||||
<h2> _{MsgTableCorrector}
|
||||
<div .container>
|
||||
^{correctionsTable}
|
||||
|
||||
<em>_{MsgProfileRemark}
|
||||
\ _{MsgProfileCorrectorRemark}
|
||||
<a href=@{CorrectionsR}>_{MsgProfileCorrections}
|
||||
|
||||
<div .container>
|
||||
<h2> _{MsgProfileSupervisor}
|
||||
<div .container>
|
||||
^{supervisorsTable}
|
||||
|
||||
<div .container>
|
||||
<h2> _{MsgProfileSupervisee}
|
||||
<div .container>
|
||||
^{superviseesTable}
|
||||
^{maybeTable' MsgProfileSubmissions Nothing (Just (msg2widget MsgProfileGroupSubmissionDates)) submissionTable}
|
||||
|
||||
^{maybeTable' MsgTableCorrector Nothing (Just (msg2widget MsgProfileCorrectorRemark <> simpleLinkI MsgProfileCorrections CorrectionsR)) correctionsTable}
|
||||
|
||||
|
||||
^{profileRemarks}
|
||||
|
||||
@ -656,12 +656,18 @@ fillDb = do
|
||||
, let rcShort = CI.mk $ "RC" <> tshow n
|
||||
]
|
||||
void . insert' $ UserCompany jost fraportAg True True 0 False
|
||||
void . insert' $ UserCompany svaupel nice True False 0 False
|
||||
void . insert' $ UserCompany svaupel nice True False 2 False
|
||||
void . insert' $ UserCompany svaupel ffacil False False 1 False
|
||||
void . insert' $ UserCompany svaupel bpol True False 2 False
|
||||
void . insert' $ UserCompany svaupel fraGround True False 1 False
|
||||
void . insert' $ UserCompany gkleen nice False False 1 True
|
||||
void . insert' $ UserCompany gkleen fraGround False True 2 False
|
||||
void . insert' $ UserCompany gkleen bpol False True 1 False
|
||||
void . insert' $ UserCompany fhamann bpol False False 1 True
|
||||
void . insert' $ UserCompany fhamann ffacil True True 2 True
|
||||
void . insert' $ UserCompany fhamann nice False False 3 False
|
||||
void . insert' $ UserCompany sbarth nice False False 3 False
|
||||
void . insert' $ UserCompany sbarth bpol True True 1 True
|
||||
-- need more tests
|
||||
insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers]
|
||||
insertMany_ [UserCompany uid bpol False False 0 False | Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user