chore(avs): adjust to newly refined VSM specifications (DONE)

src/Handler/Utils/Avs.hs

@@ -7,7 +7,7 @@ module Handler.Utils.Avs
   , getLicence, getLicenceDB
   , setLicence, setLicenceAvs, setLicencesAvs
   , checkLicences
-  , lookupAvsUser, lookupAvsUsers  
+  , lookupAvsUser, lookupAvsUsers
   ) where
 
 import Import
@@ -32,13 +32,13 @@ import Handler.Users.Add
 --------------------
 
 data AvsException
-  = AvsInterfaceUnavailable             -- Interface to AVS was not configured at startup or does not respond
+  = AvsInterfaceUnavailable                   -- Interface to AVS was not configured at startup or does not respond
-  | AvsUserUnassociated UserId          -- Manipulating AVS Data for a user that is not linked to AVS yet
+  | AvsUserUnassociated UserId                -- Manipulating AVS Data for a user that is not linked to AVS yet
-  | AvsUserUnknownByAvs AvsPersonId     -- AvsPersionId not (or no longer) found in AVS DB
+  | AvsUserUnknownByAvs AvsPersonId           -- AvsPersionId not (or no longer) found in AVS DB
-  | AvsUserAmbiguous                    -- Multiple matching existing users found in our DB
+  | AvsUserAmbiguous                          -- Multiple matching existing users found in our DB
-  | AvsPersonSearchEmpty                -- AvsPersonSearch returned empty result 
+  | AvsPersonSearchEmpty                      -- AvsPersonSearch returned empty result
-  | AvsPersonSearchAmbiguous            -- AvsPersonSearch returned more than one result 
+  | AvsPersonSearchAmbiguous                  -- AvsPersonSearch returned more than one result
-  
+  | AvsSetLicencesFailed Text                 -- AvsSetLicence total failure
   deriving (Show, Generic, Typeable)
 instance Exception AvsException
 
@@ -92,11 +92,16 @@ setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
                   Set AvsPersonLicence -> m ()
 setLicencesAvs pls = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  AvsResponseSetLicences responses <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls
+  response <- throwLeftM . avsQuerySetLicences $ AvsQuerySetLicences pls
-  forM_ responses $ \AvsLicenceResponse{..} ->
+  case response of
-    unless (sloppyBool avsResponseSuccess) $ 
+    AvsResponseSetLicencesError{..} -> do
-      -- TODO: create an Admin Problems overview page
+      $logErrorS "AVS" $ "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage
-      $logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage
+      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
 
 
 -- | Retrieve all currently valid driving licences and check against our database
@@ -123,21 +128,21 @@ upsertAvsUser _someid = error "TODO" -- TODO STUB
 -- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created.
 --   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
 upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
-upsertAvsUserById api = do  
+upsertAvsUserById api = do
   mbapd <- lookupAvsUser api
-  mbuid <- runDB $ do 
+  mbuid <- runDB $ do
     mbuid <- getBy (UniqueUserAvsId api)
     case (mbuid, mbapd) of
       (Nothing, Just AvsDataPerson{..})                         -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
-        | Just persNo <- avsPersonInternalPersonalNo -> do 
+        | Just persNo <- avsPersonInternalPersonalNo -> do
             candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] []
             case candidates of
               [uid] -> insertUniqueEntity $ UserAvs api uid
               (_:_) -> throwM AvsUserAmbiguous
               [] -> do
-                upsRes :: Either CampusUserConversionException (Entity User) 
+                upsRes :: Either CampusUserConversionException (Entity User)
                   <- try $ upsertCampusUserByCn persNo
-                case upsRes of 
+                case upsRes of
                   Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
                   _other -> return mbuid -- ==Nothing -- user could not be created somehow
       _other -> return mbuid
@@ -148,14 +153,14 @@ upsertAvsUserById api = do
           mbCompany   = firmAddress ^? _Just . _1 . _Just
           bestCard    = Set.lookupMax avsPersonPersonCards
           fakeIdent   = CI.mk $ tshow api
