fetch example: use servant-client-js, remove Miso.Fetch (#904)

Author: amesgen

README.md

@@ -50,6 +50,7 @@
 - [Internals](#internals)
 - [Examples](#examples)
 - [Building examples](#building-examples)
+- [Coverage](#interacting-with-http-apis)
 - [Coverage](#coverage)
 - [Isomorphic](#isomorphic)
 - [Benchmarks](#benchmarks)
@@ -578,6 +579,23 @@ cd result/bin/todo-mvc.jsexe && http-sever
 Serving HTTP on 0.0.0.0 port 8000 ...
 ```
 
+## Interacting with HTTP APIs 🔌
+
+If you want to interact with an HTTP API, we recommend one of the following approaches:
+
+  1. For a simple JSON-based API, you can use Miso's `fetchJSON` function.
+
+  2. In more complex cases, you can define a [Servant](https://www.servant.dev/) API and automatically obtain client functions via `servant-client-js` (or any other `servant-client-core`-based backend).
+
+     The Fetch example ([Source](https://github.com/dmjio/miso/blob/master/examples/fetch/Main.hs), [Demo](https://fetch.haskell-miso.org/)) demonstrates the necessary ingredients. Make sure to add the following to your `cabal.project`:
+
+     ```cabal
+     source-repository-package
+       type: git
+       location: https://github.com/amesgen/servant-client-js
+       tag: 2853fb4f26175f51ae7b9aaf0ec683c45070d06e
+     ```
+
 ## Coverage ✅
 
 The core engine of `miso` is the [diff](https://github.com/dmjio/miso/blob/master/ts/dom.ts) function. It is responsible for all DOM manipulation that occurs in a miso application and has [100% code coverage](http://coverage.haskell-miso.org). Tests and coverage made possible using [bun](https://github.com/oven-sh/bun).

cabal.project

@@ -5,7 +5,7 @@ packages:
   haskell-miso.org/
   sample-app/
 
-index-state: 2025-04-29T21:50:43Z
+index-state: 2025-05-01T20:28:51Z
 
 allow-newer:
   all:base
@@ -36,3 +36,9 @@ if arch(wasm32)
     location: https://github.com/haskell-wasm/foundation.git
     tag: 8e6dd48527fb429c1922083a5030ef88e3d58dd3
     subdir: basement
+
+-- for the fetch example
+source-repository-package
+  type: git
+  location: https://github.com/amesgen/servant-client-js
+  tag: 2853fb4f26175f51ae7b9aaf0ec683c45070d06e

examples/fetch/Main.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -23,6 +24,7 @@ import           GHC.Generics
 import           Language.Javascript.JSaddle (JSM)
 import           Data.Proxy
 import           Servant.API
+import           Servant.Client.JS (ClientEnv (..), ClientError, parseBaseUrl, client, runClientM)
 ----------------------------------------------------------------------------
 import           Miso hiding (defaultOptions)
 import           Miso.String
@@ -68,15 +70,17 @@ type GithubAPI = Get '[JSON] GitHub
 ----------------------------------------------------------------------------
 -- | Uses servant to reify type-safe calls to the Fetch API
 getGithubAPI
-  :: (GitHub -> JSM ())
-  -- ^ Successful callback
-  -> (MisoString -> JSM ())
-  -- ^ Errorful callback
-  -> JSM ()
-getGithubAPI = fetch (Proxy @GithubAPI) "https://api.github.com"
+  :: JSM (Either ClientError GitHub)
+getGithubAPI = do
+    baseUrl <- parseBaseUrl "https://api.github.com"
+    runClientM c (ClientEnv baseUrl)
+  where
+    c = Servant.Client.JS.client (Proxy @GithubAPI)
 ----------------------------------------------------------------------------
 updateModel :: Action -> Effect Model Action
-updateModel FetchGitHub = withSink $ \snk -> getGithubAPI (snk . SetGitHub) (snk . ErrorHandler)
+updateModel FetchGitHub = scheduleIO $ getGithubAPI <&> \case
+  Right r -> SetGitHub r
+  Left e  -> ErrorHandler $ ms $ show e
 updateModel (SetGitHub apiInfo) =
   info ?= apiInfo
 updateModel (ErrorHandler msg) =

examples/miso-examples.cabal

@@ -166,7 +166,8 @@ executable fetch
     jsaddle,
     miso,
     mtl,
-    servant
+    servant,
+    servant-client-js
 
 executable canvas2d
   import:

miso.cabal

@@ -65,7 +65,7 @@ common jsaddle
 
   if arch(wasm32)
     build-depends:
-      jsaddle-wasm >= 0.1 && < 0.2
+      jsaddle-wasm >= 0.1.1 && < 0.2
 
 common client
   if impl(ghcjs) || arch(javascript)

nix/haskell/packages/ghc/default.nix

@@ -17,6 +17,8 @@ self: super:
   jsaddle = self.callCabal2nix "jsaddle" "${source.jsaddle}/jsaddle" {};
   jsaddle-warp =
     dontCheck (self.callCabal2nix "jsaddle-warp" "${source.jsaddle}/jsaddle-warp" {});
+  servant-client-core = doJailbreak super.servant-client-core;
+  servant-client-js = self.callCabal2nix "servant-client-js" source.servant-client-js {};
 
   /* cruft */
   crypton = dontCheck super.crypton;

nix/haskell/packages/ghcjs/default.nix

@@ -12,6 +12,8 @@ self: super:
   /* examples */
   sample-app-js = self.callCabal2nix "app" source.sample-app {};
   jsaddle = self.callCabal2nix "jsaddle" "${source.jsaddle}/jsaddle" {};
+  servant-client-core = doJailbreak super.servant-client-core;
+  servant-client-js = self.callCabal2nix "servant-client-js" source.servant-client-js {};
   flatris = self.callCabal2nix "flatris" source.flatris {};
   miso-plane-core = self.callCabal2nix "miso-plane" source.miso-plane {};
   miso-plane = pkgs.runCommand "miso-plane" {} ''

nix/legacy/haskell/packages/ghc/default.nix

@@ -12,4 +12,5 @@ self: super:
 
   jsaddle = self.callCabal2nix "jsaddle" "${source.jsaddle}/jsaddle" {};
   jsaddle-warp = dontCheck (self.callCabal2nix "jsaddle-warp" "${source.jsaddle}/jsaddle-warp" {});
+  servant-client-js = self.callCabal2nix "servant-client-js" source.servant-client-js {};
 }

nix/legacy/haskell/packages/ghcjs/default.nix

@@ -10,6 +10,7 @@ self: super:
   sample-app-js = self.callCabal2nix "app" source.sample-app {};
   jsaddle = self.callCabal2nix "jsaddle" "${source.jsaddle}/jsaddle" {};
   jsaddle-warp = dontCheck (self.callCabal2nix "jsaddle-warp" "${source.jsaddle}/jsaddle-warp" {});
+  servant-client-js = self.callCabal2nix "servant-client-js" source.servant-client-js {};
   flatris = self.callCabal2nix "flatris" source.flatris {};
   miso-plane =
     let

nix/source.nix

@@ -37,6 +37,12 @@ in
     rev = "0d5e427cb99391179b143dc93dfbac9c1019237b";
     sha256 = "sha256-jyJ7bdz0gNLOSzRxOWcv7eWGIwo3N/O4PcY7HyNF8Fo=";
   };
+  servant-client-js = fetchFromGitHub {
+    owner = "amesgen";
+    repo = "servant-client-js";
+    rev = "3ff9ad6906ebeeae52a7eaa31f7026790a59769a";
+    hash = "sha256-7x2bxbm2cyuzhotXtdQ0jwfc0aMzjQ/fxDfHjmVvivQ=";
+  };
   flatris = fetchFromGitHub {
     owner = "dmjio";
     repo = "hs-flatris";

src/Miso/Fetch.hs

@@ -20,178 +20,14 @@
 -- Portability :  non-portable
 --
 -- Module for interacting with the Fetch API <https://developer.mozilla.org/en-US/docs/Web/API/Fetch_API>
--- with a servant-style interface.
+-- manually.
 --
--- > import Miso (fetch)
--- > import Data.Proxy
--- > import Servant.API
--- >
--- > data Action
--- >  = FetchGitHub
--- >  | SetGitHub GitHub
--- >  | ErrorHandler MisoString
--- >  deriving (Show, Eq)
--- >
--- > type GithubAPI = Get '[JSON] GitHub
--- >
--- > getGithubAPI
--- >   :: (GitHub -> JSM ())
--- >   -- ^ Successful callback
--- >   -> (MisoString -> JSM ())
--- >   -- ^ Errorful callback
--- >   -> JSM ()
--- > getGithubAPI = fetch (Proxy @GithubAPI) "https://api.github.com"
--- >
--- > updateModel :: Action -> Effect Model Action ()
--- > updateModel FetchGitHub =
--- >   withSink $ \snk ->
--- >     getGithubAPI (snk . SetGitHub) (snk . ErrorHandler)
--- > updateModel (SetGitHub apiInfo) =
--- >   info ?= apiInfo
--- > updateModel (ErrorHandler msg) =
--- >   io (consoleError msg)
+-- Refer to the miso README if you want to automatically interact with a Servant
+-- API.
 --
 ----------------------------------------------------------------------------
 module Miso.Fetch
-  ( -- * Class
-    Fetch (..)
-    -- ** Simple non-Servant API
-  , fetchJSON
+  ( fetchJSON
   ) where
------------------------------------------------------------------------------
-import           Data.Aeson
-import           Data.Kind (Type)
-import           Data.Proxy (Proxy(..))
-import           GHC.TypeLits
-import           Language.Javascript.JSaddle (JSM)
-import           Servant.API
-import           Servant.API.Modifiers
------------------------------------------------------------------------------
-import           Miso.FFI.Internal (fetchJSON)
-import           Miso.Lens
-import           Miso.String (MisoString, ms)
-import qualified Miso.String as MS
------------------------------------------------------------------------------
--- | Internal type used to accumulate options during the type-level traversal
-data FetchOptions
-  = FetchOptions
-  { _baseUrl :: MisoString
-  , _currentPath :: MisoString
-  , _body :: Maybe MisoString
-  , _headers :: [(MisoString, MisoString)]
-  , _queryParams :: [(MisoString,MisoString)]
-  , _queryFlags :: [MisoString]
-  }
------------------------------------------------------------------------------
-baseUrl :: Lens FetchOptions MisoString
-baseUrl = lens _baseUrl $ \record field -> record { _baseUrl = field }
------------------------------------------------------------------------------
-currentPath :: Lens FetchOptions MisoString
-currentPath = lens _currentPath $ \record field -> record { _currentPath = field }
------------------------------------------------------------------------------
-body :: Lens FetchOptions (Maybe MisoString)
-body = lens _body $ \record field -> record { _body = field }
------------------------------------------------------------------------------
-headers :: Lens FetchOptions [(MisoString,MisoString)]
-headers = lens _headers $ \record field -> record { _headers = field }
------------------------------------------------------------------------------
-queryParams :: Lens FetchOptions [(MisoString,MisoString)]
-queryParams = lens _queryParams $ \record field -> record { _queryParams = field }
------------------------------------------------------------------------------
-queryFlags :: Lens FetchOptions [MisoString]
-queryFlags = lens _queryFlags $ \record field -> record { _queryFlags = field }
------------------------------------------------------------------------------
-defaultFetchOptions :: FetchOptions
-defaultFetchOptions
-  = FetchOptions
-  { _headers = []
-  , _baseUrl = mempty
-  , _currentPath = mempty
-  , _queryParams = []
-  , _queryFlags = []
-  , _body = Nothing
-  }
------------------------------------------------------------------------------
-class Fetch (api :: Type) where
-  type ToFetch api :: Type
-  fetch :: Proxy api -> MisoString -> ToFetch api
-  fetch proxy url = fetchWith proxy (defaultFetchOptions & baseUrl .~ url)
-  fetchWith :: Proxy api -> FetchOptions -> ToFetch api
------------------------------------------------------------------------------
-instance (Fetch left , Fetch right) => Fetch (left :<|> right) where
-  type ToFetch (left :<|> right) = ToFetch left :<|> ToFetch right
-  fetchWith Proxy o = fetchWith (Proxy @left) o :<|> fetchWith (Proxy @right) o
------------------------------------------------------------------------------
-instance (Fetch api, KnownSymbol path) => Fetch (path :> api) where
-  type ToFetch (path :> api) = ToFetch api
-  fetchWith Proxy options = fetchWith (Proxy @api) options_
-    where
-      path :: MisoString
-      path = ms $ symbolVal (Proxy @path)
 
-      options_ :: FetchOptions
-      options_ = options & currentPath %~ (<> ms "/" <> path)
------------------------------------------------------------------------------
-instance (ToHttpApiData a, Fetch api, KnownSymbol path) => Fetch (Capture path a :> api) where
-  type ToFetch (Capture path a :> api) = a -> ToFetch api
-  fetchWith Proxy options arg = fetchWith (Proxy @api) options_
-    where
-      options_ :: FetchOptions
-      options_ = options & currentPath %~ (<> ms "/" <> ms (toEncodedUrlPiece arg))
------------------------------------------------------------------------------
-instance (ToHttpApiData a, Fetch api, SBoolI (FoldRequired mods), KnownSymbol name) => Fetch (QueryParam' mods name a :> api) where
-  type ToFetch (QueryParam' mods name a :> api) = RequiredArgument mods a -> ToFetch api
-  fetchWith Proxy options arg = fetchWith (Proxy @api) options_
-    where
-      param (x :: a) = [(ms $ symbolVal (Proxy @name), ms (enc x))]
-#if MIN_VERSION_http_api_data(0,5,1)
-      enc = toEncodedQueryParam
-#else
-      enc = toEncodedUrlPiece
-#endif
-      options_ :: FetchOptions
-      options_ = options & queryParams <>~ foldRequiredArgument (Proxy @mods) param (foldMap param) arg
------------------------------------------------------------------------------
-instance (Fetch api, KnownSymbol name) => Fetch (QueryFlag name :> api) where
-  type ToFetch (QueryFlag name :> api) = Bool -> ToFetch api
-  fetchWith Proxy options flag = fetchWith (Proxy @api) options_
-    where
-      options_ :: FetchOptions
-      options_ = options & queryFlags <>~ [ ms $ symbolVal (Proxy @name) | flag ]
------------------------------------------------------------------------------
-instance (ToJSON a, Fetch api) => Fetch (ReqBody '[JSON] a :> api) where
-  type ToFetch (ReqBody '[JSON] a :> api) = a -> ToFetch api
-  fetchWith Proxy options body_ = fetchWith (Proxy @api) (options_ (ms (encode body_)))
-    where
-      options_ :: MisoString -> FetchOptions
-      options_ b = options & body ?~ b
------------------------------------------------------------------------------
-instance (KnownSymbol name, ToHttpApiData a, Fetch api) => Fetch (Header name a :> api) where
-  type ToFetch (Header name a :> api) = a -> ToFetch api
-  fetchWith Proxy options value = fetchWith (Proxy @api) o
-    where
-      headerName :: MisoString
-      headerName = ms $ symbolVal (Proxy @name)
-
-      o :: FetchOptions
-      o = options & headers <>~ [ (headerName, ms (toHeader value)) ]
------------------------------------------------------------------------------
-instance (ReflectMethod method, FromJSON a) => Fetch (Verb method code content a) where
-  type ToFetch (Verb method code content a) = (a -> JSM()) -> (MisoString -> JSM ()) -> JSM ()
-  fetchWith Proxy options success_ error_ =
-    fetchJSON url method (options ^. body) (options ^. headers) success_ error_
-    where
-      method = ms (reflectMethod (Proxy @method))
-      params = MS.concat
-        [ mconcat
-           [ ms "?"
-           , MS.intercalate (ms "&")
-             [ k <> ms "=" <> v
-             | (k,v) <- options ^. queryParams
-             ]
-           ]
-         | not $ null (options ^. queryParams)
-         ]
-      flags = MS.mconcat [ ms "?" <> k | k <- options ^. queryFlags ]
-      url = options ^. baseUrl <> options ^. currentPath <> params <> flags
------------------------------------------------------------------------------
+import           Miso.FFI.Internal (fetchJSON)