Some basic first attempt at XHR

- There's a lot of wrong here:
- Send function is referenced from the GHCJS.DOM.JSFFI.Generated
  directly, so idk if this compiles to native (it's fine to ignore this
  point though because we only really care about the front-end for XHR)
- There are actions that should be generalized out, probably there
  needs to be a network client component, with an interface to keep
  track of stuff for us accross different actions that trigger http

chandlr.cabal

@@ -63,6 +63,9 @@ executable chandlr
 
     -- Modules included in this executable, other than Main.
     other-modules:    Component.CatalogGrid
+                      Action
+                      Network.Client
+                      Routes
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
@@ -72,7 +75,10 @@ executable chandlr
                        base < 5,
                        ghcjs-base,
                        miso,
-                       servant
+                       servant,
+                       ghcjs-dom,
+                       ghcjs-dom-jsffi,
+                       text
 
     -- Directories containing source files.
     hs-source-dirs:   src

default.nix

@@ -11,6 +11,7 @@ let
   env = drv.env.overrideAttrs (oldAttrs: {
     buildInputs = oldAttrs.buildInputs ++ [
       pkgs.haskellPackages.cabal-install
+      new_pkgs.haskellPackages.ghcjs-dom
       new_pkgs.haskellPackages.miso-from-html
     ];
   });

src/Action.hs

@@ -1,6 +1,8 @@
 module Action where
 
 import Component.CatalogGrid as Grid
+import Network.Client as Client
+import Data.Text (Text)
 
 data Action
     = GridAction Grid.Action
@@ -10,4 +12,6 @@ data Action
         , board           :: String
         , board_thread_id :: Int
         }
+    | HaveLatest (Client.HttpResult Text)
+    | NewConnection Client.HttpActionResult
     | NoAction

src/Main.hs

@@ -1,9 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Main where
 
