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

messages/uniworx/categories/avs/de-de-formal.msg

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

messages/uniworx/categories/avs/en-eu.msg

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

messages/uniworx/utils/navigation/menu/de-de-formal.msg

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

src/Application.hs

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

src/Handler/Admin/Apc.hs

@@ -27,18 +27,18 @@ data MetaPinRenewal = MetaPinRenewal
 
 -}      
 {-
-makePrintForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery
+makePrintForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
-makeAvsPersonForm tmpl = identifyForm FIDAvsPersonQuery . validateForm validateAvsPersonQuery $ \html -> 
+makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> 
-  flip (renderAForm FormStandard) html $ AvsPersonQuery 
+  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 ()
+validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
-validateAvsPersonQuery = do 
+validateAvsQueryPerson = do 
-  AvsPersonQuery{..} <- State.get
+  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 :: Maybe AvsQueryStatus -> Form AvsQueryStatus
-makeAvsStatusForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> 
+makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> 
   flip (renderAForm FormStandard) html $
      parseAvsIds <$> areq textField (fslI MsgAvsCardNo) (unparseAvsIds <$> tmpl)
   where 
-    parseAvsIds :: Text -> AvsStatusQuery
+    parseAvsIds :: Text -> AvsQueryStatus
-    parseAvsIds txt = AvsStatusQuery $ Set.fromList ids
+    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 :: AvsQueryStatus -> Text 
-    unparseAvsIds (AvsStatusQuery ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids 
+    unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids 
 
-validateAvsStatusQuery :: FormValidator AvsStatusQuery Handler ()
+validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
-validateAvsStatusQuery = do 
+validateAvsQueryStatus = do 
-  AvsStatusQuery ids <- State.get
+  AvsQueryStatus ids <- State.get
-  guardValidation (MsgAvsStatusQueryInvalid $ tshow ids) $ not (null ids)
+  guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 -}
 getAdminApcR, postAdminApcR :: Handler Html
 getAdminApcR = postAdminApcR

src/Handler/Admin/Avs.hs

@@ -14,18 +14,18 @@ import Handler.Utils
 import Utils.Avs
 
 
-makeAvsPersonForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery
+makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
-makeAvsPersonForm tmpl = identifyForm FIDAvsPersonQuery . validateForm validateAvsPersonQuery $ \html -> 
+makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> 
-  flip (renderAForm FormStandard) html $ AvsPersonQuery 
+  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 ()
+validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
-validateAvsPersonQuery = do 
+validateAvsQueryPerson = do 
-  AvsPersonQuery{..} <- State.get
+  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 :: Maybe AvsQueryStatus -> Form AvsQueryStatus
-makeAvsStatusForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> 
+makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> 
   flip (renderAForm FormStandard) html $
      parseAvsIds <$> areq textField (fslI MsgAvsCardNo) (unparseAvsIds <$> tmpl)
   where 
-    parseAvsIds :: Text -> AvsStatusQuery
+    parseAvsIds :: Text -> AvsQueryStatus
-    parseAvsIds txt = AvsStatusQuery $ Set.fromList ids
+    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 :: AvsQueryStatus -> Text 
-    unparseAvsIds (AvsStatusQuery ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids 
+    unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids 
 
-validateAvsStatusQuery :: FormValidator AvsStatusQuery Handler ()
+validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
-validateAvsStatusQuery = do 
+validateAvsQueryStatus = do 
-  AvsStatusQuery ids <- State.get
+  AvsQueryStatus ids <- State.get
-  guardValidation (MsgAvsStatusQueryInvalid $ tshow ids) $ not (null ids)
+  guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 
 getAdminAvsR, postAdminAvsR :: Handler Html
 getAdminAvsR = postAdminAvsR

src/Utils/Avs.hs

@@ -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 Servant.Client.Core (requestPath)
--- import qualified Network.HTTP.Client as HTTP (newManager, defaultManagerSettings) -- just to speed up type checking
 
 
 
 -- | 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    
+        | lowb == "true"  = true
-    parseJSON _                 = pure $ SloppyBool False
+        | 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 
+instance Default AvsQueryPerson where
-  def = AvsPersonQuery Nothing Nothing Nothing Nothing Nothing
+  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)
+newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
-deriveJSON defaultOptions ''AvsStatusQuery 
+  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 AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
-type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsResponseStatus
+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)
+  AvsQuery :: { avsQueryPerson :: MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
-              , avsQueryStatus :: MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus)
+              , avsQueryStatus :: MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
               }
       -> AvsQuery
 -}
 
 data AvsQuery = AvsQuery
-  { avsQueryPerson :: forall m. MonadIO m => AvsPersonQuery -> m (Either ClientError AvsResponsePerson)
+  { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
-  , avsQueryStatus :: forall m. MonadIO m => AvsStatusQuery -> m (Either ClientError AvsResponseStatus)
+  , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
   }
 
 
 makeLenses_ ''AvsQuery
 
-mkAvsQuery :: BasicAuthData -> ClientEnv -> AvsQuery
+mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
-mkAvsQuery basicAuth cliEnv = AvsQuery
+mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
-    { avsQueryPerson = \q -> liftIO $ 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
     }
   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
+  TODOs    
-run :: IO ()
+    Connect AVS query to LDAP queries for automatic synchronisation:
-run = do
+    - add query to Auth.LDAP.campusUserMatr
-  let (_avsPersonSearch :<|> avsPersonStatus) = client avsApi avsAuth
+    - add query to Auth.LDAP.campusLogin 
-  manager' <- HTTP.newManager HTTP.defaultManagerSettings
+    - jobs.Handler.dispatchJobSynchroniseLdap
-  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"
 -}

src/Utils/Form.hs

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

test/Model/TypesSpec.hs

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

test/Utils/TypesSpec.hs

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