Make payment edition to work on the frontend

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