From a90ae2653fea470b7bdf081cbba184b038b1b1af Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 6 Oct 2022 12:17:46 +0200 Subject: [PATCH] chore(avs): fix parsing for avs admin status query interface --- .../uniworx/categories/avs/de-de-formal.msg | 2 +- src/Handler/Admin/Avs.hs | 2 +- src/Jobs/Handler/LMS.hs | 8 +- src/Model/Types/Avs.hs | 86 ++++++++++--------- 4 files changed, 51 insertions(+), 47 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index e01d1a517..e58d26931 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -6,4 +6,4 @@ AvsLastName: Nachname AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsVersionNo: Versionsnummer AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! -AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma! #{show t} \ No newline at end of file +AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} \ No newline at end of file diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 9581a9c19..27bec473b 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -39,7 +39,7 @@ makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> flip (renderAForm FormStandard) html $ parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) - where + where parseAvsIds :: Text -> AvsQueryStatus parseAvsIds txt = AvsQueryStatus $ Set.fromList ids where diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index a97ef7a72..2c576dac0 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -52,7 +52,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act act = do quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali - $logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort + $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort now <- liftIO getCurrentTime case qualificationRefreshWithin quali of Nothing -> return () -- no automatic scheduling for this qid @@ -129,7 +129,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act act = do quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali - $logInfoS "lms" $ "Processing e-learning results for qualification " <> qshort + $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort now <- liftIO getCurrentTime -- TODO: notify expired used -- let nowaday = utctDay now @@ -143,7 +143,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act Nothing -> return () -- no automatic removal (Just auditDuration) -> do let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now - $logInfoS "lms" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration + $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration delusersVals <- E.select $ do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid @@ -159,7 +159,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act let delusers = E.unValue <$> delusersVals numdel = length delusers when (numdel > 0) $ do - $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort + $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index c29531094..eec74e533 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -72,20 +72,12 @@ instance FromJSON SloppyBool where parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid --- AVS Datatypes -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 - +------------------- +-- AVS Datatypes -- +------------------- newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, 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 @@ -94,6 +86,34 @@ instance FromJSON AvsCardNo where instance ToJSON AvsCardNo where toJSON (AvsCardNo cno) = toJSON cno +-- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId` +newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int + deriving (Eq, Ord, Generic, Typeable) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) +instance E.SqlString AvsPersonId +-- As opposed to AvsObjPersonId, 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 +-- Cannot tell difference between AvsPersonId and Int through Show and Read. A good or a bad idea? +instance Show AvsPersonId where + show = show . avsPersonId +instance Read AvsPersonId where + readPrec = fmap AvsPersonId readPrec + + +newtype AvsObjPersonId = AvsObjPersonId -- tagged object + { avsObjPersonID :: AvsPersonId + } + deriving (Eq, Ord, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = dropCamel 2 + , omitNothingFields = True + , tagSingleConstructors = False + , rejectUnknownFields = False + } ''AvsObjPersonId + data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable) @@ -151,7 +171,7 @@ data AvsDataPersonCard = AvsDataPersonCard , avsDataCardNo :: AvsCardNo -- always 8 digits , avsDataVersionNo :: Text } - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriving anyclass (NFData) {- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec @@ -214,30 +234,14 @@ instance ToJSON AvsDataPersonCard where , "CardNo" .= avsDataCardNo , "VersionNo" .= avsDataVersionNo ] - derivePersistFieldJSON ''AvsDataPersonCard - --- 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 , avsStatusPersonCardStatus :: Set AvsDataPersonCard -- only delivers non-Maybe fields, all Maybe-fields are Nothing } - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = \case { "avsStatusPersonCardStatus" -> "personCardStatus"; others -> dropCamel 2 others } @@ -254,7 +258,7 @@ data AvsDataPerson = AvsDataPerson , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! , avsPersonPersonCards :: Set AvsDataPersonCard } - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) makeLenses_ ''AvsDataPerson @@ -297,7 +301,7 @@ data AvsPersonLicence = AvsPersonLicence , avsLicenceRampLicence :: AvsLicence -- Schnittstelle unklar: RampDrivingLicence oder RampLicence --, avsLicenceRampDrivingLicence :: AvsLicence } - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -310,7 +314,7 @@ data AvsLicenceResponse = AvsLicenceResponse , avsResponseSuccess :: SloppyBool , avsResponseMessage :: Text } - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -324,7 +328,7 @@ deriveJSON defaultOptions --------------- newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -333,7 +337,7 @@ deriveJSON defaultOptions } ''AvsResponseStatus newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -342,7 +346,7 @@ deriveJSON defaultOptions } ''AvsResponsePerson newtype AvsResponseGetLicences = AvsResponseGetLicences (Set AvsPersonLicence) - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -351,7 +355,7 @@ deriveJSON defaultOptions } ''AvsResponseGetLicences newtype AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse) - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -370,7 +374,7 @@ data AvsQueryPerson = AvsQueryPerson , avsPersonQueryInternalPersonalNo :: Maybe Text , avsPersonQueryVersionNo :: Maybe Text } - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) instance Default AvsQueryPerson where def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing @@ -383,13 +387,13 @@ deriveJSON defaultOptions } ''AvsQueryPerson newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions ''AvsQueryStatus newtype AvsQueryGetLicences = AvsQueryGetLicences (Set AvsObjPersonId) - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions ''AvsQueryGetLicences newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence) - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions ''AvsQuerySetLicences