feat(avs): add SetRampDrivingLicence and InfoRampDrivingLicence to AVS interface

src/Model/Types/Avs.hs

@@ -8,7 +8,7 @@ module Model.Types.Avs
   ) where
 
 import Import.NoModel hiding ((.=))
---import Utils.Lens     hiding ((.=))
+import Utils.Lens.TH
 
 import qualified Data.Set           as Set
 import qualified Data.Text          as Text
@@ -34,7 +34,7 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go
 
 -- | `SloppyBool` successfully parses different variations of true/false
 newtype SloppyBool = SloppyBool { sloppyBool :: Bool }
-  deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
+  deriving (Bounded, Enum, Eq, Ord, Generic, Typeable)
 
 instance ToJSON SloppyBool where
     toJSON (SloppyBool True) = "true"
@@ -53,18 +53,34 @@ instance FromJSON SloppyBool where
     parseJSON invalid   = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid
 
 
-type AvsPersonId = Int
+-- AVS Datatypes
+type AvsPersonId = Int  -- Could be a newtype, but then toJSON/fromJSON might be a pain?
 
 
-type AvsLicence = Char 
+data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
-licenceVorfeld  :: AvsLicence
+  deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
-licenceVorfeld = 'F'
+
-licenceRollfeld :: AvsLicence
+instance ToJSON AvsLicence where
-licenceRollfeld = 'R'
+    toJSON AvsNoLicence       = Number 0
+    toJSON AvsLicenceVorfeld  = Number 1
+    toJSON AvsLicenceRollfeld = Number 2
+
+instance FromJSON AvsLicence where
+  parseJSON (Number n)  | n == 0 = pure AvsNoLicence
+                        | n == 1 = pure AvsLicenceVorfeld
+                        | n == 2 = pure AvsLicenceRollfeld
+  parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid
+
+-- | Ought to be identical to QualificationShortname!
+licence2char :: AvsLicence -> Char
+licence2char AvsNoLicence       = '0'
+licence2char AvsLicenceVorfeld  = 'F'
+licence2char AvsLicenceRollfeld = 'R'
 
 
 data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (NFData)
 
 instance ToJSON AvsDataCardColor where
   toJSON AvsCardColorGrün = "Grün"
@@ -82,6 +98,7 @@ instance FromJSON AvsDataCardColor where
     _      -> pure $ AvsCardColorMisc t
   parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid)
 
+
 data AvsDataPersonCard = AvsDataPersonCard
       { avsDataValid     :: Bool  -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
       , avsDataValidTo   :: Maybe Day   -- always Nothing if returned with AvsResponseStatus
@@ -96,6 +113,7 @@ data AvsDataPersonCard = AvsDataPersonCard
       , avsDataVersionNo :: Text
       }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (NFData)
 
 {- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec
 instance Ord AvsDataPersonCard where 
@@ -139,6 +157,10 @@ instance ToJSON AvsDataPersonCard where
     , "PostalCode"  .= avsDataPostalCode
     ]
 
+derivePersistFieldJSON ''AvsDataPersonCard
+makeLenses_ ''AvsDataPersonCard -- not possible here due to module import cycle
+
+
 data AvsStatusPerson = AvsStatusPerson
       { avsStatusPersonID         :: AvsPersonId
       , avsStatusPersonCardStatus :: Set AvsDataPersonCard
@@ -171,6 +193,19 @@ deriveJSON defaultOptions
   } ''AvsDataPerson
 
 
+data AvsDataLicence = AvsDataLicence
+      { avsLicencePersonId :: AvsPersonId
+      , avsLicenceLicence  :: AvsLicence      
+      }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { fieldLabelModifier = dropCamel 2
+  , omitNothingFields = True
+  , tagSingleConstructors = False
+  , rejectUnknownFields = False
+  } ''AvsDataLicence
+
+
 
 --------------
 -- Responses --
@@ -221,6 +256,11 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
 deriveJSON defaultOptions ''AvsQueryStatus
 
 
+newtype AvsGetLicences = AvsGetLicences (Set AvsDataLicence)
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions ''AvsGetLicences
+
+
 -----------------------
 -- Utility Functions --
 -----------------------
