chore(avs): add person status query demo interface

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

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

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

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

src/Handler/Admin/Avs.hs

@@ -6,6 +6,8 @@ module Handler.Admin.Avs
 import Import
 import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
+import qualified Data.Text as Text
+import qualified Data.Set  as Set
 
 import Handler.Utils
 import Handler.Utils.Servant.Avs
@@ -31,46 +33,53 @@ validateAvsPersonQuery = do
     is _Just avsPersonQueryInternalPersonalNo ||
     is _Just avsPersonQueryVersionNo
 
-{-
+makeAvsStatusForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery
-
+makeAvsStatusForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> 
-makeAvsForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery
+  flip (renderAForm FormStandard) html $
-makeAvsForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> 
+     parseAvsIds <$> areq textField (fslI MsgAvsCardNo) (unparseAvsIds <$> tmpl)
-  flip (renderAForm FormStandard) html $ AvsStatusQuery 
+  where 
-    <$> aopt textField (fslI MsgAvsCardNo)             (avsPersonQueryCardNo              <$> tmpl)
+    parseAvsIds :: Text -> AvsStatusQuery
-    <*> aopt textField (fslI MsgAvsFirstName)          (avsPersonQueryFirstName           <$> tmpl)
+    parseAvsIds txt = AvsStatusQuery $ Set.fromList ids
-    <*> aopt textField (fslI MsgAvsLastName)           (avsPersonQueryLastName            <$> tmpl)
+      where 
-    <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo  <$> tmpl)
+        nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt 
-    <*> aopt textField (fslI MsgAvsVersionNo)          (avsPersonQueryVersionNo           <$> tmpl)
+        ids = catMaybes $ readMay <$> nonemptys
-
+    unparseAvsIds :: AvsStatusQuery -> Text 
-validateAvsPersonQuery :: FormValidator AvsPersonQuery Handler ()
+    unparseAvsIds (AvsStatusQuery ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids 
-validateAvsPersonQuery = do 
-  AvsPersonQuery{..} <- State.get
-  guardValidation MsgAvsQueryEmpty $
-    is _Just avsPersonQueryCardNo             ||
-    is _Just avsPersonQueryFirstName          ||
-    is _Just avsPersonQueryLastName           ||
-    is _Just avsPersonQueryInternalPersonalNo ||
-    is _Just avsPersonQueryVersionNo
--}
 
+validateAvsStatusQuery :: FormValidator AvsStatusQuery Handler ()
+validateAvsStatusQuery = do 
+  AvsStatusQuery ids <- State.get
+  guardValidation (MsgAvsStatusQueryInvalid $ tshow ids) $ not (null ids)
 
 getAdminAvsR, postAdminAvsR :: Handler Html
 getAdminAvsR = postAdminAvsR
 postAdminAvsR = do 
-  ((result,widget), enctype) <- runFormPost $ makeAvsPersonForm Nothing
+  ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
-  let procForm fr = do 
+  let procFormPerson fr = do 
         res <- runAvsPersonSearch fr
         case res of 
           Left err -> return $ Just err 
           Right jsn -> return $ Just $ tshow jsn         
-  mbAnswer <- formResultMaybe result procForm
+  mbPerson <- formResultMaybe presult procFormPerson
+
+  ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
+  let procFormStatus fr = do 
+        res <- runAvsStatusSearch fr
+        case res of 
+          Left err -> return $ Just err 
+          Right jsn -> return $ Just $ tshow jsn         
+  mbStatus <- formResultMaybe sresult procFormStatus
 
   actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
   siteLayoutMsg MsgMenuAvs $ do
     setTitleI MsgMenuAvs
-    let formWidget = wrapForm widget def 
+    let personForm = wrapForm pwidget def 
                       { formAction = Just $ SomeRoute actionUrl
-                      , formEncoding = enctype
+                      , formEncoding = penctype
+                      }
+        statusForm = wrapForm swidget def 
+                      { formAction = Just $ SomeRoute actionUrl
+                      , formEncoding = senctype
                       }
     -- TODO: use i18nWidgetFile instead if this is to become permanent
     $(widgetFile "avs")  

src/Handler/Utils/Servant/Avs.hs

@@ -38,7 +38,7 @@ deriveJSON defaultOptions
 -} 
 
  -- data StatusQuery = StatusQuery
-newtype AvsStatusQuery = AvsStatusQuery (Set UserMatriculation)
+newtype AvsStatusQuery = AvsStatusQuery (Set Int)
 deriveJSON defaultOptions ''AvsStatusQuery 
 
 type AvsPersonResponse = Value 
@@ -102,6 +102,27 @@ runAvsPersonSearch qry = do
           fullQuery = avsPersonSearch avsAuth qry
       liftIO $ over _Left tshow <$> runClientM fullQuery avsClient
 
+runAvsStatusSearch :: AvsStatusQuery -> Import.Handler (Either Text AvsStatusResponse)
+runAvsStatusSearch 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 = avsPersonStatus avsAuth qry
+      liftIO $ over _Left tshow <$> runClientM fullQuery avsClient
 
 -- DEMO to check that it types
 run :: IO ()

templates/avs.hamlet

@@ -1,8 +1,17 @@
 <section>
   <p> 
-    Abfrage:
+    Person Search:
-    ^{formWidget}
+    ^{personForm}
-  $maybe answer <- mbAnswer
+  $maybe answer <- mbPerson
     <p>
       Unverarbeitete Antwort: #
       #{answer}
+
+<section>
+  <p> 
+    Person Status:
+    ^{statusForm}
+  $maybe answer <- mbStatus
+    <p>
+      Unverarbeitete Antwort: #
+      #{answer}