chore(avs): adjust avs interface to latest spec and improve upon

models/avs.model

@@ -3,12 +3,13 @@
 UserAvs
   personId        AvsPersonId -- unique identifier for user throughout avs
   user            UserId  
-  UniqueUserAvs user personId
+  UniqueUserAvsUser user
+  UniqueUserAvsId personId
   deriving Generic
 
 UserAvsCard 
   personId        AvsPersonId  
-  cardNo          Text 
+  cardNo          AvsCardNo
   card            AvsDataPersonCard
   lastSynch       UTCTime
   UniqueAvsCard cardNo

src/Handler/Utils/Avs.hs

@@ -1,6 +1,8 @@
 module Handler.Utils.Avs 
-  ( checkLicences
+  ( -- upsertAvsUser
-  , setLicence
+  --, checkLicences
+    getLicence, getLicenceDB
+  , setLicence, setLicenceAvs, setLicencesAvs
   ) where
 
 import Import
@@ -10,21 +12,85 @@ import Import
 
 import Utils.Avs
 
+import qualified Data.Set as Set
+
+
+--------------------
+-- AVS Exceptions --
+--------------------
+
+data AvsException
+  = AvsInterfaceUnavailable
+  | AvsUserUnknown UserId
+  deriving (Show, Generic, Typeable)
+instance Exception AvsException
+
+------------------
+-- AVS Handlers --
+------------------
+{-
+  TODOs
+    Connect AVS query to LDAP queries for automatic synchronisation:
+    - add query to Auth.LDAP.campusUserMatr
+    - add query to Auth.LDAP.campusLogin
+    - jobs.Handler.dispatchJobSynchroniseLdap
+
+-}
+
+
+ 
+-- Do we need this?
+getLicence :: UserId -> Handler (Maybe AvsLicence)
+getLicence uid = do 
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ runDB $ getBy $ UniqueUserAvsUser uid 
+  AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId
+  let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
+  return (avsLicenceRampLicence <$> ulicence)
+
+getLicenceDB :: UserId -> DB (Maybe AvsLicence)
+getLicenceDB uid = do 
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ getBy $ UniqueUserAvsUser uid 
+  AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId
+  let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
+  return (avsLicenceRampLicence <$> ulicence)
+
+
+setLicence :: UserId -> AvsLicence -> Handler ()
+setLicence uid lic = do 
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ runDB $ getBy $ UniqueUserAvsUser uid 
+  setLicenceAvs userAvsPersonId lic  
+
+setLicenceAvs :: AvsPersonId -> AvsLicence -> Handler ()
+setLicenceAvs apid lic = do 
+  let req = Set.singleton $ AvsPersonLicence apid lic
+  setLicencesAvs req 
+
+setLicencesAvs :: Set AvsPersonLicence -> Handler ()
+setLicencesAvs pls = do 
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+  AvsResponseSetLicences responses <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls
+  forM_ responses $ \AvsLicenceResponse{} ->
+    error "CONTINUE HERE" -- TODO STUB  
+
+{-
 -- | 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 ()
 checkLicences = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  AvsGetLicences _licences <- throwLeftM avsQueryGetLicences
+  AvsResponseGetLicences _licences <- throwLeftM avsQueryGetAllLicences
   --TODO this must be chunked into separate jobs/tasks
-  --forM licences $ \AvsDataLicence{..} -> do
+  --forM licences $ \AvsPersonLicence{..} -> do
   error "CONTINUE HERE" -- TODO STUB
+-}
 
--- Do we need this?
+{-
--- getLicence :: UserId -> Handler AvsLicence
+upsertAvsUser :: AvsStatusPerson -> 
 
---
+or 
-setLicence :: UserId -> AvsLicence -> Handler ()
+
-setLicence _uid _al = do 
+upsertAvsUser :: AvsPersonId -> 
-  error "CONTINUE HERE" -- TODO STUB
+-}

src/Model/Types/Avs.hs

@@ -8,8 +8,13 @@ module Model.Types.Avs
   ) where
 
 import Import.NoModel hiding ((.=))
+import Database.Persist.Sql 
+import qualified Database.Esqueleto.Experimental as E
+import qualified Data.Csv as Csv
 import Utils.Lens.TH
 
+import Text.Read (Read(..))
+
 import qualified Data.Set           as Set
 import qualified Data.Text          as Text
 import qualified Data.HashMap.Lazy  as HM
@@ -36,6 +41,14 @@ o .:?~ key = o .: key <|> maybe empty parseJSON go
 newtype SloppyBool = SloppyBool { sloppyBool :: Bool }
   deriving (Bounded, Enum, Eq, Ord, Generic, Typeable)
 
