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)