Refactor http example into Client component
- Client will have own Action and Model
- Model is TODO but needs to hold all of the aborts
usually a front-end client wants to abort other ongoing requests
- Network.Client will have an update function that uses effectSub to
create a thread that will inform the app of the results of the xhr
action. We shouldn't just do this in Main, it gets messy
This commit is contained in:
parent
bbc6a69d57
commit
107013756b
|
|
@ -64,6 +64,7 @@ executable chandlr
|
|||
-- Modules included in this executable, other than Main.
|
||||
other-modules: Component.CatalogGrid
|
||||
Action
|
||||
Network.Http
|
||||
Network.Client
|
||||
Routes
|
||||
|
||||
|
|
|
|||
|
|
@ -13,5 +13,5 @@ data Action
|
|||
, board_thread_id :: Int
|
||||
}
|
||||
| HaveLatest (Client.HttpResult Text)
|
||||
| NewConnection Client.HttpActionResult
|
||||
| ClientAction Client.Action
|
||||
| NoAction
|
||||
|
|
|
|||
72
src/Main.hs
72
src/Main.hs
|
|
@ -1,15 +1,10 @@
|
|||
{-# 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
|
||||
|
|
@ -27,7 +22,6 @@ import Miso
|
|||
, URI
|
||||
, runRoute
|
||||
, getCurrentURI
|
||||
, effectSub
|
||||
, consoleLog
|
||||
--, MisoString (..)
|
||||
)
|
||||
|
|
@ -36,13 +30,14 @@ import Servant.API
|
|||
|
||||
import Action
|
||||
import Routes
|
||||
import Network.Client as Client
|
||||
import qualified Network.Client as Client
|
||||
|
||||
import qualified Component.CatalogGrid as Grid
|
||||
|
||||
|
||||
data Model = Model
|
||||
{ gridModel :: Grid.Model
|
||||
, clientModel :: Client.Model
|
||||
} deriving Eq
|
||||
|
||||
|
||||
|
|
@ -63,6 +58,7 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result
|
|||
initialModel :: Model
|
||||
initialModel = Model
|
||||
{ gridModel = Grid.initialModel
|
||||
, clientModel = Client.initialModel
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -101,68 +97,24 @@ 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 GetLatest m = m <# Client.fetchLatest iClient
|
||||
|
||||
mainUpdate GetThread {..} m = noEff m
|
||||
|
||||
mainUpdate (GridAction ga) m =
|
||||
Grid.update iGrid ga (gridModel m)
|
||||
>>= \gm -> noEff (m { gridModel = gm })
|
||||
|
||||
mainUpdate (ClientAction ca) m =
|
||||
Client.update iClient ca (clientModel m)
|
||||
>>= \cm -> noEff (m { clientModel = cm })
|
||||
|
||||
|
||||
iGrid :: Grid.Interface Action
|
||||
iGrid = Grid.Interface
|
||||
|
|
@ -170,6 +122,12 @@ iGrid = Grid.Interface
|
|||
, Grid.selectThread = ()
|
||||
}
|
||||
|
||||
iClient :: Client.Interface Action
|
||||
iClient = Client.Interface
|
||||
{ Client.passAction = ClientAction
|
||||
, Client.returnResult = HaveLatest
|
||||
}
|
||||
|
||||
{-
|
||||
- TODO:
|
||||
- - Create Hello World page render ✓
|
||||
|
|
|
|||
|
|
@ -1,105 +1,58 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Network.Client
|
||||
( http
|
||||
, HttpActionResult
|
||||
, HttpMethod (..)
|
||||
, HttpResult (..)
|
||||
)
|
||||
where
|
||||
( Http.HttpActionResult
|
||||
, Http.HttpMethod (..)
|
||||
, Http.HttpResult (..)
|
||||
, Action (..)
|
||||
, Interface (..)
|
||||
, fetchLatest
|
||||
, Model
|
||||
, update
|
||||
, initialModel
|
||||
) 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)
|
||||
import Control.Monad (void)
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar (takeMVar)
|
||||
|
||||
-- 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
|
||||
import Miso (effectSub, Effect)
|
||||
|
||||
{-
|
||||
- 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)
|
||||
import qualified Network.Http as Http
|
||||
|
||||
|
||||
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
|
||||
}
|
||||
data Action = Connect Http.HttpActionResult
|
||||
|
||||
|
||||
http
|
||||
:: String
|
||||
-> HttpMethod
|
||||
-> Maybe Text
|
||||
-> IO HttpActionResult
|
||||
http url method payload = do
|
||||
xhr <- newXMLHttpRequest
|
||||
data Interface a = Interface
|
||||
{ passAction :: Action -> a
|
||||
, returnResult :: Http.HttpResult Text -> a
|
||||
}
|
||||
|
||||
resultVar <- newEmptyMVar
|
||||
|
||||
_ <- onAsync xhr load $ liftIO $ do
|
||||
result <- mkResult xhr
|
||||
putMVar resultVar result
|
||||
type Model = ()
|
||||
|
||||
openSimple xhr (show method) url
|
||||
-- "/posts?limit=10"
|
||||
initialModel :: Model
|
||||
initialModel = ()
|
||||
|
||||
send xhr (payload >>= Just . textToJSString)
|
||||
return (abort xhr, resultVar)
|
||||
|
||||
update
|
||||
:: Interface a
|
||||
-> Action
|
||||
-> Model
|
||||
-> Effect a Model
|
||||
update iface (Connect (_, resultVar)) m = effectSub m $
|
||||
\sink -> void $ forkIO $ do
|
||||
result :: Http.HttpResult Text <- takeMVar resultVar
|
||||
sink $ (returnResult iface) result
|
||||
|
||||
|
||||
fetchLatest :: Interface a -> IO a
|
||||
fetchLatest iface =
|
||||
Http.http
|
||||
"http://localhost:3000/posts?limit=10"
|
||||
Http.GET
|
||||
Nothing
|
||||
|
||||
>>= return . (passAction iface) . Connect
|
||||
|
|
|
|||
|
|
@ -0,0 +1,105 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Network.Http
|
||||
( 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)
|
||||
Loading…
Reference in New Issue