-          newUsr = AdminUserForm 
+          newUsr = AdminUserForm
             { aufTitle     = Nothing
             , aufFirstName = avsPersonFirstName
             , aufSurname   = avsPersonLastName
             , aufDisplayName = avsPersonFirstName <> " " <> avsPersonLastName
             , aufDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
             , aufMatriculation = Nothing
-            , aufSex = Nothing 
+            , aufSex = Nothing
             , aufMobile = Nothing
             , aufTelephone = Nothing
             , aufFPersonalNumber = avsPersonInternalPersonalNo
@@ -168,62 +173,62 @@ upsertAvsUserById api = do
             , aufAuth  = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
             }
       mbUid <- addNewUser newUsr -- trigger JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
-      case (mbCompany, mbUid) of 
+      case (mbCompany, mbUid) of
-        (Just cpy, Just uid) -> runDB $ do 
+        (Just cpy, Just uid) -> runDB $ do
             cid <- upsertCompany cpy
             insert_ $ UserCompany cid uid False
         _ -> return ()
-                  
+
 
           -- _newAvs = UserAvs avsPersonPersonID uid
-          -- _newAvsCards = UserAvsCard 
+          -- _newAvsCards = UserAvsCard
-      error "TODO" -- CONTINUE HERE    
+      error "TODO" -- CONTINUE HERE
-    (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates 
+    (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates
       error "TODO" -- CONTINUE HERE
 
 
--- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. 
+-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible.
 --   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
---upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+--upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
 -- upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m )
-upsertAvsUserByCard :: 
+upsertAvsUserByCard ::
   Either (AvsCardNo,AvsVersionNo) AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
 upsertAvsUserByCard persNo = do
-  let qry = case persNo of 
+  let qry = case persNo of
               Left (acn,avn) -> def{ avsPersonQueryCardNo = Just acn, avsPersonQueryVersionNo = Just avn }
               Right fpn      -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
   AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
-  case Set.elems adps of 
+  case Set.elems adps of
     []      -> throwM AvsPersonSearchEmpty
-    (_:_:_) -> throwM AvsPersonSearchAmbiguous 
+    (_:_:_) -> throwM AvsPersonSearchAmbiguous
-    [AvsDataPerson{avsPersonPersonID=appi}] -> do 
+    [AvsDataPerson{avsPersonPersonID=appi}] -> do
       mbuid <- runDB $ getBy $ UniqueUserAvsId appi
-      case mbuid of 
+      case mbuid of
         (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
         Nothing -> upsertAvsUserById appi
 
 
 
-lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                   AvsPersonId -> m (Maybe AvsDataPerson)
 lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
 
 -- | retrieves complete avs user records for given AvsPersonIds.
---   Note that this requires several AVS-API queries, since 
+--   Note that this requires several AVS-API queries, since
 --    - avsQueryPerson does not support querying an AvsPersonId directly
 --    - avsQueryStatus only provides limited information
 --   avsQuery is used to obtain all card numbers, which are then queried separately an merged
 --   May throw Servant.ClientError or AvsExceptions
 --   Does not write to our own DB!
-lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                    Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
-lookupAvsUsers apis = do 
+lookupAvsUsers apis = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
   AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis
   let forFoldlM = $(permuteFun [3,2,1]) foldlM
-  forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> 
+  forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
     forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
       AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
       return $ mergeByPersonId adps acc2
-    
+

src/Model/Types/Avs.hs

@@ -331,17 +331,12 @@ data AvsLicenceResponse = AvsLicenceResponse
         , avsResponseSuccess  :: SloppyBool
         , avsResponseMessage  :: Text
         }
-      | AvsErrorResponse
-        { avsResponseStatus   :: Text
-        , avsResponseMessage  :: Text
-        }
     deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions
   { fieldLabelModifier = dropCamel 2
   , omitNothingFields = True
   , tagSingleConstructors = False
-  , rejectUnknownFields = False
+  , rejectUnknownFields = False  
-  , sumEncoding = UntaggedValue
   } ''AvsLicenceResponse
 
 
@@ -376,13 +371,18 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False
   } ''AvsResponseGetLicences
 
-newtype AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse)
+data AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse)
+                            | AvsResponseSetLicencesError
+                                { avsResponseSetLicencesStatus   :: Text
+                                , avsResponseSetLicencesMessage  :: Text
+                                }
   deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions
-  { fieldLabelModifier = dropCamel 2
+  { fieldLabelModifier = dropCamel 4
   , omitNothingFields = True
   , tagSingleConstructors = False
   , rejectUnknownFields = False
+  , sumEncoding = UntaggedValue
   } ''AvsResponseSetLicences