From 9b72d2fbe4e91efab4b25eb2b3e54ea3e18606f3 Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Sun, 14 Jan 2024 18:54:36 -0500 Subject: [PATCH] Add json payload encoding, headers to http request - also get settings from page metadata --- chandlr.cabal | 3 ++- index.html | 14 ++++++++++++++ src/Main.hs | 38 ++++++++++++++++++++++++++++++-------- src/Network/Client.hs | 38 ++++++++++++++++++++++++-------------- src/Network/Http.hs | 25 +++++++++++++++++-------- 5 files changed, 87 insertions(+), 31 deletions(-) create mode 100644 index.html diff --git a/chandlr.cabal b/chandlr.cabal index ab92398..c4e7ba9 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -81,7 +81,8 @@ executable chandlr ghcjs-dom, ghcjs-dom-jsffi, text, - time + time, + bytestring -- Directories containing source files. hs-source-dirs: src diff --git a/index.html b/index.html new file mode 100644 index 0000000..06f2a5a --- /dev/null +++ b/index.html @@ -0,0 +1,14 @@ + + + + + + Chandlr + + + + + + + + diff --git a/src/Main.hs b/src/Main.hs index c680a93..eadd747 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,10 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where import Data.Proxy +import Data.Maybe (maybe) import Miso ( View @@ -25,7 +27,10 @@ import Miso , consoleLog --, MisoString (..) ) -import GHCJS.DOM.Types (toJSString) +import GHCJS.DOM (currentDocument) +import GHCJS.DOM.Types (toJSString, Element, JSString) +import GHCJS.DOM.ParentNode (querySelector) +import GHCJS.DOM.Element (getAttribute) import Servant.API import Action @@ -55,12 +60,23 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result h_thread board website board_thread_id _ = GetThread {..} -initialModel :: Model -initialModel = Model +initialModel :: JSString -> Model +initialModel pgroot = Model { gridModel = Grid.initialModel - , clientModel = Client.initialModel + , clientModel = Client.Model { Client.pgApiRoot = pgroot } } +getMetadata :: String -> IO (Maybe JSString) +getMetadata key = do + doc <- currentDocument + + mElem :: Maybe Element <- case doc of + Nothing -> return Nothing + Just d -> querySelector d $ "meta[name='" ++ key ++ "']" + + case mElem of + Nothing -> return Nothing + Just el -> getAttribute el ("content" :: JSString) main :: IO () main = do @@ -70,13 +86,19 @@ main = do consoleLog $ toJSString $ show uri + pg_api_root <- getMetadata "postgrest-root" >>= + return . maybe "http://localhost:2000" id + consoleLog pg_api_root + + let initial_model = initialModel pg_api_root + startApp App - { model = initialModel + { model = initial_model , update = mainUpdate , view = mainView , subs = [] , events = defaultEvents - , initialAction = initialActionFromRoute initialModel uri + , initialAction = initialActionFromRoute initial_model uri , mountPoint = Nothing , logLevel = Off } @@ -101,11 +123,11 @@ mainUpdate (HaveLatest (Client.HttpResponse {..})) m = m <# do Nothing -> do consoleLog "Didn't get anything back from API" Just posts -> do - consoleLog $ toJSString $ show posts + mapM_ (consoleLog . toJSString . show) posts return NoAction -mainUpdate GetLatest m = m <# Client.fetchLatest iClient +mainUpdate GetLatest m = m <# Client.fetchLatest (clientModel m) iClient mainUpdate GetThread {..} m = noEff m diff --git a/src/Network/Client.hs b/src/Network/Client.hs index 7c21e21..4464f71 100644 --- a/src/Network/Client.hs +++ b/src/Network/Client.hs @@ -1,4 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} module Network.Client ( Http.HttpActionResult @@ -7,16 +10,19 @@ module Network.Client , Action (..) , Interface (..) , fetchLatest - , Model + , Model (..) , update - , initialModel ) where -import Data.Text (Text) +import GHC.Generics import Control.Monad (void) import Control.Concurrent (forkIO) import Control.Concurrent.MVar (takeMVar) +import Data.Aeson (ToJSON) +import Data.Time (getCurrentTime) +import Data.Time.Clock (UTCTime) +import GHCJS.DOM.Types (JSString) import Miso (effectSub, Effect) import qualified Network.Http as Http @@ -31,11 +37,9 @@ data Interface a = Interface , returnResult :: Http.HttpResult [Post] -> a } - -type Model = () - -initialModel :: Model -initialModel = () +data Model = Model + { pgApiRoot :: JSString + } deriving Eq update @@ -48,12 +52,18 @@ update iface (Connect (abort, resultVar)) m = effectSub m $ result :: Http.HttpResult [Post] <- takeMVar resultVar sink $ (returnResult iface) result +data FetchCatalogArgs = FetchCatalogArgs + { max_time :: UTCTime + , max_row_read :: Int + } deriving (Generic, ToJSON) + +fetchLatest :: Model -> Interface a -> IO a +fetchLatest m iface = do + ct <- getCurrentTime -fetchLatest :: Interface a -> IO a -fetchLatest iface = Http.http - "http://localhost:3000/posts?limit=10" - Http.GET - Nothing - + ((pgApiRoot m) <> ("/rpc/fetch_catalog" :: JSString)) + Http.POST + [("Content-Type", "application/json")] + (Just $ FetchCatalogArgs { max_time = ct, max_row_read = 1000 }) >>= return . (passAction iface) . Connect diff --git a/src/Network/Http.hs b/src/Network/Http.hs index 699af78..6838ea9 100644 --- a/src/Network/Http.hs +++ b/src/Network/Http.hs @@ -9,11 +9,12 @@ module Network.Http where import Prelude hiding (error) +import Data.ByteString.Lazy (toStrict) import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar) -import Data.Aeson (FromJSON, eitherDecodeStrict) +import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode) import GHCJS.DOM.XMLHttpRequest ( newXMLHttpRequest , openSimple @@ -21,10 +22,11 @@ import GHCJS.DOM.XMLHttpRequest , getStatusText , getResponseText , abort + , setRequestHeader -- , send ) import GHCJS.DOM.JSFFI.Generated.XMLHttpRequest (send) -import GHCJS.DOM.Types (XMLHttpRequest) +import GHCJS.DOM.Types (XMLHttpRequest, JSString) import Data.JSString.Text (textToJSString) import GHCJS.DOM.EventM (onAsync) import GHCJS.DOM.XMLHttpRequestEventTarget (load, abortEvent, error) @@ -43,6 +45,8 @@ data HttpResult a type HttpActionResult a = (IO (), MVar (HttpResult a)) -- (abort, result) +type Header = (JSString, JSString) + mkResult :: (FromJSON a) => XMLHttpRequest -> IO (HttpResult a) mkResult xhr = do sc <- getStatus xhr @@ -73,12 +77,13 @@ mkResult xhr = do http - :: (FromJSON a) - => String + :: (FromJSON a, ToJSON b) + => JSString -> HttpMethod - -> Maybe Text + -> [Header] + -> Maybe b -> IO (HttpActionResult a) -http url method payload = do +http url method headers payload = do xhr <- newXMLHttpRequest resultVar <- newEmptyMVar @@ -96,5 +101,9 @@ http url method payload = do openSimple xhr (show method) url -- "/posts?limit=10" - send xhr (payload >>= Just . textToJSString) + mapM_ (\(k, v) -> setRequestHeader xhr k v) headers + + let p = payload >>= Just . textToJSString . decodeUtf8 . toStrict . encode + + send xhr p return (abort xhr, resultVar)