chore(avs): work on avs person query complete
This commit is contained in:
Steffen Jost
parent
cf9184b72d
commit
32ca2a3280
@ -13,15 +13,17 @@ import Handler.Utils
|
||||
|
||||
import Utils.Avs
|
||||
|
||||
avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
|
||||
avsCardNoField = convertField AvsCardNo avsCardNo textField
|
||||
|
||||
makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
|
||||
makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
|
||||
flip (renderAForm FormStandard) html $ AvsQueryPerson
|
||||
<$> aopt textField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> 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)
|
||||
<$> aopt avsCardNoField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> 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
|
||||
|
||||
@ -4,6 +4,7 @@ module Handler.Utils.Avs
|
||||
getLicence, getLicenceDB
|
||||
, setLicence, setLicenceAvs, setLicencesAvs
|
||||
, checkLicences
|
||||
, lookupAvsUser, lookupAvsUsers
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -13,7 +14,10 @@ import Import
|
||||
|
||||
import Utils.Avs
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Text as Text
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
@ -104,29 +108,38 @@ or
|
||||
-}
|
||||
|
||||
{-
|
||||
upsertAvsUser :: AvsPersonId ->
|
||||
upsertAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
AvsPersonId -> m ()
|
||||
upsertAvsUser api = do
|
||||
mbuid <- getBy $ UniqueUserAvsId api
|
||||
case mbuid
|
||||
Nothing -> do -- unknown user
|
||||
|
||||
(Just uid) -> do -- known user
|
||||
mbapd <- lookupAvsUser api
|
||||
case (mbuid, mbapd) of
|
||||
( _ , Nothing) -> error "TODO" -- CONTINUE HERE -- this should no happen
|
||||
(Nothing, Just apd) -> do -- unknown user
|
||||
error "TODO" -- CONTINUE HERE
|
||||
(Just uid, Just apd) -> do -- known user
|
||||
error "TODO" -- CONTINUE HERE
|
||||
-}
|
||||
|
||||
{-
|
||||
-- lookupAvsUser :: AvsPersonId ->
|
||||
lookupAvsUser api = do
|
||||
|
||||
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
AvsPersonId -> m (Maybe AvsDataPerson)
|
||||
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
|
||||
|
||||
-- | retrieves complete avs user records for given AvsPersonIds.
|
||||
-- Note that this requires several AVS-API queries, since
|
||||
-- - avsQueryPerson does not support querying an AvsPersonId directly
|
||||
-- - avsQueryStatus only provides limited information
|
||||
-- avsQuery is used to obtain all card numbers, which are then queried separately an merged
|
||||
-- May throw Servant.ClientError or AvsExceptions
|
||||
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
|
||||
lookupAvsUsers apis = do
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
-- avsQueryPerson does not support querying an AvsPersonId directly,
|
||||
-- hence we need a preliminary avsQueryStatus to get all AvsCardNo.
|
||||
-- Note that avsQueryStatus only provides limited information
|
||||
AvsResponseStatus statuses <- throwLeftM $ avsQueryStatus $ AvsQueryStatus $ Set.singleton api
|
||||
_avsperson <- forM statuses $ \AvsStatusPerson{avsStatusPersonCardStatus} ->
|
||||
foldlM Map.empty avsStatusPersonCardStatus
|
||||
TODO TODO TODO
|
||||
forM avsStatusPersonCardStatus $ \AvsDataPersonCard{avsDataCardNo} ->
|
||||
AvsResponsePerson ps <- throwLeftM $ avsQueryPerson $ AvsQueryPerson def{avsPersonQueryCardNo = avsDataCardNo}
|
||||
return $ mergeByPersonId ps
|
||||
|
||||
-}
|
||||
|
||||
AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis
|
||||
let forFoldlM = $(permuteFun [3,2,1]) foldlM
|
||||
forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
|
||||
forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo} -> do
|
||||
AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo}
|
||||
return $ mergeByPersonId adps acc2
|
||||
|
||||
|
||||
@ -207,20 +207,20 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
-- result :: [(Entity LmsUser, Entity LmsUserlist)]
|
||||
results <- E.select $ do
|
||||
(luser E.:& lulist) <- E.from $
|
||||
E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
|
||||
`E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent
|
||||
E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
|
||||
E.table @LmsUser `E.fullOuterJoin` E.table @LmsUserlist
|
||||
`E.on` (\(luser E.:& lulist) -> luser E.?. LmsUserIdent E.==. lulist E.?. LmsUserlistIdent
|
||||
E.&&. luser E.?. LmsUserQualification E.==. lulist E.?. LmsUserlistQualification)
|
||||
E.where_ $ luser E.?. LmsUserQualification E.?=. E.val qid
|
||||
E.&&. E.isNothing (E.joinV (luser E.?. LmsUserEnded)) -- do not process closed learners
|
||||
return (luser, lulist)
|
||||
forM_ results $ \case
|
||||
(Entity luid luser, Nothing)
|
||||
forM_ results $ \case
|
||||
(Just (Entity luid luser), Nothing)
|
||||
| isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
|
||||
, isNothing $ lmsUserEnded luser ->
|
||||
update luid [LmsUserEnded =. Just now]
|
||||
| otherwise -> return () -- users likely not yet started
|
||||
|
||||
(Entity luid luser, Just (Entity lulid lulist)) -> do
|
||||
(Just (Entity luid luser), Just (Entity lulid lulist)) -> do
|
||||
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
|
||||
queueDBJob JobSendNotification
|
||||
{ jRecipient = lmsUserUser luser
|
||||
@ -237,4 +237,6 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
|
||||
updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))]
|
||||
delete lulid
|
||||
(_,_) -> return () -- TODO CONTINUE HERE
|
||||
-- PROBLEM: Orphans funktioniert so nicht wegen E.where_ Filter! Separate Query!
|
||||
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]
|
||||
|
||||
@ -16,7 +16,6 @@ import Utils.Lens.TH
|
||||
import Text.Read (Read(..))
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- import qualified Data.HashMap.Lazy as HM
|
||||
|
||||
@ -175,9 +174,9 @@ instance Canonical AvsDataPersonCard where
|
||||
, avsDataCity = null2nothing $ avsDataCity proto
|
||||
, avsDataFirm = null2nothing $ avsDataFirm proto
|
||||
}
|
||||
-}
|
||||
-}
|
||||
instance Canonical AvsDataPersonCard where
|
||||
canonical proto =
|
||||
canonical proto =
|
||||
proto & _avsDataStreet %~ null2nothing
|
||||
& _avsDataPostalCode %~ null2nothing
|
||||
& _avsDataCity %~ null2nothing
|
||||
@ -200,14 +199,14 @@ instance FromJSON AvsDataPersonCard where
|
||||
|
||||
instance ToJSON AvsDataPersonCard where
|
||||
toJSON AvsDataPersonCard{..} = object $
|
||||
catMaybes
|
||||
catMaybes
|
||||
[ ("ValidTo" .=) <$> avsDataValidTo
|
||||
, ("IssueDate" .=) <$> avsDataIssueDate
|
||||
, ("Street" .=) <$> (avsDataStreet & null2nothing)
|
||||
, ("PostalCode" .=) <$> (avsDataPostalCode & null2nothing)
|
||||
, ("City" .=) <$> (avsDataCity & null2nothing)
|
||||
, ("Firm" .=) <$> (avsDataFirm & null2nothing)
|
||||
]
|
||||
]
|
||||
<>
|
||||
[ "Valid" .= show avsDataValid
|
||||
, "CardColor" .= avsDataCardColor
|
||||
@ -259,12 +258,6 @@ data AvsDataPerson = AvsDataPerson
|
||||
|
||||
makeLenses_ ''AvsDataPerson
|
||||
|
||||
{-
|
||||
instance Canonical AvsDataPerson where
|
||||
canonical proto =
|
||||
proto & _avsPersonInternalPersonalNo %~ null2nothing
|
||||
& _avsPersonPersonCards %~ Set.map canonical
|
||||
-}
|
||||
instance Canonical AvsDataPerson where
|
||||
canonical = over _avsPersonInternalPersonalNo null2nothing
|
||||
. over _avsPersonPersonCards canonical
|
||||
@ -280,7 +273,7 @@ instance FromJSON AvsDataPerson where
|
||||
<*> v .: "personCards" -- starts with lower case letter!
|
||||
|
||||
instance ToJSON AvsDataPerson where
|
||||
toJSON AvsDataPerson{..} = object $
|
||||
toJSON AvsDataPerson{..} = object $
|
||||
catMaybes [ ("InternalPersonalNo" .=) <$> (avsPersonInternalPersonalNo & null2nothing) ]
|
||||
<>
|
||||
[ "FirstName" .= avsPersonFirstName
|
||||
@ -371,7 +364,7 @@ deriveJSON defaultOptions
|
||||
-- Queries --
|
||||
-------------
|
||||
data AvsQueryPerson = AvsQueryPerson
|
||||
{ avsPersonQueryCardNo :: Maybe Text
|
||||
{ avsPersonQueryCardNo :: Maybe AvsCardNo
|
||||
, avsPersonQueryFirstName :: Maybe Text
|
||||
, avsPersonQueryLastName :: Maybe Text
|
||||
, avsPersonQueryInternalPersonalNo :: Maybe Text
|
||||
@ -400,118 +393,3 @@ deriveJSON defaultOptions ''AvsQueryGetLicences
|
||||
newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions ''AvsQuerySetLicences
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Utility Functions --
|
||||
-----------------------
|
||||
|
||||
-- | retrieve AvsDataPersonCard with longest validity for a given licence,
|
||||
-- first argument is a lower bound for avsDataValidTo, usually current day
|
||||
-- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
|
||||
getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
|
||||
getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
|
||||
where
|
||||
licence = licence2char licence'
|
||||
validLicenceCards = Set.filter cardMatch cards
|
||||
cardMatch AvsDataPersonCard{..} =
|
||||
avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
|
||||
|
||||
guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
|
||||
guessLicenceAddress cards
|
||||
| Just c <- Set.lookupMax cards
|
||||
, AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
|
||||
, Just street <- avsDataStreet
|
||||
, Just pcode <- avsDataPostalCode
|
||||
, Just city <- avsDataCity
|
||||
= Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]])
|
||||
| otherwise = Nothing
|
||||
|
||||
hasAddress :: AvsDataPersonCard -> Bool
|
||||
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
|
||||
|
||||
pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
|
||||
pickLicenceAddress a b
|
||||
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address
|
||||
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards
|
||||
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
|
||||
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
|
||||
| avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
|
||||
| avsDataCardColor a < avsDataCardColor b = b
|
||||
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
|
||||
| avsDataIssueDate a < avsDataIssueDate b = b
|
||||
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
|
||||
| avsDataValidTo a < avsDataValidTo b = b
|
||||
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
|
||||
| a <= b = b -- respect natural Ord instance
|
||||
| otherwise = a
|
||||
where
|
||||
pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
|
||||
pickBetter' = pickBetter a b
|
||||
licenceRollfeld = licence2char AvsLicenceRollfeld
|
||||
licenceVorfeld = licence2char AvsLicenceVorfeld
|
||||
|
||||
{- Note:
|
||||
For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so
|
||||
bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
|
||||
compare a b = compareBy avsDataValid
|
||||
<> compareBy avsDataValidTo
|
||||
<> compareBy avsDataIssueDate
|
||||
...
|
||||
where
|
||||
compareBy f = compare `on` f a b
|
||||
-}
|
||||
|
||||
mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeAvsDataPerson = Map.unionWithKey merger
|
||||
where
|
||||
merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
|
||||
merger api pa pb =
|
||||
let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
|
||||
pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
|
||||
in AvsDataPerson
|
||||
{ avsPersonFirstName = pickBy' Text.length avsPersonFirstName
|
||||
, avsPersonLastName = pickBy' Text.length avsPersonLastName
|
||||
, avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
|
||||
, avsPersonPersonNo = pickBy' id avsPersonPersonNo
|
||||
, avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
|
||||
, avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
|
||||
}
|
||||
|
||||
pickBy :: Ord b => (a -> b) -> a -> a -> a
|
||||
pickBy f x y | f x >= f y = x
|
||||
| otherwise = y
|
||||
|
||||
catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
|
||||
|
||||
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeByPersonId = Set.foldr aux Map.empty
|
||||
where
|
||||
aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
|
||||
|
||||
{- Not general enough:
|
||||
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeByPersonId = Set.foldr aux Map.empty
|
||||
where
|
||||
aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
aux adp@AvsDataPerson{avsPersonPersonID} = Map.insertWithKey merger avsPersonPersonID adp
|
||||
|
||||
merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
|
||||
merger api pa pb =
|
||||
let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
|
||||
pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
|
||||
in AvsDataPerson
|
||||
{ avsPersonFirstName = pickBy' Text.length avsPersonFirstName
|
||||
, avsPersonLastName = pickBy' Text.length avsPersonLastName
|
||||
, avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
|
||||
, avsPersonPersonNo = pickBy' id avsPersonPersonNo
|
||||
, avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
|
||||
, avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
|
||||
}
|
||||
|
||||
pickBy :: Ord b => (a -> b) -> a -> a -> a
|
||||
pickBy f x y | f x >= f y = x
|
||||
| otherwise = y
|
||||
-}
|
||||
@ -3,7 +3,9 @@ module Utils.Avs where
|
||||
import Import.NoModel
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
@ -66,3 +68,93 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
|
||||
catch404toEmpty other = other
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Utility Functions --
|
||||
-----------------------
|
||||
|
||||
-- | retrieve AvsDataPersonCard with longest validity for a given licence,
|
||||
-- first argument is a lower bound for avsDataValidTo, usually current day
|
||||
-- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
|
||||
getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
|
||||
getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
|
||||
where
|
||||
licence = licence2char licence'
|
||||
validLicenceCards = Set.filter cardMatch cards
|
||||
cardMatch AvsDataPersonCard{..} =
|
||||
avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
|
||||
|
||||
guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
|
||||
guessLicenceAddress cards
|
||||
| Just c <- Set.lookupMax cards
|
||||
, AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
|
||||
, Just street <- avsDataStreet
|
||||
, Just pcode <- avsDataPostalCode
|
||||
, Just city <- avsDataCity
|
||||
= Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]])
|
||||
| otherwise = Nothing
|
||||
|
||||
hasAddress :: AvsDataPersonCard -> Bool
|
||||
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
|
||||
|
||||
pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
|
||||
pickLicenceAddress a b
|
||||
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address
|
||||
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards
|
||||
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
|
||||
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
|
||||
| avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
|
||||
| avsDataCardColor a < avsDataCardColor b = b
|
||||
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
|
||||
| avsDataIssueDate a < avsDataIssueDate b = b
|
||||
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
|
||||
| avsDataValidTo a < avsDataValidTo b = b
|
||||
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
|
||||
| a <= b = b -- respect natural Ord instance
|
||||
| otherwise = a
|
||||
where
|
||||
pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
|
||||
pickBetter' = pickBetter a b
|
||||
licenceRollfeld = licence2char AvsLicenceRollfeld
|
||||
licenceVorfeld = licence2char AvsLicenceVorfeld
|
||||
|
||||
{- Note:
|
||||
For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
|
||||
bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
|
||||
compare a b = compareBy avsDataValid
|
||||
<> compareBy avsDataValidTo
|
||||
<> compareBy avsDataIssueDate
|
||||
...
|
||||
where
|
||||
compareBy f = compare `on` f a b
|
||||
-}
|
||||
|
||||
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeByPersonId = flip $ Set.foldr aux
|
||||
where
|
||||
aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
|
||||
|
||||
catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
|
||||
|
||||
mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeAvsDataPerson = Map.unionWithKey merger
|
||||
where
|
||||
merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
|
||||
merger api pa pb =
|
||||
let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
|
||||
pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
|
||||
in AvsDataPerson
|
||||
{ avsPersonFirstName = pickBy' Text.length avsPersonFirstName
|
||||
, avsPersonLastName = pickBy' Text.length avsPersonLastName
|
||||
, avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
|
||||
, avsPersonPersonNo = pickBy' id avsPersonPersonNo
|
||||
, avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
|
||||
, avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
|
||||
}
|
||||
|
||||
pickBy :: Ord b => (a -> b) -> a -> a -> a
|
||||
pickBy f x y | f x >= f y = x
|
||||
| otherwise = y
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user