diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,3 @@
+# Changelog for servant-reason
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Andrei Barbu (c) 2019, Matt Bray (c) 2015-2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Matt Bray nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,87 @@
+# Servant Reason
+
+[](https://travis-ci.org/abarbu/servant-reason)
+
+
+
+Automatically derive bindings for Servant APIs in Reason. Originally build by
+converting [servant-elm](http://hackage.haskell.org/package/servant-elm) to
+Reason. Types are generated using
+[reason-export](https://github.com/abarbu/reason-export).
+
+More docs on [Hackage](http://hackage.haskell.org/package/servant-reason).
+
+A full example of how to integrate Servant and Reason is available at
+[servant-reason-example](https://github.com/abarbu/servant-reason-example).
+
+## Usage
+
+Run the tests if you want a concrete example. They will build a _test-cache
+directory that contains a sample Reason repository for a servant API. test also
+contain example output files for different kinds of bindings.
+
+Usage is simple and automatic. If you have an API like the one below
+
+```haskell
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+import Reason (Spec (Spec), specsToDir, toReasonDecoderSource,
+ toReasonTypeSource)
+import GHC.Generics (Generic)
+import Servant.API ((:>), Capture, Get, JSON)
+import Servant.Reason (ReasonType, Proxy (Proxy), defReasonImports,
+ generateReasonForAPI)
+
+data Book = Book
+ { name :: String
+ } deriving (Generic)
+
+instance ReasonType Book
+
+type BooksApi = "books" :> Capture "bookId" Int :> Get '[JSON] Book
+```
+
+You can expose your API to reason with:
+
+```haskell
+module Main where
+
+import Data.Proxy
+import Reason
+import Data.Text hiding (intercalate, map)
+import Db
+
+main :: IO ()
+main = do
+ let code = defReasonImports
+ : toReasonTypeSource (Proxy :: Proxy Book)
+ : toReasonDecoderSource (Proxy :: Proxy Book)
+ : generateReasonForAPI (Proxy :: Proxy BooksApi))
+ writeFile "Api.re" $ intercalate "\n\n" $ map unpack code
+```
+
+That's it. You can now include `Api.re` in a Reason project.
+
+## Reason setup
+
+The generated code needs access to two Reason libraries
+[@glennsl/bs-json](https://github.com/glennsl/bs-json) and
+[bs-fetch](https://github.com/reasonml-community/bs-fetch). Get the latest
+install instructions from the upstream repos, but at the time of writing these
+were:
+
+```sh
+npm install --save @glennsl/bs-json
+npm install --save bs-fetch
+```
+
+Then add `@glennsl/bs-json` and `bs-fetch` to `bs-dependencies` in your `bsconfig.json`:
+```js
+{
+ ...
+ "bs-dependencies": ["@glennsl/bs-json", "bs-fetch"]
+}
+```
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/servant-reason.cabal b/servant-reason.cabal
new file mode 100644
--- /dev/null
+++ b/servant-reason.cabal
@@ -0,0 +1,118 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.1.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 6c0ebb17fd103163c20ec58213afcdd0311c5f540d9fd64e4894fc8349bea6b3
+
+name: servant-reason
+version: 0.1.0.0
+synopsis: Derive Reason types to interact with a Haskell backend
+description: Please see the README on GitHub at
+category: Web
+homepage: https://github.com/abarbu/servant-reason#readme
+bug-reports: https://github.com/abarbu/servant-reason/issues
+author: Andrei Barbu
+maintainer: andrei@0xab.com
+copyright: 2019 Andrei Barbu
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+ ChangeLog.md
+ test/reason-sources/BookType.re
+ test/reason-sources/getBooksByIdSource.re
+ test/reason-sources/getBooksByTitleSource.re
+ test/reason-sources/getBooksSource.re
+ test/reason-sources/getNothingSource.re
+ test/reason-sources/getOneSource.re
+ test/reason-sources/getOneWithDynamicUrlSource.re
+ test/reason-sources/getWithaheaderSource.re
+ test/reason-sources/getWitharesponseheaderSource.re
+ test/reason-sources/postBooksSource.re
+ test/reason-sources/postTwoSource.re
+ test/reason-sources/putNothingSource.re
+
+source-repository head
+ type: git
+ location: https://github.com/abarbu/servant-reason
+
+library
+ exposed-modules:
+ Servant.Reason
+ Servant.Reason.Internal.Foreign
+ Servant.Reason.Internal.Generate
+ Servant.Reason.Internal.Orphans
+ other-modules:
+ Paths_servant_reason
+ hs-source-dirs:
+ src
+ build-depends:
+ base >=4.7 && <5
+ , lens
+ , reason-export
+ , servant
+ , servant-foreign
+ , text
+ , wl-pprint-text
+ default-language: Haskell2010
+
+test-suite servant-reason-compile-test
+ type: exitcode-stdio-1.0
+ main-is: CompileSpec.hs
+ other-modules:
+ Common
+ GenerateSpec
+ Paths_servant_reason
+ hs-source-dirs:
+ test
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -main-is CompileSpec
+ build-depends:
+ Diff
+ , HUnit
+ , aeson
+ , base >=4.7 && <5
+ , directory
+ , hspec
+ , interpolate
+ , lens
+ , mockery
+ , process
+ , reason-export
+ , servant
+ , servant-foreign
+ , servant-reason
+ , text
+ , wl-pprint-text
+ default-language: Haskell2010
+
+test-suite servant-reason-test
+ type: exitcode-stdio-1.0
+ main-is: GenerateSpec.hs
+ other-modules:
+ Common
+ CompileSpec
+ Paths_servant_reason
+ hs-source-dirs:
+ test
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -main-is GenerateSpec
+ build-depends:
+ Diff
+ , HUnit
+ , aeson
+ , base >=4.7 && <5
+ , directory
+ , hspec
+ , interpolate
+ , lens
+ , mockery
+ , process
+ , reason-export
+ , servant
+ , servant-foreign
+ , servant-reason
+ , text
+ , wl-pprint-text
+ default-language: Haskell2010
diff --git a/src/Servant/Reason.hs b/src/Servant/Reason.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/Reason.hs
@@ -0,0 +1,36 @@
+{-|
+Basic usage:
+
+> import MyLib (MyServantApiType)
+> import Servant.Reason
+>
+> spec :: Spec
+> spec = Spec ["Generated", "MyApi"]
+> (defReasonImports : generateReasonForAPI (Proxy :: Proxy MyServantApiType))
+>
+> main :: IO ()
+> main = specsToDir [spec] "my-reason-dir"
+-}
+module Servant.Reason
+ ( generateReasonForAPI
+ , generateReasonForAPIWith
+ , ReasonOptions(..)
+ , UrlPrefix(..)
+ , defReasonOptions
+ , defReasonImports
+ -- * Convenience re-exports from the "Reason" module
+ , Spec(Spec)
+ , ReasonType
+ , specsToDir
+ -- * Convenience re-exports from "Data.Proxy"
+ , Proxy(Proxy)
+ ) where
+
+import Servant.Reason.Internal.Generate (ReasonOptions (..), UrlPrefix (..),
+ defReasonImports, defReasonOptions,
+ generateReasonForAPI,
+ generateReasonForAPIWith)
+
+import Data.Proxy (Proxy (Proxy))
+import Reason (ReasonType, Spec (Spec),
+ specsToDir)
diff --git a/src/Servant/Reason/Internal/Foreign.hs b/src/Servant/Reason/Internal/Foreign.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/Reason/Internal/Foreign.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Servant.Reason.Internal.Foreign where
+
+import Data.Proxy (Proxy (Proxy))
+import Reason (ReasonDatatype, ReasonType, toReasonType)
+import Servant.Foreign (Foreign, GenerateList, HasForeign,
+ HasForeignType, Req, listFromAPI, typeFor)
+
+
+data LangReason
+
+instance (ReasonType a) => HasForeignType LangReason ReasonDatatype a where
+ typeFor _ _ _ =
+ toReasonType (Proxy :: Proxy a)
+
+getEndpoints
+ :: ( HasForeign LangReason ReasonDatatype api
+ , GenerateList ReasonDatatype (Foreign ReasonDatatype api))
+ => Proxy api
+ -> [Req ReasonDatatype]
+getEndpoints =
+ listFromAPI (Proxy :: Proxy LangReason) (Proxy :: Proxy ReasonDatatype)
diff --git a/src/Servant/Reason/Internal/Generate.hs b/src/Servant/Reason/Internal/Generate.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/Reason/Internal/Generate.hs
@@ -0,0 +1,563 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Servant.Reason.Internal.Generate where
+
+import Prelude hiding ((<$>))
+import Control.Lens (to, (^.))
+import Data.Int (Int32)
+import Data.List (nub)
+import Data.Maybe (catMaybes)
+import Data.Proxy (Proxy)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as L
+import qualified Data.Text.Encoding as T
+import Reason (ReasonDatatype(..), ReasonPrimitive(..))
+import qualified Reason
+import Servant.API (NoContent (..))
+import Servant.Reason.Internal.Foreign (LangReason, getEndpoints)
+import Servant.Reason.Internal.Orphans ()
+import qualified Servant.Foreign as F
+import Text.PrettyPrint.Leijen.Text
+
+
+{-|
+Options to configure how code is generated.
+-}
+data ReasonOptions = ReasonOptions
+ { {- | The protocol, host and any path prefix to be used as the base for all
+ requests.
+
+ Example: @Static "https://mydomain.com/api/v1"@
+
+ When @Dynamic@, the generated Reason functions take the base URL as the first
+ argument.
+ -}
+ urlPrefix :: UrlPrefix
+ , reasonExportOptions :: Reason.Options
+ -- ^ Options to pass to reason-export
+ , emptyResponseReasonTypes :: [ReasonDatatype]
+ -- ^ Types that represent an empty Http response.
+ , stringReasonTypes :: [ReasonDatatype]
+ -- ^ Types that represent a String.
+ , intReasonTypes :: [ReasonDatatype]
+ -- ^ Types that represent a Int.
+ , floatReasonTypes :: [ReasonDatatype]
+ -- ^ Types that represent a Float.
+ , boolReasonTypes :: [ReasonDatatype]
+ -- ^ Types that represent a Bool.
+ , charReasonTypes :: [ReasonDatatype]
+ -- ^ Types that represent a Char.
+ }
+
+
+data UrlPrefix
+ = Static T.Text
+ | Dynamic
+
+
+{-|
+Default options for generating Reason code.
+
+The default options are:
+
+> { urlPrefix =
+> Static ""
+> , reasonExportOptions =
+> Reason.defaultOptions
+> , emptyResponseReasonTypes =
+> [ toReasonType NoContent ]
+> , stringReasonTypes =
+> [ toReasonType "" ]
+> }
+-}
+defReasonOptions :: ReasonOptions
+defReasonOptions = ReasonOptions
+ { urlPrefix = Static ""
+ , reasonExportOptions = Reason.defaultOptions
+ , emptyResponseReasonTypes =
+ [ Reason.toReasonType NoContent
+ , Reason.toReasonType ()
+ ]
+ , stringReasonTypes =
+ [ Reason.toReasonType ("" :: String)
+ , Reason.toReasonType ("" :: T.Text)
+ ]
+ , intReasonTypes =
+ [ Reason.toReasonType (0 :: Int)
+ , Reason.toReasonType (0 :: Int32)
+ ]
+ , floatReasonTypes =
+ [ Reason.toReasonType (0 :: Float) ]
+ , boolReasonTypes =
+ [ Reason.toReasonType (False :: Bool) ]
+ , charReasonTypes =
+ [ Reason.toReasonType (' ' :: Char) ]
+ }
+
+
+{-|
+Default imports required by generated Reason code.
+
+You probably want to include this at the top of your generated Reason module.
+-}
+defReasonImports :: Text
+defReasonImports = T.unlines []
+
+
+{-|
+Generate Reason code for the API with default options.
+
+Returns a list of Reason functions to query your Servant API from Reason.
+
+You could spit these out to a file and call them from your Reason code, but you
+would be better off creating a 'Spec' with the result and using 'specsToDir',
+which handles the module name for you.
+-}
+generateReasonForAPI
+ :: ( F.HasForeign LangReason ReasonDatatype api
+ , F.GenerateList ReasonDatatype (F.Foreign ReasonDatatype api))
+ => Proxy api
+ -> [Text]
+generateReasonForAPI =
+ generateReasonForAPIWith defReasonOptions
+
+
+{-|
+Generate Reason code for the API with custom options.
+-}
+generateReasonForAPIWith
+ :: ( F.HasForeign LangReason ReasonDatatype api
+ , F.GenerateList ReasonDatatype (F.Foreign ReasonDatatype api))
+ => ReasonOptions
+ -> Proxy api
+ -> [Text]
+generateReasonForAPIWith opts =
+ nub . map docToText . map (generateReasonForRequest opts) . getEndpoints
+
+i :: Int
+i = 4
+
+{-|
+Generate an Reason function for one endpoint.
+-}
+generateReasonForRequest :: ReasonOptions -> F.Req ReasonDatatype -> Doc
+generateReasonForRequest opts request =
+ funcDef
+ where
+ funcDef =
+ vsep
+ [ -- fnName <+> ":" <+> typeSignature
+ -- ,
+ "let" <+> fnName <+> "=" <+> args <+> "=> {"
+ , case letParams of
+ Just params ->
+ indent i
+ (vsep ["let"
+ , indent i params <> ";"
+ , indent i reasonRequest
+ ])
+ Nothing ->
+ indent i reasonRequest
+ , "}"
+ ]
+
+ fnName =
+ request ^. F.reqFuncName . to (T.replace "-" "" . F.camelCase) . to stext
+
+ typeSignature =
+ mkTypeSignature opts request
+
+ args =
+ mkArgs opts request
+
+ letParams =
+ mkLetParams opts request
+
+ reasonRequest =
+ mkRequest opts request
+
+
+mkTypeSignature :: ReasonOptions -> F.Req ReasonDatatype -> Doc
+mkTypeSignature opts request =
+ (hsep . punctuate " ->" . concat)
+ [ catMaybes [urlPrefixType]
+ , headerTypes
+ , urlCaptureTypes
+ , queryTypes
+ , catMaybes [bodyType, returnType]
+ ]
+ where
+ urlPrefixType :: Maybe Doc
+ urlPrefixType =
+ case (urlPrefix opts) of
+ Dynamic -> Just "String"
+ Static _ -> Nothing
+
+ reasonTypeRef :: ReasonDatatype -> Doc
+ reasonTypeRef eType =
+ stext (Reason.toReasonTypeRefWith (reasonExportOptions opts) eType)
+
+ headerTypes :: [Doc]
+ headerTypes =
+ [ header ^. F.headerArg . F.argType . to reasonTypeRef
+ | header <- request ^. F.reqHeaders
+ , isNotCookie header
+ ]
+
+ urlCaptureTypes :: [Doc]
+ urlCaptureTypes =
+ [ F.captureArg capture ^. F.argType . to reasonTypeRef
+ | capture <- request ^. F.reqUrl . F.path
+ , F.isCapture capture
+ ]
+
+ queryTypes :: [Doc]
+ queryTypes =
+ [ arg ^. F.queryArgName . F.argType . to reasonTypeRef
+ | arg <- request ^. F.reqUrl . F.queryStr
+ ]
+
+ bodyType :: Maybe Doc
+ bodyType =
+ fmap reasonTypeRef $ request ^. F.reqBody
+
+ returnType :: Maybe Doc
+ returnType = do
+ result <- fmap reasonTypeRef $ request ^. F.reqReturnType
+ pure ("Http.Request" <+> parens result)
+
+
+reasonHeaderArg :: F.HeaderArg ReasonDatatype -> Doc
+reasonHeaderArg header =
+ "header_" <>
+ header ^. F.headerArg . F.argName . to (stext . T.replace "-" "_" . F.unPathSegment)
+
+
+reasonCaptureArg :: F.Segment ReasonDatatype -> Doc
+reasonCaptureArg segment =
+ "capture_" <>
+ F.captureArg segment ^. F.argName . to (stext . F.unPathSegment)
+
+
+reasonQueryArg :: F.QueryArg ReasonDatatype -> Doc
+reasonQueryArg arg =
+ "query_" <>
+ arg ^. F.queryArgName . F.argName . to (stext . F.unPathSegment)
+
+
+reasonBodyArg :: Doc
+reasonBodyArg =
+ "body"
+
+
+isNotCookie :: F.HeaderArg f -> Bool
+isNotCookie header =
+ header
+ ^. F.headerArg
+ . F.argName
+ . to ((/= "cookie") . T.toLower . F.unPathSegment)
+
+
+mkArgs
+ :: ReasonOptions
+ -> F.Req ReasonDatatype
+ -> Doc
+mkArgs opts request =
+ (tupled . concat) $
+ [ -- Dynamic url prefix
+ case urlPrefix opts of
+ Dynamic -> ["urlBase"]
+ Static _ -> []
+ , -- Headers
+ [ reasonHeaderArg header
+ | header <- request ^. F.reqHeaders
+ , isNotCookie header
+ ]
+ , -- URL Captures
+ [ reasonCaptureArg segment
+ | segment <- request ^. F.reqUrl . F.path
+ , F.isCapture segment
+ ]
+ , -- Query params
+ [ reasonQueryArg arg
+ | arg <- request ^. F.reqUrl . F.queryStr
+ ]
+ , -- Request body
+ maybe [] (const [reasonBodyArg]) (request ^. F.reqBody)
+ ]
+
+
+mkLetParams :: ReasonOptions -> F.Req ReasonDatatype -> Maybe Doc
+mkLetParams opts request =
+ if null (request ^. F.reqUrl . F.queryStr) then
+ Nothing
+ else
+ Just $ "params =" <$>
+ indent i ("List.filter" <> tupled ["((x) => (String.length(x) > 0))", reasonList params])
+ where
+ params :: [Doc]
+ params = map paramToDoc (request ^. F.reqUrl . F.queryStr)
+
+ paramToDoc :: F.QueryArg ReasonDatatype -> Doc
+ paramToDoc qarg =
+ -- something wrong with indentation here...
+ case qarg ^. F.queryArgType of
+ F.Normal ->
+ let
+ toStringSrc' = toStringSrc opts (qarg ^. F.queryArgName . F.argType)
+ in
+ reasonName
+ <$$> indent 2 ("|>" <+> toStringSrc'
+ <$$> "|> Js_global.encodeURIComponent"
+ <$$> "|>" <+> "((x__) => if(String.length(x__) > 0) { "
+ <> dquotes (reasonName <> equals)
+ <+> "++ x__ } else {\"\"})")
+
+ F.Flag ->
+ "if" <> parens reasonName <+> braces (dquotes (name <> equals)) <+> "else" <+> braces (dquotes empty)
+
+ F.List ->
+ "String.concat" <> tupled [dquotes "&"
+ ,"List.map((x) => "
+ <> dquotes (name <> "[]=")
+ <> " ++ Js_global.encodeURIComponent(" <> toStringSrc opts (qarg ^. F.queryArgName . F.argType) <> "(x)), " <> reasonName <> ")"]
+ where
+ reasonName = reasonQueryArg qarg
+ name = qarg ^. F.queryArgName . F.argName . to (stext . F.unPathSegment)
+
+
+mkRequest :: ReasonOptions -> F.Req ReasonDatatype -> Doc
+mkRequest opts request =
+ "Js.Promise." <> parens (
+ line <> indent i
+ ("Fetch.fetchWithInit" <>
+ tupled [url
+ ,"Fetch.RequestInit.make" <>
+ tupled (catMaybes [Just $ "~method_=" <> method
+ ,case headers of
+ [] -> Nothing
+ _ -> Just $ "~headers="
+ <$$> indent 2 "Fetch.HeadersInit.makeWithDict("
+ <$$> indent 3 ("Js.Dict.fromList(")
+ <$$> indent 4 (reasonListOfMaybes headers) <> "))"
+ ,case body of
+ Nothing -> Nothing
+ Just b -> Just $ "~body=" <> b
+ ,Just $ "()"])])
+ <$$> "|> then_" <> parens ("Fetch.Response." <> expectResponse)
+ <$$> "|> then_" <> parens ("response => (response |>" <+> expectDecoder <> ")"))
+ -- , "timeout =" <$>
+ -- indent i "Nothing"
+ -- ]))
+ where
+ method =
+ request ^. F.reqMethod . to (stext . T.toTitle . T.decodeUtf8)
+
+ mkHeader header =
+ let headerName = header ^. F.headerArg . F.argName . to (stext . F.unPathSegment)
+ headerArgName = reasonHeaderArg header
+ argType = header ^. F.headerArg . F.argType
+ wrapped = isReasonMaybeType argType
+ toStringSrc' = toStringSrc opts (case argType of
+ (ReasonPrimitive (ROption t)) -> t
+ x -> x)
+ -- toStringSrc =
+ -- if isReasonMaybeStringType opts argType || isReasonStringType opts argType then
+ -- mempty
+ -- else
+ -- " << toString"
+ in
+ "Belt.Option.map" <> parens ((if wrapped then headerArgName else parens ("Some" <> parens headerArgName))
+ <> ", x => " <> parens (dquotes headerName <> ", x |>" <+> toStringSrc'))
+
+ headers =
+ (case (request ^. F.reqBody, request ^. F.reqBodyContentType) of
+ (Just _, F.ReqBodyJSON) ->
+ ["Some" <> parens (parens ("\"Content-Type\"" <> comma <> stext "\"application/json\""))]
+ _ -> [])
+ ++
+ [ mkHeader header
+ | header <- request ^. F.reqHeaders
+ , isNotCookie header
+ ]
+
+ url =
+ mkUrl opts (request ^. F.reqUrl . F.path)
+ <> mkQueryParams request
+
+ body =
+ case request ^. F.reqBody of
+ Nothing -> Nothing
+ Just reasonTypeExpr ->
+ let encoderName = Reason.toReasonEncoderRefWith (reasonExportOptions opts) reasonTypeExpr
+ in Just $ "Fetch.BodyInit.make" <> parens ("Js.Json.stringify" <> parens (stext encoderName <> parens reasonBodyArg))
+
+ expectResponse =
+ case request ^. F.reqReturnType of
+ Just reasonTypeExpr | isEmptyType opts reasonTypeExpr ->
+ "text"
+ Just reasonTypeExpr ->
+ "json"
+ Nothing ->
+ error "mkHttpRequest: no reqReturnType?"
+
+ expectDecoder =
+ case request ^. F.reqReturnType of
+ Just reasonTypeExpr | isEmptyType opts reasonTypeExpr ->
+ "((x) => if(String.length(x) != 0) { resolve(Belt_Result.Error(\"Expected the response body to empty\")) } else { resolve(Belt_Result.Ok(x)) })"
+ -- let reasonConstructor =
+ -- Reason.toReasonTypeRefWith (reasonExportOptions opts) reasonTypeExpr
+ -- in
+ -- "Http.expectStringResponse" <$>
+ -- indent i (parens (backslash <> braces " body " <+> "->" <$>
+ -- indent i ("if String.isEmpty body then" <$>
+ -- indent i "Ok" <+> stext reasonConstructor <$>
+ -- "else" <$>
+ -- indent i ("Err" <+> dquotes "Expected the response body to be empty")) <> line))
+ Just reasonTypeExpr ->
+ stext (Reason.toReasonDecoderRefWith (reasonExportOptions opts) reasonTypeExpr) <+> "|> ((x) => Belt_Result.Ok(x)) |> resolve"
+ Nothing -> error "mkHttpRequest: no reqReturnType?"
+
+
+mkUrl :: ReasonOptions -> [F.Segment ReasonDatatype] -> Doc
+mkUrl opts segments =
+ "String.concat" <> tupled [dquotes "/",
+ (reasonList)
+ ( case urlPrefix opts of
+ Dynamic -> "urlBase"
+ Static url -> dquotes (stext url)
+ : map segmentToDoc segments)]
+ where
+
+ segmentToDoc :: F.Segment ReasonDatatype -> Doc
+ segmentToDoc s =
+ case F.unSegment s of
+ F.Static path ->
+ dquotes (stext (F.unPathSegment path))
+ F.Cap arg ->
+ let
+ -- Don't use "toString" on Reason Strings, otherwise we get extraneous quotes.
+ toStringSrc' = toStringSrc opts (arg ^. F.argType)
+ -- toStringSrc =
+ -- if isReasonStringType opts (arg ^. F.argType) then
+ -- empty
+ -- else
+ -- "|> string_of_" <> stext (Reason.toReasonTypeRef (arg ^. F.argType))
+ in
+ (reasonCaptureArg s) <+> "|>" <+> toStringSrc' <+> "|>" <+> "Js_global.encodeURIComponent"
+
+
+mkQueryParams
+ :: F.Req ReasonDatatype
+ -> Doc
+mkQueryParams request =
+ if null (request ^. F.reqUrl . F.queryStr) then
+ empty
+ else
+ line <> "++" <+> align ("if(List.length(params)==0)" <+> braces (dquotes empty)
+ <+> "else" <+> braces (dquotes "?" <+> "++ String.concat" <> tupled [dquotes "&", "params"]))
+
+
+{- | Determines whether we construct an Reason function that expects an empty
+response body.
+-}
+isEmptyType :: ReasonOptions -> ReasonDatatype -> Bool
+isEmptyType opts reasonTypeExpr =
+ reasonTypeExpr `elem` emptyResponseReasonTypes opts
+
+{- | Determines how to stringify a value.
+-}
+toStringSrc :: ReasonOptions -> ReasonDatatype -> Doc
+toStringSrc opts argType
+ -- Don't use "toString" on Reason Strings, otherwise we get extraneous quotes.
+ -- We don't append an operator in this case
+ | isReasonStringType opts argType = stext "((x) => x)"
+ | otherwise = toStringSrcTypes opts argType
+
+
+toStringSrcTypes :: ReasonOptions -> ReasonDatatype -> Doc
+toStringSrcTypes opts (ReasonPrimitive (ROption argType)) =
+ "((x) => Belt.Option.mapWithDefault(x, \"\", " <> toStringSrcTypes opts argType <> "))"
+ -- "Maybe.map (" <> toStringSrcTypes operator opts argType <> ") |> Maybe.withDefault \"\""
+ -- [Char] == String so we can just use identity here.
+ -- We can't return `""` here, because this string might be nested in a `Maybe` or `List`.
+toStringSrcTypes _ (ReasonPrimitive (RList (ReasonPrimitive RChar))) = "((x) => x)"
+toStringSrcTypes opts (ReasonPrimitive (RList argType)) = toStringSrcTypes opts argType
+toStringSrcTypes opts argType
+ | isReasonStringType opts argType = "((x) => x)"
+ | isReasonIntType opts argType = "string_of_int"
+ | isReasonFloatType opts argType = "string_of_float"
+ | isReasonBoolType opts argType = "string_of_bool" -- We should change this to return `true`/`false` but this mimics the old behavior.
+ | isReasonCharType opts argType = "string_of_char"
+ | otherwise = error $ "Sorry, we don't support other types than `String`, `Int`, `Float`, `Bool`, and `Char` right now. " <> show argType
+
+
+
+{- | Determines whether we call `toString` on URL captures and query params of
+this type in Reason.
+-}
+isReasonStringType :: ReasonOptions -> ReasonDatatype -> Bool
+isReasonStringType opts reasonTypeExpr =
+ reasonTypeExpr `elem` stringReasonTypes opts
+
+{- | Determines whether we call `String.fromInt` on URL captures and query params of this type in Reason.
+-}
+isReasonIntType :: ReasonOptions -> ReasonDatatype -> Bool
+isReasonIntType opts reasonTypeExpr =
+ reasonTypeExpr `elem` intReasonTypes opts
+
+
+{- | Determines whether we call `String.fromFloat` on URL captures and query params of
+this type in Reason.
+-}
+isReasonFloatType :: ReasonOptions -> ReasonDatatype -> Bool
+isReasonFloatType opts reasonTypeExpr =
+ reasonTypeExpr `elem` floatReasonTypes opts
+
+
+{- | Determines whether we convert to `true` or `false`
+-}
+isReasonBoolType :: ReasonOptions -> ReasonDatatype -> Bool
+isReasonBoolType opts reasonTypeExpr =
+ reasonTypeExpr `elem` boolReasonTypes opts
+
+{- | Determines whether we call `String.fromChar` on URL captures and query params of
+this type in Reason.
+-}
+isReasonCharType :: ReasonOptions -> ReasonDatatype -> Bool
+isReasonCharType opts reasonTypeExpr =
+ reasonTypeExpr `elem` charReasonTypes opts
+
+{- | Determines whether a type is 'Maybe a' where 'a' is something akin to a 'String'.
+-}
+isReasonMaybeStringType :: ReasonOptions -> ReasonDatatype -> Bool
+isReasonMaybeStringType opts (ReasonPrimitive (ROption reasonTypeExpr)) = reasonTypeExpr `elem` stringReasonTypes opts
+isReasonMaybeStringType _ _ = False
+
+isReasonMaybeType :: ReasonDatatype -> Bool
+isReasonMaybeType (ReasonPrimitive (ROption _)) = True
+isReasonMaybeType _ = False
+
+
+-- Doc helpers
+
+
+docToText :: Doc -> Text
+docToText =
+ L.toStrict . displayT . renderPretty 0.4 100
+
+stext :: Text -> Doc
+stext = text . L.fromStrict
+
+reasonRecord :: [Doc] -> Doc
+reasonRecord = encloseSep (lbrace <> space) (line <> rbrace) (comma <> space)
+
+reasonList :: [Doc] -> Doc
+reasonList [] = lbracket <> rbracket
+reasonList ds = lbracket <+> hsep (punctuate (line <> comma) ds) <$> rbracket
+
+reasonListOfMaybes :: [Doc] -> Doc
+reasonListOfMaybes [] = lbracket <> rbracket
+reasonListOfMaybes ds = "Belt.List.keepMap" <> parens (line <> reasonList ds <> ", x => x")
diff --git a/src/Servant/Reason/Internal/Orphans.hs b/src/Servant/Reason/Internal/Orphans.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/Reason/Internal/Orphans.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Servant.Reason.Internal.Orphans where
+
+import Reason (ReasonDatatype, ReasonType, toReasonType)
+import Servant.API (NoContent, Headers, getResponse)
+
+
+instance ReasonType ReasonDatatype where
+ toReasonType = id
+
+
+instance ReasonType NoContent
+
+
+-- TODO: Generate Reason functions that can handle the response headers. PRs
+-- welcome!
+instance (ReasonType a) => ReasonType (Headers ls a) where
+ toReasonType = toReasonType . getResponse
diff --git a/test/Common.hs b/test/Common.hs
new file mode 100644
--- /dev/null
+++ b/test/Common.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+module Common where
+
+import Data.Aeson (ToJSON)
+import Data.Proxy (Proxy (Proxy))
+import Data.Text (Text)
+import Reason (ReasonType)
+import GHC.Generics (Generic)
+import Servant.API ((:<|>), (:>), Capture, Get, GetNoContent, Header,
+ Header', Headers, JSON, NoContent, Post,
+ PostNoContent, Put, QueryFlag, QueryParam,
+ QueryParam', QueryParams, ReqBody, Required)
+
+data Book = Book
+ { title :: String
+ } deriving (Generic)
+
+instance ToJSON Book
+instance ReasonType Book
+
+type TestApi =
+ "one"
+ :> Get '[JSON] Int
+ :<|> "two"
+ :> ReqBody '[JSON] String
+ :> Post '[JSON] (Maybe Int)
+ :<|> "books"
+ :> Capture "id" Int
+ :> Get '[JSON] Book
+ :<|> "books"
+ :> Capture "title" Text
+ :> Get '[JSON] Book
+ :<|> "books"
+ :> QueryFlag "published"
+ :> QueryParam "sort" String
+ :> QueryParam "year" Int
+ :> QueryParam' '[Required] "category" String
+ :> QueryParams "filters" (Maybe Bool)
+ :> Get '[JSON] [Book]
+ :<|> "books"
+ :> ReqBody '[JSON] Book
+ :> PostNoContent '[JSON] NoContent
+ :<|> "nothing"
+ :> GetNoContent '[JSON] NoContent
+ :<|> "nothing"
+ :> Put '[JSON] () -- old way to specify no content
+ :<|> "with-a-header"
+ :> Header "Cookie" String
+ :> Header "myStringHeader" String
+ :> Header "MyIntHeader" Int
+ :> Header' '[Required] "MyRequiredStringHeader" String
+ :> Header' '[Required] "MyRequiredIntHeader" Int
+ :> Get '[JSON] String
+ :<|> "with-a-response-header"
+ :> Get '[JSON] (Headers '[Header "myResponse" String] String)
+
+testApi :: Proxy TestApi
+testApi = Proxy
diff --git a/test/CompileSpec.hs b/test/CompileSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/CompileSpec.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module CompileSpec where
+
+import Test.Hspec
+import Test.Mockery.Directory
+
+import Control.Exception
+import Control.Monad (when)
+import Data.String.Interpolate
+import Data.String.Interpolate.Util
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Reason (toReasonDecoderSource,
+ toReasonEncoderSource,
+ toReasonTypeSource)
+import Servant.API (NoContent)
+import Servant.Reason
+import System.Directory (canonicalizePath,
+ createDirectoryIfMissing,
+ doesDirectoryExist,
+ getCurrentDirectory, removeFile,
+ setCurrentDirectory)
+import System.Process
+
+import Common (Book, testApi)
+
+main :: IO ()
+main =
+ hspec spec
+
+spec :: Test.Hspec.Spec
+spec = do
+ describe "generateReasonForAPI" $ do
+ it "creates compilable javascript" $ do
+ inTempReasonDir $ do
+ let generated =
+ T.intercalate "\n\n" $
+ defReasonImports :
+ [ toReasonTypeSource (Proxy :: Proxy NoContent)
+ , toReasonTypeSource (Proxy :: Proxy Book)
+ , toReasonDecoderSource (Proxy :: Proxy Book)
+ , toReasonEncoderSource (Proxy :: Proxy Book)
+ ] ++
+ generateReasonForAPI testApi
+ T.writeFile "src/Api.re" generated
+ callCommand "yarn build"
+
+inTempReasonDir :: IO a -> IO a
+inTempReasonDir action = do
+ cacheExists <- doesDirectoryExist "_test-cache"
+ when (not cacheExists)
+ createCache
+ cacheSrcExists <- doesDirectoryExist "_test-cache/src"
+ when (not cacheSrcExists) $ do
+ createDirectoryIfMissing True "_test-cache/src"
+ cacheDir <- canonicalizePath "_test-cache"
+ inTempDirectory $ do
+ callCommand ("cp -r " ++ cacheDir ++ "/* .")
+ action
+
+createCache :: IO ()
+createCache = do
+ createDirectoryIfMissing True "_test-cache"
+ withCurrentDirectory "_test-cache" $ do
+ writeFile "package.json" $ unindent $ [i|
+{
+ "name": "json-test-project",
+ "version": "0.1.0",
+ "scripts": {
+ "build": "bsb -make-world",
+ "start": "bsb -make-world -w",
+ "clean": "bsb -clean-world"
+ },
+ "keywords": [
+ "BuckleScript"
+ ],
+ "author": "",
+ "license": "MIT",
+ "devDependencies": {
+ "bs-platform": "^5.0.0"
+ },
+ "dependencies": {
+ "@glennsl/bs-json": "^3.0.0",
+ "bs-fetch": "^0.3.1"
+ }
+}
+ |]
+ writeFile "bsconfig.json" $ unindent $ [i|
+{
+ "name": "json-test-project",
+ "version": "0.1.0",
+ "sources": {
+ "dir" : "src",
+ "subdirs" : true
+ },
+ "package-specs": {
+ "module": "commonjs",
+ "in-source": true
+ },
+ "suffix": ".bs.js",
+ "bs-dependencies": [
+ "bs-fetch",
+ "@glennsl/bs-json"
+ ],
+ "warnings": {
+ "error" : "+101"
+ },
+ "namespace": true,
+ "refmt": 3
+}
+ |]
+ callCommand "yarn install"
+ compileDependencies
+
+compileDependencies :: IO ()
+compileDependencies = do
+ pure ()
+
+withCurrentDirectory :: FilePath -> IO a -> IO a
+withCurrentDirectory dir action =
+ bracket enter recover (const action)
+ where
+ enter = do
+ original <- getCurrentDirectory
+ setCurrentDirectory dir
+ return original
+ recover = setCurrentDirectory
diff --git a/test/GenerateSpec.hs b/test/GenerateSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/GenerateSpec.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module GenerateSpec where
+
+import Control.Monad (zipWithM_)
+import qualified Data.Algorithm.Diff as Diff
+import qualified Data.Algorithm.DiffOutput as Diff
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Servant.API ((:>), Get, JSON)
+import Servant.Reason
+import Reason
+import Test.Hspec (Spec, describe, hspec, it, runIO)
+import Test.HUnit (Assertion, assertBool)
+
+import Common (testApi, Book)
+
+
+main :: IO ()
+main = hspec spec
+
+spec :: Test.Hspec.Spec
+spec = do
+ runIO $ putStrLn $ T.unpack $ toReasonTypeSourceWith defaultOptions (Proxy :: Proxy Book)
+ runIO $ putStrLn $ T.unpack $ toReasonDecoderSourceWith defaultOptions (Proxy :: Proxy Book)
+ runIO $ putStrLn $ T.unpack $ toReasonEncoderSourceWith defaultOptions (Proxy :: Proxy Book)
+ describe "encoding a simple api" $
+ do it "does it" $
+ do expected <-
+ mapM
+ (\(fpath,header) -> do
+ source <- T.readFile fpath
+ return (fpath, header, source))
+ [ ( "test/reason-sources/getOneSource.re", "")
+ , ( "test/reason-sources/postTwoSource.re", "")
+ , ( "test/reason-sources/getBooksByIdSource.re", "open BookType;\n")
+ , ( "test/reason-sources/getBooksByTitleSource.re", "open BookType;\n")
+ , ( "test/reason-sources/getBooksSource.re", "open BookType;\n")
+ , ( "test/reason-sources/postBooksSource.re", "open BookType;\n")
+ , ( "test/reason-sources/getNothingSource.re", "open BookType;\n")
+ , ( "test/reason-sources/putNothingSource.re", "open BookType;\n")
+ , ( "test/reason-sources/getWithaheaderSource.re", "open BookType;\n")
+ , ( "test/reason-sources/getWitharesponseheaderSource.re", "open BookType;\n")]
+ let generated = map (<> "\n") (generateReasonForAPI testApi)
+ generated `itemsShouldBe` expected
+ it "with dynamic URLs" $
+ do expected <-
+ mapM
+ (\(fpath,header) -> do
+ source <- T.readFile fpath
+ return (fpath, header, source))
+ [( "test/reason-sources/getOneWithDynamicUrlSource.re", "open BookType;\n")]
+ let generated =
+ map
+ (<> "\n")
+ (generateReasonForAPIWith
+ (defReasonOptions
+ { urlPrefix = Dynamic
+ })
+ (Proxy :: Proxy ("one" :> Get '[JSON] Int)))
+ generated `itemsShouldBe` expected
+
+itemsShouldBe :: [Text] -> [(String, Text, Text)] -> IO ()
+itemsShouldBe actual expected =
+ zipWithM_
+ shouldBeDiff
+ (actual ++ replicate (length expected - length actual) mempty)
+ (expected ++ replicate (length actual - length expected) mempty)
+
+shouldBeDiff :: Text -> (String, Text, Text) -> Assertion
+shouldBeDiff a (fpath,header,b) =
+ assertBool
+ ("< generated\n" <> "> " <> fpath <> "\n" <>
+ Diff.ppDiff
+ (Diff.getGroupedDiff
+ (lines (T.unpack (header <> a)))
+ (lines (T.unpack b))))
+ (header <> a == b)
diff --git a/test/reason-sources/BookType.re b/test/reason-sources/BookType.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/BookType.re
@@ -0,0 +1,7 @@
+type book = { title : string}
+
+let rec decodeBook = json =>
+ {title : json |> Json.Decode.field ("title" ,Json.Decode.string),}
+
+let rec encodeBook = (x : book) =>
+ Json.Encode.object_ ([ ( "title", Json.Encode.string(x.title) )])
diff --git a/test/reason-sources/getBooksByIdSource.re b/test/reason-sources/getBooksByIdSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/getBooksByIdSource.re
@@ -0,0 +1,13 @@
+open BookType;
+let getBooksById = (capture_id) => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "books"
+ , capture_id |> string_of_int |> Js_global.encodeURIComponent
+ ])
+ ,Fetch.RequestInit.make(~method_=Get
+ ,()))
+ |> then_(Fetch.Response.json)
+ |> then_(response => (response |> decodeBook |> ((x) => Belt_Result.Ok(x)) |> resolve)))
+}
diff --git a/test/reason-sources/getBooksByTitleSource.re b/test/reason-sources/getBooksByTitleSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/getBooksByTitleSource.re
@@ -0,0 +1,13 @@
+open BookType;
+let getBooksByTitle = (capture_title) => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "books"
+ , capture_title |> ((x) => x) |> Js_global.encodeURIComponent
+ ])
+ ,Fetch.RequestInit.make(~method_=Get
+ ,()))
+ |> then_(Fetch.Response.json)
+ |> then_(response => (response |> decodeBook |> ((x) => Belt_Result.Ok(x)) |> resolve)))
+}
diff --git a/test/reason-sources/getBooksSource.re b/test/reason-sources/getBooksSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/getBooksSource.re
@@ -0,0 +1,37 @@
+open BookType;
+let getBooks = (query_published
+ ,query_sort
+ ,query_year
+ ,query_category
+ ,query_filters) => {
+ let
+ params =
+ List.filter(((x) => (String.length(x) > 0))
+ ,[ if(query_published) {"published="} else {""}
+ , query_sort
+ |> ((x) => Belt.Option.mapWithDefault(x, "", ((x) => x)))
+ |> Js_global.encodeURIComponent
+ |> ((x__) => if(String.length(x__) > 0) { "query_sort=" ++ x__ } else {""})
+ , query_year
+ |> ((x) => Belt.Option.mapWithDefault(x, "", string_of_int))
+ |> Js_global.encodeURIComponent
+ |> ((x__) => if(String.length(x__) > 0) { "query_year=" ++ x__ } else {""})
+ , query_category
+ |> ((x) => x)
+ |> Js_global.encodeURIComponent
+ |> ((x__) => if(String.length(x__) > 0) { "query_category=" ++ x__ } else {""})
+ , String.concat("&"
+ ,List.map((x) => "filters[]=" ++ Js_global.encodeURIComponent(((x) => Belt.Option.mapWithDefault(x, "", string_of_bool))(x)), query_filters))
+ ]);
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "books"
+ ])
+ ++ if(List.length(params)==0) {""} else {"?" ++ String.concat("&"
+ ,params)}
+ ,Fetch.RequestInit.make(~method_=Get
+ ,()))
+ |> then_(Fetch.Response.json)
+ |> then_(response => (response |> Json.Decode.list(decodeBook) |> ((x) => Belt_Result.Ok(x)) |> resolve)))
+}
diff --git a/test/reason-sources/getNothingSource.re b/test/reason-sources/getNothingSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/getNothingSource.re
@@ -0,0 +1,12 @@
+open BookType;
+let getNothing = () => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "nothing"
+ ])
+ ,Fetch.RequestInit.make(~method_=Get
+ ,()))
+ |> then_(Fetch.Response.text)
+ |> then_(response => (response |> ((x) => if(String.length(x) != 0) { resolve(Belt_Result.Error("Expected the response body to empty")) } else { resolve(Belt_Result.Ok(x)) }))))
+}
diff --git a/test/reason-sources/getOneSource.re b/test/reason-sources/getOneSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/getOneSource.re
@@ -0,0 +1,11 @@
+let getOne = () => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "one"
+ ])
+ ,Fetch.RequestInit.make(~method_=Get
+ ,()))
+ |> then_(Fetch.Response.json)
+ |> then_(response => (response |> Json.Decode.int |> ((x) => Belt_Result.Ok(x)) |> resolve)))
+}
diff --git a/test/reason-sources/getOneWithDynamicUrlSource.re b/test/reason-sources/getOneWithDynamicUrlSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/getOneWithDynamicUrlSource.re
@@ -0,0 +1,12 @@
+open BookType;
+let getOne = (urlBase) => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ urlBase
+ , "one"
+ ])
+ ,Fetch.RequestInit.make(~method_=Get
+ ,()))
+ |> then_(Fetch.Response.json)
+ |> then_(response => (response |> Json.Decode.int |> ((x) => Belt_Result.Ok(x)) |> resolve)))
+}
diff --git a/test/reason-sources/getWithaheaderSource.re b/test/reason-sources/getWithaheaderSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/getWithaheaderSource.re
@@ -0,0 +1,24 @@
+open BookType;
+let getWithaheader = (header_myStringHeader
+ ,header_MyIntHeader
+ ,header_MyRequiredStringHeader
+ ,header_MyRequiredIntHeader) => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "with-a-header"
+ ])
+ ,Fetch.RequestInit.make(~method_=Get
+ ,~headers=
+ Fetch.HeadersInit.makeWithDict(
+ Js.Dict.fromList(
+ Belt.List.keepMap(
+ [ Belt.Option.map(header_myStringHeader, x => ("myStringHeader", x |> ((x) => x)))
+ , Belt.Option.map(header_MyIntHeader, x => ("MyIntHeader", x |> string_of_int))
+ , Belt.Option.map((Some(header_MyRequiredStringHeader)), x => ("MyRequiredStringHeader", x |> ((x) => x)))
+ , Belt.Option.map((Some(header_MyRequiredIntHeader)), x => ("MyRequiredIntHeader", x |> string_of_int))
+ ], x => x)))
+ ,()))
+ |> then_(Fetch.Response.json)
+ |> then_(response => (response |> Json.Decode.string |> ((x) => Belt_Result.Ok(x)) |> resolve)))
+}
diff --git a/test/reason-sources/getWitharesponseheaderSource.re b/test/reason-sources/getWitharesponseheaderSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/getWitharesponseheaderSource.re
@@ -0,0 +1,12 @@
+open BookType;
+let getWitharesponseheader = () => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "with-a-response-header"
+ ])
+ ,Fetch.RequestInit.make(~method_=Get
+ ,()))
+ |> then_(Fetch.Response.json)
+ |> then_(response => (response |> Json.Decode.string |> ((x) => Belt_Result.Ok(x)) |> resolve)))
+}
diff --git a/test/reason-sources/postBooksSource.re b/test/reason-sources/postBooksSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/postBooksSource.re
@@ -0,0 +1,19 @@
+open BookType;
+let postBooks = (body) => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "books"
+ ])
+ ,Fetch.RequestInit.make(~method_=Post
+ ,~headers=
+ Fetch.HeadersInit.makeWithDict(
+ Js.Dict.fromList(
+ Belt.List.keepMap(
+ [ Some(("Content-Type","application/json"))
+ ], x => x)))
+ ,~body=Fetch.BodyInit.make(Js.Json.stringify(encodeBook(body)))
+ ,()))
+ |> then_(Fetch.Response.text)
+ |> then_(response => (response |> ((x) => if(String.length(x) != 0) { resolve(Belt_Result.Error("Expected the response body to empty")) } else { resolve(Belt_Result.Ok(x)) }))))
+}
diff --git a/test/reason-sources/postTwoSource.re b/test/reason-sources/postTwoSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/postTwoSource.re
@@ -0,0 +1,18 @@
+let postTwo = (body) => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "two"
+ ])
+ ,Fetch.RequestInit.make(~method_=Post
+ ,~headers=
+ Fetch.HeadersInit.makeWithDict(
+ Js.Dict.fromList(
+ Belt.List.keepMap(
+ [ Some(("Content-Type","application/json"))
+ ], x => x)))
+ ,~body=Fetch.BodyInit.make(Js.Json.stringify(Json.Encode.string(body)))
+ ,()))
+ |> then_(Fetch.Response.json)
+ |> then_(response => (response |> Json.Decode.optional(Json.Decode.int) |> ((x) => Belt_Result.Ok(x)) |> resolve)))
+}
diff --git a/test/reason-sources/putNothingSource.re b/test/reason-sources/putNothingSource.re
new file mode 100644
--- /dev/null
+++ b/test/reason-sources/putNothingSource.re
@@ -0,0 +1,12 @@
+open BookType;
+let putNothing = () => {
+ Js.Promise.(
+ Fetch.fetchWithInit(String.concat("/"
+ ,[ ""
+ , "nothing"
+ ])
+ ,Fetch.RequestInit.make(~method_=Put
+ ,()))
+ |> then_(Fetch.Response.text)
+ |> then_(response => (response |> ((x) => if(String.length(x) != 0) { resolve(Belt_Result.Error("Expected the response body to empty")) } else { resolve(Belt_Result.Ok(x)) }))))
+}