fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(avs): fix parsing for avs admin status query interface

Browse Source
This commit is contained in:
Steffen Jost 2022-10-06 12:17:46 +02:00
parent 6b6c09b299
commit a90ae2653f
4 changed files with 51 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -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}
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}

2
src/Handler/Admin/Avs.hs
View File

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

8
src/Jobs/Handler/LMS.hs
View File

@ -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]

86
src/Model/Types/Avs.hs
View File

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