From bbc6a69d57b9b7f6a6169c90e8647cdcbcc9cf64 Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Thu, 11 Jan 2024 18:59:00 -0500 Subject: [PATCH] Some basic first attempt at XHR - There's a lot of wrong here: - Send function is referenced from the GHCJS.DOM.JSFFI.Generated directly, so idk if this compiles to native (it's fine to ignore this point though because we only really care about the front-end for XHR) - There are actions that should be generalized out, probably there needs to be a network client component, with an interface to keep track of stuff for us accross different actions that trigger http --- chandlr.cabal | 8 +++- default.nix | 1 + src/Action.hs | 4 ++ src/Main.hs | 87 ++++++++++++++++++++++++++++++++-- src/Network/Client.hs | 105 ++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 201 insertions(+), 4 deletions(-) create mode 100644 src/Network/Client.hs diff --git a/chandlr.cabal b/chandlr.cabal index 369dbc4..0cc5e5d 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -63,6 +63,9 @@ executable chandlr -- Modules included in this executable, other than Main. other-modules: Component.CatalogGrid + Action + Network.Client + Routes -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -72,7 +75,10 @@ executable chandlr base < 5, ghcjs-base, miso, - servant + servant, + ghcjs-dom, + ghcjs-dom-jsffi, + text -- Directories containing source files. hs-source-dirs: src diff --git a/default.nix b/default.nix index be0fcb5..9b22d67 100644 --- a/default.nix +++ b/default.nix @@ -11,6 +11,7 @@ let env = drv.env.overrideAttrs (oldAttrs: { buildInputs = oldAttrs.buildInputs ++ [ pkgs.haskellPackages.cabal-install + new_pkgs.haskellPackages.ghcjs-dom new_pkgs.haskellPackages.miso-from-html ]; }); diff --git a/src/Action.hs b/src/Action.hs index 087c8ac..435d634 100644 --- a/src/Action.hs +++ b/src/Action.hs @@ -1,6 +1,8 @@ module Action where import Component.CatalogGrid as Grid +import Network.Client as Client +import Data.Text (Text) data Action = GridAction Grid.Action @@ -10,4 +12,6 @@ data Action , board :: String , board_thread_id :: Int } + | HaveLatest (Client.HttpResult Text) + | NewConnection Client.HttpActionResult | NoAction diff --git a/src/Main.hs b/src/Main.hs index b229376..1d79de4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,9 +1,16 @@ {-# 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 , startApp @@ -13,26 +20,32 @@ import Miso , text , Effect --, (#>) + , (<#) , noEff , defaultEvents , LogLevel (Off) , URI , runRoute , getCurrentURI + , effectSub + , consoleLog + --, MisoString (..) ) - -import Data.Proxy +import GHCJS.DOM.Types (toJSString) import Servant.API import Action import Routes +import Network.Client as Client import qualified Component.CatalogGrid as Grid + data Model = Model { gridModel :: Grid.Model } deriving Eq + initialActionFromRoute :: Model -> URI -> Action initialActionFromRoute model uri = either (const NoAction) id routing_result where @@ -46,15 +59,21 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result h_thread :: String -> String -> BoardThreadId -> Model -> Action h_thread board website board_thread_id _ = GetThread {..} + initialModel :: Model initialModel = Model { gridModel = Grid.initialModel } + main :: IO () main = do + consoleLog "Hello World!" + uri <- getCurrentURI + consoleLog $ toJSString $ show uri + startApp App { model = initialModel , update = mainUpdate @@ -66,6 +85,7 @@ main = do , logLevel = Off } + mainView :: Model -> View Action mainView model = div_ [] @@ -76,7 +96,68 @@ mainView model = mainUpdate :: Action -> Model -> Effect Action Model mainUpdate NoAction m = noEff m -mainUpdate GetLatest m = noEff m +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 GetThread {..} m = noEff m mainUpdate (GridAction ga) m = Grid.update iGrid ga (gridModel m) diff --git a/src/Network/Client.hs b/src/Network/Client.hs new file mode 100644 index 0000000..2535c2e --- /dev/null +++ b/src/Network/Client.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Client + ( 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)