chore(avs): connect avs form with server request

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

@@ -2,4 +2,5 @@ AvsCardNo: Ausweiskartennummer
 AvsFirstName: Vorname
 AvsLastName: Nachname
 AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
-AvsVersionNo: Versionsnummer
+AvsVersionNo: Versionsnummer
+AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!

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

@@ -2,4 +2,5 @@ AvsCardNo: Card number
 AvsFirstName: First name
 AvsLastName: Last name
 AvsInternalPersonalNo: Personnel number (Fraport AG only)
-AvsVersionNo: Version number 
+AvsVersionNo: Version number 
+AvsQueryEmpty: At least one query field must be filled!

src/Handler/Admin/Avs.hs

@@ -4,13 +4,16 @@ module Handler.Admin.Avs
   ) where
 
 import Import
+import qualified Control.Monad.State.Class as State
+-- import Data.Aeson (encode)
 
 import Handler.Utils
 import Handler.Utils.Servant.Avs
 
-makeAvsForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery
--- makeAvsForm tmpl = identifyForm FIDavsPersonQuery $ \html -> 
-makeAvsForm tmpl html = 
+
+
+makeAvsPersonForm :: Maybe AvsPersonQuery -> Form AvsPersonQuery
+makeAvsPersonForm tmpl = identifyForm FIDAvsPersonQuery . validateForm validateAvsPersonQuery $ \html -> 
   flip (renderAForm FormStandard) html $ AvsPersonQuery 
     <$> aopt textField (fslI MsgAvsCardNo)             (avsPersonQueryCardNo              <$> tmpl)
     <*> aopt textField (fslI MsgAvsFirstName)          (avsPersonQueryFirstName           <$> tmpl)
@@ -18,20 +21,55 @@ makeAvsForm tmpl html =
     <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo  <$> tmpl)
     <*> aopt textField (fslI MsgAvsVersionNo)          (avsPersonQueryVersionNo           <$> tmpl)
 
+validateAvsPersonQuery :: FormValidator AvsPersonQuery Handler ()
+validateAvsPersonQuery = do 
+  AvsPersonQuery{..} <- State.get
+  guardValidation MsgAvsQueryEmpty $
+    is _Just avsPersonQueryCardNo             ||
+    is _Just avsPersonQueryFirstName          ||
+    is _Just avsPersonQueryLastName           ||
+    is _Just avsPersonQueryInternalPersonalNo ||
+    is _Just avsPersonQueryVersionNo
+
+{-
+
+makeAvsForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery
+makeAvsForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> 
+  flip (renderAForm FormStandard) html $ AvsStatusQuery 
+    <$> 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
+  guardValidation MsgAvsQueryEmpty $
+    is _Just avsPersonQueryCardNo             ||
+    is _Just avsPersonQueryFirstName          ||
+    is _Just avsPersonQueryLastName           ||
+    is _Just avsPersonQueryInternalPersonalNo ||
+    is _Just avsPersonQueryVersionNo
+-}
+
+
 getAdminAvsR, postAdminAvsR :: Handler Html
 getAdminAvsR = postAdminAvsR
 postAdminAvsR = do 
-  ((result,widget), enctype) <- runFormPost $ makeAvsForm Nothing
-  let procForm _fr = do 
-        addMessage Success $ toHtml ("Form received but ignored for now. TODO."::Text)
-        -- TODO 
-        return $ Just ("TODO"::Text)
+  ((result,widget), enctype) <- runFormPost $ makeAvsPersonForm Nothing
+  let procForm fr = do 
+        res <- runAvsPersonSearch fr
+        case res of 
+          Left err -> return $ Just err 
+          Right jsn -> return $ Just $ tshow jsn         
   mbAnswer <- formResultMaybe result procForm
 
+  actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
   siteLayoutMsg MsgMenuAvs $ do
     setTitleI MsgMenuAvs
     let formWidget = wrapForm widget def 
