{-# LANGUAGE DeriveDataTypeable #-}
module JSDOM.Custom.XMLHttpRequest (
    module Generated
  , XHRError(..)
  , send
  , sendString
  , sendArrayBuffer
  , sendBlob
  , sendDocument
  , sendFormData
) where

import Prelude ()
import Prelude.Compat
import Data.Typeable (Typeable)
import Control.Concurrent.MVar (takeMVar, newEmptyMVar, putMVar)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Catch (onException, bracket, throwM)
import Control.Exception (Exception(..))
import Control.Lens.Operators ((^.))

import Language.Javascript.JSaddle
       (js0, js1, ToJSString, ToJSVal(..), JSVal)
import JSDOM.Types
       (DOM, MonadDOM, liftDOM, FormData(..), IsDocument, IsBlob, IsArrayBufferView)
import JSDOM.EventM (onAsync)

import JSDOM.Generated.XMLHttpRequest as Generated hiding (send)
import JSDOM.Generated.XMLHttpRequestEventTarget as Generated

data XHRError = XHRError
              | XHRAborted
              deriving (Int -> XHRError -> ShowS
[XHRError] -> ShowS
XHRError -> String
(Int -> XHRError -> ShowS)
-> (XHRError -> String) -> ([XHRError] -> ShowS) -> Show XHRError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XHRError] -> ShowS
$cshowList :: [XHRError] -> ShowS
show :: XHRError -> String
$cshow :: XHRError -> String
showsPrec :: Int -> XHRError -> ShowS
$cshowsPrec :: Int -> XHRError -> ShowS
Show, XHRError -> XHRError -> Bool
(XHRError -> XHRError -> Bool)
-> (XHRError -> XHRError -> Bool) -> Eq XHRError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XHRError -> XHRError -> Bool
$c/= :: XHRError -> XHRError -> Bool
== :: XHRError -> XHRError -> Bool
$c== :: XHRError -> XHRError -> Bool
Eq, Typeable)

instance Exception XHRError

throwXHRError :: MonadDOM m => Maybe XHRError -> m ()
throwXHRError :: Maybe XHRError -> m ()
throwXHRError = m () -> (XHRError -> m ()) -> Maybe XHRError -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (DOM () -> m ()
forall (m :: * -> *) a. MonadDOM m => DOM a -> m a
liftDOM (DOM () -> m ()) -> (XHRError -> DOM ()) -> XHRError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XHRError -> DOM ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM)

withEvent :: DOM (DOM ()) -> DOM a -> DOM a
withEvent :: DOM (DOM ()) -> DOM a -> DOM a
withEvent DOM (DOM ())
aquire = DOM (DOM ()) -> (DOM () -> DOM ()) -> (DOM () -> DOM a) -> DOM a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket DOM (DOM ())
aquire DOM () -> DOM ()
forall a. a -> a
id ((DOM () -> DOM a) -> DOM a)
-> (DOM a -> DOM () -> DOM a) -> DOM a -> DOM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DOM a -> DOM () -> DOM a
forall a b. a -> b -> a
const

