From 617706b895b96c4838520e5fbcba7ee201bafc8e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 29 Nov 2022 19:04:43 +0100 Subject: [PATCH 1/7] fix(build) --- src/Handler/Admin/Avs.hs | 83 +++++++++++++++++++++------------------- 1 file changed, 44 insertions(+), 39 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index b438803cd..10704553a 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -4,7 +4,7 @@ module Handler.Admin.Avs ( getAdminAvsR - , postAdminAvsR + , postAdminAvsR ) where import Import @@ -28,7 +28,7 @@ nullaryPathPiece ''ButtonAvsTest camelToPathPiece instance Button UniWorX ButtonAvsTest where btnLabel BtnCheckLicences = "Check all licences" -- could be msg - btnClasses BtnCheckLicences = [BCIsButton, BCPrimary] + btnClasses BtnCheckLicences = [BCIsButton, BCPrimary] -- END Button @@ -36,16 +36,17 @@ avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field avsCardNoField = convertField AvsCardNo avsCardNo textField makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson -makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> - flip (renderAForm FormStandard) html $ AvsQueryPerson +makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> + flip (renderAForm FormStandard) html $ AvsQueryPerson <$> aopt avsCardNoField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl) + <*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) <*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl) <*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl) <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) - <*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) + validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () -validateAvsQueryPerson = do +validateAvsQueryPerson = do AvsQueryPerson{..} <- State.get guardValidation MsgAvsQueryEmpty $ is _Just avsPersonQueryCardNo || @@ -55,31 +56,31 @@ validateAvsQueryPerson = do is _Just avsPersonQueryVersionNo makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus -makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> +makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> flip (renderAForm FormStandard) html $ parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) where parseAvsIds :: Text -> AvsQueryStatus parseAvsIds txt = AvsQueryStatus $ Set.fromList ids - where - nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt + where + nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt ids = catMaybes $ readMay <$> nonemptys - unparseAvsIds :: AvsQueryStatus -> Text - unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids + unparseAvsIds :: AvsQueryStatus -> Text + unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler () -validateAvsQueryStatus = do +validateAvsQueryStatus = do AvsQueryStatus ids <- State.get guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) avsLicenceOptions :: OptionList AvsLicence -avsLicenceOptions = mkOptionList - [ Option +avsLicenceOptions = mkOptionList + [ Option { optionDisplay = Text.singleton $ licence2char l , optionInternalValue = l , optionExternalValue = toJsonText l - } + } | l <- universeF ] @@ -92,27 +93,30 @@ postAdminAvsR = do Just AvsQuery{..} -> do ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing - let procFormPerson fr = do + let procFormPerson fr = do + addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr) res <- avsQueryPerson fr - case res of - Left err -> return . Just $ tshow err + case res of + Left err -> return . Just $ tshow err Right jsn -> return . Just $ tshow jsn mbPerson <- formResultMaybe presult procFormPerson ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing - let procFormStatus fr = do + let procFormStatus fr = do + addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr) res <- avsQueryStatus fr - case res of - Left err -> return . Just $ tshow err - Right jsn -> return . Just $ tshow jsn + case res of + Left err -> return . Just $ tshow err + Right jsn -> return . Just $ tshow jsn mbStatus <- formResultMaybe sresult procFormStatus - ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html -> + ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing - let procFormCrUsr fr = do + let procFormCrUsr fr = do + addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr) res <- try $ upsertAvsUser fr - case res of - (Right (Just uid)) -> do + case res of + (Right (Just uid)) -> do uuid :: CryptoUUIDUser <- encrypt uid return $ Just [whamlet|

Success:

User created or updated.|] (Right Nothing) -> @@ -122,12 +126,13 @@ postAdminAvsR = do return $ Just [whamlet|

Error:

#{msg}|] mbCrUser <- formResultMaybe crUsrRes procFormCrUsr - ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html -> + ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html -> flip (renderAForm FormStandard) html $ areq intField (fslI MsgAvsPersonId) Nothing - let procFormGetLic fr = do + let procFormGetLic fr = do + addMessage Info $ text2Html $ "Query: " <> tshow (toJSON (AvsPersonId fr)) res <- try $ getLicenceByAvsId $ AvsPersonId fr - case res of - (Right (Just lic)) -> + case res of + (Right (Just lic)) -> return $ Just [whamlet|

Success:

Licence #{tshow lic}|] (Right Nothing) -> return $ Just [whamlet|

Warning:

User not found.|] @@ -136,13 +141,13 @@ postAdminAvsR = do return $ Just [whamlet|

Error:

#{msg}|] mbGetLic <- formResultMaybe getLicRes procFormGetLic - ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html -> - flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing + ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html -> + flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld) - let procFormSetLic (aid, lic) = do + let procFormSetLic (aid, lic) = do res <- try $ setLicenceAvs (AvsPersonId aid) lic - case res of - (Right True) -> + case res of + (Right True) -> return $ Just [whamlet|

Success:

Licence #{tshow (licence2char lic)} set for #{tshow aid}.|] (Right False) -> return $ Just [whamlet|

Error:

Licence could not be set for #{tshow aid}.|] @@ -153,10 +158,10 @@ postAdminAvsR = do ((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest) - let procFormQryLic BtnCheckLicences = do + let procFormQryLic BtnCheckLicences = do res <- try checkLicences - case res of - (Right True) -> + case res of + (Right True) -> return $ Just [whamlet|

Success:

Licences sychronized.|] (Right False) -> return $ Just [whamlet|

Error:

Licences could not be synchronized, see error log.|] @@ -176,4 +181,4 @@ postAdminAvsR = do setLicForm = wrapFormHere setLicWgt setLicEnctype qryLicForm = wrapForm qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit } -- TODO: use i18nWidgetFile instead if this is to become permanent - $(widgetFile "avs") + $(widgetFile "avs") From 4b295f44d22eff08e55409f8d51ff9ddf2e49270 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 30 Nov 2022 13:30:00 +0100 Subject: [PATCH 2/7] chore(avs): fix avs interface to botched specifications --- src/Handler/Admin/Avs.hs | 40 +++++++++++++++++++++++++++++----------- src/Handler/Utils/Avs.hs | 18 ++++++++++-------- src/Model/Types/Avs.hs | 2 +- src/Utils/Avs.hs | 8 ++++---- 4 files changed, 44 insertions(+), 24 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 10704553a..c36b45493 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -113,7 +113,7 @@ postAdminAvsR = do ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing let procFormCrUsr fr = do - addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr) + -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr) res <- try $ upsertAvsUser fr case res of (Right (Just uid)) -> do @@ -127,17 +127,33 @@ postAdminAvsR = do mbCrUser <- formResultMaybe crUsrRes procFormCrUsr ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html -> - flip (renderAForm FormStandard) html $ areq intField (fslI MsgAvsPersonId) Nothing + flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing + <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing + <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing let procFormGetLic fr = do - addMessage Info $ text2Html $ "Query: " <> tshow (toJSON (AvsPersonId fr)) - res <- try $ getLicenceByAvsId $ AvsPersonId fr + res <- avsQueryGetAllLicences case res of - (Right (Just lic)) -> - return $ Just [whamlet|

Success:

Licence #{tshow lic}|] - (Right Nothing) -> - return $ Just [whamlet|

Warning:

User not found.|] - (Left e) -> do - let msg = tshow (e :: SomeException) + (Right (AvsResponseGetLicences lics)) -> do + let flics = Set.toList $ Set.filter lfltr lics + lfltr = case fr of -- not pretty, but it'll do + (Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax)) + (Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin) + (Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax) + (Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic + (Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID + (Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID + (Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID + (Nothing , Nothing, Nothing ) -> const True + addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences." + return $ Just [whamlet| +

