test(avs): add more encodings and test cases vor avs datatypes

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

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

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
 

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} ->