refactor(avs): set licence chain types
This commit is contained in:
Steffen Jost
parent
fc36161ff2
commit
8015775ce6
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user