diff options
Diffstat (limited to 'client/src/Util')
| -rw-r--r-- | client/src/Util/Ajax.hs | 63 |
1 files changed, 46 insertions, 17 deletions
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 7b65c52..a4f6a74 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,20 +1,24 @@ module Util.Ajax ( postJson + , putJson , delete ) where -import Control.Arrow (left) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as Aeson -import Data.Default (def) -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, - XhrRequest, XhrRequestConfig (..), - XhrResponse, XhrResponseHeaders (..)) -import qualified Reflex.Dom as R +import Control.Arrow (left) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Reflex.Dom (Dynamic, Event, IsXhrPayload, + MonadWidget, XhrRequest, + XhrRequestConfig (..), XhrResponse, + XhrResponseHeaders (..)) +import qualified Reflex.Dom as R postJson :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) @@ -23,7 +27,16 @@ postJson -> m (Event t (Either Text b)) postJson url input = fmap getJsonResult <$> - R.performRequestAsync (R.postJson url <$> input) + R.performRequestAsync (jsonRequest "POST" url <$> input) + +putJson + :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) + => Text + -> Event t a + -> m (Event t (Either Text b)) +putJson url input = + fmap getJsonResult <$> + R.performRequestAsync (jsonRequest "PUT" url <$> input) delete :: forall t m a. (MonadWidget t m) @@ -31,8 +44,9 @@ delete -> Event t () -> m (Event t (Either Text Text)) delete url fire = do - response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) - return $ fmap getResult response + fmap getResult <$> + (R.performRequestAsync $ + R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a getJsonResult response = @@ -50,7 +64,22 @@ getResult response = _ -> Left "NoKey" request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a -request method url sendData = +request method url payload = + let + config = XhrRequestConfig + { _xhrRequestConfig_headers = def + , _xhrRequestConfig_user = def + , _xhrRequestConfig_password = def + , _xhrRequestConfig_responseType = def + , _xhrRequestConfig_responseHeaders = def + , _xhrRequestConfig_withCredentials = False + , _xhrRequestConfig_sendData = payload + } + in + R.xhrRequest method url config + +jsonRequest :: forall a. (ToJSON a) => Text -> Text -> a -> XhrRequest ByteString +jsonRequest method url payload = let config = XhrRequestConfig { _xhrRequestConfig_headers = def @@ -59,7 +88,7 @@ request method url sendData = , _xhrRequestConfig_responseType = def , _xhrRequestConfig_responseHeaders = def , _xhrRequestConfig_withCredentials = False - , _xhrRequestConfig_sendData = sendData + , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload } in R.xhrRequest method url config |