Add json payload encoding, headers to http request

- also get settings from page metadata
2024-01-14 18:54:36 -05:00 · 2024-01-14 18:54:36 -05:00 · 9b72d2fbe4
parent 27a156f4e5
commit 9b72d2fbe4
5 changed files with 87 additions and 31 deletions
--- 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
--- a/index.html
+++ b/index.html
@ -0,0 +1,14 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <meta name="viewport" content="width=device-width, initial-scale=1.0">
+    <meta name="postgrest-root" content="http://localhost:3000">
+    <title>Chandlr</title>
+    <script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/rts.js"></script>
+    <script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/lib.js"></script>
+    <script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/out.js"></script>
+  </head>
+  <body>
+  </body>
+  <script language="javascript" src="./dist/build/chandlr/chandlr.jsexe/runmain.js" defer></script>
+</html>
--- 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

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