Success:

+
    + $forall AvsPersonLicence{..} <- flics +
  • #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence} + |] + + (Left err) -> do + let msg = tshow err return $ Just [whamlet|

    Error:

    #{msg}|] mbGetLic <- formResultMaybe getLicRes procFormGetLic @@ -145,7 +161,9 @@ postAdminAvsR = do flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld) let procFormSetLic (aid, lic) = do - res <- try $ setLicenceAvs (AvsPersonId aid) lic + let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = AvsPersonId aid } + addMessage Info $ text2Html $ "See log for detailed errors. Query: " <> tshow (toJSON $ AvsQuerySetLicences req) + res <- try $ setLicencesAvs req case res of (Right True) -> return $ Just [whamlet|

    Success:

    Licence #{tshow (licence2char lic)} set for #{tshow aid}.|] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b83f16a4e..9c070221b 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -7,7 +7,7 @@ module Handler.Utils.Avs ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard - , getLicence, getLicenceDB, getLicenceByAvsId + -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface , setLicence, setLicenceAvs, setLicencesAvs , checkLicences , lookupAvsUser, lookupAvsUsers @@ -67,6 +67,7 @@ instance Exception AvsException -} +{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround -- Do we need this? -- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence) @@ -85,14 +86,15 @@ getLicenceDB uid = do let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences return (avsLicenceRampLicence <$> ulicence) -getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => - AvsPersonId -> m (Maybe AvsLicence) -getLicenceByAvsId aid = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery - AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId aid - let ulicence = Set.lookupMax $ Set.filter ((aid ==) . avsLicencePersonID) licences - return (avsLicenceRampLicence <$> ulicence) +-- | Should be avoided, since all licences must be requested at once. +getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => + Set AvsPersonId -> m (Set AvsPersonLicence) +getLicenceByAvsId aids = do + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery + AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences + return $ Set.filter (\x -> avsLicencePersonID x `Set.member` aids) licences +-} -- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool setLicence :: (PersistUniqueRead backend, MonadThrow m, diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 2eb1210dc..3443d6938 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -470,7 +470,7 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions ''AvsQueryStatus -newtype AvsQueryGetLicences = AvsQueryGetLicences (Set AvsObjPersonId) +newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions ''AvsQueryGetLicences diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index dfd2d7c04..ef5aaf46c 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -45,15 +45,15 @@ data AvsQuery = AvsQuery { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson) , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) , avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences) - , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) + -- , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM , avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences) } makeLenses_ ''AvsQuery --- | To query all active licences, a special argument must be prepared +-- | To query all active licences, a special constant argument must be prepared avsQueryAllLicences :: AvsQueryGetLicences -avsQueryAllLicences = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId $ AvsPersonId 0 +avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId $ AvsPersonId 0 mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery @@ -61,7 +61,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv - , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv + -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv } where From b20008d3bcb730ff76a76ce2928364e6ce9e7c35 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 30 Nov 2022 15:42:47 +0100 Subject: [PATCH 3/7] fix(avs): normalize internal personal numbers between LDAP and AVS --- src/Handler/Admin/Avs.hs | 6 ++++- src/Handler/Utils/Avs.hs | 6 ++--- src/Model/Types/Avs.hs | 50 ++++++++++++++++++++++++++++++++++++++-- src/Utils.hs | 14 +++++++---- src/Utils/Avs.hs | 2 +- 5 files changed, 66 insertions(+), 12 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index c36b45493..9bff17398 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -35,6 +35,9 @@ instance Button UniWorX ButtonAvsTest where avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo avsCardNoField = convertField AvsCardNo avsCardNo textField +avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo +avsInternalPersonalNoField = convertField (canonical . AvsInternalPersonalNo) avsInternalPersonalNo textField + makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> flip (renderAForm FormStandard) html $ AvsQueryPerson @@ -42,7 +45,8 @@ makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateA <*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) <*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl) <*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl) - <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) + <*> aopt avsInternalPersonalNoField + (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 9c070221b..9c4dec62d 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -258,8 +258,8 @@ upsertAvsUserById api = do mbuid <- getBy (UniqueUserAvsId api) case (mbuid, mbapd) of (Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number - | Just persNo <- avsPersonInternalPersonalNo -> do - candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] [] + | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do + candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] [] case candidates of [uid] -> insertUniqueEntity $ UserAvs api uid (_:_) -> throwM AvsUserAmbiguous @@ -290,7 +290,7 @@ upsertAvsUserById api = do , aufSex = Nothing , aufMobile = Nothing , aufTelephone = Nothing - , aufFPersonalNumber = avsPersonInternalPersonalNo + , aufFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo , aufFDepartment = Nothing , aufPostAddress = userFirmAddr , aufPrefersPostal = isJust firmAddress diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 3443d6938..9b20eaee7 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -81,7 +81,53 @@ instance FromJSON SloppyBool where -- AVS Datatypes -- ------------------- -type AvsInternalPersonalNo = Text -- ought to be all digits, type synonym for clarity/documentation within types +newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text } -- ought to be all digits + deriving (Eq, Ord, Show, Generic, Typeable) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) +instance E.SqlString AvsInternalPersonalNo +-- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API +normalizeAvsInternalPersonalNo :: Text -> Text +normalizeAvsInternalPersonalNo = Text.dropWhile (\c -> '0' == c || Char.isSpace c) +instance Canonical AvsInternalPersonalNo where + canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn +instance FromJSON AvsInternalPersonalNo where + parseJSON x = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo <$> parseJSON x +instance ToJSON AvsInternalPersonalNo where + toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn + +type instance Element AvsInternalPersonalNo = Char +instance MonoFoldable AvsInternalPersonalNo where + ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo + ofoldr x y = Text.foldr x y . avsInternalPersonalNo + ofoldl' x y = Text.foldl' x y . avsInternalPersonalNo + otoList = Text.unpack . avsInternalPersonalNo + oall x = Text.all x . avsInternalPersonalNo + oany x = Text.any x . avsInternalPersonalNo + onull = Text.null . avsInternalPersonalNo + olength = Text.length . avsInternalPersonalNo + ofoldr1Ex x = Text.foldr1 x . avsInternalPersonalNo + ofoldl1Ex' x = Text.foldl1' x . avsInternalPersonalNo + headEx = Text.head . avsInternalPersonalNo + lastEx = Text.last . avsInternalPersonalNo + {-# INLINE ofoldMap #-} + {-# INLINE ofoldr #-} + {-# INLINE ofoldl' #-} + {-# INLINE otoList #-} + {-# INLINE oall #-} + {-# INLINE oany #-} + {-# INLINE onull #-} + {-# INLINE olength #-} + {-# INLINE ofoldr1Ex #-} + {-# INLINE ofoldl1Ex' #-} + {-# INLINE headEx #-} + {-# INLINE lastEx #-} + +{- +instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where + canonical (Just aipn) | ipn@(AvsInternalPersonalNo pn) <- canonical aipn, not (null pn) = Just ipn + canonical _ = Nothing +-} + -- CompleteCardNo = xxxxxxxx.y -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo @@ -117,7 +163,7 @@ readAvsFullCardNo _ = Nothing discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) | Text.null pv - = Just $ Right c + = Just $ Right $ AvsInternalPersonalNo c | not $ Text.null c , Just ('.', v) <- Text.uncons pv , Just (Char.isDigit -> True, "") <- Text.uncons v diff --git a/src/Utils.hs b/src/Utils.hs index 8a92fe520..7d023a4b3 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1876,14 +1876,18 @@ makePrisms ''ExitCase class Canonical a where canonical :: a -> a -instance MonoFoldable mono => Canonical (Maybe mono) where + +instance {-# OVERLAPPABLE #-} MonoFoldable mono => Canonical (Maybe mono) where canonical (Just t) | null t = Nothing canonical other = other --- instance (Canonical mono, MonoFoldable mono) => Canonical (Maybe mono) where --- canonical (Just t) | null t = Nothing --- canonical (Just t) = Just $ canonical t --- canonical other = other +{- +instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where + canonical r@(Just t) = let c = canonical t + in if null c then Nothing else + if t==c then r else Just c + canonical other = other +-} -- this instance is more of a convenient abuse of the class (expand to Foldable) instance (Ord a, Canonical a) => Canonical (Set a) where diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index ef5aaf46c..3606bb2c0 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -157,7 +157,7 @@ mergeAvsDataPerson = Map.unionWithKey merger in AvsDataPerson { avsPersonFirstName = pickBy' Text.length avsPersonFirstName , avsPersonLastName = pickBy' Text.length avsPersonLastName - , avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo + , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo , avsPersonPersonNo = pickBy' id avsPersonPersonNo , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb From 7d3b52764016dbb2ee679b22c7faced7a8075fd1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 30 Nov 2022 16:12:49 +0100 Subject: [PATCH 4/7] fix build --- test/Utils/TypesSpec.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index f5dfafb0f..80bd07ac2 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -14,6 +14,10 @@ instance Arbitrary SloppyBool where arbitrary = SloppyBool <$> arbitrary shrink (SloppyBool x) = SloppyBool <$> shrink x +instance Arbitrary AvsInternalPersonalNo where + arbitrary = canonical . AvsInternalPersonalNo <$> arbitrary + shrink (AvsInternalPersonalNo x) = canonical . AvsInternalPersonalNo <$> shrink x + instance Arbitrary AvsPersonId where arbitrary = AvsPersonId <$> arbitrary shrink (AvsPersonId x) = AvsPersonId <$> shrink x From a926cc07746afa2e72034c4eec869585990d9623 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 30 Nov 2022 18:42:40 +0100 Subject: [PATCH 5/7] chore(profile): show company, supervisors and supervisees --- .../personal_settings/de-de-formal.msg | 4 ++++ .../settings/personal_settings/en-eu.msg | 4 ++++ src/Handler/Profile.hs | 21 +++++++++++++++++++ src/Handler/Utils/Widgets.hs | 5 +++++ src/Utils.hs | 3 +++ src/Utils/Icon.hs | 2 ++ templates/profileData.hamlet | 13 ++++++++++++ test/Database/Fill.hs | 17 ++++++++++++--- 8 files changed, 66 insertions(+), 3 deletions(-) diff --git a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg index 06b915786..147d89ded 100644 --- a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg @@ -27,7 +27,11 @@ ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle E ProfileCorrections: Auflistung aller zugewiesenen Korrekturen Remarks: Hinweise +ProfileSupervisor: Übergeordnete Ansprechpartner +ProfileSupervisee: Ist Ansprechpartner für + UserTelephone: Telefon UserMobile: Mobiltelefon +Company: Firmenzugehörigkeit CompanyPersonalNumber: Personalnummer (nur Fraport AG) CompanyDepartment: Abteilung \ No newline at end of file diff --git a/messages/uniworx/categories/settings/personal_settings/en-eu.msg b/messages/uniworx/categories/settings/personal_settings/en-eu.msg index e39556769..cc3c63c19 100644 --- a/messages/uniworx/categories/settings/personal_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/personal_settings/en-eu.msg @@ -27,7 +27,11 @@ ProfileCorrectorRemark: The table above only shows registration as a corrector i ProfileCorrections: List of all assigned corrections Remarks: Remarks +ProfileSupervisor: Supervised by +ProfileSupervisee: Supervises + UserTelephone: Phone UserMobile: Mobile +Company: Company affilitaion CompanyPersonalNumber: Personnel number (Fraport AG only) CompanyDepartment: Department \ No newline at end of file diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 7c8660ee2..a7e60b53c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -664,6 +664,27 @@ makeProfileData (Entity uid User{..}) = do E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId return (studyfeat, studydegree, studyterms) + companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let companies = intersperse (text2markup ", ") $ + (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' + icnSuper = text2markup " " <> icon IconSupervisor + supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do + E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid + E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId + 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) + supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do + E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid + E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId + return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications) + let supervisees = intersperse (text2widget ", ") $ + (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees' + -- icnReroute = text2widget " " <> toWgt (icon IconLetter) --Tables (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 9e375da20..52d205d30 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -59,6 +59,11 @@ nameWidget displayName surname = toWidget $ nameHtml displayName surname userWidget :: HasUser c => c -> Widget userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname) +linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget +linkUserWidget lnk (Entity uid usr) = do + uuid <- encrypt uid + simpleLink (userWidget usr) (lnk uuid) + -- | toWidget-Version of @nameEmailHtml@, for convenience nameEmailWidget :: UserEmail -- ^ userEmail -> Text -- ^ userDisplayName diff --git a/src/Utils.hs b/src/Utils.hs index 7d023a4b3..e8eedbadb 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -363,6 +363,9 @@ toWgt :: ToMarkup a toWgt = toWidget . toHtml -- Convenience Functions to avoid type signatures: +text2markup :: Text -> Markup +text2markup t = [shamlet|#{t}|] + text2widget :: Text -> WidgetFor site () text2widget t = [whamlet|#{t}|] diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 948afe9de..8dd017bb8 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -112,6 +112,7 @@ data Icon | IconPrintCenter | IconLetter | IconAt + | IconSupervisor deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) deriving anyclass (Universe, Finite, NFData) @@ -203,6 +204,7 @@ iconText = \case IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk" IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well IconAt -> "at" + IconSupervisor -> "head-side" -- must be notably different to user nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 1255bb71e..17d4f05fc 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -68,6 +68,19 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgCompanyPersonalNumber}
    #{companyPersonalNumber} + $if not $ null companies +
    + _{MsgCompany} +
    + ^{toWgt (mconcat companies)} + $if not $ null supervisors +
    _{MsgProfileSupervisor} +
    + ^{mconcat supervisors} + $if not $ null supervisees +
    _{MsgProfileSupervisee} +
    + ^{mconcat supervisees} $if showAdminInfo
    _{MsgUserCreated} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index eb636861d..6f7a305a5 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -478,11 +478,22 @@ fillDb = do I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course. |] } - _fraportAg <- insert' $ Company "Fraport AG" "Fraport" + fraportAg <- insert' $ Company "Fraport AG" "Fraport" _fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" - _nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" + nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" _ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" - _bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" + bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" + void . insert' $ UserCompany jost fraportAg True + void . insert' $ UserCompany svaupel nice True + void . insert' $ UserCompany gkleen nice False + void . insert' $ UserCompany fhamann bpol False + void . insert' $ UserSupervisor jost gkleen True + void . insert' $ UserSupervisor jost svaupel False + void . insert' $ UserSupervisor jost sbarth False + void . insert' $ UserSupervisor jost tinaTester True + void . insert' $ UserSupervisor svaupel gkleen False + void . insert' $ UserSupervisor svaupel fhamann True + void . insert' $ UserSupervisor sbarth tinaTester True ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True avn <- insert' $ School "Fahrerausbildung" "FA" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True From 53eba95e4c16525fc3680de80340aa35c976723b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 30 Nov 2022 19:04:20 +0100 Subject: [PATCH 6/7] chore(release): 26.6.3 --- CHANGELOG.md | 7 +++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 12 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b1b83f02c..1b344ce5d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [26.6.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.2...v26.6.3) (2022-11-30) + + +### Bug Fixes + +* **avs:** normalize internal personal numbers between LDAP and AVS ([b20008d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b20008d3bcb730ff76a76ce2928364e6ce9e7c35)) + ## [26.6.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.1...v26.6.2) (2022-11-29) ## [26.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.0...v26.6.1) (2022-11-28) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index d44322bc1..c24d415e3 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "26.6.2" + "version": "26.6.3" } diff --git a/nix/docker/version.json b/nix/docker/version.json index d44322bc1..c24d415e3 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "26.6.2" + "version": "26.6.3" } diff --git a/package-lock.json b/package-lock.json index 13ff6a7f5..9df0c2462 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.6.2", + "version": "26.6.3", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 941b8a803..a22d00fa0 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.6.2", + "version": "26.6.3", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 7c89d013f..f715bedb6 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 26.6.2 +version: 26.6.3 dependencies: - base - yesod From d224443721ec17f53a6e4bffcb8f8f09747aca4f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 1 Dec 2022 09:12:08 +0100 Subject: [PATCH 7/7] refactor(addUser): blind attempt to speed up compilation --- src/Handler/Users/Add.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index d267bd85d..1553c9de9 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -36,9 +36,9 @@ data AdminUserForm = AdminUserForm } data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe AuthenticationKind -instance Finite AuthenticationKind + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable, Universe, Finite) +--instance Universe AuthenticationKind +--instance Finite AuthenticationKind embedRenderMessage ''UniWorX ''AuthenticationKind id nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2