From 840edb86ababd7dd1f8397c88923d93a3c0fbfef Mon Sep 17 00:00:00 2001
From: towards-a-new-leftypol <paul_cockshott@protonmail.com>
Date: Thu, 1 Feb 2024 01:47:10 -0500
Subject: [PATCH] Make HTTP Client more generic

- refactor our http call to easily construct more api methods
- make the Client Interface and Action types be polymorphic
    - this requires the main application keeping an Action constructor
      in the ClientAction, so we can later know what type to decode
      (this is a bit weird I'm not gonna lie but it works)
---
 src/Action.hs              |  9 ++++++---
 src/Main.hs                | 16 ++++++++--------
 src/Network/Client.hs      | 30 +++++++++++++-----------------
 src/Network/ClientTypes.hs |  8 ++++----
 4 files changed, 31 insertions(+), 32 deletions(-)

diff --git a/src/Action.hs b/src/Action.hs
index 3fc4c20..e3c897a 100644
--- a/src/Action.hs
+++ b/src/Action.hs
@@ -1,11 +1,14 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
 module Action where
 
 import Data.Text (Text)
-import Component.CatalogGrid as Grid
+import Data.Aeson (FromJSON)
 import Data.Int (Int64)
 import Miso (URI)
 
-import Network.ClientTypes as C
+import qualified Component.CatalogGrid as Grid
+import qualified Network.ClientTypes as C
 import Network.CatalogPostType (CatalogPost)
 import Network.Http (HttpResult)
 
@@ -20,6 +23,6 @@ data Action
     | GetLatest
     | GetThread GetThreadArgs
     | HaveLatest (HttpResult [CatalogPost])
-    | ClientAction C.Action
+    | forall a. (FromJSON a) => ClientAction (HttpResult a -> Action) (C.Action a)
     | ChangeURI URI
     | NoAction
diff --git a/src/Main.hs b/src/Main.hs
index f27c416..0ec8dd8 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,6 +12,7 @@ import qualified Data.Text as T
 import Network.URI (uriPath)
 import System.FilePath ((</>))
 
+import Data.Aeson (FromJSON)
 import Data.JSString (pack, append)
 import Miso
     ( View
@@ -131,7 +132,6 @@ main = do
 
 mainView :: Model -> View Action
 mainView model = view
-
     where
         view =
           either (const page404) id
@@ -168,7 +168,7 @@ mainUpdate (HaveLatest (Client.HttpResponse {..})) m = m <#
             -- mapM_ (consoleLog . toJSString . show) posts
             return $ GridAction $ Grid.DisplayItems posts
 
-mainUpdate GetLatest m = m <# Client.fetchLatest (clientModel m) iClient
+mainUpdate GetLatest m = m <# Client.fetchLatest (clientModel m) (iClient HaveLatest)
 
 -- mainUpdate GetThread {..} m = noEff m
 
@@ -194,8 +194,8 @@ mainUpdate (GridAction ga) m =
     Grid.update iGrid ga (gridModel m)
     >>= \gm -> noEff (m { gridModel = gm })
 
-mainUpdate (ClientAction ca) m =
-    Client.update iClient ca (clientModel m)
+mainUpdate (ClientAction action ca) m =
+    Client.update (iClient action) ca (clientModel m)
     >>= \cm -> noEff (m { clientModel = cm })
 
 
@@ -213,10 +213,10 @@ iGrid = Grid.Interface
             , board_thread_id = CatalogPost.board_thread_id post
             }
 
-iClient :: Client.Interface Action
-iClient = Client.Interface
-    { Client.passAction = ClientAction
-    , Client.returnResult = HaveLatest
+iClient :: (FromJSON a) => (Client.HttpResult a -> Action) -> Client.Interface Action a
+iClient action = Client.Interface
+    { Client.passAction = ClientAction action
+    , Client.returnResult = action
     }
 
 {-
diff --git a/src/Network/Client.hs b/src/Network/Client.hs
index 18f6147..dd2de9d 100644
--- a/src/Network/Client.hs
+++ b/src/Network/Client.hs
@@ -19,7 +19,7 @@ import GHC.Generics
 import Control.Monad (void)
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (takeMVar)
-import Data.Aeson (ToJSON)
+import Data.Aeson (ToJSON, FromJSON)
 import Data.Time (getCurrentTime)
 import Data.Time.Clock (UTCTime)
 
@@ -33,13 +33,13 @@ import Network.ClientTypes
 
 
 update
-    :: Interface a
-    -> Action
+    :: Interface a b
+    -> Action b
     -> Model
     -> Effect a Model
 update iface (Connect (abort, resultVar)) m = effectSub m $
     \sink -> void $ forkIO $ do
-        result :: Http.HttpResult [CatalogPost] <- takeMVar resultVar
+        result :: Http.HttpResult b <- takeMVar resultVar
         sink $ (returnResult iface) result
 
 data FetchCatalogArgs = FetchCatalogArgs
@@ -49,12 +49,12 @@ data FetchCatalogArgs = FetchCatalogArgs
 
 
 http_
-    :: (ToJSON b)
+    :: (ToJSON c, FromJSON b)
     => Model
-    -> Interface a
+    -> Interface a b
     -> JSString
     -> Http.HttpMethod
-    -> Maybe b
+    -> Maybe c
     -> IO a
 http_ m iface api_path method payload = do
     Http.http
@@ -65,20 +65,16 @@ http_ m iface api_path method payload = do
     >>= return . (passAction iface) . Connect
 
 
-fetchLatest :: Model -> Interface a -> IO a
+fetchLatest :: Model -> Interface a [ CatalogPost ] -> IO a
 fetchLatest m iface = do
-    ct <- getCurrentTime
+    now <- getCurrentTime
 
-    Http.http
-        ((pgApiRoot m) <> ("/rpc/fetch_catalog" :: JSString))
-        Http.POST
-        [("Content-Type", "application/json")]
-        ( Just $ FetchCatalogArgs
-            { max_time = ct
+    let payload = Just $ FetchCatalogArgs
+            { max_time = now
             , max_row_read = fetchCount m
             }
-        )
-    >>= return . (passAction iface) . Connect
+
+    http_ m iface "/rpc/fetch_catalog" Http.POST payload
 
 
 getThread :: A.GetThreadArgs -> IO a
diff --git a/src/Network/ClientTypes.hs b/src/Network/ClientTypes.hs
index f0d02be..3e127df 100644
--- a/src/Network/ClientTypes.hs
+++ b/src/Network/ClientTypes.hs
@@ -4,11 +4,11 @@ import qualified Network.Http as Http
 import Network.CatalogPostType (CatalogPost)
 import GHCJS.DOM.Types (JSString)
 
-data Action = Connect (Http.HttpActionResult [CatalogPost])
+data Action a = Connect (Http.HttpActionResult a)
 
-data Interface a = Interface
-    { passAction :: Action -> a
-    , returnResult :: Http.HttpResult [CatalogPost] -> a
+data Interface a b = Interface
+    { passAction :: Action b -> a
+    , returnResult :: Http.HttpResult b -> a
     }
 
 data Model = Model