refactor(avs): set licence chain types

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 

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
+--   TODO: run in a background job, once the interface is actually available
-checkLicences :: Handler ()
+checkLicences :: Handler Bool
 checkLicences = do        
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery  
+  AvsQuery{..}  <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  allLicences <- throwLeftM avsQueryGetAllLicences  
+  allLicences   <- throwLeftM avsQueryGetAllLicences
   deltaLicences <- computeDifferingLicences allLicences
-  setResponse <- throwLeftM $ avsQuerySetLicences deltaLicences
+  setResponse   <- setLicencesAvs deltaLicences
-  _ <- case setResponse of 
+  if setResponse
-    AvsResponseSetLicencesError stat msg -> error "TODO!"
+    then $logInfoS "AVS" "FRADrive Licences written to AVS successfully."
-    AvsResponseSetLicences msgs -> 
+    else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete."
-      let (ok,bad) = Set.partition (sloppyBool . avsResponseSuccess) msgs
+  return setResponse
-      in error "TODO!"
-  return ()
 
-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 $
+  return $ Set.map (AvsPersonLicence AvsNoLicence)       setTo0
-       Set.map (AvsPersonLicence AvsNoLicence)       setTo0
+        <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  setTo1 
-    <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  setTo1 
+        <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2
-    <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2
 
 
 upsertAvsUser :: Text -> Handler (Maybe UserId)

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