content: {-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables #-}
  -- | XMLHttpRequest support. IE9 and older are not supported.
  module Haste.Ajax
    ( Method (..)
    , AjaxData (..)
    , AjaxError (..)
    , ajax, ajaxWithMime
    ) where
  import Haste.Prim.Foreign
  import Haste.Prim
  import Haste.Prim.JSType
  import Control.Monad.IO.Class
  import Control.Monad (join)
  import Haste.Concurrent
  import Data.Proxy
  import Haste.Binary hiding (get)
  
  class (ToAny a, FromAny a) => AjaxData a where
    -- | The MIME type of the data represented by this type.
    mimeType     :: Proxy a -> JSString
  
    -- | The XHR response type that corresponds to this type.
    responseType :: Proxy a -> JSString
  
  instance AjaxData JSString where
    mimeType _ = ""
    responseType _ = ""
  
  instance AjaxData Blob where
    mimeType _ = "application/octet-stream"
    responseType _ = "blob"
  
  instance AjaxData () where
    mimeType _ = ""
    responseType _ = ""
  
  -- | Make an AJAX request. The return value is either the body of the requested
  --   document, or an error.
  ajax :: forall m post resp.
         (MonadConc m, AjaxData post, AjaxData resp)
       => Method post -- ^ HTTP method to use for request. @post@ is always @()@
                      --   for GET requests.
       -> URL         -- ^ URL to request.
       -> m (Either AjaxError resp)
  ajax = ajaxWithMime ""
  
  -- | Like 'ajax', but accepts a custom MIME type for POST data.
  --   Use this with the appropriate MIME type and POST data if you want to send,
  --   for instance, form data.
  ajaxWithMime :: forall m post resp.
         (MonadConc m, AjaxData post, AjaxData resp)
       => JSString    -- ^ MIME type of any POST data. Decided by the 'AjaxData'
                      --   instance for @post@ if the empty string is given.
                      --   Only relevant to POST requests.
       -> Method post -- ^ HTTP method to use for request.
       -> URL         -- ^ URL to request.
       -> m (Either AjaxError resp)
  ajaxWithMime mime method url = do
      res <- newEmptyMVar
      liftIO $ ajaxReq methodStr url mime' respType postdata $ \merr md -> do
        case (md, merr) of
          (Just d, _)   -> fromAny d >>= concurrent . putMVar res . Right
          (_, Just err) -> concurrent $ putMVar res (Left err)
      liftCIO $ takeMVar res
    where
      mime'
        | "" /= mime = mime
        | otherwise  = mimeType (Proxy :: Proxy post)
      respType = responseType (Proxy :: Proxy resp)
      (postdata, methodStr) = case method of
        GET    -> (Nothing, "GET")
        POST d -> (Just $ toAny d, "POST")
        PUT d  -> (Just $ toAny d, "PUT")
        DELETE -> (Nothing, "DELETE")
  
  -- | An error which occurred during an AJAX request.
  --   Might be either a network error (denied by CSP, host unreachable etc.)
  --   or an HTTP error, with status code and description.
  data AjaxError
    = NetworkError
    | HttpError Int JSString
      deriving (Show, Eq)
  
  instance FromAny AjaxError where
    fromAny x = do
      errtype <- get x "type"
      case errtype of
        "network" -> pure NetworkError
        "http"    -> HttpError <$> get x "status" <*> get x "status-text"
        _         -> fail $ "unknown type of ajax error: " ++ fromJSStr errtype
  
  -- | HTTP method to use for request. POST requests take an (optionally empty)
  --   JSString representing data to POST.
  data Method a where
    GET    :: Method ()
    DELETE :: Method ()
    POST   :: a -> Method a
    PUT    :: a -> Method a
  
  ajaxReq :: JSString -- ^ method (GET/POST)
          -> JSString -- ^ URI
          -> JSString -- ^ Outgoing MIME type; empty string means default
          -> JSString -- ^ responseType field
          -> Maybe JSAny -- ^ POST data
          -> (Maybe AjaxError -> Maybe JSAny -> IO ())
             -- ^ Callback; if successful, first argument is 0, the second the
             --   empty string, and the third the response data.
             --   If not, third argument is null and the other two give
             --   HTTP status and error message.
          -> IO ()
  ajaxReq = ffi "(function(method, uri, mimeout, responseType, postdata, cb) {\
      \var xhr = new XMLHttpRequest();\
      \xhr.open(method, uri);\
      \xhr.responseType = responseType;\
      \if(mimeout != '') {\
        \xhr.setRequestHeader('Content-type', mimeout);\
      \}\
      \xhr.addEventListener('load', function() {\
        \if(xhr.status < 400) {cb(null, xhr.response);}\
        \else {cb({'type':'http', 'status':xhr.status, 'status-text': xhr.statusText}, null);}\
      \});\
      \xhr.addEventListener('error', function() {\
        \if(xhr.status != 0) {\
          \cb({'type':'http', 'status':xhr.status, 'status-text': xhr.statusText}, null);\
        \} else {\
          \cb({'type':'network'}, null);\
        \}\
      \});\
      \xhr.send(postdata);\
    \})"
  