diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Moritz Kiefer (c) 2017 + +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 Moritz Kiefer 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,10 @@ +# ghcjs-fetch + +[![Travis](https://img.shields.io/travis/cocreature/ghcjs-fetch.svg)](https://travis-ci.org/cocreature/ghcjs-fetch) [![Hackage](https://img.shields.io/hackage/v/ghcjs-fetch.svg)](https://hackage.haskell.org/package/ghcjs-fetch) + +Haskell bindings for the [JavaScript Fetch +API](https://developer.mozilla.org/en-US/docs/Web/API/Fetch_API). + +## Running the tests +* Build the test executable using `cabal new-build ghcjs-fetch-test`. +* Run the tests with `node selenium.js`. 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/ghcjs-fetch.cabal b/ghcjs-fetch.cabal new file mode 100644 --- /dev/null +++ b/ghcjs-fetch.cabal @@ -0,0 +1,53 @@ +name: ghcjs-fetch +version: 0.1.0.0 +synopsis: GHCJS bindings for the JavaScript Fetch API +homepage: https://github.com/cocreature/ghcjs-fetch#readme +license: BSD3 +license-file: LICENSE +author: Moritz Kiefer +maintainer: moritz.kiefer@purelyfunctional.org +copyright: (C) 2017 Moritz Kiefer +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 +tested-with: GHC == 8.0.2 + +library + hs-source-dirs: src + exposed-modules: GHCJS.Fetch + GHCJS.Fetch.FFI + GHCJS.Fetch.Types + build-depends: aeson >= 1.1 && < 1.3 + , base >= 4.9 && < 5 + , bytestring >= 0.10 && < 0.11 + , case-insensitive >= 1.2 && < 1.3 + , http-types >= 0.9 && < 0.10 + if impl(ghcjs) + build-depends: ghcjs-base + else + build-depends: ghcjs-base-stub + default-language: Haskell2010 + +test-suite ghcjs-fetch-test + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Spec.hs + if !impl(ghcjs) + buildable: False + else + build-depends: aeson + , base + , ghcjs-base >= 0.2 && < 0.3 + , ghcjs-fetch + , hspec >= 2.4 && < 2.5 + , hspec-core >= 2.4 && < 2.5 + , http-types + , QuickCheck >= 2.9 && < 2.11 + , text >= 1.2 && < 1.3 + , unordered-containers >= 0.2 && < 0.3 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/cocreature/ghcjs-fetch diff --git a/src/GHCJS/Fetch.hs b/src/GHCJS/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Fetch.hs @@ -0,0 +1,270 @@ +{-| +Module : GHCJS.Fetch +Description : GHCJS bindings for the JavaScript Fetch API +Copyright : (c) Moritz Kiefer, 2017 +License : BSD3 +Maintainer : moritz.kiefer@purelyfunctional.org +Stability : experimental +Portability : GHCJS + +This module provides bindings for JavaScript’s [Fetch +API](https://developer.mozilla.org/en-US/docs/Web/API/Fetch_API). + +The bindings deliberately stay close to the JavaScript API so most +documentation and tutorials should be easily translatable. + +An introduction to the Fetch API can be found at +. +-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module GHCJS.Fetch + ( + -- * Fetch + fetch + -- * Request + , Request(..) + , RequestOptions(..) + , defaultRequestOptions + , RequestMode(..) + , RequestCredentials(..) + , RequestCacheMode(..) + , RequestRedirectMode(..) + , RequestReferrer(..) + -- * Response + , responseJSON + , responseText + -- * Exceptions + , JSPromiseException(..) + ) where + +import Control.Exception +import Data.Aeson (Value(..)) +import qualified Data.ByteString.Char8 as Char8 +import Data.CaseInsensitive as CI +import Data.Foldable +import qualified Data.JSString as JSString +import Data.Typeable +import GHCJS.Foreign.Callback +import GHCJS.Marshal +import GHCJS.Marshal.Pure +import GHCJS.Types +import JavaScript.Object (setProp, getProp) +import qualified JavaScript.Object as Object +import JavaScript.Object.Internal (Object(..)) +import Network.HTTP.Types +import System.IO.Unsafe + +import GHCJS.Fetch.FFI +import GHCJS.Fetch.Types + +-- | See . +data RequestMode + = Cors + | NoCors + | SameOrigin + | Navigate + deriving (Show, Eq, Ord) + +-- | See . +data RequestCredentials + = CredOmit + | CredSameOrigin + | CredInclude + deriving (Show, Eq, Ord) + +-- | See . +data RequestCacheMode + = CacheDefault + | NoStore + | Reload + | NoCache + | ForceCache + | OnlyIfCached + deriving (Show, Eq, Ord) + +-- | See . +data RequestRedirectMode + = Follow + | Error + | Manual + deriving (Show, Eq, Ord) + +-- | See . +data RequestReferrer + = NoReferrer + | Client + | ReferrerUrl !JSString + deriving (Show, Eq, Ord) + +-- | These options correspond to the @init@ argument to the [Request constructor](https://developer.mozilla.org/en-US/docs/Web/API/Request/Request). +data RequestOptions = RequestOptions + { reqOptMethod :: !Method -- ^ See . + , reqOptHeaders :: !RequestHeaders -- ^ See . + , reqOptBody :: !(Maybe JSVal) -- ^ Corresponds to the @body@ argument in . + , reqOptMode :: !RequestMode + , reqOptCredentials :: !RequestCredentials + , reqOptCacheMode :: !RequestCacheMode + , reqOptRedirectMode :: !RequestRedirectMode + , reqOptReferrer :: !RequestReferrer + } + +-- | See . +data Request = Request + { reqUrl :: !JSString + , reqOptions :: !RequestOptions + } + +-- | Default request options. These correspond to the default options +-- specified in the fetch standard. +defaultRequestOptions :: RequestOptions +defaultRequestOptions = + RequestOptions + { reqOptMethod = methodGet + , reqOptHeaders = [] + , reqOptBody = Nothing + , reqOptMode = Cors + , reqOptCredentials = CredOmit + , reqOptCacheMode = CacheDefault + , reqOptRedirectMode = Follow + , reqOptReferrer = Client + } + +requestHeadersJSVal :: RequestHeaders -> IO JSVal +requestHeadersJSVal headers = do + headersObj <- js_newHeaders + traverse_ + (\(name, val) -> do + let name' = (JSString.pack . Char8.unpack . CI.original) name + val' = (JSString.pack . Char8.unpack) val + js_appendHeader headersObj name' val') + headers + pure (jsval headersObj) + +instance PToJSVal RequestMode where + pToJSVal mode = + case mode of + Cors -> jsval ("cors" :: JSString) + NoCors -> jsval ("no-cors" :: JSString) + SameOrigin -> jsval ("same-origin" :: JSString) + Navigate -> jsval ("navigate" :: JSString) + +instance ToJSVal RequestMode where + toJSVal = pure . pToJSVal + +instance PToJSVal RequestCredentials where + pToJSVal cred = + case cred of + CredOmit -> jsval ("omit" :: JSString) + CredSameOrigin -> jsval ("same-origin" :: JSString) + CredInclude -> jsval ("include" :: JSString) + +instance ToJSVal RequestCredentials where + toJSVal = pure . pToJSVal + +instance PToJSVal RequestCacheMode where + pToJSVal cacheMode = + case cacheMode of + CacheDefault -> jsval ("default" :: JSString) + NoStore -> jsval ("no-store" :: JSString) + Reload -> jsval ("reload" :: JSString) + NoCache -> jsval ("no-cache" :: JSString) + ForceCache -> jsval ("force-cache" :: JSString) + OnlyIfCached -> jsval ("only-if-cached" :: JSString) + +instance ToJSVal RequestCacheMode where + toJSVal = pure . pToJSVal + +instance PToJSVal RequestRedirectMode where + pToJSVal redirectMode = + case redirectMode of + Follow -> jsval ("follow" :: JSString) + Error -> jsval ("error" :: JSString) + Manual -> jsval ("manual" :: JSString) + +instance ToJSVal RequestRedirectMode where + toJSVal = pure . pToJSVal + +instance PToJSVal RequestReferrer where + pToJSVal referrer = + case referrer of + NoReferrer -> jsval ("no-referrer" :: JSString) + Client -> jsval ("about:client" :: JSString) + ReferrerUrl url -> jsval url + +instance ToJSVal RequestReferrer where + toJSVal = pure . pToJSVal + +instance ToJSVal RequestOptions where + toJSVal (RequestOptions { reqOptMethod + , reqOptBody + , reqOptHeaders + , reqOptMode + , reqOptCredentials + , reqOptCacheMode + , reqOptRedirectMode + , reqOptReferrer + }) = do + obj <- Object.create + setMethod obj + setHeaders obj + setBody obj + setMode obj + setCredentials obj + setCacheMode obj + setRedirectMode obj + setReferrer obj + pure (jsval obj) + where + setMethod obj = + setProp + "method" + ((jsval . JSString.pack . Char8.unpack) reqOptMethod) + obj + setBody obj = traverse_ (\body -> setProp "body" body obj) reqOptBody + setHeaders obj = do + headers <- requestHeadersJSVal reqOptHeaders + setProp "headers" headers obj + setMode obj = setProp "mode" (pToJSVal reqOptMode) obj + setCredentials obj = + setProp "credentials" (pToJSVal reqOptCredentials) obj + setCacheMode obj = setProp "cache-mode" (pToJSVal reqOptCacheMode) obj + setRedirectMode obj = setProp "redirect" (pToJSVal reqOptRedirectMode) obj + setReferrer obj = setProp "referrer" (pToJSVal reqOptReferrer) obj + +toJSRequest :: Request -> IO JSRequest +toJSRequest (Request url opts) = do + opts' <- toJSVal opts + js_newRequest url opts' + +-- | Throws 'JSPromiseException' when the request fails. +-- See . +fetch :: Request -> IO JSResponse +fetch req = do + JSResponse <$> (await =<< js_fetch =<< toJSRequest req) + +-- | Throws 'JSPromiseException' when decoding fails. +-- +-- See . +responseJSON :: JSResponse -> IO Value +responseJSON resp = fromJSValUnchecked =<< await =<< js_responseJSON resp + +-- | Throws 'JSPromiseException' when decoding fails. +-- +-- See . +responseText :: JSResponse -> IO JSString +responseText resp = + fromJSValUnchecked =<< await =<< js_responseText resp + +await :: JSPromise a -> IO JSVal +await p = do + obj <- js_await p + Just success <- fromJSVal =<< getProp "success" obj + if success + then getProp "val" obj + else do + err <- getProp "val" obj + throwIO (JSPromiseException err) diff --git a/src/GHCJS/Fetch/FFI.hs b/src/GHCJS/Fetch/FFI.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Fetch/FFI.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE JavaScriptFFI #-} +module GHCJS.Fetch.FFI + ( js_newRequest + , js_await + , js_fetch + , js_responseJSON + , js_responseText + , js_newHeaders + , js_appendHeader + ) where + +import GHC.Stack +import GHCJS.Fetch.Types +import GHCJS.Types +import JavaScript.Object + +#ifdef ghcjs_HOST_OS +foreign import javascript safe "new Request($1, $2)" js_newRequest + :: JSString -> JSVal -> IO JSRequest + +foreign import javascript interruptible + "$1.then(function(a) { $c({ 'val': a, 'success': true }); }, function(e) { $c({ 'val': e, 'success': false }); });" + js_await :: JSPromise a -> IO Object + +foreign import javascript safe "fetch($1)" js_fetch :: + JSRequest -> IO (JSPromise JSResponse) + +foreign import javascript safe "$1.json()" js_responseJSON :: + JSResponse -> IO (JSPromise JSVal) + +foreign import javascript safe "$1.text()" js_responseText :: + JSResponse -> IO (JSPromise JSString) + +foreign import javascript safe "new Headers()" js_newHeaders :: + IO JSHeaders + +foreign import javascript safe "$1.append($2, $3);" js_appendHeader + :: JSHeaders -> JSString -> JSString -> IO () + +#else + +ghcjsOnly :: HasCallStack => a +ghcjsOnly = error "This definition is only supported on ghcjs" + +js_newRequest :: JSString -> JSVal -> IO JSRequest +js_newRequest = ghcjsOnly + +js_await :: JSPromise a -> IO Object +js_await = ghcjsOnly + +js_fetch :: JSRequest -> IO (JSPromise JSResponse) +js_fetch = ghcjsOnly + +js_responseJSON :: JSResponse -> IO (JSPromise JSVal) +js_responseJSON = ghcjsOnly + +js_responseText :: JSResponse -> IO (JSPromise JSString) +js_responseText = ghcjsOnly + +js_newHeaders :: IO JSHeaders +js_newHeaders = ghcjsOnly + +js_appendHeader :: JSHeaders -> JSString -> JSString -> IO () +js_appendHeader = ghcjsOnly +#endif diff --git a/src/GHCJS/Fetch/Types.hs b/src/GHCJS/Fetch/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHCJS/Fetch/Types.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHCJS.Fetch.Types + ( JSRequest(..) + , JSResponse(..) + , JSHeaders(..) + , JSPromise(..) + , JSPromiseException(..) + ) where + +import Control.Exception +import Data.Typeable +import GHCJS.Marshal +import GHCJS.Types + +newtype JSHeaders = + JSHeaders JSVal + +instance IsJSVal JSHeaders + +newtype JSRequest = JSRequest JSVal + +newtype JSPromise a = JSPromise JSVal + +instance Show JSPromiseException where + show _ = "PromiseException" + +data JSPromiseException = + JSPromiseException !JSVal + deriving (Typeable) + +instance Exception JSPromiseException + +newtype JSResponse = + JSResponse JSVal + deriving (FromJSVal) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Exception (catch, finally) +import Data.Aeson (Value(..), Object) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.JSString as JSString +import Data.Text (Text) +import GHCJS.Fetch +import GHCJS.Marshal +import GHCJS.Types +import Network.HTTP.Types +import Test.Hspec +import Test.Hspec.Core.Runner (Config(..), hspecWith, defaultConfig, ColorMode(..)) +import Test.QuickCheck + +main :: IO () +main = do + flip finally seleniumAsync $ + hspecWith defaultConfig {configColorMode = ColorNever} $ do + describe "fetch" $ do + it "can GET" $ do + resp <- + fetch (Request "https://httpbin.org/get" defaultRequestOptions) + val <- responseJSON resp + withObject val $ \obj -> + HashMap.lookup "url" obj `shouldBe` + Just (String "https://httpbin.org/get") + it "should throw on nonexisting URL" $ + fetch (Request "https://nonexistent.AA" defaultRequestOptions) `shouldThrow` + (\(JSPromiseException _) -> True) + it "can’t POST using GET" $ do + resp <- + fetch (Request "https://httpbin.org/post" defaultRequestOptions) + responseText resp `shouldReturn` + JSString.unlines + [ "" + , "405 Method Not Allowed" + , "

