diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 6ee40f5c3..9581a9c19 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 28dc51cb5..ee1343c13 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 + diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1f710ae52..f2c483fd9 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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|] diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 48c111609..c29531094 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -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 --} \ No newline at end of file diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 6dd39d705..15b65b39a 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -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 + +