Skip to content

Commit 80e4e42

Browse files
dmjiodmjio
authored
Servant support for miso's Fetch API implementation. (dmjio#871)
* Servant support for miso's Fetch API implementation. - [x] Adds a servant interpretation for Fetch API - [x] Method support (GET/PUT/POST/PATCH, etc.) - [x] Body support for POST/PUT - [/] Adds error handler callback - [ ] Query Param support - [ ] Query Flag support - [ ] Additional headers support Gives miso a servant-style type-safe Fetch API to facilitate AJAX simply and securely. * HasFetch -> Fetch. wire-up Fetch to examples/fetch. - Export Fetch(fetch) for use in examples/fetch. * Regenerate JS * Put camel2To '_' to work. * Drop ghcjs-base, use jsaddle * Add support for Header, QueryFlag, QueryParam. Add withSink, (?~) - Adds some light error handling * Drop console.log, update example w/ emoji * Return statusMessage in the case of Error. * Regen js * Miso.Fetch * Add example haddock * Set queryParams and queryFlag on url in Verb instance * Set headers appropriately
1 parent 8aea121 commit 80e4e42

File tree

12 files changed

+363
-87
lines changed

12 files changed

+363
-87
lines changed

‎examples/fetch/Main.hs

Lines changed: 73 additions & 58 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,10 @@
11
-----------------------------------------------------------------------------
22
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE DataKinds #-}
34
{-# LANGUAGE DeriveGeneric #-}
4-
{-# LANGUAGE OverloadedStrings #-}
55
{-# LANGUAGE RecordWildCards #-}
6+
{-# LANGUAGE TypeApplications #-}
7+
{-# LANGUAGE OverloadedStrings #-}
68
-----------------------------------------------------------------------------
79
-- |
810
-- Module : Main
@@ -14,11 +16,13 @@
1416
----------------------------------------------------------------------------
1517
module Main where
1618
----------------------------------------------------------------------------
17-
import Control.Monad.Writer
1819
import Data.Aeson
1920
import qualified Data.Map as M
2021
import Data.Maybe
2122
import GHC.Generics
23+
import Language.Javascript.JSaddle (JSM)
24+
import Data.Proxy
25+
import Servant.API
2226
----------------------------------------------------------------------------
2327
import Miso hiding (defaultOptions)
2428
import Miso.String
@@ -39,19 +43,21 @@ main = run $ startApp app
3943
----------------------------------------------------------------------------
4044
-- | Model
4145
newtype Model = Model
42-
{ _info :: Maybe APIInfo
46+
{ _info :: Maybe GitHub
4347
} deriving (Eq, Show)
4448
----------------------------------------------------------------------------
4549
-- | Lens for info field
46-
info :: Lens Model (Maybe APIInfo)
50+
info :: Lens Model (Maybe GitHub)
4751
info = lens _info $ \r x -> r { _info = x }
4852
----------------------------------------------------------------------------
4953
-- | Action
5054
data Action
51-
= FetchGitHub
52-
| SetGitHub APIInfo
53-
deriving (Show, Eq)
55+
= FetchGitHub
56+
| SetGitHub GitHub
57+
| ErrorHandler MisoString
58+
deriving (Show, Eq)
5459
----------------------------------------------------------------------------
60+
-- | WASM support
5561
#ifdef WASM
5662
foreign export javascript "hs_start" main :: IO ()
5763
#endif
@@ -62,15 +68,24 @@ app = defaultApp emptyModel updateModel viewModel
6268
emptyModel :: Model
6369
emptyModel = Model Nothing
6470
----------------------------------------------------------------------------
71+
-- | GitHub API method
72+
type GithubAPI = Get '[JSON] GitHub
73+
----------------------------------------------------------------------------
74+
-- | Uses servant to reify type-safe calls to the Fetch API
75+
getGithubAPI
76+
:: (GitHub -> JSM ())
77+
-- ^ Successful callback
78+
-> (MisoString -> JSM ())
79+
-- ^ Errorful callback
80+
-> JSM ()
81+
getGithubAPI = fetch (Proxy @GithubAPI) "https://api.github.com"
82+
----------------------------------------------------------------------------
6583
updateModel :: Action -> Effect Model Action ()
66-
updateModel FetchGitHub
67-
= tell
68-
[ \snk ->
69-
fetchJSON "https://api.github.com"
70-
(snk . SetGitHub)
71-
]
84+
updateModel FetchGitHub = withSink $ \snk -> getGithubAPI (snk . SetGitHub) (snk . ErrorHandler)
7285
updateModel (SetGitHub apiInfo) =
7386
info ?= apiInfo
87+
updateModel (ErrorHandler msg) =
88+
io (consoleError msg)
7489
----------------------------------------------------------------------------
7590
-- | View function, with routing
7691
viewModel :: Model -> View Action
@@ -86,19 +101,19 @@ viewModel m = view
86101
[ h1_
87102
[ class_ $ pack "title"
88103
]
89-
[ text $ pack "Miso Fetch Example"
104+
[ "🍜 Miso Fetch API"
90105
]
91106
, button_
92107
attrs
93-
[ text $ pack "Fetch JSON from https://api.github.com via Fetch API"
108+
[ "Fetch JSON from https://api.github.com"
94109
]
95110
, case m ^. info of
96111
Nothing ->
97112
div_
98113
[]
99114
[ "No data"
100115
]
101-
Just APIInfo {..} ->
116+
Just GitHub {..} ->
102117
table_
103118
[ class_ "table is-striped" ]
104119
[ thead_
@@ -113,14 +128,14 @@ viewModel m = view
113128
]
114129
, tbody_
115130
[]
116-
[ tr current_user_url
117-
, tr emojis_url
118-
, tr emails_url
119-
, tr events_url
120-
, tr gists_url
121-
, tr feeds_url
122-
, tr followers_url
123-
, tr following_url
131+
[ tr currentUserUrl
132+
, tr emojisUrl
133+
, tr emailsUrl
134+
, tr eventsUrl
135+
, tr gistsUrl
136+
, tr feedsUrl
137+
, tr followersUrl
138+
, tr followingUrl
124139
]
125140
]
126141
]
@@ -138,40 +153,40 @@ viewModel m = view
138153
]
139154
----------------------------------------------------------------------------
140155
-- | Structure to capture the JSON returned from https://api.github.com
141-
data APIInfo
142-
= APIInfo
143-
{ current_user_url :: MisoString
144-
, current_user_authorizations_html_url :: MisoString
145-
, authorizations_url :: MisoString
146-
, code_search_url :: MisoString
147-
, commit_search_url :: MisoString
148-
, emails_url :: MisoString
149-
, emojis_url :: MisoString
150-
, events_url :: MisoString
151-
, feeds_url :: MisoString
152-
, followers_url :: MisoString
153-
, following_url :: MisoString
154-
, gists_url :: MisoString
155-
, hub_url :: MisoString
156-
, issue_search_url :: MisoString
157-
, issues_url :: MisoString
158-
, keys_url :: MisoString
159-
, notifications_url :: MisoString
160-
, organization_repositories_url :: MisoString
161-
, organization_url :: MisoString
162-
, public_gists_url :: MisoString
163-
, rate_limit_url :: MisoString
164-
, repository_url :: MisoString
165-
, repository_search_url :: MisoString
166-
, current_user_repositories_url :: MisoString
167-
, starred_url :: MisoString
168-
, starred_gists_url :: MisoString
169-
, user_url :: MisoString
170-
, user_organizations_url :: MisoString
171-
, user_repositories_url :: MisoString
172-
, user_search_url :: MisoString
156+
data GitHub
157+
= GitHub
158+
{ currentUserUrl :: MisoString
159+
, currentUserAuthorizationsHtmlUrl :: MisoString
160+
, authorizationsUrl :: MisoString
161+
, codeSearchUrl :: MisoString
162+
, commitSearchUrl :: MisoString
163+
, emailsUrl :: MisoString
164+
, emojisUrl :: MisoString
165+
, eventsUrl :: MisoString
166+
, feedsUrl :: MisoString
167+
, followersUrl :: MisoString
168+
, followingUrl :: MisoString
169+
, gistsUrl :: MisoString
170+
, hubUrl :: MisoString
171+
, issueSearchUrl :: MisoString
172+
, issuesUrl :: MisoString
173+
, keysUrl :: MisoString
174+
, notificationsUrl :: MisoString
175+
, organizationRepositoriesUrl :: MisoString
176+
, organizationUrl :: MisoString
177+
, publicGistsUrl :: MisoString
178+
, rateLimitUrl :: MisoString
179+
, repositoryUrl :: MisoString
180+
, repositorySearchUrl :: MisoString
181+
, currentUserRepositoriesUrl :: MisoString
182+
, starredUrl :: MisoString
183+
, starredGistsUrl :: MisoString
184+
, userUrl :: MisoString
185+
, userOrganizationsUrl :: MisoString
186+
, userRepositoriesUrl :: MisoString
187+
, userSearchUrl :: MisoString
173188
} deriving (Show, Eq, Generic)
174189
----------------------------------------------------------------------------
175-
instance FromJSON APIInfo where
176-
parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = camelTo2 '_'}
190+
instance FromJSON GitHub where
191+
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }
177192
----------------------------------------------------------------------------

‎examples/miso-examples.cabal

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -163,9 +163,10 @@ executable fetch
163163
aeson,
164164
base < 5,
165165
containers,
166-
ghcjs-base,
166+
jsaddle,
167167
miso,
168-
mtl
168+
mtl,
169+
servant
169170

170171
executable canvas2d
171172
import:

‎js/miso.js

Lines changed: 18 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -15,10 +15,14 @@ function mkVNode() {
1515
tag: "div",
1616
key: null,
1717
events: {},
18-
onDestroyed: () => {},
19-
onBeforeDestroyed: () => {},
20-
onCreated: () => {},
21-
onBeforeCreated: () => {},
18+
onDestroyed: () => {
19+
},
20+
onBeforeDestroyed: () => {
21+
},
22+
onCreated: () => {
23+
},
24+
onBeforeCreated: () => {
25+
},
2226
type: "vnode"
2327
};
2428
}
@@ -635,13 +639,17 @@ function callBlur(id, delay) {
635639
function setBodyComponent(componentId) {
636640
document.body.setAttribute("data-component-id", componentId);
637641
}
638-
function fetchJSON(url, callback) {
639-
const options = {
640-
headers: {
641-
"Content-Type": "application/json"
642+
function fetchJSON(url, method, body, headers, successful, errorful) {
643+
var options = { method, headers };
644+
if (body) {
645+
options["body"] = body;
646+
}
647+
fetch(url, options).then((response) => {
648+
if (!response.ok) {
649+
throw new Error(response.statusMessage);
642650
}
643-
};
644-
fetch(url, options).then((response) => response.json()).then(callback).catch((e) => console.error(e));
651+
return response.json();
652+
}).then(successful).catch(errorful);
645653
}
646654
var version = "1.9.0.0";
647655

‎js/miso.prod.js

Lines changed: 1 addition & 1 deletion
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎miso.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -154,6 +154,7 @@ library
154154
Miso.Event.Decoder
155155
Miso.Event.Types
156156
Miso.Exception
157+
Miso.Fetch
157158
Miso.FFI
158159
Miso.FFI.History
159160
Miso.FFI.SSE

‎src/Miso.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,8 @@ module Miso
4242
, module Miso.Subscription
4343
-- * Storage
4444
, module Miso.Storage
45+
-- * Fetch
46+
, module Miso.Fetch
4547
-- * Util
4648
, module Miso.Util
4749
-- * FFI
@@ -62,6 +64,7 @@ import Miso.Diff
6264
import Miso.Effect
6365
import Miso.Event
6466
import Miso.Exception
67+
import Miso.Fetch
6568
import Miso.FFI
6669
import qualified Miso.FFI.Internal as FFI
6770
import Miso.Html

‎src/Miso/Effect.hs

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ module Miso.Effect
3232
, batchEff
3333
, io
3434
, issue
35+
, withSink
3536
-- * Internal
3637
, runEffect
3738
) where
@@ -185,6 +186,14 @@ scheduleIOFor_ action = scheduleSub $ \sink -> action >>= flip for_ sink
185186
scheduleSub :: Sub action -> Effect model action ()
186187
scheduleSub sub = Effect $ lift $ tell [ sub ]
187188
-----------------------------------------------------------------------------
189+
-- | 'withSink' allows users to access the sink of the 'Component' or top-level
190+
-- 'App' in their application. This is useful for introducing I/O into the system.
191+
--
192+
-- > update FetchJSON = withSink $ \sink -> getJSON (sink . ReceivedJSON) (sink . HandleError)
193+
--
194+
withSink :: (Sink action -> JSM ()) -> Effect model action ()
195+
withSink f = Effect $ lift $ tell [ f ]
196+
-----------------------------------------------------------------------------
188197
-- | A synonym for @tell@, specialized to @Effect@
189198
--
190199
-- > update :: Action -> Effect Model Action ()

‎src/Miso/FFI.hs

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,6 @@ module Miso.FFI
2727
, syncCallback
2828
, syncCallback1
2929
, asyncCallback
30-
, fetchJSON
3130
) where
3231
-----------------------------------------------------------------------------
3332
import Miso.FFI.Internal

‎src/Miso/FFI/Internal.hs

Lines changed: 30 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,7 @@ module Miso.FFI.Internal
5858
) where
5959
-----------------------------------------------------------------------------
6060
import Control.Concurrent (ThreadId, forkIO)
61-
import Control.Monad (void)
61+
import Control.Monad (void, forM_)
6262
import Control.Monad.IO.Class (liftIO)
6363
import Data.Aeson hiding (Object)
6464
import qualified Data.Aeson as A
@@ -331,7 +331,7 @@ undelegate mountPoint events debug callback = do
331331
-- entry point into isomorphic javascript
332332
--
333333
-- <https://en.wikipedia.org/wiki/Hydration_(web_development)>
334-
--
334+
--
335335
hydrate :: Bool -> JSVal -> JSVal -> JSM ()
336336
hydrate logLevel mountPoint vtree = void $ do
337337
ll <- toJSVal logLevel
@@ -417,17 +417,41 @@ addStyleSheet url = do
417417
fetchJSON
418418
:: FromJSON action
419419
=> MisoString
420+
-- ^ url
421+
-> MisoString
422+
-- ^ method
423+
-> Maybe MisoString
424+
-- ^ body
425+
-> [(MisoString,MisoString)]
426+
-- ^ headers
420427
-> (action -> JSM ())
428+
-- ^ successful callback
429+
-> (MisoString -> JSM ())
430+
-- ^ errorful callback
421431
-> JSM ()
422-
fetchJSON url callback = do
423-
callback_ <- toJSVal =<< do
432+
fetchJSON url method maybeBody headers successful errorful = do
433+
successful_ <- toJSVal =<< do
424434
asyncCallback1 $ \jval ->
425435
fromJSON <$> fromJSValUnchecked jval >>= \case
426436
Error string ->
427437
error ("fetchJSON: " <> string <> ": decode failure")
428438
Success result -> do
429-
callback result
439+
successful result
440+
errorful_ <- toJSVal =<< do
441+
asyncCallback1 $ \jval ->
442+
errorful =<< fromJSValUnchecked jval
430443
moduleMiso <- jsg "miso"
431444
url_ <- toJSVal url
432-
void $ moduleMiso # "fetchJSON" $ [url_, callback_]
445+
method_ <- toJSVal method
446+
body_ <- toJSVal maybeBody
447+
let jsonHeaders =
448+
[ (ms "Content-Type", ms "application/json")
449+
, (ms "Accept", ms "application/json")
450+
]
451+
Object headers_ <- do
452+
o <- create
453+
forM_ (headers <> jsonHeaders) $ \(k,v) -> do
454+
set k v o
455+
pure o
456+
void $ moduleMiso # "fetchJSON" $ [url_, method_, body_, headers_, successful_, errorful_]
433457
-----------------------------------------------------------------------------

0 commit comments

Comments
 (0)