├── .gitignore ├── .gitmodules ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── docs.sh ├── ghcjs-servant-client.cabal ├── src └── Servant │ ├── Client.hs │ └── Common │ ├── BaseUrl.hs │ └── Req.hs ├── stack.yaml ├── test-server ├── LICENSE ├── Setup.hs ├── app │ └── Main.hs ├── src │ ├── Api.hs │ └── Server.hs ├── stack.yaml └── test-server.cabal └── tests ├── Api.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virthualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | .stack-work 12 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - 7.8 5 | 6 | before_install: 7 | - git clone https://github.com/haskell-servant/servant.git 8 | - cabal sandbox init 9 | - cabal sandbox add-source servant/ 10 | 11 | notifications: 12 | irc: 13 | channels: 14 | - "irc.freenode.org#servant" 15 | template: 16 | - "%{repository}#%{build_number} - %{commit} on %{branch} by %{author}: %{message}" 17 | - "Build details: %{build_url} - Change view: %{compare_url}" 18 | skip_join: true 19 | on_success: change 20 | on_failure: always 21 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for ghcjs-servant-client 2 | 3 | ## 0.1.1.1 -- 2016-11-21 4 | 5 | * Relax base restriction. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Plow Technologies 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-client 2 | 3 | ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) 4 | 5 | This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice. 6 | 7 | ## Example 8 | 9 | ``` haskell 10 | type MyApi = "books" :> Get '[JSON] [Book] -- GET /books 11 | :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books 12 | 13 | myApi :: Proxy MyApi 14 | myApi = Proxy 15 | 16 | getAllBooks :: EitherT String IO [Book] 17 | postNewBook :: Book -> EitherT String IO Book 18 | -- 'client' allows you to produce operations to query an API from a client. 19 | (getAllBooks :<|> postNewBook) = client myApi host 20 | where host = BaseUrl Http "localhost" 8080 21 | ``` 22 | 23 | ## Testing 24 | 25 | Testing right now is a bit fragile. It makes the following assumptions: 26 | 27 | You are running the GHC servant-server in test-server: 28 | 29 | ``` 30 | cd test-server 31 | stack build 32 | stack exec test-server 33 | ``` 34 | 35 | And that you have the node package `xmlhttprequest` in the node directory that 36 | GHJCS is pointing to (on my computer it is `~/node_modules`, it may differ on 37 | your system). 38 | 39 | Then you can run: 40 | 41 | ``` 42 | stack setup 43 | stack test 44 | ``` 45 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /docs.sh: -------------------------------------------------------------------------------- 1 | SERVANT_DIR=/tmp/servant-client-gh-pages 2 | 3 | # Make a temporary clone 4 | 5 | rm -rf $SERVANT_DIR 6 | 7 | git clone . $SERVANT_DIR 8 | 9 | cd $SERVANT_DIR 10 | 11 | # Make sure to pull the latest 12 | 13 | git remote add haskell-servant git@github.com:haskell-servant/servant-client.git 14 | 15 | git fetch haskell-servant 16 | 17 | git reset --hard haskell-servant/gh-pages 18 | 19 | # Clear everything away 20 | 21 | git rm -rf $SERVANT_DIR/* 22 | 23 | # Switch back and build the haddocks 24 | 25 | cd - 26 | 27 | cabal configure --builddir=$SERVANT_DIR 28 | 29 | cabal haddock --hoogle --hyperlink-source --html-location='https://hackage.haskell.org/package/$pkg-$version/docs' --builddir=$SERVANT_DIR 30 | 31 | commit_hash=$(git rev-parse HEAD) 32 | 33 | # Move the HTML docs to the root 34 | 35 | cd $SERVANT_DIR 36 | 37 | rm * 38 | rm -rf build 39 | mv doc/html/servant-client/* . 40 | rm -r doc/ 41 | 42 | # Add everything 43 | 44 | git add . 45 | 46 | git commit -m "Built from $commit_hash" 47 | 48 | # Push to update the pages 49 | 50 | git push haskell-servant HEAD:gh-pages 51 | 52 | rm -rf $SERVANT_DIR 53 | -------------------------------------------------------------------------------- /ghcjs-servant-client.cabal: -------------------------------------------------------------------------------- 1 | name: ghcjs-servant-client 2 | version: 1.1.1.1 3 | synopsis: undefined 4 | description: undefined 5 | license: MIT 6 | license-file: LICENSE 7 | author: Kevin Cotrone, Michael Sewell, James M.C. Haver II 8 | maintainer: kevincotrone@gmail.com, michael.sewell@plowtech.net, mchaver@gmail.com 9 | copyright: 2016 Plow Technologies 10 | category: Web 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | Bug-reports: http://github.com/plow-technologies/ghcjs-servant-client/issues 14 | 15 | library 16 | hs-source-dirs: src 17 | default-language: Haskell2010 18 | ghc-options: -Wall 19 | exposed-modules: Servant.Client 20 | Servant.Common.BaseUrl 21 | Servant.Common.Req 22 | build-depends: base >=4.7 && <5 23 | , aeson 24 | , attoparsec 25 | , bytestring 26 | , case-insensitive 27 | , either 28 | , exceptions 29 | , ghcjs-base 30 | , ghcjs-ffiqq 31 | , ghcjs-prim 32 | , http-api-data 33 | , http-media 34 | , http-types 35 | , network-uri >= 2.6 36 | , primitive 37 | , safe 38 | , servant == 0.9.* 39 | , split 40 | , string-conversions 41 | , text 42 | , transformers 43 | 44 | 45 | test-suite ghcjs-servant-client-tests 46 | hs-source-dirs: tests 47 | default-language: Haskell2010 48 | type: exitcode-stdio-1.0 49 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 50 | main-is: Spec.hs 51 | other-modules: Api 52 | build-depends: base >= 4 && < 5 53 | , aeson 54 | -- , bytestring 55 | , either 56 | , ghcjs-base 57 | , ghcjs-ffiqq 58 | , ghcjs-hspec-json 59 | , ghcjs-jsval-combinators 60 | , ghcjs-servant-client 61 | , hspec 62 | , servant 63 | , text 64 | , transformers 65 | -- , QuickCheck 66 | -- , text 67 | -- , time 68 | 69 | source-repository head 70 | type: git 71 | location: http://github.com/plow-technologies/ghcjs-servant-client.git 72 | -------------------------------------------------------------------------------- /src/Servant/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE InstanceSigs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | #if !MIN_VERSION_base(4,8,0) 13 | {-# LANGUAGE OverlappingInstances #-} 14 | #endif 15 | -- | This module provides 'client' which can automatically generate 16 | -- querying functions for each endpoint just from the type representing your 17 | -- API. 18 | module Servant.Client 19 | ( client 20 | , printServantError 21 | , HasClient(..) 22 | , ServantError(..) 23 | , module Servant.Common.BaseUrl 24 | ) where 25 | 26 | #if !MIN_VERSION_base(4,8,0) 27 | import Control.Applicative ((<$>)) 28 | #endif 29 | import Control.Monad 30 | import Control.Monad.Trans.Either 31 | import Data.List 32 | import Data.Proxy 33 | import Data.String.Conversions 34 | import Data.Text (unpack) 35 | import GHC.TypeLits 36 | import Network.HTTP.Media hiding (Accept) 37 | import qualified Network.HTTP.Types as H 38 | import qualified Network.HTTP.Types.Header as HTTP 39 | import Servant.API 40 | import Servant.Common.BaseUrl 41 | import Servant.Common.Req 42 | 43 | 44 | import Data.JSString (JSString(..)) 45 | import GHCJS.Marshal 46 | import GHCJS.Types 47 | 48 | -- * Accessing APIs as a Client 49 | 50 | -- | 'client' allows you to produce operations to query an API from a client. 51 | -- 52 | -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books 53 | -- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books 54 | -- > 55 | -- > myApi :: Proxy MyApi 56 | -- > myApi = Proxy 57 | -- > 58 | -- > getAllBooks :: EitherT String IO [Book] 59 | -- > postNewBook :: Book -> EitherT String IO Book 60 | -- > (getAllBooks :<|> postNewBook) = client myApi host 61 | -- > where host = BaseUrl Http "localhost" 8080 62 | client :: HasClient layout => Proxy layout -> Maybe BaseUrl -> Client layout 63 | client p baseurl = clientWithRoute p defReq baseurl 64 | 65 | -- | This class lets us define how each API combinator 66 | -- influences the creation of an HTTP request. It's mostly 67 | -- an internal class, you can just use 'client'. 68 | class HasClient layout where 69 | type Client layout :: * 70 | clientWithRoute :: Proxy layout -> Req -> Maybe BaseUrl -> Client layout 71 | 72 | {-type Client layout = Client layout-} 73 | 74 | -- | A client querying function for @a ':<|>' b@ will actually hand you 75 | -- one function for querying @a@ and another one for querying @b@, 76 | -- stitching them together with ':<|>', which really is just like a pair. 77 | -- 78 | -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books 79 | -- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books 80 | -- > 81 | -- > myApi :: Proxy MyApi 82 | -- > myApi = Proxy 83 | -- > 84 | -- > getAllBooks :: EitherT String IO [Book] 85 | -- > postNewBook :: Book -> EitherT String IO Book 86 | -- > (getAllBooks :<|> postNewBook) = client myApi host 87 | -- > where host = BaseUrl Http "localhost" 8080 88 | instance (HasClient a, HasClient b) => HasClient (a :<|> b) where 89 | type Client (a :<|> b) = Client a :<|> Client b 90 | clientWithRoute Proxy req baseurl = 91 | clientWithRoute (Proxy :: Proxy a) req baseurl :<|> 92 | clientWithRoute (Proxy :: Proxy b) req baseurl 93 | 94 | -- | If you use a 'Capture' in one of your endpoints in your API, 95 | -- the corresponding querying function will automatically take 96 | -- an additional argument of the type specified by your 'Capture'. 97 | -- That function will take care of inserting a textual representation 98 | -- of this value at the right place in the request path. 99 | -- 100 | -- You can control how values for this type are turned into 101 | -- text by specifying a 'ToText' instance for your type. 102 | -- 103 | -- Example: 104 | -- 105 | -- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book 106 | -- > 107 | -- > myApi :: Proxy MyApi 108 | -- > myApi = Proxy 109 | -- > 110 | -- > getBook :: Text -> EitherT String IO Book 111 | -- > getBook = client myApi host 112 | -- > where host = BaseUrl Http "localhost" 8080 113 | -- > -- then you can just use "getBook" to query that endpoint 114 | 115 | instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) 116 | => HasClient (Capture capture a :> sublayout) where 117 | 118 | type Client (Capture capture a :> sublayout) = 119 | a -> Client sublayout 120 | 121 | clientWithRoute Proxy req baseurl val = 122 | clientWithRoute (Proxy :: Proxy sublayout) 123 | (appendToPath p req) 124 | baseurl 125 | 126 | where p = unpack (toUrlPiece val) 127 | 128 | 129 | instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) 130 | => HasClient (CaptureAll capture a :> sublayout) where 131 | 132 | type Client (CaptureAll capture a :> sublayout) = 133 | [a] -> Client sublayout 134 | 135 | clientWithRoute Proxy req baseurl vals = 136 | clientWithRoute (Proxy :: Proxy sublayout) 137 | (foldl' (flip appendToPath) req ps) 138 | baseurl 139 | where ps = map (unpack . toUrlPiece) vals 140 | 141 | -- | If you have a 'Delete' endpoint in your API, the client 142 | -- side querying function that is created when calling 'client' 143 | -- will just require an argument that specifies the scheme, host 144 | -- and port to send the request to. 145 | instance 146 | #if MIN_VERSION_base(4,8,0) 147 | {-# OVERLAPPABLE #-} 148 | #endif 149 | -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances 150 | (GHCJSUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where 151 | type Client (Delete cts' a) = EitherT ServantError IO a 152 | clientWithRoute Proxy req baseurl = 153 | snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl 154 | 155 | -- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content 156 | -- HTTP header. 157 | instance 158 | #if MIN_VERSION_base(4,8,0) 159 | {-# OVERLAPPING #-} 160 | #endif 161 | HasClient (Delete cts ()) where 162 | type Client (Delete cts ()) = EitherT ServantError IO () 163 | clientWithRoute Proxy req baseurl = 164 | void $ performRequestNoBody H.methodDelete req [204] baseurl 165 | 166 | -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the 167 | -- corresponding headers. 168 | instance 169 | #if MIN_VERSION_base(4,8,0) 170 | {-# OVERLAPPING #-} 171 | #endif 172 | -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances 173 | ( GHCJSUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) 174 | ) => HasClient (Delete cts' (Headers ls a)) where 175 | type Client (Delete cts' (Headers ls a)) = EitherT ServantError IO (Headers ls a) 176 | clientWithRoute Proxy req baseurl = do 177 | (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl 178 | return $ Headers { getResponse = resp 179 | , getHeadersHList = buildHeadersTo hdrs 180 | } 181 | 182 | -- | If you have a 'Get' endpoint in your API, the client 183 | -- side querying function that is created when calling 'client' 184 | -- will just require an argument that specifies the scheme, host 185 | -- and port to send the request to. 186 | instance 187 | #if MIN_VERSION_base(4,8,0) 188 | {-# OVERLAPPABLE #-} 189 | #endif 190 | (GHCJSUnrender ct result) => HasClient (Get (ct ': cts) result) where 191 | type Client (Get (ct ': cts) result) = EitherT ServantError IO result 192 | clientWithRoute Proxy req baseurl = 193 | snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl 194 | 195 | -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content 196 | -- HTTP status. 197 | instance 198 | #if MIN_VERSION_base(4,8,0) 199 | {-# OVERLAPPING #-} 200 | #endif 201 | HasClient (Get (ct ': cts) ()) where 202 | type Client (Get (ct ': cts) ()) = EitherT ServantError IO () 203 | clientWithRoute Proxy req baseurl = 204 | performRequestNoBody H.methodGet req [204] baseurl 205 | 206 | -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the 207 | -- corresponding headers. 208 | instance 209 | #if MIN_VERSION_base(4,8,0) 210 | {-# OVERLAPPING #-} 211 | #endif 212 | ( GHCJSUnrender ct a, BuildHeadersTo ls 213 | ) => HasClient (Get (ct ': cts) (Headers ls a)) where 214 | type Client (Get (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a) 215 | clientWithRoute Proxy req baseurl = do 216 | (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl 217 | return $ Headers { getResponse = resp 218 | , getHeadersHList = buildHeadersTo hdrs 219 | } 220 | 221 | -- | If you use a 'Header' in one of your endpoints in your API, 222 | -- the corresponding querying function will automatically take 223 | -- an additional argument of the type specified by your 'Header', 224 | -- wrapped in Maybe. 225 | -- 226 | -- That function will take care of encoding this argument as Text 227 | -- in the request headers. 228 | -- 229 | -- All you need is for your type to have a 'ToText' instance. 230 | -- 231 | -- Example: 232 | -- 233 | -- > newtype Referer = Referer { referrer :: Text } 234 | -- > deriving (Eq, Show, Generic, FromText, ToText) 235 | -- > 236 | -- > -- GET /view-my-referer 237 | -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer 238 | -- > 239 | -- > myApi :: Proxy MyApi 240 | -- > myApi = Proxy 241 | -- > 242 | -- > viewReferer :: Maybe Referer -> EitherT String IO Book 243 | -- > viewReferer = client myApi host 244 | -- > where host = BaseUrl Http "localhost" 8080 245 | -- > -- then you can just use "viewRefer" to query that endpoint 246 | -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments 247 | instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) 248 | => HasClient (Header sym a :> sublayout) where 249 | 250 | type Client (Header sym a :> sublayout) = 251 | Maybe a -> Client sublayout 252 | 253 | clientWithRoute Proxy req baseurl mval = 254 | clientWithRoute (Proxy :: Proxy sublayout) 255 | (maybe req 256 | (\value -> Servant.Common.Req.addHeader hname value req) 257 | mval 258 | ) 259 | baseurl 260 | 261 | where hname = symbolVal (Proxy :: Proxy sym) 262 | 263 | -- | If you have a 'Post' endpoint in your API, the client 264 | -- side querying function that is created when calling 'client' 265 | -- will just require an argument that specifies the scheme, host 266 | -- and port to send the request to. 267 | instance 268 | #if MIN_VERSION_base(4,8,0) 269 | {-# OVERLAPPABLE #-} 270 | #endif 271 | (GHCJSUnrender ct a) => HasClient (Post (ct ': cts) a) where 272 | type Client (Post (ct ': cts) a) = EitherT ServantError IO a 273 | clientWithRoute Proxy req baseurl = 274 | snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl 275 | 276 | -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content 277 | -- HTTP header. 278 | instance 279 | #if MIN_VERSION_base(4,8,0) 280 | {-# OVERLAPPING #-} 281 | #endif 282 | HasClient (Post (ct ': cts) ()) where 283 | type Client (Post (ct ': cts) ()) = EitherT ServantError IO () 284 | clientWithRoute Proxy req baseurl = 285 | void $ performRequestNoBody H.methodPost req [204] baseurl 286 | 287 | -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the 288 | -- corresponding headers. 289 | instance 290 | #if MIN_VERSION_base(4,8,0) 291 | {-# OVERLAPPING #-} 292 | #endif 293 | ( GHCJSUnrender ct a, BuildHeadersTo ls 294 | ) => HasClient (Post (ct ': cts) (Headers ls a)) where 295 | type Client (Post (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a) 296 | clientWithRoute Proxy req baseurl = do 297 | (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl 298 | return $ Headers { getResponse = resp 299 | , getHeadersHList = buildHeadersTo hdrs 300 | } 301 | 302 | -- | If you have a 'Put' endpoint in your API, the client 303 | -- side querying function that is created when calling 'client' 304 | -- will just require an argument that specifies the scheme, host 305 | -- and port to send the request to. 306 | instance 307 | #if MIN_VERSION_base(4,8,0) 308 | {-# OVERLAPPABLE #-} 309 | #endif 310 | (GHCJSUnrender ct a) => HasClient (Put (ct ': cts) a) where 311 | type Client (Put (ct ': cts) a) = EitherT ServantError IO a 312 | clientWithRoute Proxy req baseurl = 313 | snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl 314 | 315 | -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content 316 | -- HTTP header. 317 | instance 318 | #if MIN_VERSION_base(4,8,0) 319 | {-# OVERLAPPING #-} 320 | #endif 321 | HasClient (Put (ct ': cts) ()) where 322 | type Client (Put (ct ': cts) ()) = EitherT ServantError IO () 323 | clientWithRoute Proxy req baseurl = 324 | void $ performRequestNoBody H.methodPut req [204] baseurl 325 | 326 | -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the 327 | -- corresponding headers. 328 | instance 329 | #if MIN_VERSION_base(4,8,0) 330 | {-# OVERLAPPING #-} 331 | #endif 332 | ( GHCJSUnrender ct a, BuildHeadersTo ls 333 | ) => HasClient (Put (ct ': cts) (Headers ls a)) where 334 | type Client (Put (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a) 335 | clientWithRoute Proxy req baseurl = do 336 | (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl 337 | return $ Headers { getResponse = resp 338 | , getHeadersHList = buildHeadersTo hdrs 339 | } 340 | 341 | -- | If you have a 'Patch' endpoint in your API, the client 342 | -- side querying function that is created when calling 'client' 343 | -- will just require an argument that specifies the scheme, host 344 | -- and port to send the request to. 345 | instance 346 | #if MIN_VERSION_base(4,8,0) 347 | {-# OVERLAPPABLE #-} 348 | #endif 349 | (GHCJSUnrender ct a) => HasClient (Patch (ct ': cts) a) where 350 | type Client (Patch (ct ': cts) a) = EitherT ServantError IO a 351 | clientWithRoute Proxy req baseurl = 352 | snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl 353 | 354 | -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content 355 | -- HTTP header. 356 | instance 357 | #if MIN_VERSION_base(4,8,0) 358 | {-# OVERLAPPING #-} 359 | #endif 360 | HasClient (Patch (ct ': cts) ()) where 361 | type Client (Patch (ct ': cts) ()) = EitherT ServantError IO () 362 | clientWithRoute Proxy req baseurl = 363 | void $ performRequestNoBody H.methodPatch req [204] baseurl 364 | 365 | -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the 366 | -- corresponding headers. 367 | instance 368 | #if MIN_VERSION_base(4,8,0) 369 | {-# OVERLAPPING #-} 370 | #endif 371 | ( GHCJSUnrender ct a, BuildHeadersTo ls 372 | ) => HasClient (Patch (ct ': cts) (Headers ls a)) where 373 | type Client (Patch (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a) 374 | clientWithRoute Proxy req baseurl = do 375 | (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl 376 | return $ Headers { getResponse = resp 377 | , getHeadersHList = buildHeadersTo hdrs 378 | } 379 | 380 | -- | If you use a 'QueryParam' in one of your endpoints in your API, 381 | -- the corresponding querying function will automatically take 382 | -- an additional argument of the type specified by your 'QueryParam', 383 | -- enclosed in Maybe. 384 | -- 385 | -- If you give Nothing, nothing will be added to the query string. 386 | -- 387 | -- If you give a non-'Nothing' value, this function will take care 388 | -- of inserting a textual representation of this value in the query string. 389 | -- 390 | -- You can control how values for your type are turned into 391 | -- text by specifying a 'ToText' instance for your type. 392 | -- 393 | -- Example: 394 | -- 395 | -- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] 396 | -- > 397 | -- > myApi :: Proxy MyApi 398 | -- > myApi = Proxy 399 | -- > 400 | -- > getBooksBy :: Maybe Text -> EitherT String IO [Book] 401 | -- > getBooksBy = client myApi host 402 | -- > where host = BaseUrl Http "localhost" 8080 403 | -- > -- then you can just use "getBooksBy" to query that endpoint. 404 | -- > -- 'getBooksBy Nothing' for all books 405 | -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov 406 | instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) 407 | => HasClient (QueryParam sym a :> sublayout) where 408 | 409 | type Client (QueryParam sym a :> sublayout) = 410 | Maybe a -> Client sublayout 411 | 412 | -- if mparam = Nothing, we don't add it to the query string 413 | clientWithRoute Proxy req baseurl mparam = 414 | clientWithRoute (Proxy :: Proxy sublayout) 415 | (maybe req 416 | (flip (appendToQueryString pname) req . Just) 417 | mparamText 418 | ) 419 | baseurl 420 | 421 | where pname = cs pname' 422 | pname' = symbolVal (Proxy :: Proxy sym) 423 | mparamText = fmap toQueryParam mparam 424 | 425 | -- | If you use a 'QueryParams' in one of your endpoints in your API, 426 | -- the corresponding querying function will automatically take 427 | -- an additional argument, a list of values of the type specified 428 | -- by your 'QueryParams'. 429 | -- 430 | -- If you give an empty list, nothing will be added to the query string. 431 | -- 432 | -- Otherwise, this function will take care 433 | -- of inserting a textual representation of your values in the query string, 434 | -- under the same query string parameter name. 435 | -- 436 | -- You can control how values for your type are turned into 437 | -- text by specifying a 'ToText' instance for your type. 438 | -- 439 | -- Example: 440 | -- 441 | -- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] 442 | -- > 443 | -- > myApi :: Proxy MyApi 444 | -- > myApi = Proxy 445 | -- > 446 | -- > getBooksBy :: [Text] -> EitherT String IO [Book] 447 | -- > getBooksBy = client myApi host 448 | -- > where host = BaseUrl Http "localhost" 8080 449 | -- > -- then you can just use "getBooksBy" to query that endpoint. 450 | -- > -- 'getBooksBy []' for all books 451 | -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' 452 | -- > -- to get all books by Asimov and Heinlein 453 | instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) 454 | => HasClient (QueryParams sym a :> sublayout) where 455 | 456 | type Client (QueryParams sym a :> sublayout) = 457 | [a] -> Client sublayout 458 | 459 | clientWithRoute Proxy req baseurl paramlist = 460 | clientWithRoute (Proxy :: Proxy sublayout) 461 | (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) 462 | req 463 | paramlist' 464 | ) 465 | baseurl 466 | 467 | where pname = cs pname' 468 | pname' = symbolVal (Proxy :: Proxy sym) 469 | paramlist' = map (Just . toQueryParam) paramlist 470 | 471 | -- | If you use a 'QueryFlag' in one of your endpoints in your API, 472 | -- the corresponding querying function will automatically take 473 | -- an additional 'Bool' argument. 474 | -- 475 | -- If you give 'False', nothing will be added to the query string. 476 | -- 477 | -- Otherwise, this function will insert a value-less query string 478 | -- parameter under the name associated to your 'QueryFlag'. 479 | -- 480 | -- Example: 481 | -- 482 | -- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] 483 | -- > 484 | -- > myApi :: Proxy MyApi 485 | -- > myApi = Proxy 486 | -- > 487 | -- > getBooks :: Bool -> EitherT String IO [Book] 488 | -- > getBooks = client myApi host 489 | -- > where host = BaseUrl Http "localhost" 8080 490 | -- > -- then you can just use "getBooks" to query that endpoint. 491 | -- > -- 'getBooksBy False' for all books 492 | -- > -- 'getBooksBy True' to only get _already published_ books 493 | instance (KnownSymbol sym, HasClient sublayout) 494 | => HasClient (QueryFlag sym :> sublayout) where 495 | 496 | type Client (QueryFlag sym :> sublayout) = 497 | Bool -> Client sublayout 498 | 499 | clientWithRoute Proxy req baseurl flag = 500 | clientWithRoute (Proxy :: Proxy sublayout) 501 | (if flag 502 | then appendToQueryString paramname Nothing req 503 | else req 504 | ) 505 | baseurl 506 | 507 | where paramname = cs $ symbolVal (Proxy :: Proxy sym) 508 | 509 | -- | If you use a 'MatrixParam' in one of your endpoints in your API, 510 | -- the corresponding querying function will automatically take 511 | -- an additional argument of the type specified by your 'MatrixParam', 512 | -- enclosed in Maybe. 513 | -- 514 | -- If you give Nothing, nothing will be added to the query string. 515 | -- 516 | -- If you give a non-'Nothing' value, this function will take care 517 | -- of inserting a textual representation of this value in the query string. 518 | -- 519 | -- You can control how values for your type are turned into 520 | -- text by specifying a 'ToText' instance for your type. 521 | -- 522 | -- Example: 523 | -- 524 | -- > type MyApi = "books" :> MatrixParam "author" Text :> Get '[JSON] [Book] 525 | -- > 526 | -- > myApi :: Proxy MyApi 527 | -- > myApi = Proxy 528 | -- > 529 | -- > getBooksBy :: Maybe Text -> EitherT String IO [Book] 530 | -- > getBooksBy = client myApi host 531 | -- > where host = BaseUrl Http "localhost" 8080 532 | -- > -- then you can just use "getBooksBy" to query that endpoint. 533 | -- > -- 'getBooksBy Nothing' for all books 534 | -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov 535 | 536 | {- 537 | instance (KnownSymbol sym, ToText a, HasClient sublayout) 538 | => HasClient (MatrixParam sym a :> sublayout) where 539 | 540 | type Client (MatrixParam sym a :> sublayout) = 541 | Maybe a -> Client sublayout 542 | 543 | -- if mparam = Nothing, we don't add it to the query string 544 | clientWithRoute Proxy req baseurl mparam = 545 | clientWithRoute (Proxy :: Proxy sublayout) 546 | (maybe req 547 | (flip (appendToMatrixParams pname . Just) req) 548 | mparamText 549 | ) 550 | baseurl 551 | 552 | where pname = symbolVal (Proxy :: Proxy sym) 553 | mparamText = fmap (cs . toText) mparam 554 | -} 555 | 556 | -- | If you use a 'MatrixParams' in one of your endpoints in your API, 557 | -- the corresponding querying function will automatically take an 558 | -- additional argument, a list of values of the type specified by your 559 | -- 'MatrixParams'. 560 | -- 561 | -- If you give an empty list, nothing will be added to the query string. 562 | -- 563 | -- Otherwise, this function will take care of inserting a textual 564 | -- representation of your values in the path segment string, under the 565 | -- same matrix string parameter name. 566 | -- 567 | -- You can control how values for your type are turned into text by 568 | -- specifying a 'ToText' instance for your type. 569 | -- 570 | -- Example: 571 | -- 572 | -- > type MyApi = "books" :> MatrixParams "authors" Text :> Get '[JSON] [Book] 573 | -- > 574 | -- > myApi :: Proxy MyApi 575 | -- > myApi = Proxy 576 | -- > 577 | -- > getBooksBy :: [Text] -> EitherT String IO [Book] 578 | -- > getBooksBy = client myApi host 579 | -- > where host = BaseUrl Http "localhost" 8080 580 | -- > -- then you can just use "getBooksBy" to query that endpoint. 581 | -- > -- 'getBooksBy []' for all books 582 | -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' 583 | -- > -- to get all books by Asimov and Heinlein 584 | 585 | {- 586 | instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) 587 | => HasClient (MatrixParams sym a :> sublayout) where 588 | 589 | type Client (MatrixParams sym a :> sublayout) = 590 | [a] -> Client sublayout 591 | 592 | clientWithRoute Proxy req baseurl paramlist = 593 | clientWithRoute (Proxy :: Proxy sublayout) 594 | (foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) 595 | req 596 | paramlist' 597 | ) 598 | baseurl 599 | 600 | where pname = cs pname' 601 | pname' = symbolVal (Proxy :: Proxy sym) 602 | paramlist' = map (Just . toQueryParam) paramlist 603 | -} 604 | -- | If you use a 'MatrixFlag' in one of your endpoints in your API, 605 | -- the corresponding querying function will automatically take an 606 | -- additional 'Bool' argument. 607 | -- 608 | -- If you give 'False', nothing will be added to the path segment. 609 | -- 610 | -- Otherwise, this function will insert a value-less matrix parameter 611 | -- under the name associated to your 'MatrixFlag'. 612 | -- 613 | -- Example: 614 | -- 615 | -- > type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book] 616 | -- > 617 | -- > myApi :: Proxy MyApi 618 | -- > myApi = Proxy 619 | -- > 620 | -- > getBooks :: Bool -> EitherT String IO [Book] 621 | -- > getBooks = client myApi host 622 | -- > where host = BaseUrl Http "localhost" 8080 623 | -- > -- then you can just use "getBooks" to query that endpoint. 624 | -- > -- 'getBooksBy False' for all books 625 | -- > -- 'getBooksBy True' to only get _already published_ books 626 | 627 | {- 628 | instance (KnownSymbol sym, HasClient sublayout) 629 | => HasClient (MatrixFlag sym :> sublayout) where 630 | 631 | type Client (MatrixFlag sym :> sublayout) = 632 | Bool -> Client sublayout 633 | 634 | clientWithRoute Proxy req baseurl flag = 635 | clientWithRoute (Proxy :: Proxy sublayout) 636 | (if flag 637 | then appendToMatrixParams paramname Nothing req 638 | else req 639 | ) 640 | baseurl 641 | 642 | where paramname = cs $ symbolVal (Proxy :: Proxy sym) 643 | -} 644 | -- | Pick a 'Method' and specify where the server you want to query is. You get 645 | -- back the full `Response`. 646 | instance HasClient Raw where 647 | type Client Raw = H.Method -> EitherT ServantError IO (Int, JSVal, MediaType, [HTTP.Header]) 648 | 649 | clientWithRoute :: Proxy Raw -> Req -> Maybe BaseUrl -> Client Raw 650 | clientWithRoute Proxy req baseurl httpMethod = do 651 | performRequest httpMethod req (const True) baseurl 652 | 653 | -- | If you use a 'ReqBody' in one of your endpoints in your API, 654 | -- the corresponding querying function will automatically take 655 | -- an additional argument of the type specified by your 'ReqBody'. 656 | -- That function will take care of encoding this argument as JSON and 657 | -- of using it as the request body. 658 | -- 659 | -- All you need is for your type to have a 'ToJSON' instance. 660 | -- 661 | -- Example: 662 | -- 663 | -- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book 664 | -- > 665 | -- > myApi :: Proxy MyApi 666 | -- > myApi = Proxy 667 | -- > 668 | -- > addBook :: Book -> EitherT String IO Book 669 | -- > addBook = client myApi host 670 | -- > where host = BaseUrl Http "localhost" 8080 671 | -- > -- then you can just use "addBook" to query that endpoint 672 | instance (GHCJSRender ct a, HasClient sublayout) 673 | => HasClient (ReqBody (ct ': cts) a :> sublayout) where 674 | 675 | type Client (ReqBody (ct ': cts) a :> sublayout) = 676 | a -> Client sublayout 677 | 678 | clientWithRoute Proxy req baseurl body = 679 | clientWithRoute (Proxy :: Proxy sublayout) 680 | (let ctProxy = Proxy :: Proxy ct 681 | in setRQBody (ghcjsRender ctProxy body) 682 | (contentType ctProxy) 683 | req 684 | ) 685 | baseurl 686 | 687 | -- | Make the querying function append @path@ to the request path. 688 | instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where 689 | type Client (path :> sublayout) = Client sublayout 690 | 691 | clientWithRoute Proxy req baseurl = 692 | clientWithRoute (Proxy :: Proxy sublayout) 693 | (appendToPath p req) 694 | baseurl 695 | 696 | where p = symbolVal (Proxy :: Proxy path) 697 | 698 | 699 | class Accept ctype => GHCJSRender ctype a where 700 | ghcjsRender :: Proxy ctype -> a -> IO JSVal 701 | 702 | instance ToJSVal a => GHCJSRender JSON a where 703 | ghcjsRender _ = toJSVal 704 | -------------------------------------------------------------------------------- /src/Servant/Common/BaseUrl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | module Servant.Common.BaseUrl ( 5 | -- * types 6 | BaseUrl (..) 7 | , InvalidBaseUrlException 8 | , Scheme (..) 9 | -- * functions 10 | , parseBaseUrl 11 | , showBaseUrl 12 | ) where 13 | 14 | import Control.Monad.Catch (MonadThrow, throwM, Exception) 15 | import Data.List 16 | import Data.Typeable 17 | import GHC.Generics 18 | import Network.URI 19 | import Safe 20 | import Text.Read 21 | 22 | -- | URI scheme to use 23 | data Scheme = 24 | Http -- ^ http:// 25 | | Https -- ^ https:// 26 | deriving (Show, Eq, Ord, Generic) 27 | 28 | -- | Simple data type to represent the target of HTTP requests 29 | -- for servant's automatically-generated clients. 30 | data BaseUrl = BaseUrl 31 | { baseUrlScheme :: Scheme -- ^ URI scheme to use 32 | , baseUrlHost :: String -- ^ host (eg "haskell.org") 33 | , baseUrlPort :: Int -- ^ port (eg 80) 34 | } deriving (Show, Eq, Ord, Generic) 35 | 36 | showBaseUrl :: BaseUrl -> String 37 | showBaseUrl (BaseUrl urlscheme host port) = 38 | schemeString ++ "//" ++ host ++ portString 39 | where 40 | schemeString = case urlscheme of 41 | Http -> "http:" 42 | Https -> "https:" 43 | portString = case (urlscheme, port) of 44 | (Http, 80) -> "" 45 | (Https, 443) -> "" 46 | _ -> ":" ++ show port 47 | 48 | data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable) 49 | instance Exception InvalidBaseUrlException 50 | 51 | parseBaseUrl :: MonadThrow m => String -> m BaseUrl 52 | parseBaseUrl s = case parseURI (removeTrailingSlash s) of 53 | -- This is a rather hacky implementation and should be replaced with something 54 | -- implemented in attoparsec (which is already a dependency anyhow (via aeson)). 55 | Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> 56 | return (BaseUrl Http host port) 57 | Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") -> 58 | return (BaseUrl Http host 80) 59 | Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> 60 | return (BaseUrl Https host port) 61 | Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> 62 | return (BaseUrl Https host 443) 63 | _ -> if "://" `isInfixOf` s 64 | then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) 65 | else parseBaseUrl ("http://" ++ s) 66 | where 67 | removeTrailingSlash str = case lastMay str of 68 | Just '/' -> init str 69 | _ -> str 70 | -------------------------------------------------------------------------------- /src/Servant/Common/Req.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeSynonymInstances #-} 11 | 12 | module Servant.Common.Req where 13 | 14 | #if !MIN_VERSION_base(4,8,0) 15 | import Control.Applicative 16 | #endif 17 | 18 | import Control.Concurrent.MVar 19 | import Control.Exception 20 | import Control.Monad 21 | import Control.Monad.Catch (MonadThrow) 22 | import Control.Monad.IO.Class 23 | import Control.Monad.Trans.Either 24 | import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, unpack) 25 | import Data.ByteString.Char8 (unpack, pack) 26 | import qualified Data.ByteString as BS 27 | import Data.CaseInsensitive 28 | import Data.Char 29 | import Data.IORef 30 | import Data.JSString (JSString) 31 | import qualified Data.JSString as JSString 32 | import Data.String 33 | import Data.String.Conversions 34 | import Data.Proxy 35 | import Data.Text (Text) 36 | import Data.Text.Encoding 37 | import qualified Data.Text as T 38 | import Data.List.Split 39 | import Data.Maybe 40 | import Data.Text.Encoding 41 | import Data.Typeable 42 | import Data.Primitive.Addr 43 | import Data.Primitive.ByteArray 44 | import Data.ByteString.Unsafe (unsafePackAddressLen) 45 | import GHCJS.Foreign (jsTrue, jsFalse) 46 | import GHCJS.Foreign.Callback ( Callback (..) 47 | , OnBlocked(..) 48 | , syncCallback) 49 | import GHCJS.Foreign.QQ 50 | import GHCJS.Marshal 51 | import GHCJS.Prim 52 | import Network.HTTP.Media hiding (Accept) 53 | import Network.HTTP.Types 54 | import qualified Network.HTTP.Types.Header as HTTP 55 | import Network.URI 56 | import Servant.API.ContentTypes 57 | import Servant.Common.BaseUrl 58 | 59 | import System.IO.Unsafe 60 | import Unsafe.Coerce 61 | import Web.HttpApiData 62 | 63 | 64 | 65 | data ServantError 66 | = FailureResponse 67 | { responseStatus :: Status 68 | , responseContentType :: MediaType 69 | , responseBody :: JSVal 70 | } 71 | | DecodeFailure 72 | { decodeError :: String 73 | , responseContentType :: MediaType 74 | , responseBody :: JSVal 75 | } 76 | | UnsupportedContentType 77 | { responseContentType :: MediaType 78 | , responseBody :: JSVal 79 | } 80 | | InvalidContentTypeHeader 81 | { responseContentTypeHeader :: ByteString 82 | , responseBody :: JSVal 83 | } 84 | deriving (Typeable) 85 | 86 | 87 | -- there is no show instance because fromJSVal is an IO function 88 | printServantError :: ServantError -> IO () 89 | printServantError (FailureResponse x y z) = do 90 | print "FailureResponse" 91 | print x 92 | print y 93 | pz <- (fromJSVal z :: IO (Maybe JSString)) 94 | print pz 95 | printServantError (DecodeFailure x y z) = do 96 | print "DecodeFailure" 97 | print x 98 | print y 99 | pz <- (fromJSVal z :: IO (Maybe JSString)) 100 | print pz 101 | printServantError (UnsupportedContentType x y) = do 102 | print "UnsupportedContentType" 103 | print x 104 | py <- (fromJSVal y :: IO (Maybe JSString)) 105 | print py 106 | printServantError (InvalidContentTypeHeader x y) = do 107 | print "InvalidContentTypeHeader" 108 | print x 109 | py <- (fromJSVal y :: IO (Maybe JSString)) 110 | print py 111 | 112 | data ForeignRetention 113 | = NeverRetain -- ^ do not retain data unless the callback is directly 114 | -- referenced by a Haskell thread. 115 | | AlwaysRetain -- ^ retain references indefinitely, until `freeCallback` 116 | -- is called (the callback will be kept in memory until it's freed) 117 | | DomRetain JSVal -- ^ retain data as long as the `JSVal` is a DOM element in 118 | -- `window.document` or in a DOM tree referenced by a Haskell 119 | -- thread. 120 | 121 | data Req = Req 122 | { reqPath :: String 123 | , qs :: QueryText 124 | , reqBody :: Maybe (IO JSVal, MediaType) 125 | , reqAccept :: [MediaType] 126 | , headers :: [(String, Text)] 127 | } 128 | 129 | defReq :: Req 130 | defReq = Req "" [] Nothing [] [] 131 | 132 | appendToPath :: String -> Req -> Req 133 | appendToPath p req = 134 | req { reqPath = reqPath req ++ "/" ++ p } 135 | 136 | appendToMatrixParams :: String 137 | -> Maybe String 138 | -> Req 139 | -> Req 140 | appendToMatrixParams pname pvalue req = 141 | req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue } 142 | 143 | appendToQueryString :: Text -- ^ param name 144 | -> Maybe Text -- ^ param value 145 | -> Req 146 | -> Req 147 | appendToQueryString pname pvalue req = 148 | req { qs = qs req ++ [(pname, pvalue)] 149 | } 150 | 151 | addHeader :: ToHttpApiData a => String -> a -> Req -> Req 152 | addHeader name val req = req { headers = headers req 153 | ++ [(name, decodeUtf8 (toHeader val))] 154 | } 155 | 156 | 157 | setRQBody :: IO JSVal -> MediaType -> Req -> Req 158 | setRQBody b t req = req { reqBody = Just (b, t) } 159 | 160 | displayHttpRequest :: Method -> String 161 | displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" 162 | 163 | performRequest :: Method -> Req -> (Int -> Bool) -> Maybe BaseUrl 164 | -> EitherT ServantError IO ( Int, JSVal, MediaType 165 | , [HTTP.Header]) 166 | performRequest reqMethod req isWantedStatus reqHost = do 167 | eResp <- liftIO $ makeRequest reqMethod req isWantedStatus reqHost 168 | case eResp of 169 | (Left err) -> left err 170 | (Right (status_code, hrds, body)) -> do 171 | ct <- case lookup "Content-Type" hrds of 172 | Nothing -> pure $ "application"//"octet-stream" 173 | Just t -> case parseAccept t of 174 | Nothing -> left $ InvalidContentTypeHeader (cs t) body 175 | Just t' -> pure t' 176 | return (status_code, body, ct, hrds) 177 | 178 | 179 | performRequestCT :: GHCJSUnrender ct result => 180 | Proxy ct -> Method -> Req -> [Int] -> Maybe BaseUrl -> EitherT ServantError IO ([HTTP.Header], result) 181 | performRequestCT ct reqMethod req wantedStatus reqHost = do 182 | let acceptCT = contentType ct 183 | (_status, respBody, respCT, hrds) <- 184 | performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost 185 | unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody 186 | res <- liftIO $ ghcjsUnrender ct respBody 187 | case res of 188 | Left err -> left $ DecodeFailure err respCT respBody 189 | Right val -> return (hrds, val) 190 | 191 | performRequestNoBody :: Method -> Req -> [Int] -> Maybe BaseUrl -> EitherT ServantError IO () 192 | performRequestNoBody reqMethod req wantedStatus reqHost = do 193 | _ <- performRequest reqMethod req (`elem` wantedStatus) reqHost 194 | return () 195 | 196 | 197 | 198 | -- foreign import javascript unsafe "var XMLHttpRequest = require('xmlhttprequest').XMLHttpRequest; new XMLHttpRequest();" 199 | -- tests are performed with node. it doesnt natively hav XMLHttpRequest 200 | -- this makes this function useable in node or javascript 201 | foreign import javascript unsafe "(function () {if (typeof XMLHttpRequest === 'undefined') { XMLHttpRequest = require('xmlhttprequest').XMLHttpRequest; return new XMLHttpRequest(); } else { return new XMLHttpRequest(); } }())" 202 | jsXhrRequest :: IO JSVal 203 | foreign import javascript unsafe "$1.open($2, $3, $4)" 204 | jsXhrOpen :: JSVal -> JSString -> JSString -> JSVal -> IO () 205 | foreign import javascript unsafe "$1.send()" 206 | jsXhrSend :: JSVal -> IO () 207 | foreign import javascript unsafe "$1.send($2)" 208 | jsXhrSendWith :: JSVal -> JSVal -> IO () 209 | foreign import javascript unsafe "$1.onreadystatechange = $2" 210 | jsXhrOnReadyStateChange:: JSVal -> Callback (IO ()) -> IO () 211 | foreign import javascript unsafe "$1.readyState" 212 | jsXhrReadyState:: JSVal -> IO JSVal 213 | foreign import javascript unsafe "$1.responseText" 214 | jsXhrResponseText:: JSVal -> IO JSString 215 | --foreign import javascript unsafe "$1.response" 216 | jsXhrResponse:: JSVal -> IO JSVal 217 | jsXhrResponse jsv = [jsu| 218 | (function () { 219 | var contentResponse = typeof `jsv.response; 220 | if( contentResponse == "undefined" ) { // This takes care of the lack of a 'response' field in ie9 221 | return JSON.parse(JSON.stringify(`jsv.responseText)); 222 | } else if (contentResponse == "string" ) { // IE11 bug 223 | return JSON.parse(JSON.stringify(`jsv.response)); 224 | } else { 225 | return `jsv.response; 226 | } 227 | }()) 228 | |] 229 | 230 | foreign import javascript unsafe "$1.responseType = $2" 231 | jsXhrResponseType:: JSVal -> JSString -> IO () 232 | foreign import javascript unsafe "$1.status" 233 | jsXhrStatus:: JSVal -> IO JSVal 234 | foreign import javascript unsafe "$1.getAllResponseHeaders()" 235 | jsXhrResponseHeaders :: JSVal -> IO JSString 236 | foreign import javascript unsafe "$1.setRequestHeader($2, $3)" 237 | jsXhrSetRequestHeader :: JSVal -> JSString -> JSString -> IO () 238 | foreign import javascript unsafe "$1.statusText" 239 | jsXhrGetStatusText :: JSVal -> IO JSString 240 | foreign import javascript unsafe "xh = $1" 241 | jsDebugXhr :: JSVal -> IO () 242 | foreign import javascript safe "h$wrapBuffer($3, true, $1, $2)" 243 | js_wrapBuffer :: Int -> Int -> JSVal -> IO JSVal 244 | foreign import javascript unsafe "h$release($1)" 245 | js_release :: Callback (IO ()) -> IO () 246 | foreign import javascript unsafe "JSON.stringify($1)" 247 | js_stringify :: JSVal -> IO JSVal 248 | 249 | xhrResponseHeaders :: JSVal -> IO [HTTP.Header] 250 | xhrResponseHeaders jReq = do 251 | (headers :: JSString) <- jsXhrResponseHeaders jReq 252 | let headersStrings = T.lines . T.pack . JSString.unpack $ headers 253 | return $ catMaybes $ buildHeader <$> headersStrings 254 | 255 | 256 | buildHeader :: Text -> Maybe HTTP.Header 257 | buildHeader xs = parseXs $ splitStr xs 258 | where splitStr = T.splitOn (":") 259 | parseXs :: [Text] -> Maybe HTTP.Header 260 | parseXs (c:cs) = Just (mk $ encodeUtf8 $ T.strip c, encodeUtf8 $ T.strip $ T.concat cs) 261 | parseXs _ = Nothing 262 | 263 | bufferByteString :: Int -- ^ offset from the start in bytes 264 | -> Int -- ^ length in bytes (use zero or a negative number to get the whole ArrayBuffer) 265 | -> JSVal 266 | -> IO BS.ByteString 267 | bufferByteString offset length buf = do 268 | (ByteArray ba) <- wrapBuffer offset length buf 269 | byteArrayByteString ba 270 | 271 | byteArrayByteString :: ByteArray# -> IO BS.ByteString 272 | byteArrayByteString arr = 273 | #ifdef ghcjs_HOST_OS 274 | let ba = ByteArray arr 275 | !(Addr a) = byteArrayContents ba 276 | in unsafePackAddressLen (sizeofByteArray ba) a 277 | #else 278 | error "GHCJS.Foreign.byteArrayToByteString: not JS" 279 | #endif 280 | 281 | wrapBuffer :: Int -- ^ offset from the start in bytes, if this is not a multiple of 8, 282 | -- not all types can be read from the ByteArray# 283 | -> Int -- ^ length in bytes (use zero or a negative number to use the whole ArrayBuffer) 284 | -> JSVal -- ^ JavaScript ArrayBuffer object 285 | -> IO ByteArray -- ^ result 286 | wrapBuffer offset size buf = unsafeCoerce <$> js_wrapBuffer offset size buf 287 | {-# INLINE wrapBuffer #-} 288 | 289 | makeRequest :: Method -> Req -> (Int -> Bool) -> Maybe BaseUrl -> IO (Either ServantError (Int, [HTTP.Header], JSVal)) 290 | makeRequest method req isWantedStatus bUrl = do 291 | jRequest <- jsXhrRequest 292 | let url = JSString.pack . show $ buildUrl req bUrl 293 | methodText = JSString.pack $ unpack method 294 | jsXhrOpen jRequest methodText url jsTrue 295 | jsXhrResponseType jRequest "json" 296 | resp <- newEmptyMVar 297 | cb <- syncCallback ThrowWouldBlock $ do 298 | r <- jsXhrReadyState jRequest :: IO JSVal 299 | state <- fromJSVal r 300 | when ((state :: Maybe Int) == Just 4) $ do 301 | statusCode <- fromMaybe (-1) <$> (fromJSVal =<< jsXhrStatus jRequest) 302 | if (statusCode >= 200 && statusCode < 300) 303 | then do 304 | bsResp <- jsXhrResponse jRequest 305 | headers <- xhrResponseHeaders jRequest 306 | putMVar resp $ Right (statusCode, headers, bsResp) 307 | else do 308 | bsStatusText <- jsXhrGetStatusText jRequest 309 | respBody <- jsXhrResponse jRequest 310 | [js_| console.log(`respBody); |] 311 | putMVar resp $ Left $ FailureResponse (mkStatus statusCode . 312 | pack . JSString.unpack $ bsStatusText) 313 | ("unknown" // "unknown") 314 | (respBody) 315 | 316 | 317 | jsXhrOnReadyStateChange jRequest cb 318 | case reqBody req of 319 | Nothing -> jsXhrSend jRequest 320 | (Just (body, mediaType)) -> do 321 | jsXhrSetRequestHeader jRequest "Content-Type" $ JSString.pack $ show mediaType 322 | jsXhrSendWith jRequest =<< js_stringify =<< body 323 | res <- takeMVar resp 324 | release cb 325 | return res 326 | 327 | release :: Callback (IO ()) -- ^ the callback 328 | -> IO () 329 | release = js_release 330 | 331 | buildUrl :: Req -> Maybe BaseUrl -> URI 332 | buildUrl req@(Req path qText mBody rAccept hs) baseurl = 333 | (baseURI baseurl){uriPath = path, uriQuery = query} 334 | where 335 | query = unpack $ renderQuery True $ queryTextToQuery qText 336 | baseURI Nothing = nullURI 337 | baseURI (Just (BaseUrl scheme host port)) = 338 | nullURI { 339 | uriScheme = schemeText, 340 | uriAuthority = Just $ URIAuth "" host portText 341 | } 342 | where 343 | portText = ":" <> (show port) 344 | schemeText = case scheme of 345 | Http -> "http:" 346 | Https -> "https:" 347 | 348 | class Accept ctype => GHCJSUnrender ctype a where 349 | ghcjsUnrender :: Proxy ctype -> JSVal -> IO (Either String a) 350 | 351 | instance FromJSVal a => GHCJSUnrender JSON a where 352 | ghcjsUnrender _ val = maybe (Left "Error when marshalling from JSVal") Right <$> fromJSVal val 353 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.8 2 | compiler: ghcjs-0.2.1.9007008_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007008_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2016-11-07-lts-7.8-9007008.tar.gz 10 | sha1: 190300a3725cde44b2a08be9ef829f2077bf8825 11 | 12 | packages: 13 | - '.' 14 | - location: 15 | git: git@github.com:ghcjs/ghcjs-ffiqq.git 16 | commit: b52338c2dcd3b0707bc8aff2e171411614d4aedb 17 | 18 | # for testing 19 | - location: 20 | git: git@github.com:plow-technologies/ghcjs-jsval-combinators.git 21 | commit: 46e481dd5b762c785cb5e62b956a19e1e62488f4 22 | extra-dep: true 23 | - location: 24 | git: git@github.com:plow-technologies/ghcjs-hspec-json.git 25 | commit: a8452b13252411db2f46c803258eee719646aea6 26 | extra-dep: true 27 | 28 | extra-deps: 29 | - servant-0.9.1.1 30 | - http-api-data-0.3.3 31 | -------------------------------------------------------------------------------- /test-server/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /test-server/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test-server/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Network.Wai.Handler.Warp as Warp 4 | import Server 5 | 6 | main :: IO () 7 | main = Warp.run 3000 $ app 8 | -------------------------------------------------------------------------------- /test-server/src/Api.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Api where 7 | 8 | import Data.Aeson 9 | import Data.Text (Text) 10 | import Servant 11 | import Servant.API 12 | 13 | type Api = "user" :> QueryParam "name" String :> Get '[JSON] (Maybe User) 14 | :<|> "user" :> "add" :> ReqBody '[JSON] User :> Post '[JSON] (Maybe User) 15 | :<|> "user" :> "delete" :> QueryParam "name" String :> Delete '[JSON] Bool 16 | :<|> "user" :> "exists" :> QueryParam "name" String :> Get '[JSON] Bool 17 | :<|> "user" :> "upsert" :> ReqBody '[JSON] User :> Post '[JSON] User 18 | :<|> "users" :> "add" :> ReqBody '[JSON] [User] :> Post '[JSON] [User] 19 | :<|> "capture" :> "test" :> Capture "segment" Text :> Get '[JSON] (Text) 20 | :<|> "capture" :> "all" :> "test" :> CaptureAll "segment" Text :> Get '[JSON] [Text] 21 | 22 | -- :<|> "capture" :> "test" :> Capture "segment" Text :> Get '[JSON] (Text) 23 | 24 | 25 | data User = User { 26 | name :: String 27 | , age :: Int 28 | } deriving (Eq,Read,Show) 29 | 30 | instance ToJSON User where 31 | toJSON (User {..}) = object [ 32 | "name" .= name 33 | , "age" .= age 34 | ] 35 | 36 | instance FromJSON User where 37 | parseJSON = withObject "User" $ \o -> 38 | User <$> o .: "name" 39 | <*> o .: "age" 40 | -------------------------------------------------------------------------------- /test-server/src/Server.hs: -------------------------------------------------------------------------------- 1 | module Server where 2 | 3 | import Api 4 | import Control.Monad.IO.Class (liftIO) 5 | import Network.Wai 6 | import Servant 7 | 8 | app :: Application 9 | app = serve serverApi $ server 10 | 11 | serverApi :: Proxy Api 12 | serverApi = Proxy 13 | 14 | server :: Server Api 15 | server = getUserH :<|> postUserH :<|> deleteUserH :<|> existsUserH :<|> upsertUserH :<|> postUsersH :<|> captureTestH :<|> captureAllTestH 16 | where 17 | getUserH mUserName = do 18 | liftIO $ print "getUser" 19 | return (User <$> mUserName <*> pure 25) 20 | postUserH user = do 21 | liftIO $ print "postUser" 22 | return . Just $ user 23 | deleteUserH user = do 24 | liftIO $ print "deleteUser" 25 | return True 26 | existsUserH user = do 27 | liftIO $ print "existsUser" 28 | return True 29 | upsertUserH user = do 30 | liftIO $ print "upsertUser" 31 | return user 32 | postUsersH users = do 33 | liftIO $ print "postUsers" 34 | return users 35 | captureTestH t = do 36 | liftIO $ print "captureTest" 37 | return t 38 | captureAllTestH ts = do 39 | liftIO $ print "captureAllTest" 40 | return ts 41 | -------------------------------------------------------------------------------- /test-server/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.8 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: 7 | - servant-0.9.1.1 8 | - servant-server-0.9.1.1 9 | - http-api-data-0.3.3 10 | -------------------------------------------------------------------------------- /test-server/test-server.cabal: -------------------------------------------------------------------------------- 1 | name: test-server 2 | version: 0.1.0.0 3 | synopsis: undefined 4 | description: undefined 5 | license: BSD3 6 | license-file: LICENSE 7 | author: James M.C. Haver II 8 | maintainer: mchaver@gmail.com 9 | copyright: 2016 Plow Technologies 10 | category: Web 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | library 15 | hs-source-dirs: src 16 | exposed-modules: Api 17 | Server 18 | build-depends: base >= 4.7 && < 5 19 | , aeson 20 | , servant == 0.9.* 21 | , servant-server == 0.9.* 22 | , transformers 23 | , text 24 | , wai 25 | default-language: Haskell2010 26 | 27 | executable test-server 28 | hs-source-dirs: app 29 | main-is: Main.hs 30 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 31 | build-depends: base 32 | , test-server 33 | , warp 34 | default-language: Haskell2010 35 | -------------------------------------------------------------------------------- /tests/Api.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | 12 | module Api where 13 | 14 | import Control.Monad 15 | import Control.Monad.Trans.Either 16 | import Control.Monad.Trans.Maybe 17 | import Control.Monad.IO.Class 18 | 19 | import Data.Aeson 20 | import Data.Proxy 21 | import Data.Text (Text) 22 | import qualified Data.Text as T 23 | 24 | import Servant.API 25 | import Servant.Client 26 | 27 | import GHCJS.JSVal.Combinators 28 | import GHCJS.Marshal 29 | 30 | data ApiInterface = ApiInterface { 31 | apiGetUser :: Maybe String -> EitherT ServantError IO (Maybe User) 32 | , apiPostUser :: User -> EitherT ServantError IO (Maybe User) 33 | , apiDeleteUser :: Maybe String -> EitherT ServantError IO (Bool) 34 | , apiExistsUser :: Maybe String -> EitherT ServantError IO (Bool) 35 | , apiUpsertUser :: User -> EitherT ServantError IO (User) 36 | , apiPostUsers :: [User] -> EitherT ServantError IO [User] 37 | , apiGetCapture :: Text -> EitherT ServantError IO Text 38 | , apiGetCaptureAll :: [Text] -> EitherT ServantError IO [Text] 39 | } 40 | 41 | type Api = "user" :> QueryParam "name" String :> Get '[JSON] (Maybe User) 42 | :<|> "user" :> "add" :> ReqBody '[JSON] User :> Post '[JSON] (Maybe User) 43 | :<|> "user" :> "delete" :> QueryParam "name" String :> Delete '[JSON] Bool 44 | :<|> "user" :> "exists" :> QueryParam "name" String :> Get '[JSON] Bool 45 | :<|> "user" :> "upsert" :> ReqBody '[JSON] User :> Post '[JSON] User 46 | :<|> "users" :> "add" :> ReqBody '[JSON] [User] :> Post '[JSON] [User] 47 | :<|> "capture" :> "test" :> Capture "segment" Text :> Get '[JSON] (Text) 48 | :<|> "capture" :> "all" :> "test" :> CaptureAll "segments" Text :> Get '[JSON] [Text] 49 | 50 | -- the following doesn't compile 51 | -- "user" :> "add" :> ReqBody '[JSON] User :> Post '[] () 52 | 53 | data User = User { 54 | name :: String 55 | , age :: Int 56 | } deriving (Eq,Read,Show) 57 | 58 | createApiInterface :: IO (ApiInterface) 59 | createApiInterface = do 60 | return $ ApiInterface apiGetUser' apiPostUser' apiDeleteUser' apiExistsUser' apiUpsertUser' apiPostUsers' apiGetCapture' apiGetCaptureAll' 61 | where 62 | apiGetUser' :: Maybe String -> EitherT ServantError IO (Maybe User) 63 | apiPostUser' :: User -> EitherT ServantError IO (Maybe User) 64 | apiDeleteUser' :: Maybe String -> EitherT ServantError IO (Bool) 65 | apiExistsUser' :: Maybe String -> EitherT ServantError IO (Bool) 66 | apiUpsertUser' :: User -> EitherT ServantError IO (User) 67 | apiPostUsers' :: [User] -> EitherT ServantError IO [User] 68 | apiGetCapture' :: Text -> EitherT ServantError IO (Text) 69 | apiGetCaptureAll' :: [Text] -> EitherT ServantError IO [Text] 70 | apiGetUser' :<|> apiPostUser' :<|> apiDeleteUser' :<|> apiExistsUser' :<|> apiUpsertUser' :<|> apiPostUsers' :<|> apiGetCapture' :<|> apiGetCaptureAll' = client api $ Just $ BaseUrl scheme url port 71 | api :: Proxy Api 72 | api = Proxy 73 | url = "127.0.0.1" 74 | port = 3000 75 | scheme = Http 76 | 77 | 78 | instance ToJSON User where 79 | toJSON (User {..}) = object [ 80 | "name" .= name 81 | , "age" .= age 82 | ] 83 | 84 | instance FromJSON User where 85 | parseJSON = withObject "User" $ \o -> 86 | User <$> o .: "name" 87 | <*> o .: "age" 88 | 89 | instance ToJSVal User where 90 | toJSVal (User {..}) = createObject [ 91 | "name" .=> name 92 | , "age" .=> age 93 | ] 94 | 95 | instance FromJSVal User where 96 | fromJSVal o = runMaybeT $ 97 | User <$> o .-> "name" 98 | <*> o .-> "age" 99 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import Api 5 | import Control.Monad.Trans.Either 6 | import Servant.Common.Req (printServantError) 7 | import Test.Hspec 8 | 9 | 10 | main :: IO () 11 | main = hspec spec 12 | 13 | spec :: Spec 14 | spec = do 15 | interface <- runIO createApiInterface 16 | describe "ghcjs-servant-client" $ do 17 | it "GET QueryParam" $ do 18 | eitherUser <- runEitherT $ apiGetUser interface (Just "James") 19 | case eitherUser of 20 | Left _ -> fail "GET QueryParam test failed." 21 | Right user -> user `shouldBe` (Just (User "James" 25)) 22 | it "POST JSON ReqBody" $ do 23 | eitherUser <- runEitherT $ apiPostUser interface (User "James" 40) 24 | case eitherUser of 25 | Left _ -> fail "POST JSON ReqBody failed." 26 | Right user -> user `shouldBe` (Just (User "James" 40)) 27 | it "DELETE QueryParam" $ do 28 | eitherResult <- runEitherT $ apiDeleteUser interface (Just "James") 29 | case eitherResult of 30 | Left _ -> fail "Delete QueryParam failed." 31 | Right r -> r `shouldBe` True 32 | it "GET QueryParam" $ do 33 | eitherResult <- runEitherT $ apiExistsUser interface (Just "James") 34 | case eitherResult of 35 | Left _ -> fail "Get QueryParam failed." 36 | Right r -> r `shouldBe` True 37 | it "POST JSON ReqBody List" $ do 38 | eitherResult <- runEitherT $ apiPostUsers interface ([User "James" 40, User "Rick" 50]) 39 | case eitherResult of 40 | Left _ -> fail "POST JSON ReqBody List failed." 41 | Right r -> r `shouldBe` ([User "James" 40, User "Rick" 50]) 42 | it "GET Capture Text" $ do 43 | eitherResult <- runEitherT $ apiGetCapture interface "This is only a test" 44 | case eitherResult of 45 | Left err -> do 46 | printServantError err 47 | fail "GET Capture Text failed." 48 | Right r -> r `shouldBe` "This is only a test" 49 | it "GET CaptureAll Text" $ do 50 | eitherResult <- runEitherT $ apiGetCaptureAll interface ["1","2","Hello World!"] 51 | case eitherResult of 52 | Left err -> do 53 | printServantError err 54 | fail "GET CaptureAll Text failed." 55 | Right r -> r `shouldBe` ["1","2","Hello World!"] 56 | --------------------------------------------------------------------------------