Method Not Allowed

" + , "

The method is not allowed for the requested URL.

" + ] + it "can POST" $ do + resp <- + fetch + (Request + "https://httpbin.org/post" + defaultRequestOptions {reqOptMethod = methodPost}) + val <- responseJSON resp + withObject val $ \obj -> + HashMap.lookup "url" obj `shouldBe` + Just (String "https://httpbin.org/post") + it "can POST text/plain" $ do + resp <- + fetch + (Request + "https://httpbin.org/post" + defaultRequestOptions + { reqOptMethod = methodPost + , reqOptBody = Just (jsval ("my-text" :: JSString)) + }) + val <- responseJSON resp + withObject val $ \obj -> do + (lookupKey "Content-Type" =<< HashMap.lookup "headers" obj) `shouldBe` + Just (String "text/plain;charset=UTF-8") + HashMap.lookup "data" obj `shouldBe` Just (String "my-text") + it "can set HEADERS" $ do + resp <- + fetch + (Request + "https://httpbin.org/get" + defaultRequestOptions + {reqOptHeaders = [("My-Header-Name", "my-header-value")]}) + val <- responseJSON resp + withObject val $ \obj -> + (lookupKey "My-Header-Name" =<< HashMap.lookup "headers" obj) `shouldBe` + Just (String "my-header-value") + +withObject :: Value -> (Object -> Expectation) -> Expectation +withObject (Object obj) f = f obj +withObject val _ = expectationFailure ("Expected Object but got: " ++ show val) + +lookupKey :: Text -> Value -> Maybe Value +lookupKey k (Object obj) = HashMap.lookup k obj +lookupKey _ _ = Nothing + +foreign import javascript safe "console.log($1);" consoleLog :: + JSVal -> IO () +foreign import javascript safe "window.seleniumCallback();" + seleniumAsync :: IO ()