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