{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Convenience functions for dealing with XMLHttpRequest.
-}
module Reflex.Dom.Contrib.Xhr where
------------------------------------------------------------------------------
import Control.Lens
import Control.Monad.Reader
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Default
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.String.Conv
import qualified Data.Text as T
import Network.HTTP.Types.URI
------------------------------------------------------------------------------
import Reflex
import Reflex.Dom
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- | URL encodes a map of key-value pairs.
formEncode :: Map String ByteString -> String
formEncode m =
intercalate "&" $
map (\(k,v) -> k ++ "=" ++ (encodeToString v)) $ M.toList m
where
encodeToString :: ByteString -> String
encodeToString = toS . urlEncode True . toS
------------------------------------------------------------------------------
-- | Form encodes a JSON object.
formEncodeJSON :: ToJSON a => a -> String
formEncodeJSON a = case toJSON a of
Object m ->
formEncode $ M.fromList $ map (bimap T.unpack encode) $ itoList m
_ -> error "formEncodeJSON requires an Object"
------------------------------------------------------------------------------
-- | Convenience function for constructing a POST request.
toPost
:: String
-- ^ URL
-> String
-- ^ The post data
-> XhrRequest
toPost url d =
XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
, _xhrRequestConfig_sendData = Just d
}
where
headerUrlEnc :: Map String String
headerUrlEnc = "Content-type" =: "application/x-www-form-urlencoded"
------------------------------------------------------------------------------
-- | This is the foundational primitive for the XHR API because it gives you
-- full control over request generation and response parsing and also allows
-- you to match things that generated the request with their corresponding
-- responses.
performAJAX
:: (MonadWidget t m)
=> (a -> XhrRequest)
-- ^ Function to build the request
-> (XhrResponse -> b)
-- ^ Function to parse the response
-> Event t a
-> m (Event t (a, b))
performAJAX mkRequest parseResponse req =
performEventAsync $ ffor req $ \a cb -> do
_ <- newXMLHttpRequest (mkRequest a) $ \response ->
liftIO $ cb (a, parseResponse response)
return ()
------------------------------------------------------------------------------
-- | Performs an async XHR taking a JSON object as input and another JSON
-- object as output.
performJsonAjax
:: (MonadWidget t m, ToJSON a, FromJSON b)
=> Event t (String, a)
-- ^ Event with a URL and a JSON object to be sent
-> m (Event t (a, Maybe b))
performJsonAjax req =
performEventAsync $ ffor req $ \(url,a) cb -> do
_ <- newXMLHttpRequest (mkRequest url a) $ \response ->
liftIO $ cb (a, decodeXhrResponse response)
return ()
where
mkRequest url a = toPost url (formEncodeJSON a)