From c3849e15811d8fe8468b744dd688e1590e77c21a Mon Sep 17 00:00:00 2001 From: Eugene Date: Sun, 4 Sep 2016 11:58:36 +0300 Subject: [PATCH 1/4] Added ability to pass external XHR instance to xhr* family of functions --- .gitignore | 1 + JavaScript/Web/XMLHttpRequest.hs | 119 +++++++++++++++++++------------ 2 files changed, 73 insertions(+), 47 deletions(-) diff --git a/.gitignore b/.gitignore index 2e38caf..62d0047 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ *~ *# /dist +.stack-work diff --git a/JavaScript/Web/XMLHttpRequest.hs b/JavaScript/Web/XMLHttpRequest.hs index 5d51324..3314f0b 100644 --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -5,9 +5,15 @@ LambdaCase, MultiParamTypeClasses, DeriveGeneric #-} module JavaScript.Web.XMLHttpRequest ( xhr + , xhr' , xhrByteString + , xhrByteString' , xhrText + , xhrText' , xhrString + , xhrString' + , xhrCreate + , xhrAbort , Method(..) , Request(..) , RequestData(..) @@ -57,7 +63,7 @@ data Method = GET | POST | PUT | DELETE data XHRError = XHRError String | XHRAborted - deriving (Generic, Data, Typeable, Show, Eq) + deriving (Generic, Data, Typeable, Show, Eq) instance Exception XHRError @@ -124,53 +130,59 @@ newtype XHR = XHR JSVal deriving (Typeable) -- ----------------------------------------------------------------------------- -- main entry point +doRequest :: forall a. ResponseType a => Request -> XHR -> IO (Response a) +doRequest req x = do + case reqLogin req of + Nothing -> + js_open2 (methodJSString (reqMethod req)) (reqURI req) x + Just (user, pass) -> + js_open4 (methodJSString (reqMethod req)) (reqURI req) user pass x + js_setResponseType + (getResponseTypeString (Proxy :: Proxy a)) x + forM_ (reqHeaders req) (\(n,v) -> js_setRequestHeader n v x) + + case reqWithCredentials req of + True -> js_setWithCredentials x + False -> return () + + r <- case reqData req of + NoData -> + js_send0 x + StringData str -> + js_send1 (pToJSVal str) x + TypedArrayData (SomeTypedArray t) -> + js_send1 t x + FormData xs -> do + fd@(JSFormData fd') <- js_createFormData + forM_ xs $ \(name, val) -> case val of + StringVal str -> + js_appendFormData2 name (pToJSVal str) fd + BlobVal (SomeBlob b) mbFile -> + appendFormData name b mbFile fd + FileVal (SomeBlob b) mbFile -> + appendFormData name b mbFile fd + js_send1 fd' x + case r of + 0 -> do + status <- js_getStatus x + r <- do + hr <- js_hasResponse x + if hr then Just . wrapResponseType <$> js_getResponse x + else pure Nothing + return $ Response r + status + (js_getAllResponseHeaders x) + (\h -> getResponseHeader' h x) + 1 -> throwIO XHRAborted + 2 -> throwIO (XHRError "network request error") + xhr :: forall a. ResponseType a => Request -> IO (Response a) -xhr req = js_createXHR >>= \x -> - let doRequest = do - case reqLogin req of - Nothing -> - js_open2 (methodJSString (reqMethod req)) (reqURI req) x - Just (user, pass) -> - js_open4 (methodJSString (reqMethod req)) (reqURI req) user pass x - js_setResponseType - (getResponseTypeString (Proxy :: Proxy a)) x - forM_ (reqHeaders req) (\(n,v) -> js_setRequestHeader n v x) - - case reqWithCredentials req of - True -> js_setWithCredentials x - False -> return () - - r <- case reqData req of - NoData -> - js_send0 x - StringData str -> - js_send1 (pToJSVal str) x - TypedArrayData (SomeTypedArray t) -> - js_send1 t x - FormData xs -> do - fd@(JSFormData fd') <- js_createFormData - forM_ xs $ \(name, val) -> case val of - StringVal str -> - js_appendFormData2 name (pToJSVal str) fd - BlobVal (SomeBlob b) mbFile -> - appendFormData name b mbFile fd - FileVal (SomeBlob b) mbFile -> - appendFormData name b mbFile fd - js_send1 fd' x - case r of - 0 -> do - status <- js_getStatus x - r <- do - hr <- js_hasResponse x - if hr then Just . wrapResponseType <$> js_getResponse x - else pure Nothing - return $ Response r - status - (js_getAllResponseHeaders x) - (\h -> getResponseHeader' h x) - 1 -> throwIO XHRAborted - 2 -> throwIO (XHRError "network request error") - in doRequest `onException` js_abort x +xhr req = js_createXHR >>= \x -> doRequest req x `onException` js_abort x + +-- applications might need to abort xhr requests based on their business logic +-- so we provide them a way to have xhr handle to cancel the xhr on demand +xhr' :: forall a. ResponseType a => XHR -> Request -> IO (Response a) +xhr' xo req = doRequest req xo `onException` js_abort xo appendFormData :: JSString -> JSVal -> Maybe JSString -> JSFormData -> IO () @@ -197,6 +209,19 @@ xhrByteString :: Request -> IO (Response ByteString) xhrByteString = fmap (fmap (Buffer.toByteString 0 Nothing . Buffer.createFromArrayBuffer)) . xhr +xhrString' :: XHR -> Request -> IO (Response String) +xhrString' xo = fmap (fmap JSS.unpack) . xhr' xo + +xhrText' :: XHR -> Request -> IO (Response Text) +xhrText' xo = fmap (fmap textFromJSString) . xhr' xo + +xhrByteString' :: XHR -> Request -> IO (Response ByteString) +xhrByteString' xo = fmap + (fmap (Buffer.toByteString 0 Nothing . Buffer.createFromArrayBuffer)) . xhr' xo + + -- ----------------------------------------------------------------------------- +xhrCreate = js_createXHR +xhrAbort = js_abort -- ----------------------------------------------------------------------------- foreign import javascript unsafe From c18c2702cd0e5a6b5ad2f8c997b56b126119398c Mon Sep 17 00:00:00 2001 From: Eugene Date: Sun, 4 Sep 2016 12:28:11 +0300 Subject: [PATCH 2/4] Export XHR newtype --- JavaScript/Web/XMLHttpRequest.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/JavaScript/Web/XMLHttpRequest.hs b/JavaScript/Web/XMLHttpRequest.hs index 3314f0b..f594978 100644 --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -21,6 +21,7 @@ module JavaScript.Web.XMLHttpRequest ( xhr , ResponseType(..) , FormDataVal(..) , XHRError(..) + , XHR(..) ) where import Control.Applicative From 004dcae6e685ecf2df9a3f62709a3ee2584afef4 Mon Sep 17 00:00:00 2001 From: Eugene Naumenko Date: Sat, 15 Jul 2017 16:14:16 +0300 Subject: [PATCH 3/4] bumped dependency version for dlist to <0.9 --- ghcjs-base.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal index 68f1d26..77cd3cd 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -140,7 +140,7 @@ library transformers >= 0.3 && < 0.6, primitive >= 0.5 && < 0.7, deepseq >= 1.3 && < 1.5, - dlist >= 0.7 && < 0.8 + dlist >= 0.7 && < 0.9 test-suite tests type: exitcode-stdio-1.0 From a5e3eaefdceacbc20446067132bb4fd8663ab4d3 Mon Sep 17 00:00:00 2001 From: Eugene Naumenko Date: Wed, 13 Feb 2019 19:13:10 +0200 Subject: [PATCH 4/4] added PATCH http method --- JavaScript/Web/XMLHttpRequest.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/JavaScript/Web/XMLHttpRequest.hs b/JavaScript/Web/XMLHttpRequest.hs index f594978..18bbf30 100644 --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -59,7 +59,7 @@ import JavaScript.Web.Blob.Internal import JavaScript.Web.File -data Method = GET | POST | PUT | DELETE +data Method = GET | POST | PUT | PATCH | DELETE deriving (Show, Eq, Ord, Enum) data XHRError = XHRError String @@ -72,6 +72,7 @@ methodJSString :: Method -> JSString methodJSString GET = "GET" methodJSString POST = "POST" methodJSString PUT = "PUT" +methodJSString PATCH = "PATCH" methodJSString DELETE = "DELETE" type Header = (JSString, JSString)