+-- Cannot tell difference between SloppyBool and Bool through Show and Read. A good or a bad idea?
+instance Show SloppyBool where 
+  show = show . sloppyBool
+
+instance Read SloppyBool where
+  readPrec = fmap SloppyBool readPrec
+  -- readsPrec n s = first SloppyBool <$> readsPrec n s
+
 instance ToJSON SloppyBool where
     toJSON (SloppyBool True) = "true"
     toJSON _                 = "false"
@@ -54,7 +67,26 @@ instance FromJSON SloppyBool where
 
 
 -- AVS Datatypes
-type AvsPersonId = Int  -- Could be a newtype, but then toJSON/fromJSON might be a pain?
+newtype AvsPersonId = AvsPersonId { avsPersonId :: Int }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
+instance E.SqlString AvsPersonId
+-- AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API
+instance FromJSON AvsPersonId where 
+  parseJSON x = AvsPersonId <$> parseJSON x
+instance ToJSON AvsPersonId where 
+  toJSON (AvsPersonId pid) = toJSON pid 
+
+newtype AvsCardNo = AvsCardNo { avsCardNo :: Text }  -- always 8 digits
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
+instance E.SqlString AvsCardNo 
+-- AvsCardNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
+instance FromJSON AvsCardNo where 
+  parseJSON x = AvsCardNo <$> parseJSON x
+instance ToJSON AvsCardNo where 
+  toJSON (AvsCardNo cno) = toJSON cno
+
 
 
 data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
@@ -110,7 +142,7 @@ data AvsDataPersonCard = AvsDataPersonCard
       , avsDataPostalCode:: Maybe Text  -- always Nothing if returned with AvsResponseStatus
       , avsDataCity      :: Maybe Text  -- always Nothing if returned with AvsResponseStatus
       , avsDataFirm      :: Maybe Text  -- always Nothing if returned with AvsResponseStatus       
-      , avsDataCardNo    :: Text  -- always 8 digits
+      , avsDataCardNo    :: AvsCardNo   -- always 8 digits
       , avsDataVersionNo :: Text
       }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -161,6 +193,19 @@ instance ToJSON AvsDataPersonCard where
 derivePersistFieldJSON ''AvsDataPersonCard
 makeLenses_ ''AvsDataPersonCard -- not possible here due to module import cycle
 
+-- The AVS API sometimes requests PersonIds as numbers and sometimes as objects.
+newtype AvsObjPersonId = AvsObjPersonId
+      { avsObjPersonID :: AvsPersonId      
+      }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = dropCamel 2
+  , omitNothingFields = True
+  , tagSingleConstructors = False
+  , rejectUnknownFields = False
+  } ''AvsObjPersonId
+
 
 data AvsStatusPerson = AvsStatusPerson
       { avsStatusPersonID         :: AvsPersonId
@@ -168,7 +213,6 @@ data AvsStatusPerson = AvsStatusPerson
       }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-
 deriveJSON defaultOptions
   { fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others }
   , omitNothingFields = True
@@ -194,9 +238,23 @@ deriveJSON defaultOptions
   } ''AvsDataPerson
 
 
-data AvsDataLicence = AvsDataLicence
+data AvsPersonLicence = AvsPersonLicence
-      { avsLicencePersonId :: AvsPersonId
+      { avsLicencePersonID     :: AvsPersonId
-      , avsLicenceLicence  :: AvsLicence      
+      , avsLicenceRampLicence  :: AvsLicence    -- Schnittstelle unklar: RampDrivingLicence oder RampLicence
+      --, avsLicenceRampDrivingLicence  :: AvsLicence   
+      }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { fieldLabelModifier = dropCamel 2
+  , omitNothingFields = True
+  , tagSingleConstructors = False
+  , rejectUnknownFields = False
+  } ''AvsPersonLicence
+
+data AvsLicenceResponse = AvsLicenceResponse
+      { avsResponsePersonID :: AvsPersonId  
+      , avsResponseSuccess  :: SloppyBool
+      , avsResponseMessage  :: Text    
       }
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions
@@ -204,8 +262,7 @@ deriveJSON defaultOptions
   , omitNothingFields = True
   , tagSingleConstructors = False
   , rejectUnknownFields = False
-  } ''AvsDataLicence
+  } ''AvsLicenceResponse
-
 
 
 --------------
@@ -230,6 +287,23 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False
   } ''AvsResponsePerson
 
