0
/
chandler-miso
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add json payload encoding, headers to http request 

- also get settings from page metadata
This commit is contained in:
towards-a-new-leftypol 2024-01-14 18:54:36 -05:00
parent 27a156f4e5
commit 9b72d2fbe4
5 changed files with 87 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
chandlr.cabal
View File

@ -81,7 +81,8 @@ executable chandlr
ghcjs-dom, ghcjs-dom,
ghcjs-dom-jsffi, ghcjs-dom-jsffi,
text, text,
time time,
bytestring
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src hs-source-dirs: src

14
index.html Normal file
View File

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

38
src/Main.hs
View File

@ -1,10 +1,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where module Main where
import Data.Proxy import Data.Proxy
import Data.Maybe (maybe)
import Miso import Miso
( View ( View
@ -25,7 +27,10 @@ import Miso
, consoleLog , consoleLog
--, MisoString (..) --, 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 Servant.API
import Action import Action
@ -55,12 +60,23 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result
h_thread board website board_thread_id _ = GetThread {..} h_thread board website board_thread_id _ = GetThread {..}
initialModel :: Model initialModel :: JSString -> Model
initialModel = Model initialModel pgroot = Model
{ gridModel = Grid.initialModel { 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 :: IO ()
main = do main = do
@ -70,13 +86,19 @@ main = do
consoleLog $ toJSString $ show uri 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 startApp App
{ model = initialModel { model = initial_model
, update = mainUpdate , update = mainUpdate
, view = mainView , view = mainView
, subs = [] , subs = []
, events = defaultEvents , events = defaultEvents
, initialAction = initialActionFromRoute initialModel uri , initialAction = initialActionFromRoute initial_model uri
, mountPoint = Nothing , mountPoint = Nothing
, logLevel = Off , logLevel = Off
} }
@ -101,11 +123,11 @@ mainUpdate (HaveLatest (Client.HttpResponse {..})) m = m <# do
Nothing -> do Nothing -> do
consoleLog "Didn't get anything back from API" consoleLog "Didn't get anything back from API"
Just posts -> do Just posts -> do
consoleLog $ toJSString $ show posts mapM_ (consoleLog . toJSString . show) posts
return NoAction return NoAction
mainUpdate GetLatest m = m <# Client.fetchLatest iClient mainUpdate GetLatest m = m <# Client.fetchLatest (clientModel m) iClient
mainUpdate GetThread {..} m = noEff m mainUpdate GetThread {..} m = noEff m

38
src/Network/Client.hs
View File

@ -1,4 +1,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
module Network.Client module Network.Client
( Http.HttpActionResult ( Http.HttpActionResult
@ -7,16 +10,19 @@ module Network.Client
, Action (..) , Action (..)
, Interface (..) , Interface (..)
, fetchLatest , fetchLatest
, Model , Model (..)
, update , update
, initialModel
) where ) where
import Data.Text (Text) import GHC.Generics
import Control.Monad (void) import Control.Monad (void)
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (takeMVar) 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 Miso (effectSub, Effect)
import qualified Network.Http as Http import qualified Network.Http as Http
@ -31,11 +37,9 @@ data Interface a = Interface
, returnResult :: Http.HttpResult [Post] -> a , returnResult :: Http.HttpResult [Post] -> a
} }
data Model = Model
type Model = () { pgApiRoot :: JSString
} deriving Eq
initialModel :: Model
initialModel = ()
update update
@ -48,12 +52,18 @@ update iface (Connect (abort, resultVar)) m = effectSub m $
result :: Http.HttpResult [Post] <- takeMVar resultVar result :: Http.HttpResult [Post] <- takeMVar resultVar
sink $ (returnResult iface) result 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.http
"http://localhost:3000/posts?limit=10" ((pgApiRoot m) <> ("/rpc/fetch_catalog" :: JSString))
Http.GET Http.POST
Nothing [("Content-Type", "application/json")]
(Just $ FetchCatalogArgs { max_time = ct, max_row_read = 1000 })
>>= return . (passAction iface) . Connect >>= return . (passAction iface) . Connect

25
src/Network/Http.hs
View File

@ -9,11 +9,12 @@ module Network.Http
where where
import Prelude hiding (error) import Prelude hiding (error)
import Data.ByteString.Lazy (toStrict)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar)
import Data.Aeson (FromJSON, eitherDecodeStrict) import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode)
import GHCJS.DOM.XMLHttpRequest import GHCJS.DOM.XMLHttpRequest
( newXMLHttpRequest ( newXMLHttpRequest
, openSimple , openSimple
@ -21,10 +22,11 @@ import GHCJS.DOM.XMLHttpRequest
, getStatusText , getStatusText
, getResponseText , getResponseText
, abort , abort
, setRequestHeader
-- , send -- , send
) )
import GHCJS.DOM.JSFFI.Generated.XMLHttpRequest (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 Data.JSString.Text (textToJSString)
import GHCJS.DOM.EventM (onAsync) import GHCJS.DOM.EventM (onAsync)
import GHCJS.DOM.XMLHttpRequestEventTarget (load, abortEvent, error) import GHCJS.DOM.XMLHttpRequestEventTarget (load, abortEvent, error)
@ -43,6 +45,8 @@ data HttpResult a
type HttpActionResult a = (IO (), MVar (HttpResult a)) -- (abort, result) type HttpActionResult a = (IO (), MVar (HttpResult a)) -- (abort, result)
type Header = (JSString, JSString)
mkResult :: (FromJSON a) => XMLHttpRequest -> IO (HttpResult a) mkResult :: (FromJSON a) => XMLHttpRequest -> IO (HttpResult a)
mkResult xhr = do mkResult xhr = do
sc <- getStatus xhr sc <- getStatus xhr
@ -73,12 +77,13 @@ mkResult xhr = do
http http
:: (FromJSON a) :: (FromJSON a, ToJSON b)
=> String => JSString
-> HttpMethod -> HttpMethod
-> Maybe Text -> [Header]
-> Maybe b
-> IO (HttpActionResult a) -> IO (HttpActionResult a)
http url method payload = do http url method headers payload = do
xhr <- newXMLHttpRequest xhr <- newXMLHttpRequest
resultVar <- newEmptyMVar resultVar <- newEmptyMVar
@ -96,5 +101,9 @@ http url method payload = do
openSimple xhr (show method) url openSimple xhr (show method) url
-- "/posts?limit=10" -- "/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) return (abort xhr, resultVar)