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

refactor(avs): account for 404 response instead of empty search results, more quickcheck tests

Browse Source
This commit is contained in:
Steffen Jost 2022-07-01 16:15:17 +02:00
parent 390b1424c9
commit 7a6ea92063
10 changed files with 157 additions and 137 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

@ -4,4 +4,4 @@ AvsLastName: Nachname
AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
AvsVersionNo: Versionsnummer
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
AvsStatusQueryInvalid t@Text: Nur numerische IDs eingeben, durch Komma! #{show t}
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma! #{show t}

2
messages/uniworx/categories/avs/en-eu.msg
View File

@ -4,4 +4,4 @@ AvsLastName: Last name
AvsInternalPersonalNo: Personnel number (Fraport AG only)
AvsVersionNo: Version number
AvsQueryEmpty: At least one query field must be filled!
AvsStatusQueryInvalid t: Numeric IDs only, comma seperated! #{show t}
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}

4
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -132,8 +132,8 @@ MenuLmsResult: Melden Ergebnisse E-Lernen
MenuLmsUpload: Hochladen
MenuLmsDirect: Direkter Upload
MenuAvs: Schnitstelle AVS
MenuApc: Schnitstelle Druckerei
MenuAvs: Schnittstelle AVS
MenuApc: Schnittstelle Druckerei
MenuApiDocs: API-Dokumentation (Englisch)
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

2
src/Application.hs
View File

@ -364,7 +364,7 @@ makeFoundation appSettings''@AppSettings{..} = do
{ basicAuthUsername = avsUser avsConf
, basicAuthPassword = avsPass avsConf
}
return . Just $ mkAvsQuery avsAuth avsEnv
return . Just $ mkAvsQuery avsServer avsAuth avsEnv
$logDebugS "Runtime configuration" $ tshow appSettings'

32
src/Handler/Admin/Apc.hs
View File

@ -27,18 +27,18 @@ data MetaPinRenewal = MetaPinRenewal
-}
{-
makePrintForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery
makeAvsPersonForm tmpl = identifyForm FIDAvsPersonQuery . validateForm validateAvsPersonQuery $ \html ->
flip (renderAForm FormStandard) html $ AvsPersonQuery
makePrintForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
flip (renderAForm FormStandard) html $ AvsQueryPerson
<$> aopt textField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl)
<*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl)
<*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl)
<*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl)
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
validateAvsPersonQuery :: FormValidator AvsPersonQuery Handler ()
validateAvsPersonQuery = do
AvsPersonQuery{..} <- State.get
validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
validateAvsQueryPerson = do
AvsQueryPerson{..} <- State.get
guardValidation MsgAvsQueryEmpty $
is _Just avsPersonQueryCardNo ||
is _Just avsPersonQueryFirstName ||
@ -46,23 +46,23 @@ validateAvsPersonQuery = do
is _Just avsPersonQueryInternalPersonalNo ||
is _Just avsPersonQueryVersionNo
makeAvsStatusForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery
makeAvsStatusForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html ->
makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
flip (renderAForm FormStandard) html $
parseAvsIds <$> areq textField (fslI MsgAvsCardNo) (unparseAvsIds <$> tmpl)
where
parseAvsIds :: Text -> AvsStatusQuery
parseAvsIds txt = AvsStatusQuery $ Set.fromList ids
parseAvsIds :: Text -> AvsQueryStatus
parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
where
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
ids = catMaybes $ readMay <$> nonemptys
unparseAvsIds :: AvsStatusQuery -> Text
unparseAvsIds (AvsStatusQuery ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
unparseAvsIds :: AvsQueryStatus -> Text
unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
validateAvsStatusQuery :: FormValidator AvsStatusQuery Handler ()
validateAvsStatusQuery = do
AvsStatusQuery ids <- State.get
guardValidation (MsgAvsStatusQueryInvalid $ tshow ids) $ not (null ids)
validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
validateAvsQueryStatus = do
AvsQueryStatus ids <- State.get
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
-}
getAdminApcR, postAdminApcR :: Handler Html
getAdminApcR = postAdminApcR

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

