diff --git a/CHANGELOG.md b/CHANGELOG.md index 1b344ce5d..f6277d4e0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ 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.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.3...v26.6.4) (2022-12-02) + ## [26.6.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.2...v26.6.3) (2022-11-30) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index c24d415e3..863c6fce8 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "26.6.3" + "version": "26.6.4" } diff --git a/nix/docker/version.json b/nix/docker/version.json index c24d415e3..863c6fce8 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "26.6.3" + "version": "26.6.4" } diff --git a/package-lock.json b/package-lock.json index 9df0c2462..9f352bc2d 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.6.3", + "version": "26.6.4", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index a22d00fa0..8ad468f71 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "26.6.3", + "version": "26.6.4", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f715bedb6..acd9e9c09 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 26.6.3 +version: 26.6.4 dependencies: - base - yesod diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 23c1eb341..fc225edf4 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -146,7 +146,7 @@ campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover ( campusUserReTest' pool doTest mode User{userIdent} = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) []) -campusUser :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) +campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 9d4bbb1f2..e43fa0b7b 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -4,7 +4,8 @@ module Foundation.Yesod.Auth ( authenticate - , upsertCampusUser, upsertCampusUserByCn + , ldapLookupAndUpsert + , upsertCampusUser , decodeUserTest , CampusUserConversionException(..) , campusUserFailoverMode, updateUserLanguage @@ -106,10 +107,10 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} - UniWorX{..} <- getYesod + $logDebugS "auth" $ tshow Creds{..} + ldapPool' <- getsYesod $ view _appLdapPool - flip catches excHandlers $ case appLdapPool of + flip catches excHandlers $ case ldapPool' of Just ldapPool | Just upsertMode' <- upsertMode -> do ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} @@ -152,14 +153,25 @@ _upsertCampusUserMode mMode cs@Creds{..} defaultOther = apHash +ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) +ldapLookupAndUpsert ident = + getsYesod (view _appLdapPool) >>= \case + Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." + Just ldapPool -> + campusUser'' ldapPool campusUserFailoverMode ident >>= \case + Nothing -> throwM CampusUserNoResult + Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse + +{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP! upsertCampusUserByCn :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m ) => Text -> SqlPersistT m (Entity User) upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])] +-} - +-- | Upsert User DB according to given LDAP data (does not query LDAP itself) upsertCampusUser :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -208,7 +220,7 @@ decodeUserTest mbIdent ldapData = do decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_) -decodeUser now UserDefaultConf{..} upsertMode ldapData = do +decodeUser now UserDefaultConf{..} upsertMode ldapData = do let userTelephone = decodeLdap ldapUserTelephone userMobile = decodeLdap ldapUserMobile diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 9bff17398..6d24f2ffa 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -19,7 +19,7 @@ import Handler.Utils.Avs import Utils.Avs -- Button needed only here -data ButtonAvsTest = BtnCheckLicences +data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonAvsTest instance Finite ButtonAvsTest @@ -27,8 +27,10 @@ instance Finite ButtonAvsTest nullaryPathPiece ''ButtonAvsTest camelToPathPiece instance Button UniWorX ButtonAvsTest where - btnLabel BtnCheckLicences = "Check all licences" -- could be msg - btnClasses BtnCheckLicences = [BCIsButton, BCPrimary] + btnLabel BtnCheckLicences = "Check all licences" -- could be msg + btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg + btnClasses BtnCheckLicences = [BCIsButton, BCPrimary] + btnClasses BtnSynchLicences = [BCIsButton, BCDanger] -- END Button @@ -36,7 +38,7 @@ avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field avsCardNoField = convertField AvsCardNo avsCardNo textField avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo -avsInternalPersonalNoField = convertField (canonical . AvsInternalPersonalNo) avsInternalPersonalNo textField +avsInternalPersonalNoField = convertField mkAvsInternalPersonalNo avsInternalPersonalNo textField makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> @@ -180,16 +182,42 @@ postAdminAvsR = do ((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest) - let procFormQryLic BtnCheckLicences = do - res <- try checkLicences - 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.|] - (Left e) -> do - let msg = tshow (e :: SomeException) - return $ Just [whamlet|

Error:

#{msg}|] + let procFormQryLic btn = case btn of + BtnCheckLicences -> do + res <- try $ do + allLicences <- throwLeftM avsQueryGetAllLicences + computeDifferingLicences allLicences + case res of + (Right diffs) -> do + let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs + r_grant = showLics AvsLicenceRollfeld + f_set = showLics AvsLicenceVorfeld + revoke = showLics AvsNoLicence + return $ Just [whamlet| +

Licence check differences: +

Grant R: +

+ #{r_grant} +

Set to F: +

+ #{f_set} +

Revoke licence: +

+ #{revoke} + |] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Licence check error:

#{msg}|] + BtnSynchLicences -> do + res <- try checkLicences + 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.|] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Licence synchronisation error:

#{msg}|] mbQryLic <- formResultMaybe qryLicRes procFormQryLic actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs index 4a2df7730..c3ed22c2a 100644 --- a/src/Handler/Admin/Ldap.hs +++ b/src/Handler/Admin/Ldap.hs @@ -10,67 +10,46 @@ module Handler.Admin.Ldap ) where import Import -import qualified Control.Monad.State.Class as State +-- import qualified Control.Monad.State.Class as State -- import Data.Aeson (encode) import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -- import qualified Data.Set as Set -import Foundation.Yesod.Auth (decodeUserTest) - +import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException()) import Handler.Utils import qualified Ldap.Client as Ldap import Auth.LDAP -data LdapQueryPerson = LdapQueryPerson - { ldapQueryIdent :: Maybe Text - -- , ldapQueryName :: Maybe Text - , ldapQueryPNum :: Maybe Text - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson -makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html -> - flip (renderAForm FormStandard) html $ LdapQueryPerson - <$> aopt textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl) - -- <*> aopt textField (fslI MsgAdminUserSurname) (ldapQueryName <$> tmpl) - <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl) - -validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler () -validateLdapQueryPerson = do - LdapQueryPerson{..} <- State.get - guardValidation MsgAvsQueryEmpty $ - is _Just ldapQueryIdent || - -- is _Just ldapQueryName || - is _Just ldapQueryPNum - - getAdminLdapR, postAdminLdapR :: Handler Html getAdminLdapR = postAdminLdapR postAdminLdapR = do - ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing - - let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList [])) - procFormPerson LdapQueryPerson{..} = do - ldapPool' <- getsYesod $ view _appLdapPool - - if isNothing ldapPool' - then addMessage Warning $ text2Html "LDAP Configuration missing." - else addMessage Info $ text2Html "Input for LDAP test received." - fmap join . for ldapPool' $ \ldapPool -> do - ldapData <- if | Just lqi <- ldapQueryIdent -> campusUser'' ldapPool FailoverUnlimited lqi - | Just lqn <- ldapQueryPNum -> campusUserMatr' ldapPool FailoverUnlimited lqn - | otherwise -> addMessageI Error MsgAvsQueryEmpty >> pure Nothing - decodedErr <- decodeUserTest (CI.mk <$> ldapQueryIdent) $ concat ldapData - whenIsLeft decodedErr $ addMessageI Error - return ldapData - + ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> + flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing + let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList [])) + procFormPerson lid = do + ldapPool' <- getsYesod $ view _appLdapPool + case ldapPool' of + Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing + Just ldapPool -> do + addMessage Info $ text2Html "Input for LDAP test received." + ldapData <- campusUser'' ldapPool campusUserFailoverMode lid + decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData + whenIsLeft decodedErr $ addMessageI Error + return ldapData mbLdapData <- formResultMaybe presult procFormPerson + ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> + flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing + let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User))) + procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) + mbLdapUpsert <- formResultMaybe uresult procFormUpsert + + actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute siteLayoutMsg MsgMenuLdap $ do setTitleI MsgMenuLdap @@ -78,7 +57,10 @@ postAdminLdapR = do { formAction = Just $ SomeRoute actionUrl , formEncoding = penctype } - + upsertForm = wrapForm uwidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = uenctype + } presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 9c4dec62d..d97f2e8e5 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -8,9 +8,10 @@ module Handler.Utils.Avs ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface - , setLicence, setLicenceAvs, setLicencesAvs + , setLicence, setLicenceAvs, setLicencesAvs, computeDifferingLicences , checkLicences , lookupAvsUser, lookupAvsUsers + , AvsException(..) ) where import Import @@ -25,7 +26,7 @@ import qualified Data.Map as Map import qualified Data.CaseInsensitive as CI -- import Auth.LDAP (ldapUserPrincipalName) -import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException()) +import Foundation.Yesod.Auth (ldapLookupAndUpsert, CampusUserConversionException()) import Handler.Utils.Company import Handler.Users.Add @@ -111,24 +112,35 @@ setLicenceAvs apid lic = do let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } setLicencesAvs req + --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => Set AvsPersonLicence -> m Bool -setLicencesAvs pls = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - response <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls - case response of - AvsResponseSetLicencesError{..} -> do - let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage - $logErrorS "AVS" msg - throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus +setLicencesAvs persLics = do + AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + aux aqsl True persLics + where + aux aqsl batch0_ok pls + | Set.null pls = return batch0_ok + | otherwise = do + let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls + response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1 + case response of + AvsResponseSetLicencesError{..} -> do + let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage + $logErrorS "AVS" msg + throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus + + AvsResponseSetLicences msgs -> do + let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs + ok_ids = Set.map avsResponsePersonID ok + bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient + batch1_ok = length ok == length batch1 + forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} -> + $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg + -- TODO: Admin Error page + aux aqsl (batch0_ok && batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) - AvsResponseSetLicences msgs -> do - let (ok,bad) = Set.partition (sloppyBool . avsResponseSuccess) msgs - forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} -> - $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg - -- TODO: Admin Error page - return $ length ok == length pls -- | Retrieve all currently valid driving licences and check against our database -- Only react to changes as compared to last seen status in avs.model @@ -216,20 +228,17 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do <> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1 <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2 - -upsertAvsUser :: Text -> Handler (Maybe UserId) +-- | Always update AVS Data +upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! -upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now - {- maybe this code helps? - upsRes :: Either CampusUserConversionException (Entity User) - <- try $ upsertCampusUserByOther persNo - case upsRes of - Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid - _other -> return mbuid -- ==Nothing -- user could not be created somehow - -} +upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail + try (runDB $ ldapLookupAndUpsert otherId) >>= \case + Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) + Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now + _ -> return Nothing --- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. +-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update. -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! upsertAvsUserByCard persNo = do @@ -241,11 +250,12 @@ upsertAvsUserByCard persNo = do case Set.elems adps of [] -> throwM AvsPersonSearchEmpty (_:_:_) -> throwM AvsPersonSearchAmbiguous - [AvsDataPerson{avsPersonPersonID=appi}] -> do - mbuid <- runDB $ getBy $ UniqueUserAvsId appi - case mbuid of - (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau - Nothing -> upsertAvsUserById appi + [AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update + -- do + -- mbuid <- runDB $ getBy $ UniqueUserAvsId api + -- case mbuid of + -- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau + -- Nothing -> upsertAvsUserById api @@ -259,13 +269,15 @@ upsertAvsUserById api = do case (mbuid, mbapd) of (Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do + $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] [] case candidates of - [uid] -> insertUniqueEntity $ UserAvs api uid + [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid) (_:_) -> throwM AvsUserAmbiguous [] -> do upsRes :: Either CampusUserConversionException (Entity User) - <- try $ upsertCampusUserByCn persNo + <- try $ ldapLookupAndUpsert persNo + $logInfoS "AVS" $ "No matching user found. attempted LDAP upsert returned: " <> tshow upsRes case upsRes of Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway _other -> return mbuid -- ==Nothing -- user could not be created somehow diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 9b20eaee7..0fddc70cf 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -86,8 +86,13 @@ newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: 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) + +mkAvsInternalPersonalNo :: Text -> AvsInternalPersonalNo +mkAvsInternalPersonalNo = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo + instance Canonical AvsInternalPersonalNo where canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn instance FromJSON AvsInternalPersonalNo where @@ -163,7 +168,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 $ AvsInternalPersonalNo c + = Just $ Right $ mkAvsInternalPersonalNo 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 e8eedbadb..8fa9a42b7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -788,6 +788,9 @@ partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) . mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v) mapFromSetM = (sequenceA .) . Map.fromSet +setToMap :: (Ord k) => (v -> k) -> Set v -> Map k v +setToMap mkKey = Map.fromList . fmap (\x -> (mkKey x, x)) . Set.toList + mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v) mapFM = sequenceA . mapF diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 3606bb2c0..7f1807b90 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -27,6 +27,8 @@ type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Po type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences +avsMaxSetLicenceAtOnce :: Int +avsMaxSetLicenceAtOnce = 99 -- maximum input set size for avsQuerySetLicences as enforced by AVS avsApi :: Proxy AVS avsApi = Proxy diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet index 227cc2e4d..a2b2a1533 100644 --- a/templates/ldap.hamlet +++ b/templates/ldap.hamlet @@ -22,3 +22,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later UTF8: #{presentUtf8 lv} — Latin: #{presentLatin1 lv} +
+

+ LDAP Upsert user in DB: + ^{upsertForm} + $maybe answer <- mbLdapUpsert +

+ Antwort: # +

+ #{tshow answer} diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index 80bd07ac2..d1a82bb09 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -15,8 +15,8 @@ instance Arbitrary SloppyBool where shrink (SloppyBool x) = SloppyBool <$> shrink x instance Arbitrary AvsInternalPersonalNo where - arbitrary = canonical . AvsInternalPersonalNo <$> arbitrary - shrink (AvsInternalPersonalNo x) = canonical . AvsInternalPersonalNo <$> shrink x + arbitrary = mkAvsInternalPersonalNo <$> arbitrary + shrink (AvsInternalPersonalNo x) = mkAvsInternalPersonalNo <$> shrink x instance Arbitrary AvsPersonId where arbitrary = AvsPersonId <$> arbitrary