Merge branch 'fradrive/jost'

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

@@ -22,6 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
 AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
 AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
 AdminUserNoPassword: Kein Passwort gesetzt
+AdminUserPinPassNotIncluded: Hinweis: Das Passwort wird hier zur Bequemlichkeit zusätzlich angezeigt und ist selbstverständlich nicht im originalem Inhalt enthalten.
 AdminUserAssimilate: Diesen Benutzer assimilieren von
 UserAdded: Benutzer erfolgreich angelegt
 UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden

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

@@ -22,6 +22,7 @@ AdminUserPostAddress: Postal Address
 AdminUserPrefersPostal: Prefers postal letters over email
 AdminUserPinPassword: Password used for PDF attachments to emails
 AdminUserNoPassword: No password set
+AdminUserPinPassNotIncluded: Note: the password is shown here only for convenience, but is not contained in the original content, of course.
 AdminUserAssimilate: Assimilate user by another user
 UserAdded: Successfully added user
 UserCollision: Could not create user due to uniqueness constraint

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -153,6 +153,7 @@ MenuCommCenter: Benachrichtigungen
 MenuMailCenter: E‑Mails
 MenuMailHtml !ident-ok: Html
 MenuMailPlain !ident-ok: Text
+MenuMailAttachment: Anhang
 
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -153,6 +153,7 @@ MenuCommCenter: Notifications
 MenuMailCenter: Email
 MenuMailHtml: Html
 MenuMailPlain: Text
+MenuMailAttachment: Attachment
 
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)

messages/uniworx/utils/utils/de-de-formal.msg

@@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
 AmbiguousEmail: E-Mail-Adresse nicht eindeutig
 InvalidEmailAddress: E-Mail-Adresse ist ungültig
 InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
+MailFileAttachment: Dateianhang
 UtilExamResultGrade: Note
 UtilExamResultPass: Bestanden/Nicht Bestanden
 UtilExamResultNoShow: Nicht erschienen

messages/uniworx/utils/utils/en-eu.msg

@@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
 AmbiguousEmail: Email address is ambiguous
 InvalidEmailAddress: Email address is invalid
 InvalidEmailAddressWith e: Email asdress #{show e} is invalid
+MailFileAttachment: Attached file
 UtilExamResultGrade: Grade
 UtilExamResultPass: Passed/Failed
 UtilExamResultNoShow: Not present

routes

@@ -82,6 +82,7 @@
 /comm/email                           MailCenterR     GET POST
 /comm/email/html/#CryptoUUIDSentMail  MailHtmlR       GET
 /comm/email/plain/#CryptoUUIDSentMail MailPlainR      GET
+/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer

src/Foundation/Navigation.hs

@@ -134,6 +134,7 @@ breadcrumb CommCenterR      = i18nCrumb MsgMenuCommCenter       Nothing
 breadcrumb MailCenterR      = i18nCrumb MsgMenuMailCenter     $ Just CommCenterR
 breadcrumb MailHtmlR{}      = i18nCrumb MsgMenuMailHtml       $ Just MailCenterR
 breadcrumb MailPlainR{}     = i18nCrumb MsgMenuMailPlain      $ Just MailCenterR
+breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
 
 breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc            $ Just CommCenterR
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR

src/Handler/Admin/Avs.hs