@ -14,18 +14,18 @@ import Handler.Utils
import Utils.Avs
makeAvsPersonForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery
makeAvsPersonForm tmpl = identifyForm FIDAvsPersonQuery . validateForm validateAvsPersonQuery $ \html ->
flip (renderAForm FormStandard) html $ AvsPersonQuery
makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
flip (renderAForm FormStandard) html $ AvsQueryPerson
<$> aopt textField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl)
<*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl)
<*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl)
<*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl)
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
validateAvsPersonQuery :: FormValidator AvsPersonQuery Handler ()
validateAvsPersonQuery = do
AvsPersonQuery{..} <- State.get
validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
validateAvsQueryPerson = do
AvsQueryPerson{..} <- State.get
guardValidation MsgAvsQueryEmpty $
is _Just avsPersonQueryCardNo ||
is _Just avsPersonQueryFirstName ||
@ -33,23 +33,23 @@ validateAvsPersonQuery = do
is _Just avsPersonQueryInternalPersonalNo ||
is _Just avsPersonQueryVersionNo
makeAvsStatusForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery
makeAvsStatusForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html ->
makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
flip (renderAForm FormStandard) html $
parseAvsIds <$> areq textField (fslI MsgAvsCardNo) (unparseAvsIds <$> tmpl)
where
parseAvsIds :: Text -> AvsStatusQuery
parseAvsIds txt = AvsStatusQuery $ Set.fromList ids
parseAvsIds :: Text -> AvsQueryStatus
parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
where
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
ids = catMaybes $ readMay <$> nonemptys
unparseAvsIds :: AvsStatusQuery -> Text
unparseAvsIds (AvsStatusQuery ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
unparseAvsIds :: AvsQueryStatus -> Text
unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
validateAvsStatusQuery :: FormValidator AvsStatusQuery Handler ()
validateAvsStatusQuery = do
AvsStatusQuery ids <- State.get
guardValidation (MsgAvsStatusQueryInvalid $ tshow ids) $ not (null ids)
validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
validateAvsQueryStatus = do
AvsQueryStatus ids <- State.get
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
getAdminAvsR, postAdminAvsR :: Handler Html
getAdminAvsR = postAdminAvsR

87
src/Utils/Avs.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE GADTs #-}
module Utils.Avs where
import Import.NoModel hiding ((.=))
@ -14,13 +12,12 @@ import Data.Aeson.Types
import Servant
import Servant.Client
-- import qualified Network.HTTP.Client as HTTP (newManager, defaultManagerSettings) -- just to speed up type checking
import Servant.Client.Core (requestPath)
-- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
-- Note that the type also works for optional Field
-- Note that the type also works for an optional field
-- Taken from Data.Aeson.Filthy, which could somehow not be added as a dependency.
(.:~) :: FromJSON a => Object -> Text -> Parser a
o .:~ key = o .: key <|> maybe empty parseJSON go
@ -41,10 +38,16 @@ instance ToJSON SloppyBool where
toJSON _ = "false"
instance FromJSON SloppyBool where
parseJSON (Bool b) = pure $ SloppyBool b
parseJSON (Bool b) = pure $ SloppyBool b
parseJSON (String t)
| Text.toLower t == "true" = pure $ SloppyBool True
parseJSON _ = pure $ SloppyBool False
| lowb == "true" = true
| lowb == "t" = true
| lowb == "f" = false
| lowb == "false" = false
where lowb = Text.toLower $ Text.strip t
true = pure $ SloppyBool True
false = pure $ SloppyBool False
parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid
type AvsPersonId = Int
@ -174,7 +177,7 @@ deriveJSON defaultOptions
-------------
-- Queries --
-------------
data AvsPersonQuery = AvsPersonQuery
data AvsQueryPerson = AvsQueryPerson
{ avsPersonQueryCardNo :: Maybe Text
, avsPersonQueryFirstName :: Maybe Text
, avsPersonQueryLastName :: Maybe Text
@ -183,18 +186,19 @@ data AvsPersonQuery = AvsPersonQuery
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Default AvsPersonQuery where
def = AvsPersonQuery Nothing Nothing Nothing Nothing Nothing
instance Default AvsQueryPerson where
def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing
deriveJSON defaultOptions
{ fieldLabelModifier = dropCamel 3
, omitNothingFields = True
, tagSingleConstructors = False
, rejectUnknownFields = False
} ''AvsPersonQuery
} ''AvsQueryPerson
newtype AvsStatusQuery = AvsStatusQuery (Set AvsPersonId)
deriveJSON defaultOptions ''AvsStatusQuery
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions ''AvsQueryStatus
@ -202,58 +206,45 @@ deriveJSON defaultOptions ''AvsStatusQuery
-- AVS API --
-------------
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus)
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsResponsePerson
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsResponseStatus
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
avsApi :: Proxy AVS
avsApi = Proxy
{- Somehow the GADT-style declaration is not flexible enough to compile at the location of the function call
{-
-- Somehow the GADT-style declaration is not flexible enough to compile at the location of the function call
data AvsQuery where
AvsQuery :: { avsQueryPerson :: MonadIO m => AvsPersonQuery -> m (Either ClientError AvsResponsePerson)
, avsQueryStatus :: MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus)
AvsQuery :: { avsQueryPerson :: MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
, avsQueryStatus :: MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
}
-> AvsQuery
-}
data AvsQuery = AvsQuery
{ avsQueryPerson :: forall m. MonadIO m => AvsPersonQuery -> m (Either ClientError AvsResponsePerson)
, avsQueryStatus :: forall m. MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus)
{ avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
}
makeLenses_ ''AvsQuery
mkAvsQuery :: BasicAuthData -> ClientEnv -> AvsQuery
mkAvsQuery basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
}
where
(rawQueryPerson :<|> rawQueryStatus) = 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
{-
-- DEMO to check that it types here instead of waiting for Application to be compiled
run :: IO ()
run = do
let (_avsPersonSearch :<|> avsPersonStatus) = client avsApi avsAuth
manager' <- HTTP.newManager HTTP.defaultManagerSettings
let query = avsPersonStatus $ AvsStatusQuery $ Set.singleton 123
res <- runClientM query (mkClientEnv manager' avsServer)
case res of
Left err -> putStrLn $ "Error: " ++ tshow err
--Right resp -> do
Right (AvsResponseStatus resp) -> do
print resp
where
avsServer :: BaseUrl
avsServer = BaseUrl
{ baseUrlScheme = Https
, baseUrlHost = "skytest.fra.fraport.de"
, baseUrlPort = 80
, baseUrlPath = ""
}
avsAuth = BasicAuthData "foo" "bar"
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
-}

4
src/Utils/Form.hs
View File

@ -295,8 +295,8 @@ data FormIdentifier
| FIDTestDownload
| FIDAllocationRegister
| FIDAllocationNotification
| FIDAvsPersonQuery
| FIDAvsStatusQuery
| FIDAvsQueryPerson
| FIDAvsQueryStatus
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where

22
test/Model/TypesSpec.hs
View File

@ -401,24 +401,6 @@ instance Arbitrary SheetAuthorshipStatementMode where
instance Arbitrary LmsStatus where
arbitrary = genericArbitrary
instance Arbitrary AvsDataCardColor where
arbitrary = genericArbitrary
instance Arbitrary AvsDataPersonCard where
arbitrary = genericArbitrary
instance Arbitrary AvsStatusPerson where
arbitrary = genericArbitrary
instance Arbitrary AvsDataPerson where
arbitrary = genericArbitrary
instance Arbitrary AvsResponsePerson where
arbitrary = genericArbitrary
instance Arbitrary AvsResponseStatus where
arbitrary = genericArbitrary
spec :: Spec
spec = do
@ -533,10 +515,6 @@ spec = do
[ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ]
lawsCheckHspec (Proxy @LmsStatus)
[ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
lawsCheckHspec (Proxy @AvsResponsePerson)
[ eqLaws, showLaws, showReadLaws, jsonLaws]
lawsCheckHspec (Proxy @AvsResponseStatus)
[ eqLaws, showLaws, showReadLaws, jsonLaws]
describe "TermIdentifier" $ do
it "has compatible encoding/decoding to/from Text" . property $

51
test/Utils/TypesSpec.hs Normal file
View File

@ -0,0 +1,51 @@
module Utils.TypesSpec where
import TestImport
import Utils.Avs
instance Arbitrary AvsDataCardColor where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary AvsDataPersonCard where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary AvsStatusPerson where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary AvsDataPerson where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary AvsResponsePerson where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary AvsResponseStatus where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary AvsQueryStatus where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary AvsQueryPerson where
arbitrary = genericArbitrary
shrink = genericShrink
spec :: Spec
spec = do
parallel $ do
lawsCheckHspec (Proxy @AvsResponsePerson)
[ eqLaws, showLaws, showReadLaws, jsonLaws]
lawsCheckHspec (Proxy @AvsResponseStatus)
[ eqLaws, showLaws, showReadLaws, jsonLaws]
lawsCheckHspec (Proxy @AvsQueryPerson)
[ eqLaws, showLaws, showReadLaws, jsonLaws]
lawsCheckHspec (Proxy @AvsQueryStatus)
[ eqLaws, showLaws, showReadLaws, jsonLaws]