Merge branch 'fradrive/newletter'

messages/uniworx/categories/avs/de-de-formal.msg

@@ -4,7 +4,9 @@
 AvsPersonInfo: AVS Personendaten
 AvsPersonId: AVS Personen Id
 AvsPersonNo: AVS Personennummer
+AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
 AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert
+AvsPersonNoDiffers: Es sind derzeit zwei verschiedene AVS Personennummern zugeordnet. Bitte einen Administrator kontaktieren.
 AvsCardNo: Ausweiskartennummer 
 AvsFirstName: Vorname
 AvsLastName: Nachname
@@ -15,7 +17,6 @@ AvsQueryNeeded: Benötigt Verbindung zum AVS.
 AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
 AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
 AvsLicence: Fahrberechtigung
-AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
 AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive
 BtnAvsRevokeUnknown: Fahrberechtigungen im AVS sofort entziehen
 BtnAvsImportUnknown: AVS Daten unbekannter Personen importieren
@@ -45,6 +46,7 @@ AvsCardColorBlue: Blau
 AvsCardColorRed: Rot
 AvsCardColorYellow: Gelb
 LastAvsSynchronisation: Letzte AVS-Synchronisation
+LastAvsSyncedBefore: Letzte AVS-Synchronisation vor
 LastAvsSynchError: Letzte AVS-Fehlermeldung
 
 AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht

messages/uniworx/categories/avs/en-eu.msg

@@ -4,7 +4,9 @@
 AvsPersonInfo: AVS person info
 AvsPersonId: AVS person id
 AvsPersonNo: AVS person number
+AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
 AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive
+AvsPersonNoDiffers: There are currently two differing AVS person numbers associated with this user. Please contact an administrator to resolve this.
 AvsCardNo: Card number
 AvsFirstName: First name
 AvsLastName: Last name
@@ -15,7 +17,7 @@ AvsQueryNeeded: AVS connection required.
 AvsQueryEmpty: At least one query field must be filled!
 AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
 AvsLicence: Driving Licence
-AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
+
 AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
 BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately
 BtnAvsImportUnknown: Import AVS data for unknown persons
@@ -45,6 +47,7 @@ AvsCardColorBlue: Blue
 AvsCardColorRed: Red
 AvsCardColorYellow: Yellow
 LastAvsSynchronisation: Last AVS synchronisation
+LastAvsSyncedBefore: Last AVS synchronisation before
 LastAvsSynchError: Last AVS Error
 
 AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond

messages/uniworx/categories/settings/personal_settings/de-de-formal.msg

@@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: Die Anzeige von Kurse, zu denen Sie angemeldet sind wi
 ProfileGroupSubmissionDates: Bei Gruppenabgaben wird kein Datum angezeigt, wenn Sie die Gruppenabgabe nie selbst hochgeladen haben.
 ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt. Auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier dann nicht aufgeführt werden.
 ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
-Remarks: Hinweise
+Remarks: Hinweis:
 
-ProfileSupervisor: Übergeordnete Ansprechpartner
+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
 UserMobile: Mobiltelefon

messages/uniworx/categories/settings/personal_settings/en-eu.msg

@@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: The feature to display courses you have registered for
 ProfileGroupSubmissionDates: No date is shown for group submissions if you have never uploaded the submission yourself.
 ProfileCorrectorRemark: The table above only shows registration as a corrector in principle. Even without registration corrections can be assigned individually and are not listed.
 ProfileCorrections: List of all assigned corrections
-Remarks: Remarks
+Remarks: Remark:
 
-ProfileSupervisor: Supervised by
+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
 UserMobile: Mobile

src/Foundation/I18n.hs

@@ -88,15 +88,14 @@ pluralDE num singularForm pluralForm
   | otherwise = pluralForm
 
 pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
--- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
 pluralDEx c n t = pluralDE n t $ t `snoc` c
 
--- | like `pluralDEe` but also prefixes with the number
+-- | like `pluralDEx` but also prefixes with the number
 pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
 pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
 
 pluralDEe :: (Eq a, Num a) => a -> Text -> Text
--- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
+-- ^ @pluralDEe n "Monat" = pluralDEe n "Monat" "Monate"@
 pluralDEe = pluralDEx 'e'
 
 -- | like `pluralDEe` but also prefixes with the number
@@ -124,14 +123,14 @@ noneOneMoreDE num noneText singularForm pluralForm
   | num == 1  = singularForm
   | 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)
          =>    a -- ^ Count