@@ -266,33 +266,103 @@ postAdminAvsR = do
 
 
   (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
-  mbQryLic <- case qryLicRes of
+  (mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
-    Nothing -> return Nothing
+    Nothing -> return mempty
     (Just BtnCheckLicences) -> do
       res <- try $ do
         allLicences <- avsQueryNoCache AvsQueryGetAllLicences
         computeDifferingLicences allLicences
-      case res of
+      basediffs <- case res of
         (Right diffs) -> do
-          let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
+          let showLics l =
-              r_grant = showLics AvsLicenceRollfeld
+                let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
-              f_set   = showLics AvsLicenceVorfeld
+                in if Set.null chgs
-              revoke  = showLics AvsNoLicence
+                    then ("[ ]", 0)
+                    else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
+              (r_grant, rg_size) = showLics AvsLicenceRollfeld
+              (f_set  , fs_size) = showLics AvsLicenceVorfeld
+              (revoke , rv_size) = showLics AvsNoLicence
           return $ Just [whamlet|
               <h2>Licence check differences:
-              <h3>Grant R:
+              <dl .deflist>
-              <p>
+                <dt .deflist__dt>Grant R (#{rg_size}):
-                #{r_grant}
+                <dd .deflist__dd>#{r_grant}
-              <h3>Set to F:
+
-              <p>
+                <dt .deflist__dt>Set to F (#{fs_size}):
-                #{f_set}
+                <dd .deflist__dd>#{f_set}
-              <h3>Revoke licence:
+
-              <p>
+                <dt .deflist__dt>Revoke licence (#{rv_size}):
-                #{revoke}
+                <dd .deflist__dd>#{revoke}
             |]
         (Left e) -> do
           let msg = tshow (e :: SomeException)
           return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
+      autoDiffs <- do
+        -- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
+        AvsLicenceSynchConf
+          { avsLicenceSynchLevel        = synchLevel   -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
+          , avsLicenceSynchReasonFilter = reasonFilter
+          , avsLicenceSynchMaxChanges   = maxChanges
+          } <- getsYesod $ view _appAvsLicenceSynchConf
+        guardMonoidM (synchLevel > 0) $ do
+          let showApids apids
+                | null apids = "[ ]"
+                | otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
+              procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Html
+              procLic aLic up apids
+                | n <- Set.size apids, n > 0 =
+                  let subtype   = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
+                  in if NTop (Just n) <= NTop maxChanges
+                      then
+                        [shamlet|
+                          <dt .deflist__dt>#{subtype} (#{n}):
+                          <dd .deflist__dd>#{showApids apids}
+                        |]
+                      else
+                        [shamlet|
+                          <dt .deflist__dt>#{subtype} (#{n}):
+                          <dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
+                        |]
+                | otherwise = mempty
+
+          (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
+          -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
+          reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
+            now <- liftIO getCurrentTime
+            firmBlocks <- runDBRead $ E.select $ do
+              (uavs :& _qualUser :& qblock) <- X.from $ E.table @UserAvs
+                `E.innerJoin` E.table @QualificationUser      `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
+                `E.innerJoin` E.table @QualificationUserBlock `X.on` (\(_uavs :& qualUser :& qblock) ->
+                    qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
+                    E.&&. qblock `isLatestBlockBefore'` E.val now)
+              E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
+                    E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
+              return $ uavs E.^. UserAvsPersonId
+            return $ Set.fromList $ map E.unValue firmBlocks
+
+          let fltrIds
+                | synchLevel >= 5 = id
+                | synchLevel >= 3 = flip Set.difference   reasonFltrdIds
+                | otherwise       = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
+
+              l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
+              l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
+              l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
+              l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
+          return $ Just [shamlet|
+              <h3>
+                Next automatic AVS licence synchronisation:
+              <dl .deflist>
+                ^{l4}
+                ^{l3}
+                ^{l2}
+                ^{l1}
+                $maybe reason <- reasonFilter
+                  <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
+                  <dd .deflist__dd>#{showApids reasonFltrdIds}
+            |]
+      return (basediffs, autoDiffs)
+
     -- (Just BtnSynchLicences) -> do
     --   res <- try synchAvsLicences
     --   case res of

src/Handler/MailCenter.hs

@@ -8,6 +8,7 @@ module Handler.MailCenter
   ( getMailCenterR, postMailCenterR
   , getMailHtmlR
   , getMailPlainR
+  , getMailAttachmentR
   ) where
 
 import Import
@@ -163,6 +164,27 @@ postMailCenterR = do
     $(widgetFile "mail-center")
 
 
+typePDF :: ContentType
+typePDF = "application/pdf"
+
+getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
+getMailAttachmentR cusm attdisp = do
+  smid <- decrypt cusm
+  (sm,cn) <- runDBRead $ do
+    sm <- get404 smid
+    cn <- get404 $ sm ^. _sentMailContentRef
+    return (sm,cn)
+  let mcontent = getMailContent (sentMailContentContent cn)
+      getAttm alts = case selectAlternative [typePDF] alts of
+        (Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
+          | t == attdisp
+            -> Just pc
+        _ -> Nothing
+      attm = firstJust getAttm mcontent
+  case attm of
+    (Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
+    _              -> notFound
+
 getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
 getMailHtmlR  = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml])  [typeHtml,typePlain]
 
@@ -180,6 +202,7 @@ handleMailShow hdr prefTypes cusm = do
     setTitleI hdr
     let mcontent = getMailContent (sentMailContentContent cn)
         getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
+        mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
     [whamlet|
       <section>
         <dl .deflist>
@@ -214,10 +237,8 @@ handleMailShow hdr prefTypes cusm = do
               #{decodeEncodedWord r}
 
       <section>
-        $forall mc <- mcontent
+        $forall pt <- mparts
-          $maybe pt <- selectAlternative prefTypes mc
+          ^{part2widget cusm pt}
-            <p>
-              ^{part2widget pt}
     |]
       -- Include for Debugging:
       -- <section>
@@ -237,24 +258,36 @@ selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
     aux []     (pt:_)     = Just pt
     aux _      []         = Nothing
 
+reorderParts :: [Part] -> [Part]
+reorderParts = sortBy pOrder
+  where
+    pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
+
+    dispoOrder DefaultDisposition DefaultDisposition                 = EQ
+    dispoOrder DefaultDisposition _                                  = LT
+    dispoOrder _ DefaultDisposition                                  = GT
+    dispoOrder (InlineDisposition t1) (InlineDisposition t2)         = compare t1 t2
+    dispoOrder (InlineDisposition _) _                               = LT
+    dispoOrder _ (InlineDisposition _)                               = GT
+    dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
+
 disposition2widget :: Disposition -> Widget
-disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
+disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
-disposition2widget (InlineDisposition     n) = [whamlet|<h3>#{n}|]
+disposition2widget (InlineDisposition     n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
 disposition2widget  DefaultDisposition       = mempty
 
-part2widget :: Part -> Widget
+part2widget :: CryptoUUIDSentMail -> Part -> Widget
-part2widget Part{partContent=NestedParts ps} =
+part2widget cusm Part{partContent=NestedParts ps} =
   [whamlet|
-    <section>
       $forall p <- ps
-        <p>
+        ^{part2widget cusm p}
-          ^{part2widget p}
   |]
-part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
+part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
     [whamlet|
       <section>
         ^{disposition2widget dispo}
         ^{showBody}
+      ^{showPass}
     |]
   where
     showBody
@@ -263,8 +296,38 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD
       | pt == decodeUtf8 typeJson  =
           let jw :: Aeson.Value -> Widget = jsonWidget
           in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
-      | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
+      | pt == decodeUtf8 typePDF
-
+      , AttachmentDisposition t <- dispo
+        = [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
+      | otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
+    showPass
+      | pt == decodeUtf8 typePlain
+      , let cw = T.words $ decodeUtf8 pc
+      , Just name <- listBracket ("Inhaber","Gültig") cw                               -- heursitic for dirving licence renewal letters only; improve
+                <|>  listBracket ("Licensee","Valid") cw
+      = let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
+        liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
+          Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
+          Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
+            [whamlet|
+              <section>
+                $maybe pw <- mbpw
+                  <details>
+                    <summary>
+                      _{MsgAdminUserPinPassword}
+                    <p>
+                      <dl .deflist>
+                        <dt .deflist__dt>
+                          ^{userWidget u}
+                        <dd .deflist__dd>
+                          <b>
+                            #{pw}
+                    <p>
+                      _{MsgAdminUserPinPassNotIncluded}
+                $nothing
+                  _{MsgAdminUserNoPassword}
+            |]
+      | otherwise = mempty
 
 ------------------------------
 -- Decode MIME Encoded Word

src/Handler/Utils/Avs.hs

@@ -381,7 +381,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                       ]
 
         -- update company association & supervision
-        Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
+        newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
         oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
         primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
         let oldCompanyId = entityKey <$> oldCompanyEnt
@@ -445,6 +445,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                   -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
                   -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
                   -- return pst_up
+        upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo [usrId]   -- ensure firmInfo superior is supervisor for this user
         update usrId usr_up2                                         -- update user by company switch first (due to possible conflicts with usr_up2)
         update usrId usr_up1                                         -- update user eventually
         update uaId  avs_ups                                         -- update stored avsinfo for future updates
@@ -587,7 +588,7 @@ upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
 upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
     mbFirmEnt <- getAvsCompany newAvsFirmInfo --  primarily by AvsId, then Shorthand, then name
     $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
-    cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
+    case (mbFirmEnt, mbOldAvsFirmInfo) of
       (Nothing, _) -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
         afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
                 then return $ newAvsFirmInfo ^. _avsFirmFirmNo
@@ -630,8 +631,6 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
           _otherwise -> return res_cmp
         $logInfoS "AVS" "Update company completed."
         return res_cmp2
-    void $ upsertCompanySuperior cmpEnt newAvsFirmInfo mbOldAvsFirmInfo                -- ensure firmInfo superior is supervisor
-    return cmpEnt
   where
     firmInfo2key =
         CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI  -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
@@ -644,9 +643,10 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
       -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
       ]
 
--- upsert company supervisor from AvsFirmEMailSuperior
+
-upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> DB () -- (Maybe UserId) possibly return superior, but currently not needed
+-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
-upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi = do
+upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> [UserId] -> DB () -- may return superior (Maybe UserId), but currently not needed
+upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrs =
   let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
       getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
       newAvsNo    = newAfi ^.         _avsFirmFirmNo
@@ -657,49 +657,55 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi =
       getOldId    = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
       unchangedCompany  = oldAvsNo   == Just newAvsNo
       changedSuperior   = mbSupEmail /= mbOldEmail     -- beware, both could be Nothing
-  mbSupId <- getSupId
+      --   1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
-  -- delete old superiors, if any
+      --   2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
-  when (unchangedCompany && changedSuperior) $
+      --   3. unchangedCompany && changedSuperior: update superior for all users
-    deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
+  in unless (unchangedCompany && not changedSuperior) $ do      -- do nothing if (unchangedCompany && not changedSuperior).
-                        [ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
+    mbSupId <- getSupId
-  -- ensure superior supervision
+    -- delete old superiors, if any
-  case mbSupId of
+    when (unchangedCompany && changedSuperior) $
-    Just supId -> do
+      deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
-      -- ensure association between company and superior at equal-to-top priority
+                          [ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
-      prio <- getCompanyUserMaxPrio supId
+    unless unchangedCompany $
-      void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
+      deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser <-. usrs ]
-      -- ensure all company associates are irregularly supervised by the superior
+    -- ensure superior supervision
-      E.insertSelectWithConflict UniqueUserSupervisor
+    case mbSupId of
-        (do
+      Just supId -> do
-          usr <- E.from $ E.table @UserCompany
+        -- ensure association between company and superior at equal-to-top priority
-          E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
+        prio <- getCompanyUserMaxPrio supId
-              -- E.&&. E.notExists (do                                                              -- restrict to primary company only
+        void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
-              --     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.!=. E.val cid                       -- redundant due to > above, but likely performance improving
-              --   )
-          return $ UserSupervisor
-            E.<#  E.val supId
-            E.<&> (usr E.^. UserCompanyUser)
-            E.<&> E.false
-            E.<&> E.justVal cid
-            E.<&> E.val reasonSuperior
-        )
-        (\_old _new -> [] -- do not change exisitng supervision
-          -- [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
-          -- , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
-          -- , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
-          -- ]
-        )
-      when (unchangedCompany && changedSuperior) $ do
-        oldSupId <- getOldId
-        reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
-    Nothing ->
-      when (unchangedCompany && changedSuperior) $ do
-        oldSupId <- getOldId
-        reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
 
+        -- ensure all company associates are irregularly supervised by the superior
+        E.insertSelectWithConflict UniqueUserSupervisor
+          (do
+            usr <- E.from $ E.table @UserCompany
+            E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
+                -- E.&&. E.notExists (do                                                              -- restrict to primary company only
+                --     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.!=. E.val cid                       -- redundant due to > above, but likely performance improving
+                --   )
+            return $ UserSupervisor
+              E.<#  E.val supId
+              E.<&> (usr E.^. UserCompanyUser)
+              E.<&> E.false
+              E.<&> E.justVal cid
+              E.<&> E.val reasonSuperior
+          )
+          (\_old _new -> [] -- do not change exisitng supervision
+            -- [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
+            -- , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
+            -- , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
+            -- ]
+          )
+        when (unchangedCompany && changedSuperior) $ do
+          oldSupId <- getOldId
+          reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
+      Nothing ->
+        when (unchangedCompany && changedSuperior) $ do
+          oldSupId <- getOldId
+          reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
 
 queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
 queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User)    (E.^. UserId)      (\usr    -> usr E.^. UserId             `E.in_` E.vals uids)

src/Jobs/Handler/SynchroniseAvs.hs

@@ -14,7 +14,7 @@ import Import
 
 import qualified Data.Text            as Text
 import qualified Data.Set             as Set
-import qualified Data.Map             as Map
+-- import qualified Data.Map             as Map
 import qualified Data.Conduit.List as C
 
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -151,7 +151,7 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
       procLic aLic up apids
         | n <- Set.size apids, n > 0 =
           let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
-              logit errm = runDB $ logInterface' "AVS" subtype False (isJust errm) (Just n) (fromMaybe "Automatic synch" errm)
+              logit errm = runDB $ logInterface' "AVS" subtype False (isNothing errm) (Just n) (fromMaybe "Automatic synch" errm)
               catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1))
           in if NTop (Just n) <= NTop maxChanges
               then do
@@ -163,7 +163,7 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
 
   (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
   -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
-  multiFirmBlocks <- ifNothingM reasonFilter mempty $ \reasons -> do
+  reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
     now <- liftIO getCurrentTime
     firmBlocks <- runDBRead $ E.select $ do
       (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs
@@ -172,16 +172,14 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
             qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
             E.&&. qblock `isLatestBlockBefore'` E.val now)
       E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
-          E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld)
+          E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
-          E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock)
       return $ uavs E.^. UserAvsPersonId
-    firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks                      -- may throw, but we need to abort then
+    return $ Set.fromList $ map E.unValue firmBlocks
-    return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData
 
   let fltrIds
         | synchLevel >= 5 = id
-        | synchLevel >= 3 = flip Set.difference   multiFirmBlocks
+        | synchLevel >= 3 = flip Set.difference   reasonFltrdIds
-        | otherwise       = flip Set.difference $ multiFirmBlocks `Set.union` rsChanged
+        | otherwise       = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
 
   when (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
   when (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld

src/Model/Types/Avs.hs

@@ -501,9 +501,11 @@ deriveJSON defaultOptions
   } ''AvsDataPerson
 -}
 
+{- Did not work as intended! Verify, if needed again.
 hasMultipleFirms :: AvsDataPerson -> Bool
 hasMultipleFirms AvsDataPerson{avsPersonPersonCards=crds} =
   1 < Set.size (Set.filter isJust $ Set.map avsDataFirm crds)
+-}
 
 data AvsPersonLicence = AvsPersonLicence
       { avsLicenceRampLicence  :: AvsLicence

src/Model/Types/Misc.hs

@@ -69,7 +69,7 @@ data SupervisorReason
 --       so do not change values here without a proper migration
 instance Show SupervisorReason where
   show SupervisorReasonCompanyDefault = "Firmenstandard"
-  show SupervisorReasonAvsSuperior    = "Vorgesetzer"
+  show SupervisorReasonAvsSuperior    = "Vorgesetzter"
   show SupervisorReasonUnknown        = "Unbekannt"
 
 

src/Utils.hs

@@ -813,6 +813,19 @@ checkAsc :: Ord a => [a] -> Bool
 checkAsc (x:r@(y:_)) = x<=y && checkAsc r
 checkAsc _ = True
 
+-- return a part of a list between two given elements, if it exists
+listBracket :: Eq a => (a,a) -> [a] -> Maybe [a]
+listBracket _     []    = Nothing
+listBracket b@(s,e) (h:t)
+    | s == h    = listUntil  [] t
+    | otherwise = listBracket b t
+  where
+    listUntil _      [] = Nothing
+    listUntil l1 (h1:t1)
+      | e == h1   = Just $ reverse l1
+      | otherwise = listUntil (h1:l1) t1
+
+
 ----------
 -- Sets --
 ----------

templates/avs.hamlet

@@ -35,6 +35,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   $maybe answer <- mbQryLic
     <p>
       ^{answer}  
+  $maybe autodiffs <- mbAutoDiffs
+    <p>
+      #{autodiffs}
 
 <section>
   <p> 

templates/i18n/avs-synchronisation/de-de-formal.hamlet

@@ -50,27 +50,27 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 $if notNull avsLicenceSynchTimes
   <section>
     <h2>
-      Automatische AVS Fahrlizen Sychronisation
+      Automatische AVS Fahrlizenzen Sychronisation
     <p>
       <dl .deflist>
         <dt .deflist__dt>
           Uhrzeiten Synchronisation
         <dd .deflist__dd>
-          Werktags, weniger Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
+          Werktags, wenige Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
         <dt .deflist__dt>
           Synchronisationslevel
         <dd .deflist__dd>
-          #{avsLicenceSynchLevel} #
+          <strong>#{avsLicenceSynchLevel}: #
-            $case avsLicenceSynchLevel
+          $case avsLicenceSynchLevel
-              $of 1
+            $of 1
-                Nur Vorfeld-Fahrberechtigungen entziehen
+              Nur Vorfeld-Fahrberechtigungen entziehen
-              $of 2 
+            $of 2 
-                Vorfeld-Fahrberechtigungen entziehen und gewähren
+              Vorfeld-Fahrberechtigungen entziehen und gewähren
-              $of 3
+            $of 3
-                Vorfeld-Fahrberechtigungen entziehen und gewähren, #
+              Vorfeld-Fahrberechtigungen entziehen und gewähren, #
-                so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
+              so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
-              $of _
+            $of _
-                Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
+              Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
         $maybe reasons <- avsLicenceSynchReasonFilter
           <dt .deflist__dt>
             Ausnahmen
@@ -80,4 +80,4 @@ $if notNull avsLicenceSynchTimes
           <dt .deflist__dt>
             Maximal Änderungen
           <dd .deflist__dd>
-            Keine Synchronisation durchführen, wenn es mehr als #{maxChange} Änderungen pro Level wären
+            Keine Synchronisation eines Levels durchführen, welches mehr als #{maxChange} Änderungen hätte

templates/i18n/avs-synchronisation/en-eu.hamlet

@@ -60,16 +60,16 @@ $if notNull avsLicenceSynchTimes
         <dt .deflist__dt>
           Synchronisation level
         <dd .deflist__dd>
-          #{avsLicenceSynchLevel} #
+          <strong>#{avsLicenceSynchLevel}: #
-            $case avsLicenceSynchLevel
+          $case avsLicenceSynchLevel
-              $of 1
+            $of 1
-                Revoke apron driving licences only
+              Revoke apron driving licences only
-              $of 2 
+            $of 2 
-                Grant and revoke apron driving licences only
+              Grant and revoke apron driving licences only
-              $of 3
+            $of 3
-                Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
+              Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
-              $of _
+            $of _
-                Grant and revoke all driving licences automatically
+              Grant and revoke all driving licences automatically
         $maybe reasons <- avsLicenceSynchReasonFilter
           <dt .deflist__dt>
             Exemptions
@@ -79,4 +79,4 @@ $if notNull avsLicenceSynchTimes
           <dt .deflist__dt>
             Max changes
           <dd .deflist__dd>
-            Do not synchronize a licence if the number of changes exceeds #{maxChange}
+            Do not synchronize a licence level if the number of changes exceeds #{maxChange}

test/Database/Fill.hs

@@ -113,10 +113,10 @@ fillDb = do
     , userMobile = Nothing
     , userCompanyPersonalNumber = Just "00000"
     , userCompanyDepartment = Nothing
-    , userPinPassword = Nothing
+    , userPinPassword = Just "1234.5"
     , userPostAddress = Just $ markdownToStoredMarkup ("Büro 127   \nMathematisches Institut der Ludwig-Maximilians-Universität München   \nTheresienstr. 39   \nD-80333 München"::Text)
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = True
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -202,7 +202,7 @@ fillDb = do
     , userPinPassword = Nothing
     , userPostAddress = Nothing
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = True
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -766,7 +766,7 @@ fillDb = do
   void . insert' $ QualificationUser jost       qid_r  (n_day   99) (n_day $  -11) (n_day $  -222) True (n_day' $ -9) -- TODO: better dates!
   void . insert' $ QualificationUser jost       qid_l  (n_day  999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
   void . insert' $ QualificationUser jost       qid_rp (n_day  999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
-  qfkleen <- insert' $ QualificationUser gkleen qid_f  (n_day 33) (n_day $ -4) (n_day $ -20) True  (n_day' $ -9)
+  qfkleen <- insert' $ QualificationUser gkleen qid_f  (n_day 10) (n_day $ -40) (n_day $ -120) True  (n_day' $ -20)
   void . insert  $ QualificationUserBlock qfkleen False (n_day' 1) "Future block"   (Just svaupel)
   void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) False (n_day' $ -1)
   qfvaupel <- insert' $ QualificationUser svaupel    qid_f (n_day    2) (n_day $ -1) (n_day $  -2) True  (n_day' $ -9)