aboutsummaryrefslogtreecommitdiff
path: root/client/src/Util
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/Util')
-rw-r--r--client/src/Util/Ajax.hs63
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