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

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

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 =
+mainUpdate (ClientAction action ca) m =
-    Client.update iClient ca (clientModel 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 :: (FromJSON a) => (Client.HttpResult a -> Action) -> Client.Interface Action a
-iClient = Client.Interface
+iClient action = Client.Interface
-    { Client.passAction = ClientAction
+    { Client.passAction = ClientAction action
-    , Client.returnResult = HaveLatest
+    , Client.returnResult = action
     }
 
 {-

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
+    :: Interface a b
-    -> Action
+    -> 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
+    let payload = Just $ FetchCatalogArgs
-        ((pgApiRoot m) <> ("/rpc/fetch_catalog" :: JSString))
+            { max_time = now
-        Http.POST
-        [("Content-Type", "application/json")]
-        ( Just $ FetchCatalogArgs
-            { max_time = ct
             , max_row_read = fetchCount m
             }
-        )
+
-    >>= return . (passAction iface) . Connect
+    http_ m iface "/rpc/fetch_catalog" Http.POST payload
 
 
 getThread :: A.GetThreadArgs -> IO a

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
+data Interface a b = Interface
-    { passAction :: Action -> a
+    { passAction :: Action b -> a
-    , returnResult :: Http.HttpResult [CatalogPost] -> a
+    , returnResult :: Http.HttpResult b -> a
     }
 
 data Model = Model