-                      { formAction = Just $ SomeRoute AdminAvsR
+                      { formAction = Just $ SomeRoute actionUrl
                       , formEncoding = enctype
                       }
     -- TODO: use i18nWidgetFile instead if this is to become permanent

src/Handler/Utils/Servant/Avs.hs

@@ -6,12 +6,14 @@
 module Handler.Utils.Servant.Avs where
 
 import Import
-import Servant
+import Servant 
 import Servant.Client
 -- import Servant.API.Flatten -- requires package servant-flatten
 
 import qualified Network.HTTP.Client as HTTP (newManager, defaultManagerSettings) 
-    
+
+
+
 data AvsPersonQuery = AvsPersonQuery
         { avsPersonQueryCardNo             :: Maybe Text
         , avsPersonQueryFirstName          :: Maybe Text
@@ -52,6 +54,9 @@ type AVSRoute a = AVSAuth :> "FraVSMService" :> "v1" :> a
 type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsPersonQuery :> Post '[JSON] AvsPersonResponse
 type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsStatusQuery :> Post '[JSON] AvsStatusResponse
 
+avsApi :: Proxy AVS
+avsApi = Proxy
+
 {-
 -- Option 1:
 type AVS = AVSRoute (AVSPersonSearch :<|> AVSPersonStatus)
@@ -75,18 +80,30 @@ avsPersonStatus :: BasicAuthData -> AvsStatusQuery -> ClientM AvsStatusResponse
 (avsPersonSearch :<|> avsPersonStatus) = client avsApi
 
 
-avsApi :: Proxy AVS
-avsApi = Proxy
-
-avsServer :: BaseUrl
-avsServer = BaseUrl
-    { baseUrlScheme = Https
-    , baseUrlHost   = "skytest.fra.fraport.de"
-    , baseUrlPort   = 80
-    , baseUrlPath   = ""
-    }
+runAvsPersonSearch :: AvsPersonQuery -> Import.Handler (Either Text AvsPersonResponse)
+runAvsPersonSearch qry = do 
+  manager <- getsYesod $ view _appHttpManager 
+  mbAvsConf <- getsYesod $ view _appAvsConf
+  case mbAvsConf of 
+    Nothing -> return $ Left "appAvsConfig is empty, i.e. invalid AVS configuration settings."
+    Just avsConf -> do 
+      -- TODO: consider using Servant.Client.Core.parseBaseUrl within Settings already at Startup!
+      let avsServer = BaseUrl 
+                        { baseUrlScheme = Https
+                        , baseUrlHost = avsHost avsConf
+                        , baseUrlPort = avsPort avsConf
+                        , baseUrlPath = ""
+                        }
+          avsAuth = BasicAuthData
+                      { basicAuthUsername = avsUser avsConf
+                      , basicAuthPassword = avsPass avsConf
+                      }
+          avsClient = mkClientEnv manager avsServer
+          fullQuery = avsPersonSearch avsAuth qry
+      liftIO $ over _Left tshow <$> runClientM fullQuery avsClient
 
 
+-- DEMO to check that it types
 run :: IO ()
 run = do
   manager' <- HTTP.newManager HTTP.defaultManagerSettings
@@ -95,4 +112,12 @@ run = do
   case res of
     Left err -> putStrLn $ "Error: " ++ tshow err
     Right resp -> do
-      print resp
+      print resp
+  where 
+    avsServer :: BaseUrl
+    avsServer = BaseUrl
+      { baseUrlScheme = Https
+      , baseUrlHost   = "skytest.fra.fraport.de"
+      , baseUrlPort   = 80
+      , baseUrlPath   = ""
+      }

src/Utils.hs

@@ -868,6 +868,11 @@ whenIsRight (Left  _) _ = return ()
 throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a
 throwLeft = either throwM return
 
+{- Just a reminder for Steffen:
+mapLeft :: (a -> c) -> Either a b -> Either c b 
+mapLeft = over _Left 
+-}
+
 ---------------
 -- Exception --
 ---------------

src/Utils/Form.hs

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

templates/avs.hamlet

@@ -3,5 +3,6 @@
     Abfrage:
     ^{formWidget}
   $maybe answer <- mbAnswer
-    <p>Unverarbeitete Antwort:
+    <p>
+      Unverarbeitete Antwort: #
       #{answer}