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..18bbf30 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(..) @@ -15,6 +21,7 @@ module JavaScript.Web.XMLHttpRequest ( xhr , ResponseType(..) , FormDataVal(..) , XHRError(..) + , XHR(..) ) where import Control.Applicative @@ -52,12 +59,12 @@ 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 | XHRAborted - deriving (Generic, Data, Typeable, Show, Eq) + deriving (Generic, Data, Typeable, Show, Eq) instance Exception XHRError @@ -65,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) @@ -124,53 +132,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 +211,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 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