From 27a156f4e5fc1adafb88308fae80afb8e047b3da Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Sat, 13 Jan 2024 12:52:03 -0500 Subject: [PATCH] Http decodes data with aeson --- chandlr.cabal | 4 ++- src/Action.hs | 4 ++- src/Common | 2 +- src/Main.hs | 4 +-- src/Network/Client.hs | 7 ++--- src/Network/Http.hs | 60 +++++++++++++++++-------------------------- 6 files changed, 37 insertions(+), 44 deletions(-) diff --git a/chandlr.cabal b/chandlr.cabal index 719ffb0..ab92398 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -67,6 +67,7 @@ executable chandlr Network.Http Network.Client Routes + Common.PostsType -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -79,7 +80,8 @@ executable chandlr servant, ghcjs-dom, ghcjs-dom-jsffi, - text + text, + time -- Directories containing source files. hs-source-dirs: src diff --git a/src/Action.hs b/src/Action.hs index c118bb8..487d979 100644 --- a/src/Action.hs +++ b/src/Action.hs @@ -4,6 +4,8 @@ import Component.CatalogGrid as Grid import Network.Client as Client import Data.Text (Text) +import Common.PostsType (Post) + data Action = GridAction Grid.Action | GetLatest @@ -12,6 +14,6 @@ data Action , board :: String , board_thread_id :: Int } - | HaveLatest (Client.HttpResult Text) + | HaveLatest (Client.HttpResult [Post]) | ClientAction Client.Action | NoAction diff --git a/src/Common b/src/Common index 0026e48..a5d90ea 160000 --- a/src/Common +++ b/src/Common @@ -1 +1 @@ -Subproject commit 0026e48cea06e2768f7a22f4a25bf115debcea35 +Subproject commit a5d90ea96195ed6a5a7e3196d5b0e32b65af5058 diff --git a/src/Main.hs b/src/Main.hs index 60db15c..c680a93 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -100,8 +100,8 @@ mainUpdate (HaveLatest (Client.HttpResponse {..})) m = m <# do case body of Nothing -> do consoleLog "Didn't get anything back from API" - Just txt -> do - consoleLog $ toJSString txt + Just posts -> do + consoleLog $ toJSString $ show posts return NoAction diff --git a/src/Network/Client.hs b/src/Network/Client.hs index 8d68db0..7c21e21 100644 --- a/src/Network/Client.hs +++ b/src/Network/Client.hs @@ -20,14 +20,15 @@ import Control.Concurrent.MVar (takeMVar) import Miso (effectSub, Effect) import qualified Network.Http as Http +import Common.PostsType (Post) -data Action = Connect Http.HttpActionResult +data Action = Connect (Http.HttpActionResult [Post]) data Interface a = Interface { passAction :: Action -> a - , returnResult :: Http.HttpResult Text -> a + , returnResult :: Http.HttpResult [Post] -> a } @@ -44,7 +45,7 @@ update -> Effect a Model update iface (Connect (abort, resultVar)) m = effectSub m $ \sink -> void $ forkIO $ do - result :: Http.HttpResult Text <- takeMVar resultVar + result :: Http.HttpResult [Post] <- takeMVar resultVar sink $ (returnResult iface) result diff --git a/src/Network/Http.hs b/src/Network/Http.hs index c87964b..699af78 100644 --- a/src/Network/Http.hs +++ b/src/Network/Http.hs @@ -10,8 +10,10 @@ where import Prelude hiding (error) import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar) +import Data.Aeson (FromJSON, eitherDecodeStrict) import GHCJS.DOM.XMLHttpRequest ( newXMLHttpRequest , openSimple @@ -27,33 +29,6 @@ import Data.JSString.Text (textToJSString) import GHCJS.DOM.EventM (onAsync) import GHCJS.DOM.XMLHttpRequestEventTarget (load, abortEvent, error) --- 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 @@ -65,10 +40,10 @@ data HttpResult a , body :: Maybe a } -type HttpActionResult = (IO (), MVar (HttpResult Text)) -- (abort, result) +type HttpActionResult a = (IO (), MVar (HttpResult a)) -- (abort, result) -mkResult :: XMLHttpRequest -> IO (HttpResult Text) +mkResult :: (FromJSON a) => XMLHttpRequest -> IO (HttpResult a) mkResult xhr = do sc <- getStatus xhr @@ -78,18 +53,31 @@ mkResult xhr = do mBody :: Maybe Text <- getResponseText xhr - return HttpResponse - { status_code = status_code_int - , status_text = st - , body = mBody - } + let mBytes = mBody >>= Just . encodeUtf8 + + case mBytes of + Nothing -> return HttpResponse + { status_code = status_code_int + , status_text = st + , body = Nothing + } + Just bs -> do + let parse_result = eitherDecodeStrict bs + case parse_result of + Left _ -> return Error + Right x -> return HttpResponse + { status_code = status_code_int + , status_text = st + , body = Just x + } http - :: String + :: (FromJSON a) + => String -> HttpMethod -> Maybe Text - -> IO HttpActionResult + -> IO (HttpActionResult a) http url method payload = do xhr <- newXMLHttpRequest