+newtype AvsResponseGetLicences = AvsResponseGetLicences (Set AvsPersonLicence)
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { fieldLabelModifier = dropCamel 2
+  , omitNothingFields = True
+  , tagSingleConstructors = False
+  , rejectUnknownFields = False
+  } ''AvsResponseGetLicences
+
+newtype AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse)
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { fieldLabelModifier = dropCamel 2
+  , omitNothingFields = True
+  , tagSingleConstructors = False
+  , rejectUnknownFields = False
+  } ''AvsResponseSetLicences
 
 
 -------------
@@ -258,10 +332,13 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions ''AvsQueryStatus
 
-
+newtype AvsQueryGetLicences = AvsQueryGetLicences (Set AvsObjPersonId)
-newtype AvsGetLicences = AvsGetLicences (Set AvsDataLicence)
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
-deriveJSON defaultOptions ''AvsGetLicences
+deriveJSON defaultOptions ''AvsQueryGetLicences
+
+newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions ''AvsQuerySetLicences
 
 
 -----------------------

src/Model/Types/Lms.hs

@@ -9,7 +9,7 @@ module Model.Types.Lms
 
 import Import.NoModel
 import Database.Persist.Sql 
-import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Experimental as E
 import qualified Data.Csv as Csv
 import qualified Data.Time.Format as Time
 import Data.Time.Format.ISO8601 (iso8601ParseM)
@@ -18,7 +18,7 @@ import Utils.Lens.TH
 newtype LmsIdent = LmsIdent { getLmsIdent :: Text }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
-instance E.SqlString LmsIdent where
+instance E.SqlString LmsIdent 
 makeLenses_ ''LmsIdent
 
 deriveJSON defaultOptions

src/Utils/Avs.hs

@@ -3,6 +3,8 @@ module Utils.Avs where
 import Import.NoModel
 import Utils.Lens
 
+import qualified Data.Set as Set
+
 import Servant
 import Servant.Client
 import Servant.Client.Core (requestPath)
@@ -13,11 +15,12 @@ import Model.Types.Avs
 -------------
 -- AVS API --
 -------------
-type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSSetRampLicence :<|> AVSGetRampLicences)
+type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
 type AVSPersonSearch    = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
 type AVSPersonStatus    = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
-type AVSSetRampLicence  = "SetRampDrivingLicence" :> ReqBody '[JSON] AvsDataLicence :> Post '[JSON] ()
+type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
-type AVSGetRampLicences = "InfoRampDrivingLicence" :> Post '[JSON] AvsGetLicences
+type AVSSetRampLicences = "RampDrivingLicence"     :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
+
 
 avsApi :: Proxy AVS
 avsApi = Proxy
@@ -32,46 +35,29 @@ 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 ())
+  , avsQueryGetAllLicences :: forall m. MonadIO m =>                        m (Either ClientError AvsResponseGetLicences)
-  , avsQueryGetLicences :: forall m. MonadIO m =>                   m (Either ClientError AvsGetLicences)
+  , avsQueryGetLicences    :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences)
+  , avsQuerySetLicences    :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
   }
 
 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
+    , avsQueryGetAllLicences =    liftIO $                     runClientM (rawQueryGetLicences allPersonIds)  cliEnv
-    , avsQueryGetLicences =       liftIO $                     runClientM  rawQueryGetLicences   cliEnv
+    , avsQueryGetLicences = \q -> liftIO $                     runClientM (rawQueryGetLicences            q)  cliEnv
+    , avsQuerySetLicences = \q -> liftIO $                     runClientM (rawQuerySetLicences            q)  cliEnv
     }
   where
-    (rawQueryPerson :<|> rawQueryStatus :<|> rawQuerySetLicence :<|> rawQueryGetLicences) = client avsApi basicAuth
+    (rawQueryPerson :<|> rawQueryStatus :<|> rawQueryGetLicences :<|> rawQuerySetLicences) = 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!
     catch404toEmpty other = other
 
-
+    allPersonIds :: AvsQueryGetLicences
-
+    allPersonIds = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId 0
---------------------
--- AVS Exceptions --
---------------------
-
-data AvsException
-  = AvsInterfaceUnavailable
-  deriving (Show, Generic, Typeable)
-instance Exception AvsException
-
-
-
-{- 
-  TODOs    
-    Connect AVS query to LDAP queries for automatic synchronisation:
-    - add query to Auth.LDAP.campusUserMatr
-    - add query to Auth.LDAP.campusLogin 
-    - jobs.Handler.dispatchJobSynchroniseLdap
-
--}