diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b28adcacb..4e1ab4ad5 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + module Handler.Utils.Avs ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard , getLicence, getLicenceDB @@ -27,6 +29,10 @@ import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException import Handler.Utils.Company import Handler.Users.Add +--import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +--import qualified Database.Esqueleto.Utils as E + + -------------------- -- AVS Exceptions -- -------------------- @@ -84,7 +90,7 @@ setLicence uid lic = do setLicenceAvs :: AvsPersonId -> AvsLicence -> DB () setLicenceAvs apid lic = do - let req = Set.singleton $ AvsPersonLicence apid lic + let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } setLicencesAvs req -- setLicencesAvs :: Set AvsPersonLicence -> DB () @@ -95,7 +101,8 @@ setLicencesAvs pls = do response <- throwLeftM . avsQuerySetLicences $ AvsQuerySetLicences pls case response of AvsResponseSetLicencesError{..} -> do - $logErrorS "AVS" $ "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage + let msg = "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage + $logErrorS "AVS" msg throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus AvsResponseSetLicences responses -> forM_ responses $ \AvsLicenceResponse{..} -> @@ -109,8 +116,23 @@ setLicencesAvs pls = do -- TODO: turn into a job, once the interface is actually available checkLicences :: Handler () checkLicences = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponseGetLicences _licences <- throwLeftM avsQueryGetAllLicences + {- + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences + + --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences + -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld + let (noOrVorfeld, rollfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) licences + (_nolicence , vorfeld) = Set.spanAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) noOrVorfeld + now <- liftIO getCurrentTime + + + + runDB $ do + E.select $ do + -} + + --TODO this must be chunked into separate jobs/tasks --forM licences $ \AvsPersonLicence{..} -> do error "CONTINUE HERE" -- TODO STUB diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index b3a441dc0..f35ee6c96 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -164,8 +164,9 @@ discernAvsIds someid = aux someid | otherwise = Nothing aux _ = Right . AvsPersonId <$> readMay someid -- must always succeed at that point + data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld - deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable) + deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable, Finite, Universe) instance ToJSON AvsLicence where -- toJSON al = Number $ fromEnum AvsLicence -- would do, but... @@ -176,13 +177,26 @@ instance ToJSON AvsLicence where instance FromJSON AvsLicence where parseJSON (Number n) | n == 1 = pure AvsLicenceVorfeld -- ordered by occurrence, n==1 is most common case | n == 2 = pure AvsLicenceRollfeld - | n == 0 = pure AvsNoLicence -- n==0 never received from AVS, only sent to AVS + | n == 0 = pure AvsNoLicence -- n==0 never received from AVS, only sent to AVS #ifdef DEVELOPMENT parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid #else parseJSON _ = pure AvsNoLicence -- we simply ignore all other values #endif +-- we assume that the Ord-Instance is respected by the SQL Backend! +instance PersistField AvsLicence where + toPersistValue = PersistInt64 . fromIntegral . fromEnum + fromPersistValue (PersistInt64 v') + | let v = fromIntegral v' + , v >= fromEnum (minBound::AvsLicence) + , v <= fromEnum (maxBound::AvsLicence) + = Right $ toEnum v + fromPersistValue other = Left $ "Encoding of AvsLicence " <> tshow other <> " is out of range" + +instance PersistFieldSql AvsLicence where + sqlType _ = SqlInt64 + -- | Ought to be identical to QualificationShortname! licence2char :: AvsLicence -> Char licence2char AvsNoLicence = '0' @@ -352,8 +366,8 @@ deriveJSON defaultOptions -} data AvsPersonLicence = AvsPersonLicence - { avsLicencePersonID :: AvsPersonId - , avsLicenceRampLicence :: AvsLicence + { avsLicenceRampLicence :: AvsLicence + , avsLicencePersonID :: AvsPersonId } deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions @@ -363,6 +377,13 @@ deriveJSON defaultOptions , rejectUnknownFields = False } ''AvsPersonLicence +avsPersonLicenceIs :: AvsPersonLicence -> AvsLicence -> Bool +avsPersonLicenceIs = (==) . avsLicenceRampLicence + +avsPersonLicenceIsLEQ :: AvsPersonLicence -> AvsLicence -> Bool +avsPersonLicenceIsLEQ = (<=) . avsLicenceRampLicence + + data AvsLicenceResponse = AvsLicenceResponse { avsResponsePersonID :: AvsPersonId , avsResponseSuccess :: SloppyBool diff --git a/src/Utils.hs b/src/Utils.hs index 775304a4d..42c8d3b11 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -623,10 +623,7 @@ mTuple = liftA2 (,) -- Lists -- ----------- -<<<<<<< HEAD -======= -- avoids some parenthesis within guards ->>>>>>> master notNull :: MonoFoldable mono => mono -> Bool notNull = not . null diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index 4a8ec9579..dde67f33b 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -7,6 +7,9 @@ module Utils.TypesSpec where import TestImport import Utils +import qualified Data.Aeson as Aeson + + instance Arbitrary SloppyBool where arbitrary = SloppyBool <$> arbitrary shrink (SloppyBool x) = SloppyBool <$> shrink x @@ -95,6 +98,8 @@ spec = do [ eqLaws, ordLaws, showLaws, jsonLaws ] lawsCheckHspec (Proxy @AvsDataPerson) --iso failed [ eqLaws, ordLaws, showLaws, jsonLaws ] + lawsCheckHspec (Proxy @AvsLicence) + [ eqLaws, ordLaws, showLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @AvsPersonLicence) [ eqLaws, ordLaws, showLaws, jsonLaws ] lawsCheckHspec (Proxy @AvsLicenceResponse) @@ -116,6 +121,24 @@ spec = do lawsCheckHspec (Proxy @AvsQuerySetLicences) [ eqLaws, showLaws, jsonLaws] + describe "AvsLicence" $ do + it "ordering is consistent with its PersistField instance" . property $ -- this assumption is used in Handler.Utils.Avs.checkLicences + \a (b :: AvsLicence) -> compare a b == compare (toPersistValue a) (toPersistValue b) + it "assigns AvsLicence fixed SQL values" . example $ do -- ensure that DB encoding does not change unnoticed + toPersistValue AvsLicenceVorfeld `shouldBe` toPersistValue (1::Int64) + toPersistValue AvsLicenceRollfeld `shouldBe` toPersistValue (2::Int64) + it "assigns AvsLicence fixed JSON values" . example $ do -- ensure that SQL encoding does not change unnoticed + Aeson.toJSON AvsLicenceVorfeld `shouldBe` Aeson.Number 1 + Aeson.toJSON AvsLicenceRollfeld `shouldBe` Aeson.Number 2 + + describe "Ord AvsPersonLicence" $ do + it "proritises avsLicenceRampLicence" . property $ + \p0 p1@AvsPersonLicence{avsLicenceRampLicence=v1} -> + let p2@AvsPersonLicence{avsLicenceRampLicence=v2} = p0 in + (v1 /= v2) ==> compare p1 p2 == compare v1 v2 + it "has antitone Function avsPersonLicenceIsGEQ" . property $ -- this assumption is used in Handler.Utils.Avs.checkLicences + \j k l -> j < k ==> avsPersonLicenceIsLEQ j l >= avsPersonLicenceIsLEQ k l + describe "Ord AvsDataCard" $ do it "prioritises avsDataValid" . property $ \p0 p1@AvsDataPersonCard{avsDataValid=v1} ->