@@ -164,14 +163,14 @@ noneOneMoreEN num noneText singularForm pluralForm
   | num == 1  = singularForm
   | 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
           => a

src/Handler/Admin/Avs.hs

@@ -560,7 +560,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         , sortable (Just "avspersonno")  (i18nCell MsgAvsPersonNo)    $ \(view  resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
         -- , colUserCompany
         , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
-            companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+            companies' <- liftHandler . runDBRead . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
               E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
               E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
               E.orderBy [E.asc (comp E.^. CompanyName)]
@@ -639,8 +639,8 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
       mkOption :: E.Value Text -> Option Text
       mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
       suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
-      suggestionsBlock   = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
+      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 = mconcat
@@ -949,4 +949,3 @@ getProblemAvsErrorR = do
   siteLayoutMsg MsgMenuAvsSynchError $ do
     setTitleI MsgMenuAvsSynchError
     [whamlet|^{avsSyncErrTbl}|]
-    

src/Handler/Course/Register.hs

@@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
       | otherwise
         -> return $ FormSuccess ()
 
-    mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> do
+    mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
       E.where_ $  course E.^. CourseId E.==. E.val cid
            E.&&. (       isSchoolAdminLike muid ata (course E.^. CourseSchool)
                    E.||. mayEditCourse muid ata course

src/Handler/Firm.hs

@@ -119,7 +119,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
     faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
 
     faHandler (FirmActNotifyData, Set.toList -> fids) = do
-      usrs <- runDB $ E.select $ E.distinct $ do
+      usrs <- runDBRead $ E.select $ E.distinct $ do
         (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
         E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
         return $ usr E.^. UserId
@@ -325,34 +325,33 @@ addDefaultSupervisorsAll mutualSupervision cids = do
 ------------------------------
 -- repeatedly useful queries
 
+usrSuperiorCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
+-- usrSuperiorCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
+usrSuperiorCompanies cmp usr = do
+  othr <- E.from $ E.table @UserCompany
+  E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
+      E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
+      E.&&.  othr E.^. UserCompanyCompany  E.!=. cmp E.^. CompanyId                     -- redundant due to > above, but likely performance improving
+  -- return othr
+
 fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
 fromUserCompany mbFltr cmpy = do
   usrCmpy <- E.from $ E.table @UserCompany
   let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
   E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
 
-firmCountUsers        :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsers              :: E.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
-    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
   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.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
@@ -1375,14 +1374,14 @@ handleFirmCommR ultDest cs = do
     csKeys = CompanyKey <$> cs
   mbUser <- maybeAuthId
   -- get employees of chosen companies
-  empys <- mkCompanyUsrList <$> runDB (E.select $ do
+  empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
       (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
       E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
       E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
       return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
     )
   -- get supervisors of employees
-  sprs <- mkCompanyUsrList <$> runDB (E.select $ do
+  sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
       (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
       E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
         E.||. (spr E.^. UserId E.=?. E.val mbUser)

src/Handler/LMS.hs

@@ -792,7 +792,7 @@ viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser
 viewLmsUserR msid mqsh uuid = do
   uid <- decrypt uuid
   now <- liftIO getCurrentTime
-  (user@User{userDisplayName}, quals, qblocks) <- runDB $ do 
+  (user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
     usr <- get404 uid
     qs  <- Ex.select $ do
           (qual :& qualUsr :& lmsUsr) <-

src/Handler/News.hs

@@ -315,16 +315,16 @@ newsUpcomingExams uid = do
                     | otherwise -> mempty
             ]
           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.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
                   E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId

src/Handler/Profile.hs

@@ -156,7 +156,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
   where
     schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
     schoolsForm' = do
-      allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
+      allSchools <- liftHandler . runDBRead $ selectList [] [Asc SchoolName]
 
       let
         schoolForm (Entity ssh School{schoolName})
@@ -585,6 +585,41 @@ getForProfileDataR cID = do
     setTitleI $ MsgHeadingForProfileData $ userDisplayName user
     dataWidget
 
+-- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget}
+-- a poor man's record subsitute
+
+{-
+type TableHasData = (Bool, Widget)
+tableHasRows :: TableHasData -> Bool
+tableHasRows = fst
+tableWidget :: TableHasData -> Widget
+tableWidget  = snd
+-}
+
+maybeTable :: (RenderMessage UniWorX a)
+           => a -> (Bool, Widget) -> Widget
+maybeTable m = maybeTable' m Nothing Nothing
+
+maybeTable' :: (RenderMessage UniWorX a)
+           => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
+maybeTable' _   Nothing       _ (False, _ ) = mempty
+maybeTable' _   (Just nodata) _ (False, _ ) =
+  [whamlet|
+    <div .container>
+      _{nodata}
+  |]
+maybeTable' hdr _ mbRemark      (True ,tbl) =
+  [whamlet|
+    <div .container>
+      <h2> _{hdr}
+      <div .container>
+        ^{tbl}
+        $maybe remark <- mbRemark
+          <em>_{MsgProfileRemark}
+          \ ^{remark}
+  |]
+
+
 makeProfileData :: Entity User -> DB Widget
 makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
   now <- liftIO getCurrentTime
@@ -605,42 +640,51 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
       E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
       return  (studyfeat, studydegree, studyterms)
   companies <- wgtCompanies uid
-  supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+  -- 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
-  (hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
+  ownedCoursesTable    <- mkOwnedCoursesTable         uid -- Tabelle mit eigenen Kursen
   enrolledCoursesTable <- mkEnrolledCoursesTable      uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
   submissionTable      <- mkSubmissionTable           uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
   submissionGroupTable <- mkSubmissionGroupTable      uid -- Tabelle mit allen Abgabegruppen
   correctionsTable     <- mkCorrectionsTable          uid -- Tabelle mit allen Korrektor-Aufgaben
   qualificationsTable  <- mkQualificationsTable  now  uid -- Tabelle mit allen Qualifikationen
   supervisorsTable     <- mkSupervisorsTable          uid -- Tabelle mit allen Supervisors
-  superviseesTable     <- mkSuperviseesTable          uid -- Tabelle mit allen Supervisees
+  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
   mCRoute <- getCurrentRoute
   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")
   return $(widgetFile "profileData")
 
@@ -698,7 +742,7 @@ mkOwnedCoursesTable =
 
 
 -- | Table listing all courses that the given user is enrolled in
-mkEnrolledCoursesTable :: UserId -> DB Widget
+mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
 mkEnrolledCoursesTable =
   let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
                -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
@@ -706,7 +750,7 @@ mkEnrolledCoursesTable =
 
       validator = def & defaultSorting [SortDescBy "time"]
 
-  in \uid -> dbTableWidget' validator
+  in \uid -> (_1 %~ getAny) <$> dbTableWidget validator
     DBTable
       { dbtIdent     = "courseMembership" :: Text
       , dbtSQLQuery  = \(course `E.InnerJoin` participant) -> do
@@ -717,7 +761,7 @@ mkEnrolledCoursesTable =
       , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
       , dbtProj      = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
       , dbtColonnade = mconcat
-          [ sortable (Just "term") (i18nCell MsgTableTerm) $
+          [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
               termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
           , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
               schoolCell <$> view _courseTerm
@@ -750,7 +794,7 @@ mkEnrolledCoursesTable =
 
 
 -- | Table listing all submissions for the given user
-mkSubmissionTable :: UserId -> DB Widget
+mkSubmissionTable :: UserId -> DB (Bool, Widget)
 mkSubmissionTable =
   let dbtIdent = "submissions" :: Text
       dbtStyle = def
@@ -784,7 +828,7 @@ mkSubmissionTable =
         <&> _dbrOutput . _4 %~ E.unValue
 
       dbtColonnade = mconcat
-        [ sortable (Just "term") (i18nCell MsgTableTerm) $
+        [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
             termCell    <$> view (_dbrOutput . _1 . _1)
         , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
             schoolCell  <$> view  _1
@@ -828,14 +872,10 @@ mkSubmissionTable =
       dbtExtraReps = []
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                   dbtSorting  = dbtSorting'  uid
-              in  dbTableWidget' validator DBTable{..}
+              in   (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
---   in do dbtSQLQuery <- dbtSQLQuery'
---         dbtSorting  <- dbtSorting'
---         return $ dbTableWidget' validator $ DBTable {..}
-
 
 -- | Table listing all submissions for the given user
-mkSubmissionGroupTable :: UserId -> DB Widget
+mkSubmissionGroupTable :: UserId -> DB (Bool, Widget)
 mkSubmissionGroupTable =
   let dbtIdent = "subGroups" :: Text
       dbtStyle = def
@@ -858,7 +898,7 @@ mkSubmissionGroupTable =
         <&> _dbrOutput . _1 %~ $(E.unValueN 3)
 
       dbtColonnade = mconcat
-        [ sortable (Just "term") (i18nCell MsgTableTerm) $
+        [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
             termCell    <$> view (_dbrOutput . _1 . _1)
         , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
             schoolCell  <$> view _1
@@ -887,10 +927,10 @@ mkSubmissionGroupTable =
       dbtCsvDecode = Nothing
       dbtExtraReps = []
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
-              in  dbTableWidget' validator DBTable{..}
+              in  (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 
-mkCorrectionsTable :: UserId -> DB Widget
+mkCorrectionsTable :: UserId -> DB (Bool, Widget)
 mkCorrectionsTable =
   let dbtIdent = "corrections" :: Text
       dbtStyle = def
@@ -923,7 +963,7 @@ mkCorrectionsTable =
         <&> _dbrOutput . _2 %~ E.unValue
 
       dbtColonnade = mconcat
-        [ sortable (Just "term") (i18nCell MsgTableTerm) $
+        [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
             termCellCL   <$> view (_dbrOutput . _1)
         , sortable (Just "school") (i18nCell MsgTableCourseSchool) $
             schoolCellCL <$> view (_dbrOutput . _1)
@@ -960,7 +1000,7 @@ mkCorrectionsTable =
       dbtCsvDecode = Nothing
       dbtExtraReps = []
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
-              in  dbTableWidget' validator DBTable{..}
+              in  (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 
 -- | Table listing all qualifications that the given user is enrolled in
@@ -983,7 +1023,7 @@ mkQualificationsTable =
       , dbtProj      = dbtProjId
       , dbtColonnade = mconcat
           [ 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 "last-refresh")  (i18nCell MsgTableQualificationLastRefresh) $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)    $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
@@ -1027,8 +1067,8 @@ instance HasUser TblSupervisorData where
   hasUser = _dbrOutput . _1 . _entityVal
 
 -- | 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
     dbtIdent = "userSupervisedBy" :: Text
     dbtStyle = def
@@ -1043,8 +1083,15 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
     dbtColonnade = mconcat
         [ colUserNameModalHdr MsgTableSupervisor ForProfileDataR
         , colUserEmail
-        , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b          
+        -- , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> 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 "reason")      (i18nCell MsgSupervisorReason)    $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
         ]
@@ -1054,6 +1101,11 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
         , singletonMap & uncurry $ sortUserEmail    queryUser
         , singletonMap "postal-pref"  $ SortColumn $ queryUser            >>> (E.^. UserPrefersPostal)
         , singletonMap "rerouted"     $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorRerouteNotifications)
+        -- , singletonMap "reroute"      $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) ->  mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal))
+        , singletonMap "reroute"      $ SortColumns  $ \row ->
+            [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
+            , SomeExprValue $ queryUser           row E.^. UserPrefersPostal
+            ]
         , singletonMap "cshort"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorCompany)
         , singletonMap "reason"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorReason)
         ]
@@ -1068,8 +1120,8 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
 
 
 -- | 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
     dbtIdent = "userSupervisedBy" :: Text
     dbtStyle = def
@@ -1081,11 +1133,15 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
     dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
     dbtProj = dbtProjId
 
+    iconCellLetterOrEmail = spacerCell <> iconFixedCell (iconLetterOrEmail userPrefersPostal) -- only notification type of supervisor matters here
     dbtColonnade = mconcat
         [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR
-        -- , colUserEmail
+        , colUserEmail
+        -- , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
         -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
-        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
+        , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
+            let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
+            in  tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
         , sortable (Just "cshort")      (i18nCell MsgTableCompany)        $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
         , sortable (Just "reason")      (i18nCell MsgSupervisorReason)    $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
         ]
@@ -1093,8 +1149,12 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
     dbtSorting = mconcat
         [ singletonMap & uncurry $ sortUserNameLink 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 "reason"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorReason)
         ]

src/Handler/SAP.hs

@@ -98,7 +98,7 @@ getQualificationSAPDirectR = do
   now   <- liftIO getCurrentTime
   fdate <- formatTime' "%Y%m%d_%H-%M" now
   let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
-  qualUsers <- runDB $ E.select $ do
+  qualUsers <- runDBRead $ E.select $ do
     (qual :& qualUser :& user :& qualBlock) <-
       E.from $ E.table @Qualification
       `E.innerJoin` E.table @QualificationUser

src/Handler/Users.hs

@@ -121,21 +121,21 @@ postUsersR = do
 --           (AdminUserR <$> encrypt uid)
 --           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
       , sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-            supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+            supervisors' <- liftHandler . runDBRead . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
               E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
               E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
               E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
               return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
             let supervisors = intersperse (text2widget ", ") $
                   (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
-                icnReroute = text2widget " " <> toWgt (icon IconLetter)
+                icnReroute = text2widget " " <> toWgt (icon IconReroute)
             pure $ mconcat supervisors
       , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
       , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
       , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
       , flip foldMap universeF $ \function ->
           sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-            schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
+            schools <- liftHandler . runDBRead . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
               E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
               E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
                    E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
@@ -148,7 +148,7 @@ postUsersR = do
                   <li>#{sh}
               |]
       , sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
-          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
+          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDBRead $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
            in listCell' getFunctions i18nCell
       , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
           { formCellAttrs    = []
@@ -299,6 +299,12 @@ postUsersR = do
                       in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
                 | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
             )
+          , ( "avs-sync", FilterColumn . E.mkExistsFilter $ \user criterion ->
+                E.from $ \usrAvs -> do
+                  let minTime = (E.val criterion :: E.SqlExpr (E.Value UTCTime))
+                  E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
+                      E.&&.  usrAvs E.^. UserAvsLastSynch E.<=. minTime
+            )
           , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
                 E.from $ \(usrComp `E.InnerJoin` comp) -> do
                   let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
@@ -343,6 +349,7 @@ postUsersR = do
           , 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 "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
+          , prismAForm (singletonFilter "avs-sync"      . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLastAvsSyncedBefore)
           ]
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = DBParamsForm

src/Handler/Utils/Avs.hs

@@ -171,11 +171,11 @@ lookupAvsUsers apis = do
 updateReceivers :: UserId -> Handler  (Entity User, [Entity User], Bool)
 updateReceivers uid = do
   -- First perform AVS update for receiver
-  runDB (getBy (UniqueUserAvsUser uid)) >>= \case
+  runDBRead (getBy (UniqueUserAvsUser uid)) >>= \case
       Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
       Nothing -> return ()
   -- Retrieve updated user and supervisors now
-  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
+  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDBRead $ (,)
     <$> getJustEntity uid
     <*> (E.select $ do
           (usrSuper :& usrAvs) <-
@@ -194,7 +194,7 @@ updateReceivers uid = do
   if null receiverIDs
     then directResult
     else do
-      receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
+      receivers <- runDBRead $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
       if null receivers
         then directResult
         else return (underling, receivers, uid `elem` (entityKey <$> receivers))
@@ -450,7 +450,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
 
 linktoAvsUserByUIDs :: Set UserId -> Handler ()
 linktoAvsUserByUIDs uids = do
-    ips <- runDB $ E.select $ do
+    ips <- runDBRead $ E.select $ do
       usr <- E.from $ E.table @User
       let uid = usr E.^. UserId
           ipn = usr E.^. UserCompanyPersonalNumber
@@ -484,18 +484,18 @@ createAvsUserById muid api = do
   case Set.toList contactRes of
     []      -> throwM $ AvsUserUnknownByAvs api
     (_:_:_) -> throwM $ AvsUserAmbiguous    api
-    [AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
+    [adc@AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
       | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
       | otherwise -> do
         -- check for matching existing user
         let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
-            persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
+            -- persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
-        oldUsr <- runDB $ do
+        oldUsr <- runDBRead $ do
           mbUid <- if isJust muid
               then return muid
               else firstJustM $ catMaybes
                 [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
-                , persMail       <&> guessUserByEmail
+                -- , persMail       <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail!
                 ]
           mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
           return (mbUid, mbUAvs)
@@ -533,11 +533,11 @@ createAvsUserById muid api = do
                   , audFirstName        = cpi ^. _avsInfoFirstName    & Text.strip
                   , audSurname          = cpi ^. _avsInfoLastName     & Text.strip
                   , audDisplayName      = cpi ^. _avsInfoDisplayName
-                  , audDisplayEmail     = persMail & fromMaybe mempty
+                  , 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
-                  , audMatriculation    = cpi ^. _avsInfoPersonNo     & Just . tshow
+                  , audMatriculation    = cpi ^. _avsInfoPersonNo     & Just
                   , audSex              = Nothing
                   , audBirthday         = cpi ^. _avsInfoDateOfBirth
                   , audMobile           = cpi ^. _avsInfoPersonMobilePhoneNo
@@ -676,9 +676,14 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
           oldSup    = snd <$> oldChanges
       unless (supChange == Just False) $ do
         -- upsert new superior company supervisor
+        mbMaxPrio <- E.selectOne $ do
+          usrCmp <- E.from $ E.table @UserCompany
+          E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
+          return . E.max_ $ usrCmp E.^. UserCompanyPriority
+        let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
         suprEnt <- upsertBy (UniqueUserCompany supid cid)
-                              (UserCompany supid cid True False 1 True)
+                              (UserCompany supid cid True False maxPrio True)
-                              [UserCompanySupervisor =. True]
+                              [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio]
         E.insertSelectWithConflict UniqueUserSupervisor
           (do
             usr <- E.from $ E.table @UserCompany
@@ -736,15 +741,15 @@ guessAvsUser :: Text -> Handler (Maybe UserId)
 guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
   | prefix=="AVSID:" =
       let avsid = AvsPersonId nr in
-      runDB (getBy $ UniqueUserAvsId avsid)          >>= \case
+      runDBRead (getBy $ UniqueUserAvsId avsid)          >>= \case
         (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
         Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
   | prefix=="AVSNO:" =
-      runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
+      runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
 guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
     catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
       Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
-        runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
+        runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
       other -> return other
 guessAvsUser someid = do
     try (runDB $ ldapLookupAndUpsert someid) >>= \case

src/Handler/Utils/AvsUpdate.hs

@@ -109,7 +109,7 @@ data CU_UserAvs_User
   | CU_UA_UserMatrikelnummer
   | CU_UA_UserCompanyPersonalNumber
   | CU_UA_UserLdapPrimaryKey
-  -- CU_UA_UserDisplayEmail         -- use _avsContactPrimaryEmailAddress instead
+  -- CU_UA_UserDisplayEmail         -- use _avsContactPrimaryEmail instead
   deriving (Show, Eq)
 
 instance MkCheckUpdate CU_UserAvs_User where

src/Handler/Utils/Company.hs

@@ -40,16 +40,16 @@ wgtCompanies = \uid -> do
                 ^{c}
             $forall c <- otherCmp
               <p>
-                #{c}
+                ^{c}
           |]
     return $ toMaybe (notNull topCmp) resWgt
   where
-    procCmp _ [] = (0, [],[])
+    procCmp _ [] = (0, [], [])
     procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
-      let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
+      let isTop  = cmpPrio >= maxPri
-          isTop  = cmpPrio >= maxPri
+          cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
           (accPri,accTop,accRem) = procCmp maxPri cs
-      in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpName : accRem) accRem isTop) -- lazy evaluation after repmin example
+      in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
 
 -- TODO: use this function in company view Handler.Firm #157
 -- | add all company supervisors for a given users

src/Handler/Utils/Qualification.hs

@@ -112,12 +112,14 @@ validQualification' cutoff qualUser =
            E.&&. quserBlock' False cutoff qualUser
 
 -- 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 =
   -- cutoff <- utctDay <$> liftIO getCurrentTime
   E.select $ do

src/Handler/Utils/Table/Cells.hs

@@ -41,6 +41,9 @@ cellTell = flip tellCell
 indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
 indicatorCell = writerCell . tell $ Any True
 
+addIndicatorCell :: IsDBTable m Any => DBCell m Any -> DBCell m Any
+addIndicatorCell = tellCell $ Any True
+
 writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
 writerCell act = mempty & cellContents %~ (<* act)
 
@@ -51,6 +54,10 @@ cellMaybe = foldMap
 maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
 maybeCell = flip foldMap
 
+boolCell :: IsDBTable m b => Bool -> DBCell m b -> DBCell m b
+boolCell True   c = c
+boolCell False  _ = mempty
+
 htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
 htmlCell = cell . toWidget . toMarkup
 

src/Handler/Utils/Widgets.hs

@@ -62,7 +62,7 @@ userWidget :: HasUser c => c -> Widget
 userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
 
 userIdWidget :: UserId -> Widget
-userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDB $ get uid)
+userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)
 
 linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
 linkUserWidget lnk (Entity uid usr) = do
@@ -71,7 +71,7 @@ linkUserWidget lnk (Entity uid usr) = do
 
 -- | like linkUserWidget, but on Id only. Requires DB access, use with caution
 linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
-linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDB $ get uid)
+linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)
 
 userEmailWidget :: HasUser c => c -> Widget
 userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
@@ -141,15 +141,20 @@ modalAccess wdgtNo wdgtYes writeAccess route = do
     else       wdgtNo
 
 -- also see Handler.Utils.Table.Cells.companyCell
-companyWidget :: (CompanyShorthand, CompanyName, Bool) -> Widget
+companyWidget :: 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
     curl = FirmUsersR csh
     corg = ciOriginal cname
     name
-      | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
+      | isSupervisor = text2markup (corg <> " ")
       | otherwise    = text2markup  corg
 
+
 ----------
 -- HEAT --
 ----------

src/Jobs/Handler/SynchroniseAvs.hs

@@ -101,7 +101,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
 
 dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
 dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
-    jobs <- runDB $ do
+    jobs <- runDBRead $ do
       E.select (do
           (avsSync :& usrAvs) <- E.from $  E.table @AvsSync
                               `E.leftJoin` E.table @UserAvs

src/Utils.hs

@@ -412,6 +412,10 @@ citext2widget t = [whamlet|#{CI.original t}|]
 str2widget :: String -> WidgetFor site ()
 str2widget s = [whamlet|#{s}|]
 
+-- | hamlet does not like quotes
+spaceWidget :: WidgetFor site ()
+spaceWidget = str2widget " "
+
 int2widget :: Int64 -> WidgetFor site ()
 int2widget i = [whamlet|#{tshow i}|]
 

src/Utils/Icon.hs

@@ -106,19 +106,21 @@ data Icon
   | IconBlocked
   | IconCertificate
   | IconPrintCenter
-  | IconLetter
+  | IconLetter            -- only to be used for postal matters
   | IconAt
   | IconSupervisor
   | IconSupervisorForeign
+  | IconSuperior          -- supervisor and head of department
   --  IconWaitingForUser
   | IconExpired
   | IconLocked
   | IconUnlocked
-  | IconResetTries -- also see IconReset
+  | IconResetTries        -- also see IconReset
   | IconCompany
   | IconEdit
   | IconUserEdit
-  --  IconMagic      -- indicates automatic updates
+  --  IconMagic           -- indicates automatic updates
+  | IconReroute           -- for notification rerouting
 
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
   deriving anyclass (Universe, Finite, NFData)
@@ -158,7 +160,7 @@ iconText = \case
     IconSFTHint                 -> "life-ring"          -- for SheetFileType only
     IconSFTSolution             -> "exclamation-circle" -- for SheetFileType only
     IconSFTMarking              -> "check-circle"       -- for SheetFileType only
-    IconEmail                   -> "envelope" -- envelope is no longer unamibuous, use IconAt or IconLetter if email and postal need to be distinguished
+    IconEmail                   -> "envelope" -- envelope is no longer unambiguous, use IconAt or IconLetter if email and postal need to be distinguished
     IconRegisterTemplate        -> "file-alt"
     IconNoCorrectors            -> "user-slash"
     IconRemoveUser              -> "user-slash"
@@ -207,6 +209,7 @@ iconText = \case
     IconAt                      -> "at"        -- alternative for IconEmail to distinguish from IconLetter
     IconSupervisor              -> "head-side" -- must be notably different to user
     IconSupervisorForeign       -> "alien"
+    IconSuperior                -> "user-tie"  -- user-crown
     -- IconWaitingForUser          -> "user-cog"  -- Waiting on a user to do something
     IconExpired                 -> "hourglass-end"
     IconLocked                  -> "lock"
@@ -216,7 +219,7 @@ iconText = \case
     IconEdit                    -> "edit"
     IconUserEdit                -> "user-edit"
     -- IconMagic                   -> "wand-magic"
-
+    IconReroute                 -> "directions"
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon
 
@@ -316,6 +319,8 @@ iconExamRegister :: Bool -> Markup
 iconExamRegister True  = icon IconExamRegisterTrue
 iconExamRegister False = icon IconExamRegisterFalse
 
+-- | indicator whether notifications are sent by letter or email
+--   use iconReroute if type of rerouting is unclear
 iconLetterOrEmail :: Bool -> Markup
 iconLetterOrEmail True  = icon IconLetter
 iconLetterOrEmail False = icon IconAt

templates/profileData.hamlet

@@ -15,11 +15,18 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       <dd .deflist__dd>
         _{userAuthentication}
       $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
           <dt .deflist__dt>
             _{MsgLastAvsSynchError}
@@ -29,15 +36,18 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           _{MsgLastAvsSynchronisation}
         <dd .deflist__dd>
           ^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
+      $nothing
+        $maybe matnr <- userMatrikelnummer
+          <dt .deflist__dt>
+            _{MsgTableMatrikelNr}
+            ^{messageTooltip tooltipAvsPersNo}
+            ^{usrAutomatic CU_UA_UserMatrikelnummer}
+          <dd .deflist__dd>
+            ^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)}
       <dt .deflist__dt>
         _{MsgNameSet} ^{usrAutomatic CU_UA_UserDisplayName}
       <dd .deflist__dd>
         ^{nameWidget userDisplayName userSurname}
-      $maybe matnr <- userMatrikelnummer
-        <dt .deflist__dt>
-          _{MsgTableMatrikelNr} ^{usrAutomatic CU_UA_UserMatrikelnummer}
-        <dd .deflist__dd>
-          ^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)}          
       $maybe sex <- userSex 
         <dt .deflist__dt>
           _{MsgTableSex}
@@ -84,6 +94,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           #{userEmail}
       <dt .deflist__dt>
         _{MsgAdminUserPinPassword}
+        ^{usrAutomatic CU_UA_UserPinPassword}
       <dd .deflist__dd>
         $maybe pass <- userPinPassword
           #{pass}
@@ -114,18 +125,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           _{MsgCompany}
         <dd .deflist__dd>
           ^{compWgt}
-      $if numSupervisors > 0
-        <dt .deflist__dt>_{MsgProfileSupervisor}
-          $if numSupervisors > 3
-            \ #{numSupervisors}
-        <dd .deflist__dd>
-          ^{mconcat supervisors}
-      $if numSupervisees > 0
-        <dt .deflist__dt>_{MsgProfileSupervisee}
-          $if length supervisees > 3
-            \ #{numSupervisees}
-        <dd .deflist__dd>
-          ^{mconcat supervisees}
       $if showAdminInfo
         <dt .deflist__dt>
           _{MsgUserCreated}
@@ -197,67 +196,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
                   $nothing
                     ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
 <section>
-  <div .container>
-    $if hasRowsOwnedCourses
-      <div .container>
-        <h2>_{MsgProfileCourses}
-        <div .container>
-          ^{ownedCoursesTable}
 
-  <div .container>
+  ^{supervisorsWgt}
-    <h2>_{MsgProfileCourseParticipations}
+  
-    <div .container>
+  ^{superviseesWgt}
-      ^{enrolledCoursesTable}
 
   <div .container>
     <h2>_{MsgProfileQualifications}
     <div .container>
       ^{qualificationsTable}
 
-  <div .container>
+  ^{maybeTable MsgProfileCourses ownedCoursesTable}
-    <h2>_{MsgProfileCourseExamResults}
-    <div .container>
-      ^{examTable}
   
-  <div .container>
+  ^{maybeTable MsgProfileCourseParticipations enrolledCoursesTable}
-    <h2>_{MsgProfileTutorials}
-    <div .container>
-      ^{ownTutorialTable}
 
-  <div .container>
+  ^{maybeTable MsgProfileSubmissionGroups submissionGroupTable}
-    <h2>_{MsgProfileTutorialParticipations}
-    <div .container>
-      ^{tutorialTable}
 
-  <div .container>
+  ^{maybeTable' MsgProfileSubmissions Nothing (Just (msg2widget MsgProfileGroupSubmissionDates)) submissionTable}
-    <h2>_{MsgProfileSubmissionGroups}
-    <div .container>
-      ^{submissionGroupTable}
   
-  <div .container>
+  ^{maybeTable' MsgTableCorrector Nothing (Just (msg2widget MsgProfileCorrectorRemark <> simpleLinkI MsgProfileCorrections CorrectionsR)) correctionsTable}
-    <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}

test/Database/Fill.hs

@@ -656,12 +656,18 @@ fillDb = do
                           , let rcShort = CI.mk $ "RC" <> tshow n
                           ]
   void . insert' $ UserCompany jost    fraportAg    True   True  0 False
-  void . insert' $ UserCompany svaupel nice         True   False 0 False
+  void . insert' $ UserCompany svaupel nice         True   False 2 False
+  void . insert' $ UserCompany svaupel ffacil       False  False 1 False
+  void . insert' $ UserCompany svaupel bpol         True   False 2 False
+  void . insert' $ UserCompany svaupel fraGround    True   False 1 False
   void . insert' $ UserCompany gkleen  nice         False  False 1 True
   void . insert' $ UserCompany gkleen  fraGround    False  True  2 False
+  void . insert' $ UserCompany gkleen  bpol         False  True  1 False
   void . insert' $ UserCompany fhamann bpol         False  False 1 True
   void . insert' $ UserCompany fhamann ffacil       True   True  2 True
   void . insert' $ UserCompany fhamann nice         False  False 3 False
+  void . insert' $ UserCompany sbarth  nice         False  False 3 False
+  void . insert' $ UserCompany sbarth  bpol         True   True  1 True
   -- need more tests
   insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers]
   insertMany_ [UserCompany uid bpol False False 0 False     | Entity uid User{userFirstName = "Elizabeth"} <- matUsers]