fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into fradrive/api-avs

Browse Source
This commit is contained in:
Steffen Jost 2022-12-05 16:45:34 +01:00
commit a4716cb92f
16 changed files with 162 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CHANGELOG.md
View File

@ -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)

2
nix/docker/demo-version.json
View File

@ -1,3 +1,3 @@
{
"version": "26.6.3"
"version": "26.6.4"
}

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{
"version": "26.6.3"
"version": "26.6.4"
}

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "26.6.3",
"version": "26.6.4",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "26.6.3",
"version": "26.6.4",
"description": "",
"keywords": [],
"author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 26.6.3
version: 26.6.4
dependencies:
- base
- yesod

2
src/Auth/LDAP.hs
View File

@ -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 []))

24
src/Foundation/Yesod/Auth.hs
View File

@ -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

56
src/Handler/Admin/Avs.hs
View File

@ -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|<h2>Success:</h2> Licences sychronized.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{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|
<h2>Licence check differences:
<h3>Grant R:
<p>
#{r_grant}
<h3>Set to F:
<p>
#{f_set}
<h3>Revoke licence:
<p>
#{revoke}
|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
BtnSynchLicences -> do
res <- try checkLicences
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
mbQryLic <- formResultMaybe qryLicRes procFormQryLic
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute

70
src/Handler/Admin/Ldap.hs
View File

@ -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)

80
src/Handler/Utils/Avs.hs
View File

@ -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

7
src/Model/Types/Avs.hs
View File

@ -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

3
src/Utils.hs
View File

@ -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

2
src/Utils/Avs.hs
View File

@ -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

9
templates/ldap.hamlet
View File

@ -22,3 +22,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
UTF8: #{presentUtf8 lv}
&#8212;
Latin: #{presentLatin1 lv}
<section>
<p>
LDAP Upsert user in DB:
^{upsertForm}
$maybe answer <- mbLdapUpsert
<h1>
Antwort: #
<p>
#{tshow answer}

4
test/Utils/TypesSpec.hs
View File

@ -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