packages feed

ghcjs-fetch (empty) → 0.1.0.0

raw patch · 8 files changed

+556/−0 lines, 8 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bytestring, case-insensitive, ghcjs-base, ghcjs-base-stub, ghcjs-fetch, hspec, hspec-core, http-types, text, unordered-containers

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghcjs-fetch.cabal view
@@ -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
+ src/GHCJS/Fetch.hs view
@@ -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+<https://developer.mozilla.org/en-US/docs/Web/API/Fetch_API/Using_Fetch>.+-}+{-# 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 <https://developer.mozilla.org/en-US/docs/Web/API/Request/mode>.+data RequestMode+  = Cors+  | NoCors+  | SameOrigin+  | Navigate+  deriving (Show, Eq, Ord)++-- | See <https://developer.mozilla.org/en-US/docs/Web/API/Request/credentials>.+data RequestCredentials+  = CredOmit+  | CredSameOrigin+  | CredInclude+  deriving (Show, Eq, Ord)++-- | See <https://developer.mozilla.org/en-US/docs/Web/API/Request/cache>.+data RequestCacheMode+  = CacheDefault+  | NoStore+  | Reload+  | NoCache+  | ForceCache+  | OnlyIfCached+  deriving (Show, Eq, Ord)++-- | See <https://developer.mozilla.org/en-US/docs/Web/API/Request/redirect>.+data RequestRedirectMode+  = Follow+  | Error+  | Manual+  deriving (Show, Eq, Ord)++-- | See <https://developer.mozilla.org/en-US/docs/Web/API/Request/referrer>.+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 <https://developer.mozilla.org/en-US/docs/Web/API/Request/method>.+  , reqOptHeaders :: !RequestHeaders -- ^ See <https://developer.mozilla.org/en-US/docs/Web/API/Headers>.+  , reqOptBody :: !(Maybe JSVal) -- ^ Corresponds to the @body@ argument in <https://developer.mozilla.org/en-US/docs/Web/API/Headers>.+  , reqOptMode :: !RequestMode+  , reqOptCredentials :: !RequestCredentials+  , reqOptCacheMode :: !RequestCacheMode+  , reqOptRedirectMode :: !RequestRedirectMode+  , reqOptReferrer :: !RequestReferrer+  }++-- | See <https://developer.mozilla.org/en-US/docs/Web/API/Request>.+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 <https://developer.mozilla.org/en-US/docs/Web/API/WindowOrWorkerGlobalScope/fetch>.+fetch :: Request -> IO JSResponse+fetch req = do+  JSResponse <$> (await =<< js_fetch =<< toJSRequest req)++-- | Throws 'JSPromiseException' when decoding fails.+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Body/json>.+responseJSON :: JSResponse -> IO Value+responseJSON resp = fromJSValUnchecked =<< await =<< js_responseJSON resp++-- | Throws 'JSPromiseException' when decoding fails.+--+-- See <https://developer.mozilla.org/en-US/docs/Web/API/Body/text>.+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)
+ src/GHCJS/Fetch/FFI.hs view
@@ -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
+ src/GHCJS/Fetch/Types.hs view
@@ -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)
+ test/Spec.hs view
@@ -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+              [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"+              , "<title>405 Method Not Allowed</title>"+              , "<h1>Method Not Allowed</h1>"+              , "<p>The method is not allowed for the requested URL.</p>"+              ]+        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 ()