+import Control.Concurrent.MVar (takeMVar)
+import Data.Proxy
+import Data.Text (Text)
+import Control.Monad (void)
+import Control.Concurrent (forkIO)
+
 import Miso
     ( View
     , startApp
@@ -13,26 +20,32 @@ import Miso
     , text
     , Effect
     --, (#>)
+    , (<#)
     , noEff
     , defaultEvents
     , LogLevel (Off)
     , URI
     , runRoute
     , getCurrentURI
+    , effectSub
+    , consoleLog
+    --, MisoString (..)
     )
-
-import Data.Proxy
+import GHCJS.DOM.Types (toJSString)
 import Servant.API
 
 import Action
 import Routes
+import Network.Client as Client
 
 import qualified Component.CatalogGrid as Grid
 
+
 data Model = Model
     { gridModel :: Grid.Model
     } deriving Eq
 
+
 initialActionFromRoute :: Model -> URI -> Action
 initialActionFromRoute model uri = either (const NoAction) id routing_result
     where
@@ -46,15 +59,21 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result
         h_thread :: String -> String -> BoardThreadId -> Model -> Action
         h_thread board website board_thread_id _ = GetThread {..}
 
+
 initialModel :: Model
 initialModel = Model
     { gridModel = Grid.initialModel
     }
 
+
 main :: IO ()
 main = do
+    consoleLog "Hello World!"
+
     uri <- getCurrentURI
 
+    consoleLog $ toJSString $ show uri
+
     startApp App
         { model         = initialModel
         , update        = mainUpdate
@@ -66,6 +85,7 @@ main = do
         , logLevel      = Off
         }
 
+
 mainView :: Model -> View Action
 mainView model =
     div_ []
@@ -76,7 +96,68 @@ mainView model =
 
 mainUpdate :: Action -> Model -> Effect Action Model
 mainUpdate NoAction m = noEff m
-mainUpdate GetLatest m = noEff m
+mainUpdate (HaveLatest Client.Error) m = noEff m
+
+mainUpdate (HaveLatest (Client.HttpResponse {..})) m = m <# do
+    case body of
+        Nothing -> do
+            putStrLn "Didn't get anything back from API"
+            consoleLog "Didn't get anything back from API"
+        Just txt -> do
+            print txt
+            consoleLog $ toJSString txt
+
+    return NoAction
+
+mainUpdate (NewConnection (_, resultVar)) m = effectSub m $ \sink -> do
+    void $ forkIO $ do
+        result :: Client.HttpResult Text <- takeMVar resultVar
+        sink $ HaveLatest result
+
+mainUpdate GetLatest m = m <# do
+    putStrLn "Getting Latest!"
+
+    stuff <- Client.http
+        "http://localhost:3000/posts?limit=10"
+        Client.GET
+        Nothing
+
+    return $ NewConnection stuff
+
+{-
+mainUpdate GetLatest m =
+    Client.http
+        "/posts?limit=10"
+        Client.GET
+        Nothing
+
+    <# \(abort, resultVar) ->
+        effectSub m (httpSub resultVar) <> noEff m
+
+  where
+    httpSub :: MVar (Client.HttpResult Text) -> Sink Action -> IO ()
+    httpSub resultVar sink = do
+        result :: Client.HttpResult Text <- liftIO $ takeMVar resultVar
+        liftIO $ sink (HaveLatest result)
+-}
+
+{-
+mainUpdate GetLatest m = do
+    (abort, resultVar) <- Client.http
+            "/posts?limit=10"
+            Client.GET
+            Nothing
+
+    -- return noEff m
+    return $ effectSub m (httpSub resultVar) <> noEff m -- { abortAction = Just abort }
+
+  where
+    httpSub :: MVar (Client.HttpResult Text) -> Sink Action -> IO ()
+    httpSub resultVar sink = do
+        result :: Client.HttpResult Text <- liftIO $ takeMVar resultVar
+        liftIO $ sink (HaveLatest result)
+-}
+
 mainUpdate GetThread {..} m = noEff m
 mainUpdate (GridAction ga) m =
     Grid.update iGrid ga (gridModel m)

src/Network/Client.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Network.Client
+    ( http
+    , HttpActionResult
+    , HttpMethod (..)
+    , HttpResult (..)
+    )
+    where
+
+import Data.Text (Text)
+import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar)
+import GHCJS.DOM.XMLHttpRequest
+    ( newXMLHttpRequest
+    , openSimple
+    , getStatus
+    , getStatusText
+    , getResponseText
+    , abort
+    -- , send
+    )
+import GHCJS.DOM.JSFFI.Generated.XMLHttpRequest (send)
+import GHCJS.DOM.Types (XMLHttpRequest)
+import Data.JSString.Text (textToJSString)
+import GHCJS.DOM.EventM (onAsync)
+import GHCJS.DOM.XMLHttpRequestEventTarget (load)
+
+-- 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
+
+data HttpResult a
+    = Error
+    | HttpResponse
+        { status_code :: Int
+        , status_text :: String
+        , body        :: Maybe a
+        }
+
+type HttpActionResult = (IO (), MVar (HttpResult Text)) -- (abort, result)
+
+
+mkResult :: XMLHttpRequest -> IO (HttpResult Text)
+mkResult xhr = do
+        sc <- getStatus xhr
+
+        let status_code_int :: Int = fromEnum sc
+
+        st :: String <- getStatusText xhr
+
+        mBody :: Maybe Text <- getResponseText xhr
+
+        return HttpResponse
+            { status_code = status_code_int
+            , status_text = st
+            , body = mBody
+            }
+
+
+http
+    :: String
+    -> HttpMethod
+    -> Maybe Text
+    -> IO HttpActionResult
+http url method payload = do
+    xhr <- newXMLHttpRequest
+
+    resultVar <- newEmptyMVar
+
+    _ <- onAsync xhr load $ liftIO $ do
+        result <- mkResult xhr
+        putMVar resultVar result
+
+    openSimple xhr (show method) url
+    -- "/posts?limit=10"
+
+    send xhr (payload >>= Just . textToJSString)
+    return (abort xhr, resultVar)