From 107013756bb8eb11354cd70933304e0c00f51d3b Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Fri, 12 Jan 2024 18:59:20 -0500 Subject: [PATCH] Refactor http example into Client component - Client will have own Action and Model - Model is TODO but needs to hold all of the aborts usually a front-end client wants to abort other ongoing requests - Network.Client will have an update function that uses effectSub to create a thread that will inform the app of the results of the xhr action. We shouldn't just do this in Main, it gets messy --- chandlr.cabal | 1 + src/Action.hs | 2 +- src/Main.hs | 72 +++++------------------ src/Network/Client.hs | 133 ++++++++++++++---------------------------- src/Network/Http.hs | 105 +++++++++++++++++++++++++++++++++ 5 files changed, 165 insertions(+), 148 deletions(-) create mode 100644 src/Network/Http.hs diff --git a/chandlr.cabal b/chandlr.cabal index 0cc5e5d..719ffb0 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -64,6 +64,7 @@ executable chandlr -- Modules included in this executable, other than Main. other-modules: Component.CatalogGrid Action + Network.Http Network.Client Routes diff --git a/src/Action.hs b/src/Action.hs index 435d634..c118bb8 100644 --- a/src/Action.hs +++ b/src/Action.hs @@ -13,5 +13,5 @@ data Action , board_thread_id :: Int } | HaveLatest (Client.HttpResult Text) - | NewConnection Client.HttpActionResult + | ClientAction Client.Action | NoAction diff --git a/src/Main.hs b/src/Main.hs index 1d79de4..f4d5872 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,15 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Concurrent.MVar (takeMVar) import Data.Proxy -import Data.Text (Text) -import Control.Monad (void) -import Control.Concurrent (forkIO) import Miso ( View @@ -27,7 +22,6 @@ import Miso , URI , runRoute , getCurrentURI - , effectSub , consoleLog --, MisoString (..) ) @@ -36,13 +30,14 @@ import Servant.API import Action import Routes -import Network.Client as Client +import qualified Network.Client as Client import qualified Component.CatalogGrid as Grid data Model = Model { gridModel :: Grid.Model + , clientModel :: Client.Model } deriving Eq @@ -63,6 +58,7 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result initialModel :: Model initialModel = Model { gridModel = Grid.initialModel + , clientModel = Client.initialModel } @@ -101,68 +97,24 @@ mainUpdate (HaveLatest Client.Error) m = noEff m mainUpdate (HaveLatest (Client.HttpResponse {..})) m = m <# do case body of Nothing -> do - putStrLn "Didn't get anything back from API" consoleLog "Didn't get anything back from API" Just txt -> do - print txt consoleLog $ toJSString txt return NoAction -mainUpdate (NewConnection (_, resultVar)) m = effectSub m $ \sink -> do - void $ forkIO $ do - result :: Client.HttpResult Text <- takeMVar resultVar - sink $ HaveLatest result - -mainUpdate GetLatest m = m <# do - putStrLn "Getting Latest!" - - stuff <- Client.http - "http://localhost:3000/posts?limit=10" - Client.GET - Nothing - - return $ NewConnection stuff - -{- -mainUpdate GetLatest m = - Client.http - "/posts?limit=10" - Client.GET - Nothing - - <# \(abort, resultVar) -> - effectSub m (httpSub resultVar) <> noEff m - - where - httpSub :: MVar (Client.HttpResult Text) -> Sink Action -> IO () - httpSub resultVar sink = do - result :: Client.HttpResult Text <- liftIO $ takeMVar resultVar - liftIO $ sink (HaveLatest result) --} - -{- -mainUpdate GetLatest m = do - (abort, resultVar) <- Client.http - "/posts?limit=10" - Client.GET - Nothing - - -- return noEff m - return $ effectSub m (httpSub resultVar) <> noEff m -- { abortAction = Just abort } - - where - httpSub :: MVar (Client.HttpResult Text) -> Sink Action -> IO () - httpSub resultVar sink = do - result :: Client.HttpResult Text <- liftIO $ takeMVar resultVar - liftIO $ sink (HaveLatest result) --} +mainUpdate GetLatest m = m <# Client.fetchLatest iClient mainUpdate GetThread {..} m = noEff m + 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) + >>= \cm -> noEff (m { clientModel = cm }) + iGrid :: Grid.Interface Action iGrid = Grid.Interface @@ -170,6 +122,12 @@ iGrid = Grid.Interface , Grid.selectThread = () } +iClient :: Client.Interface Action +iClient = Client.Interface + { Client.passAction = ClientAction + , Client.returnResult = HaveLatest + } + {- - TODO: - - Create Hello World page render ✓ diff --git a/src/Network/Client.hs b/src/Network/Client.hs index 2535c2e..da72b4b 100644 --- a/src/Network/Client.hs +++ b/src/Network/Client.hs @@ -1,105 +1,58 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.Client - ( http - , HttpActionResult - , HttpMethod (..) - , HttpResult (..) - ) - where + ( Http.HttpActionResult + , Http.HttpMethod (..) + , Http.HttpResult (..) + , Action (..) + , Interface (..) + , fetchLatest + , Model + , update + , initialModel + ) where import Data.Text (Text) -import Control.Monad.IO.Class (liftIO) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar) -import GHCJS.DOM.XMLHttpRequest - ( newXMLHttpRequest - , openSimple - , getStatus - , getStatusText - , getResponseText - , abort - -- , send - ) -import GHCJS.DOM.JSFFI.Generated.XMLHttpRequest (send) -import GHCJS.DOM.Types (XMLHttpRequest) -import Data.JSString.Text (textToJSString) -import GHCJS.DOM.EventM (onAsync) -import GHCJS.DOM.XMLHttpRequestEventTarget (load) +import Control.Monad (void) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (takeMVar) --- What we actually want is to call send and not block the thread --- - so that we can put the request into our list of ongoing requests. --- - and have the response come back as an Action? --- - we would need the onload event to send an Action to updateModel +import Miso (effectSub, Effect) -{- - - Okay what the hell do I even want from an http function? - - - - the js implementation has these features: - - - - - url - - - method - - - ability to abort - - - is async - - - get the result from it - - - this should be a fn (IO result), let's not expose the xhr object? - - - - Also want: - - - return the same data structure always, but that data structure should - - inform of any errors, and have the status code, response body, - - and status text. - - - - - - Do we really need some sort of isomorphic framework? I think that's - - more work than just using a simple http lib server-side... tbqh - -} - -data HttpMethod = GET | PUT | POST | DELETE | PATCH - deriving Show - -data HttpResult a - = Error - | HttpResponse - { status_code :: Int - , status_text :: String - , body :: Maybe a - } - -type HttpActionResult = (IO (), MVar (HttpResult Text)) -- (abort, result) +import qualified Network.Http as Http -mkResult :: XMLHttpRequest -> IO (HttpResult Text) -mkResult xhr = do - sc <- getStatus xhr - - let status_code_int :: Int = fromEnum sc - - st :: String <- getStatusText xhr - - mBody :: Maybe Text <- getResponseText xhr - - return HttpResponse - { status_code = status_code_int - , status_text = st - , body = mBody - } +data Action = Connect Http.HttpActionResult -http - :: String - -> HttpMethod - -> Maybe Text - -> IO HttpActionResult -http url method payload = do - xhr <- newXMLHttpRequest +data Interface a = Interface + { passAction :: Action -> a + , returnResult :: Http.HttpResult Text -> a + } - resultVar <- newEmptyMVar - _ <- onAsync xhr load $ liftIO $ do - result <- mkResult xhr - putMVar resultVar result +type Model = () - openSimple xhr (show method) url - -- "/posts?limit=10" +initialModel :: Model +initialModel = () - send xhr (payload >>= Just . textToJSString) - return (abort xhr, resultVar) + +update + :: Interface a + -> Action + -> Model + -> Effect a Model +update iface (Connect (_, resultVar)) m = effectSub m $ + \sink -> void $ forkIO $ do + result :: Http.HttpResult Text <- takeMVar resultVar + sink $ (returnResult iface) result + + +fetchLatest :: Interface a -> IO a +fetchLatest iface = + Http.http + "http://localhost:3000/posts?limit=10" + Http.GET + Nothing + + >>= return . (passAction iface) . Connect diff --git a/src/Network/Http.hs b/src/Network/Http.hs new file mode 100644 index 0000000..96c5d23 --- /dev/null +++ b/src/Network/Http.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Http + ( http + , HttpActionResult + , HttpMethod (..) + , HttpResult (..) + ) +where + +import Data.Text (Text) +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar) +import GHCJS.DOM.XMLHttpRequest + ( newXMLHttpRequest + , openSimple + , getStatus + , getStatusText + , getResponseText + , abort + -- , send + ) +import GHCJS.DOM.JSFFI.Generated.XMLHttpRequest (send) +import GHCJS.DOM.Types (XMLHttpRequest) +import Data.JSString.Text (textToJSString) +import GHCJS.DOM.EventM (onAsync) +import GHCJS.DOM.XMLHttpRequestEventTarget (load) + +-- What we actually want is to call send and not block the thread +-- - so that we can put the request into our list of ongoing requests. +-- - and have the response come back as an Action? +-- - we would need the onload event to send an Action to updateModel + +{- + - Okay what the hell do I even want from an http function? + - + - the js implementation has these features: + - + - - url + - - method + - - ability to abort + - - is async + - - get the result from it + - - this should be a fn (IO result), let's not expose the xhr object? + - + - Also want: + - - return the same data structure always, but that data structure should + - inform of any errors, and have the status code, response body, + - and status text. + - + - + - Do we really need some sort of isomorphic framework? I think that's + - more work than just using a simple http lib server-side... tbqh + -} + +data HttpMethod = GET | PUT | POST | DELETE | PATCH + deriving Show + +data HttpResult a + = Error + | HttpResponse + { status_code :: Int + , status_text :: String + , body :: Maybe a + } + +type HttpActionResult = (IO (), MVar (HttpResult Text)) -- (abort, result) + + +mkResult :: XMLHttpRequest -> IO (HttpResult Text) +mkResult xhr = do + sc <- getStatus xhr + + let status_code_int :: Int = fromEnum sc + + st :: String <- getStatusText xhr + + mBody :: Maybe Text <- getResponseText xhr + + return HttpResponse + { status_code = status_code_int + , status_text = st + , body = mBody + } + + +http + :: String + -> HttpMethod + -> Maybe Text + -> IO HttpActionResult +http url method payload = do + xhr <- newXMLHttpRequest + + resultVar <- newEmptyMVar + + _ <- onAsync xhr load $ liftIO $ do + result <- mkResult xhr + putMVar resultVar result + + openSimple xhr (show method) url + -- "/posts?limit=10" + + send xhr (payload >>= Just . textToJSString) + return (abort xhr, resultVar)