@@ -229,20 +269,21 @@ deriveJSON defaultOptions ''AvsQueryStatus
 --   first argument is a lower bound for avsDataValidTo, usually current day
 --   Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
 getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
-getValidLicence cutoff licence cards = Set.lookupMax validLicenceCards     
+getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards     
   where 
+    licence = licence2char licence'
     validLicenceCards = Set.filter cardMatch cards 
     cardMatch AvsDataPersonCard{..} =
       avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
 
-guessLicencseAddress :: Set AvsDataPersonCard -> Maybe Text
+guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
-guessLicencseAddress cards  
+guessLicenceAddress cards  
   | Just c <- Set.lookupMax cards
   , AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
   , Just street <- avsDataStreet
   , Just pcode  <- avsDataPostalCode
   , Just city   <- avsDataCity
-    = Just $ Text.unlines [street, Text.unwords [pcode, city]]
+    = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]])
   | otherwise = Nothing
 
 hasAddress :: AvsDataPersonCard -> Bool
@@ -264,6 +305,8 @@ pickLicenceAddress a b
   where 
     pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
     pickBetter' = pickBetter a b 
+    licenceRollfeld = licence2char AvsLicenceRollfeld
+    licenceVorfeld  = licence2char AvsLicenceVorfeld
  
 {- Note:
 For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this can be conveniently be used like so

src/Utils/Avs.hs

@@ -1,7 +1,7 @@
 module Utils.Avs where
 
-import Import.NoModel hiding ((.=))
+import Import.NoModel
-import Utils.Lens     hiding ((.=))
+import Utils.Lens
 
 import Servant
 import Servant.Client
@@ -13,9 +13,11 @@ import Model.Types.Avs
 -------------
 -- AVS API --
 -------------
-type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus)
+type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSSetRampLicence :<|> AVSGetRampLicences)
-type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
+type AVSPersonSearch    = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
-type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
+type AVSPersonStatus    = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
+type AVSSetRampLicence  = "SetRampDrivingLicence" :> ReqBody '[JSON] AvsDataLicence :> Post '[JSON] ()
+type AVSGetRampLicences = "InfoRampDrivingLicence" :> Post '[JSON] AvsGetLicences
 
 avsApi :: Proxy AVS
 avsApi = Proxy
@@ -30,20 +32,23 @@ data AvsQuery where
 -}
 
 data AvsQuery = AvsQuery
-  { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
+  { avsQueryPerson      :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
-  , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
+  , avsQueryStatus      :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
+  , avsQuerySetLicence  :: forall m. MonadIO m => AvsDataLicence -> m (Either ClientError ())
+  , avsQueryGetLicences :: forall m. MonadIO m =>                   m (Either ClientError AvsGetLicences)
   }
 
-
 makeLenses_ ''AvsQuery
 
 mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
 mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
-    { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
+    { avsQueryPerson      = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson     q) cliEnv
-    , avsQueryStatus = \q -> liftIO $                     runClientM (rawQueryStatus q) cliEnv
+    , avsQueryStatus      = \q -> liftIO $                     runClientM (rawQueryStatus     q) cliEnv
+    , avsQuerySetLicence  = \q -> liftIO $                     runClientM (rawQuerySetLicence q) cliEnv
+    , avsQueryGetLicences =       liftIO $                     runClientM  rawQueryGetLicences   cliEnv
     }
   where
-    (rawQueryPerson :<|> rawQueryStatus) = client avsApi basicAuth
+    (rawQueryPerson :<|> rawQueryStatus :<|> rawQuerySetLicence :<|> rawQueryGetLicences) = client avsApi basicAuth
     catch404toEmpty :: Either ClientError AvsResponsePerson -> Either ClientError AvsResponsePerson
     catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404)))
       | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
@@ -55,4 +60,5 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
     - add query to Auth.LDAP.campusUserMatr
     - add query to Auth.LDAP.campusLogin 
     - jobs.Handler.dispatchJobSynchroniseLdap
+
 -}