send' :: (MonadDOM m) => XMLHttpRequest -> Maybe JSVal -> m ()
send' :: XMLHttpRequest -> Maybe JSVal -> m ()
send' XMLHttpRequest
self Maybe JSVal
mbVal = DOM () -> m ()
forall (m :: * -> *) a. MonadDOM m => DOM a -> m a
liftDOM (DOM () -> m ()) -> DOM () -> m ()
forall a b. (a -> b) -> a -> b
$ (DOM () -> DOM () -> DOM ()
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` XMLHttpRequest -> DOM ()
forall (m :: * -> *). MonadDOM m => XMLHttpRequest -> m ()
abort XMLHttpRequest
self) (DOM () -> DOM ()) -> DOM () -> DOM ()
forall a b. (a -> b) -> a -> b
$ do
    MVar (Maybe XHRError)
result <- IO (MVar (Maybe XHRError)) -> JSM (MVar (Maybe XHRError))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar (Maybe XHRError))
forall a. IO (MVar a)
newEmptyMVar
    Maybe XHRError
r <- DOM (DOM ()) -> DOM (Maybe XHRError) -> DOM (Maybe XHRError)
forall a. DOM (DOM ()) -> DOM a -> DOM a
withEvent (XMLHttpRequest
-> EventName XMLHttpRequest XMLHttpRequestProgressEvent
-> EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
-> DOM (DOM ())
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> EventM t e () -> DOM (DOM ())
onAsync XMLHttpRequest
self EventName XMLHttpRequest XMLHttpRequestProgressEvent
forall self.
(IsXMLHttpRequestEventTarget self, IsEventTarget self) =>
EventName self XMLHttpRequestProgressEvent
Generated.error (EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
 -> DOM (DOM ()))
-> (IO () -> EventM XMLHttpRequest XMLHttpRequestProgressEvent ())
-> IO ()
-> DOM (DOM ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DOM (DOM ())) -> IO () -> DOM (DOM ())
forall a b. (a -> b) -> a -> b
$ MVar (Maybe XHRError) -> Maybe XHRError -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe XHRError)
result (XHRError -> Maybe XHRError
forall a. a -> Maybe a
Just XHRError
XHRError)) (DOM (Maybe XHRError) -> DOM (Maybe XHRError))
-> DOM (Maybe XHRError) -> DOM (Maybe XHRError)
forall a b. (a -> b) -> a -> b
$
            DOM (DOM ()) -> DOM (Maybe XHRError) -> DOM (Maybe XHRError)
forall a. DOM (DOM ()) -> DOM a -> DOM a
withEvent (XMLHttpRequest
-> EventName XMLHttpRequest XMLHttpRequestProgressEvent
-> EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
-> DOM (DOM ())
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> EventM t e () -> DOM (DOM ())
onAsync XMLHttpRequest
self EventName XMLHttpRequest XMLHttpRequestProgressEvent
forall self.
(IsXMLHttpRequestEventTarget self, IsEventTarget self) =>
EventName self XMLHttpRequestProgressEvent
abortEvent (EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
 -> DOM (DOM ()))
-> (IO () -> EventM XMLHttpRequest XMLHttpRequestProgressEvent ())
-> IO ()
-> DOM (DOM ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DOM (DOM ())) -> IO () -> DOM (DOM ())
forall a b. (a -> b) -> a -> b
$ MVar (Maybe XHRError) -> Maybe XHRError -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe XHRError)
result (XHRError -> Maybe XHRError
forall a. a -> Maybe a
Just XHRError
XHRAborted)) (DOM (Maybe XHRError) -> DOM (Maybe XHRError))
-> DOM (Maybe XHRError) -> DOM (Maybe XHRError)
forall a b. (a -> b) -> a -> b
$
                DOM (DOM ()) -> DOM (Maybe XHRError) -> DOM (Maybe XHRError)
forall a. DOM (DOM ()) -> DOM a -> DOM a
withEvent (XMLHttpRequest
-> EventName XMLHttpRequest XMLHttpRequestProgressEvent
-> EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
-> DOM (DOM ())
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> EventM t e () -> DOM (DOM ())
onAsync XMLHttpRequest
self EventName XMLHttpRequest XMLHttpRequestProgressEvent
forall self.
(IsXMLHttpRequestEventTarget self, IsEventTarget self) =>
EventName self XMLHttpRequestProgressEvent
load (EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
 -> DOM (DOM ()))
-> (IO () -> EventM XMLHttpRequest XMLHttpRequestProgressEvent ())
-> IO ()
-> DOM (DOM ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> EventM XMLHttpRequest XMLHttpRequestProgressEvent ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DOM (DOM ())) -> IO () -> DOM (DOM ())
forall a b. (a -> b) -> a -> b
$ MVar (Maybe XHRError) -> Maybe XHRError -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe XHRError)
result Maybe XHRError
forall a. Maybe a
Nothing) (DOM (Maybe XHRError) -> DOM (Maybe XHRError))
-> DOM (Maybe XHRError) -> DOM (Maybe XHRError)
forall a b. (a -> b) -> a -> b
$ do
                    JSM JSVal -> DOM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> DOM ()) -> JSM JSVal -> DOM ()
forall a b. (a -> b) -> a -> b
$
                        case Maybe JSVal
mbVal of
                            Maybe JSVal
Nothing  -> XMLHttpRequest
self XMLHttpRequest
-> Getting (JSM JSVal) XMLHttpRequest (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. String -> JSF
forall name. ToJSString name => name -> JSF
js0 String
"send"
                            Just JSVal
val -> XMLHttpRequest
self XMLHttpRequest
-> Getting (JSM JSVal) XMLHttpRequest (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. String -> JSVal -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 String
"send" JSVal
val
                    IO (Maybe XHRError) -> DOM (Maybe XHRError)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe XHRError) -> DOM (Maybe XHRError))
-> IO (Maybe XHRError) -> DOM (Maybe XHRError)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe XHRError) -> IO (Maybe XHRError)
forall a. MVar a -> IO a
takeMVar MVar (Maybe XHRError)
result
    Maybe XHRError -> DOM ()
forall (m :: * -> *). MonadDOM m => Maybe XHRError -> m ()
throwXHRError Maybe XHRError
r

-- | <https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest#send() Mozilla XMLHttpRequest.send documentation>
send :: (MonadDOM m) => XMLHttpRequest -> m ()
send :: XMLHttpRequest -> m ()
send XMLHttpRequest
self = XMLHttpRequest -> Maybe JSVal -> m ()
forall (m :: * -> *).
MonadDOM m =>
XMLHttpRequest -> Maybe JSVal -> m ()
send' XMLHttpRequest
self Maybe JSVal
forall a. Maybe a
Nothing

-- | <https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest#send() Mozilla XMLHttpRequest.send documentation>
sendString :: (MonadDOM m, ToJSString str) => XMLHttpRequest -> str -> m ()
sendString :: XMLHttpRequest -> str -> m ()
sendString XMLHttpRequest
self str
str = DOM () -> m ()
forall (m :: * -> *) a. MonadDOM m => DOM a -> m a
liftDOM (DOM () -> m ()) -> DOM () -> m ()
forall a b. (a -> b) -> a -> b
$ str -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal str
str JSM JSVal -> (JSVal -> DOM ()) -> DOM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= XMLHttpRequest -> Maybe JSVal -> DOM ()
forall (m :: * -> *).
MonadDOM m =>
XMLHttpRequest -> Maybe JSVal -> m ()
send' XMLHttpRequest
self (Maybe JSVal -> DOM ())
-> (JSVal -> Maybe JSVal) -> JSVal -> DOM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Maybe JSVal
forall a. a -> Maybe a
Just

-- | <https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest#send() Mozilla XMLHttpRequest.send documentation>
sendArrayBuffer :: (MonadDOM m, IsArrayBufferView view) => XMLHttpRequest -> view -> m ()
sendArrayBuffer :: XMLHttpRequest -> view -> m ()
sendArrayBuffer XMLHttpRequest
self view
view = DOM () -> m ()
forall (m :: * -> *) a. MonadDOM m => DOM a -> m a
liftDOM (DOM () -> m ()) -> DOM () -> m ()
forall a b. (a -> b) -> a -> b
$ view -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal view
view JSM JSVal -> (JSVal -> DOM ()) -> DOM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= XMLHttpRequest -> Maybe JSVal -> DOM ()
forall (m :: * -> *).
MonadDOM m =>
XMLHttpRequest -> Maybe JSVal -> m ()
send' XMLHttpRequest
self (Maybe JSVal -> DOM ())
-> (JSVal -> Maybe JSVal) -> JSVal -> DOM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Maybe JSVal
forall a. a -> Maybe a
Just

-- | <https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest#send() Mozilla XMLHttpRequest.send documentation>
sendBlob :: (MonadDOM m, IsBlob blob) => XMLHttpRequest -> blob -> m ()
sendBlob :: XMLHttpRequest -> blob -> m ()
sendBlob XMLHttpRequest
self blob
blob = DOM () -> m ()
forall (m :: * -> *) a. MonadDOM m => DOM a -> m a
liftDOM (DOM () -> m ()) -> DOM () -> m ()
forall a b. (a -> b) -> a -> b
$ blob -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal blob
blob JSM JSVal -> (JSVal -> DOM ()) -> DOM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= XMLHttpRequest -> Maybe JSVal -> DOM ()
forall (m :: * -> *).
MonadDOM m =>
XMLHttpRequest -> Maybe JSVal -> m ()
send' XMLHttpRequest
self (Maybe JSVal -> DOM ())
-> (JSVal -> Maybe JSVal) -> JSVal -> DOM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Maybe JSVal
forall a. a -> Maybe a
Just

-- | <https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest#send() Mozilla XMLHttpRequest.send documentation>
sendDocument :: (MonadDOM m, IsDocument doc) => XMLHttpRequest -> doc -> m ()
sendDocument :: XMLHttpRequest -> doc -> m ()
sendDocument XMLHttpRequest
self doc
doc = DOM () -> m ()
forall (m :: * -> *) a. MonadDOM m => DOM a -> m a
liftDOM (DOM () -> m ()) -> DOM () -> m ()
forall a b. (a -> b) -> a -> b
$ doc -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal doc
doc JSM JSVal -> (JSVal -> DOM ()) -> DOM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= XMLHttpRequest -> Maybe JSVal -> DOM ()
forall (m :: * -> *).
MonadDOM m =>
XMLHttpRequest -> Maybe JSVal -> m ()
send' XMLHttpRequest
self (Maybe JSVal -> DOM ())
-> (JSVal -> Maybe JSVal) -> JSVal -> DOM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Maybe JSVal
forall a. a -> Maybe a
Just

-- | <https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest#send() Mozilla XMLHttpRequest.send documentation>
sendFormData :: (MonadDOM m) => XMLHttpRequest -> FormData -> m ()
sendFormData :: XMLHttpRequest -> FormData -> m ()
sendFormData XMLHttpRequest
self FormData
formData = DOM () -> m ()
forall (m :: * -> *) a. MonadDOM m => DOM a -> m a
liftDOM (DOM () -> m ()) -> DOM () -> m ()
forall a b. (a -> b) -> a -> b
$ FormData -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal FormData
formData JSM JSVal -> (JSVal -> DOM ()) -> DOM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= XMLHttpRequest -> Maybe JSVal -> DOM ()
forall (m :: * -> *).
MonadDOM m =>
XMLHttpRequest -> Maybe JSVal -> m ()
send' XMLHttpRequest
self (Maybe JSVal -> DOM ())
-> (JSVal -> Maybe JSVal) -> JSVal -> DOM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> Maybe JSVal
forall a. a -> Maybe a
Just