242 lines
8.6 KiB
Haskell
242 lines
8.6 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
|
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
|
|
module Servant.Client.Internal.XhrClient where
|
|
|
|
import Control.Arrow
|
|
import Data.ByteString.Builder (toLazyByteString)
|
|
import Control.Concurrent
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import Control.Monad.Base (MonadBase (..))
|
|
import Control.Monad.Catch (MonadCatch, MonadThrow)
|
|
import Control.Monad.Error.Class (MonadError (..))
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
|
import Control.Monad.Trans.Except
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import Data.CaseInsensitive
|
|
import Data.Char
|
|
import Data.Foldable (toList)
|
|
import Data.Functor.Alt (Alt (..))
|
|
import Data.Proxy (Proxy (..))
|
|
import qualified Data.Sequence as Seq
|
|
import Data.String.Conversions
|
|
import Foreign.StablePtr
|
|
import GHC.Generics
|
|
import GHCJS.Foreign.Callback
|
|
import GHCJS.Prim
|
|
import Network.HTTP.Types
|
|
import Servant.Client.Core
|
|
|
|
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
|
|
|
|
newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
|
|
|
|
newtype GhcjsClientEnv
|
|
= GhcjsClientEnv
|
|
{ baseUrl :: BaseUrl }
|
|
deriving (Eq, Show)
|
|
|
|
client :: HasClient GhcjsClientM api => Proxy api -> Client GhcjsClientM api
|
|
client api = api `clientIn` (Proxy :: Proxy GhcjsClientM)
|
|
|
|
newtype GhcjsClientM a = GhcjsClientM
|
|
{ runGhcjsClientM' :: ReaderT GhcjsClientEnv (ExceptT ServantError IO) a }
|
|
deriving ( Functor, Applicative, Monad, MonadIO, Generic
|
|
, MonadReader GhcjsClientEnv, MonadError ServantError, MonadThrow
|
|
, MonadCatch)
|
|
|
|
instance MonadBase IO GhcjsClientM where
|
|
liftBase = GhcjsClientM . liftBase
|
|
|
|
instance MonadBaseControl IO GhcjsClientM where
|
|
type StM GhcjsClientM a = Either ServantError a
|
|
|
|
liftBaseWith f = GhcjsClientM (liftBaseWith (\g -> f (g . runGhcjsClientM')))
|
|
|
|
restoreM st = GhcjsClientM (restoreM st)
|
|
|
|
-- | Try clients in order, last error is preserved.
|
|
instance Alt GhcjsClientM where
|
|
a <!> b = a `catchError` const b
|
|
|
|
instance RunClient GhcjsClientM where
|
|
runRequest = performRequest
|
|
throwServantError = throwError
|
|
catchServantError = catchError
|
|
|
|
instance ClientLike (GhcjsClientM a) (GhcjsClientM a) where
|
|
mkClient = id
|
|
|
|
runGhcjsClientM :: GhcjsClientM a -> GhcjsClientEnv -> IO (Either ServantError a)
|
|
runGhcjsClientM cm env = runExceptT $ flip runReaderT env $ runGhcjsClientM' cm
|
|
|
|
performRequest :: Request -> GhcjsClientM Response
|
|
performRequest req = do
|
|
xhr <- liftIO initXhr
|
|
burl <- asks baseUrl
|
|
liftIO $ performXhr xhr burl req
|
|
toResponse xhr
|
|
|
|
-- * initialization
|
|
|
|
initXhr :: IO JSXMLHttpRequest
|
|
initXhr = do
|
|
lib <- requireXMLHttpRequestClass
|
|
newXMLHttpRequest lib
|
|
|
|
foreign import javascript unsafe
|
|
-- branching between node (for testing) and browsers
|
|
"(function () {if (typeof require !== 'undefined') { return require('xhr2'); } else { return XMLHttpRequest; };})()"
|
|
requireXMLHttpRequestClass :: IO JSXMLHttpRequestClass
|
|
|
|
foreign import javascript unsafe "new $1()"
|
|
newXMLHttpRequest :: JSXMLHttpRequestClass -> IO JSXMLHttpRequest
|
|
|
|
-- * performing requests
|
|
-- Performs the xhr and blocks until the response was received
|
|
performXhr :: JSXMLHttpRequest -> BaseUrl -> Request -> IO ()
|
|
performXhr xhr burl request = do
|
|
|
|
waiter <- newEmptyMVar
|
|
|
|
bracket (acquire waiter) releaseCallback $ \_callback -> do
|
|
t <- myThreadId
|
|
s <- newStablePtr t
|
|
|
|
openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
|
|
setHeaders xhr $ toList $ requestHeaders request
|
|
sendXhr xhr (toBody request)
|
|
takeMVar waiter
|
|
|
|
freeStablePtr s
|
|
where
|
|
acquire waiter = onReadyStateChange xhr $ do
|
|
state <- readyState xhr
|
|
case state of
|
|
-- onReadyStateChange's callback can fire state 4
|
|
-- (which means "request finished and response is ready")
|
|
-- multiple times. By using tryPutMVar, only the first time
|
|
-- state 4 is fired will cause an MVar to be put. Subsequent
|
|
-- fires are ignored.
|
|
4 -> void $ tryPutMVar waiter ()
|
|
_ -> return ()
|
|
|
|
onReadyStateChange :: JSXMLHttpRequest -> IO () -> IO (Callback (IO ()))
|
|
onReadyStateChange xhr action = do
|
|
callback <- asyncCallback action
|
|
js_onReadyStateChange xhr callback
|
|
return callback
|
|
foreign import javascript safe "$1.onreadystatechange = $2;"
|
|
js_onReadyStateChange :: JSXMLHttpRequest -> Callback (IO ()) -> IO ()
|
|
|
|
foreign import javascript unsafe "$1.readyState"
|
|
readyState :: JSXMLHttpRequest -> IO Int
|
|
|
|
openXhr :: JSXMLHttpRequest -> String -> String -> Bool -> IO ()
|
|
openXhr xhr method url =
|
|
js_openXhr xhr (toJSString method) (toJSString url)
|
|
foreign import javascript unsafe "$1.open($2, $3, $4)"
|
|
js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
|
|
|
|
toUrl :: BaseUrl -> Request -> String
|
|
toUrl burl request =
|
|
let pathS = cs $ toLazyByteString $ requestPath request
|
|
queryS =
|
|
cs $
|
|
renderQuery True $
|
|
toList $
|
|
requestQueryString request
|
|
in showBaseUrl burl ++ pathS ++ queryS
|
|
|
|
setHeaders :: JSXMLHttpRequest -> RequestHeaders -> IO ()
|
|
setHeaders xhr headers = forM_ headers $ \ (key, value) ->
|
|
js_setRequestHeader xhr (toJSString $ cs $ original key) (toJSString $ cs value)
|
|
foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
|
|
js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
|
|
|
|
sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
|
|
sendXhr xhr Nothing = js_sendXhr xhr
|
|
sendXhr xhr (Just body) =
|
|
js_sendXhrWithBody xhr (toJSString body)
|
|
|
|
foreign import javascript unsafe "$1.send()"
|
|
js_sendXhr :: JSXMLHttpRequest -> IO ()
|
|
|
|
foreign import javascript unsafe "$1.send($2)"
|
|
js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
|
|
|
|
toBody :: Request -> Maybe String
|
|
toBody request = case requestBody request of
|
|
Nothing -> Nothing
|
|
Just (RequestBodyLBS "", _) -> Nothing
|
|
Just (RequestBodyLBS x, _) -> Just $ cs x
|
|
|
|
-- * inspecting the xhr response
|
|
|
|
-- This function is only supposed to handle 'ConnectionError's. Other
|
|
-- 'ServantError's are created in Servant.Client.Req.
|
|
toResponse :: JSXMLHttpRequest -> GhcjsClientM Response
|
|
toResponse xhr = do
|
|
status <- liftIO $ getStatus xhr
|
|
case status of
|
|
0 -> throwError $ ConnectionError "connection error"
|
|
_ -> liftIO $ do
|
|
statusText <- cs <$> getStatusText xhr
|
|
headers <- parseHeaders <$> getAllResponseHeaders xhr
|
|
responseText <- cs <$> getResponseText xhr
|
|
pure Response
|
|
{ responseStatusCode = mkStatus status statusText
|
|
, responseBody = responseText
|
|
, responseHeaders = Seq.fromList headers
|
|
, responseHttpVersion = http11 -- this is made up
|
|
}
|
|
|
|
foreign import javascript unsafe "$1.status"
|
|
getStatus :: JSXMLHttpRequest -> IO Int
|
|
|
|
getStatusText :: JSXMLHttpRequest -> IO String
|
|
getStatusText = fmap fromJSString . js_statusText
|
|
foreign import javascript unsafe "$1.statusText"
|
|
js_statusText :: JSXMLHttpRequest -> IO JSVal
|
|
|
|
getAllResponseHeaders :: JSXMLHttpRequest -> IO String
|
|
getAllResponseHeaders xhr =
|
|
fromJSString <$> js_getAllResponseHeaders xhr
|
|
foreign import javascript unsafe "$1.getAllResponseHeaders()"
|
|
js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
|
|
|
|
getResponseText :: JSXMLHttpRequest -> IO String
|
|
getResponseText xhr = fromJSString <$> js_responseText xhr
|
|
foreign import javascript unsafe "$1.responseText"
|
|
js_responseText :: JSXMLHttpRequest -> IO JSVal
|
|
|
|
parseHeaders :: String -> ResponseHeaders
|
|
parseHeaders s =
|
|
(first mk . first strip . second strip . parseHeader) <$>
|
|
splitOn "\r\n" (cs s)
|
|
where
|
|
parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
|
|
parseHeader h = case BS.breakSubstring ":" (cs h) of
|
|
(key, BS.drop 1 -> value) -> (key, value)
|
|
|
|
splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
|
|
splitOn separator input = case BS.breakSubstring separator input of
|
|
(prefix, "") -> [prefix]
|
|
(prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
|
|
|
|
strip :: BS.ByteString -> BS.ByteString
|
|
strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
|