From 8015775ce6100aca6793004c15044feb44adb9c2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 28 Nov 2022 15:21:39 +0100 Subject: [PATCH] refactor(avs): set licence chain types --- src/Handler/SAP.hs | 7 ++-- src/Handler/Utils/Avs.hs | 75 ++++++++++++++++++++-------------------- src/Jobs/Handler/LMS.hs | 11 +++--- 3 files changed, 47 insertions(+), 46 deletions(-) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 513070a82..543ef0a92 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -16,6 +16,7 @@ import Handler.Utils.Csv -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E @@ -69,12 +70,12 @@ sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value val getQualificationSAPDirectR :: Handler TypedContent getQualificationSAPDirectR = do qualUsers <- runDB $ Ex.select $ do - (qual Ex.:& qualUser Ex.:& user) <- + (qual :& qualUser :& user) <- Ex.from $ Ex.table @Qualification `Ex.innerJoin` Ex.table @QualificationUser - `Ex.on` (\(qual Ex.:& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification) + `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification) `Ex.innerJoin` Ex.table @User - `Ex.on` (\(_ Ex.:& qualUser Ex.:& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId) + `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId) Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId) Ex.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber) return diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index ecdf343c5..158b0a033 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -4,10 +4,6 @@ {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO: remove this line, once the module is completed -{-# OPTIONS_GHC -Wno-error=unused-local-binds #-} -- TODO: remove this line, once the module is completed -{-# OPTIONS_GHC -Wno-error=unused-matches #-} -- TODO: remove this line, once the module is completed - module Handler.Utils.Avs ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard @@ -34,10 +30,9 @@ import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException import Handler.Utils.Company import Handler.Users.Add -import Database.Esqueleto.Experimental ((:&)) +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E -import qualified Database.Esqueleto.PostgreSQL as E -------------------- @@ -90,51 +85,56 @@ getLicenceDB uid = do let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences return (avsLicenceRampLicence <$> ulicence) -setLicence :: UserId -> AvsLicence -> DB () + +-- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool +setLicence :: (PersistUniqueRead backend, MonadThrow m, + MonadHandler m, HandlerSite m ~ UniWorX, + BaseBackend backend ~ SqlBackend) => + UserId -> AvsLicence -> ReaderT backend m Bool setLicence uid lic = do Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid setLicenceAvs userAvsPersonId lic -setLicenceAvs :: AvsPersonId -> AvsLicence -> DB () +setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => + AvsPersonId -> AvsLicence -> m Bool setLicenceAvs apid lic = do let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } setLicencesAvs req --- setLicencesAvs :: Set AvsPersonLicence -> DB () +--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => - Set AvsPersonLicence -> m () + Set AvsPersonLicence -> m Bool setLicencesAvs pls = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - response <- throwLeftM . avsQuerySetLicences $ AvsQuerySetLicences pls + response <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls case response of AvsResponseSetLicencesError{..} -> do - let msg = "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage + let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage $logErrorS "AVS" msg throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus - AvsResponseSetLicences responses -> - forM_ responses $ \AvsLicenceResponse{..} -> - unless (sloppyBool avsResponseSuccess) $ do - -- TODO: create an Admin Problems overview page - $logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage + 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 --- TODO: turn into a job, once the interface is actually available -checkLicences :: Handler () +-- TODO: run in a background job, once the interface is actually available +checkLicences :: Handler Bool checkLicences = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - allLicences <- throwLeftM avsQueryGetAllLicences + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + allLicences <- throwLeftM avsQueryGetAllLicences deltaLicences <- computeDifferingLicences allLicences - setResponse <- throwLeftM $ avsQuerySetLicences deltaLicences - _ <- case setResponse of - AvsResponseSetLicencesError stat msg -> error "TODO!" - AvsResponseSetLicences msgs -> - let (ok,bad) = Set.partition (sloppyBool . avsResponseSuccess) msgs - in error "TODO!" - return () + setResponse <- setLicencesAvs deltaLicences + if setResponse + then $logInfoS "AVS" "FRADrive Licences written to AVS successfully." + else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete." + return setResponse -computeDifferingLicences :: AvsResponseGetLicences -> Handler AvsQuerySetLicences +computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) computeDifferingLicences (AvsResponseGetLicences licences) = do now <- liftIO getCurrentTime --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences @@ -150,10 +150,10 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId) antijoinAvsLicences lic avsLics = fmap unwrapIds $ E.select $ do - ((_qauli E.:& _qualUser E.:& usrAvs) E.:& excl) <- + ((_qauli :& _qualUser :& usrAvs) :& excl) <- E.from $ ( E.table @Qualification `E.innerJoin` E.table @QualificationUser - `E.on` ( \(quali E.:& qualUser) -> + `E.on` ( \(quali :& qualUser) -> (quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work! E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence @@ -162,9 +162,9 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- no blocked ) `E.innerJoin` E.table @UserAvs - `E.on` (\(_ E.:& qualUser E.:& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) + `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) ) `E.fullOuterJoin` E.toValues (set2NonEmpty noOne avsLics) -- left-hand side produces all currently valid matching qualifications - `E.on` (\((_ E.:& _ E.:& usrAvs) E.:& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl) + `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl) E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join return (usrAvs E.?. UserAvsPersonId, excl) @@ -179,7 +179,7 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do <$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld let setTo0 = vorfRevoke -- ready to use with SET 0 - setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke) + setTo1 = (vorfGrant \\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke) setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : @@ -202,10 +202,9 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld) -} - return $ AvsQuerySetLicences $ - Set.map (AvsPersonLicence AvsNoLicence) setTo0 - <> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1 - <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2 + return $ Set.map (AvsPersonLicence AvsNoLicence) setTo0 + <> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1 + <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2 upsertAvsUser :: Text -> Handler (Maybe UserId) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 073834cfa..f097c9cfd 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -17,6 +17,7 @@ import Import import Jobs.Queue -- import Jobs.Handler.Intervals.Utils +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E --import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant @@ -180,14 +181,14 @@ dispatchJobLmsResults qid = JobHandlerAtomic act -- otherwise there is nothing to do: we cannot renew s qualification without a specified validDuration -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)] results <- E.select $ do - (quser E.:& luser E.:& lresult) <- E.from $ + (quser :& luser :& lresult) <- E.from $ E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! `E.innerJoin` E.table @LmsUser - `E.on` (\(quser E.:& luser) -> + `E.on` (\(quser :& luser) -> luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) `E.innerJoin` E.table @LmsResult - `E.on` (\(_ E.:& luser E.:& lresult) -> + `E.on` (\(_ :& luser :& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid @@ -232,9 +233,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsUserlist)] results <- E.select $ do - (luser E.:& lulist) <- E.from $ + (luser :& lulist) <- E.from $ E.table @LmsUser `E.leftJoin` E.table @LmsUserlist - `E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent + `E.on` (\(luser :& 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