Delete payment

1 files changed, 51 insertions, 16 deletions

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 1e8e4c7..14675df 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,20 +1,55 @@
 module Util.Ajax
-  ( post
+  ( postJson
+  , delete
   ) where
 
-import           Data.Aeson (ToJSON)
-import           Data.Text  (Text)
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
+import           Data.Aeson    (ToJSON)
+import           Data.Default  (def)
+import qualified Data.Map.Lazy as LM
+import           Data.Text     (Text)
+import           Reflex.Dom    (Dynamic, Event, IsXhrPayload, MonadWidget,
+                                XhrRequest, XhrRequestConfig (..), XhrResponse,
+                                XhrResponseHeaders (..))
+import qualified Reflex.Dom    as R
 
-post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text))
-post url input =
-  fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = R.postJson url <$> input
-        getResult response =
-          case R._xhrResponse_responseText response of
-            Just responseText ->
-              if R._xhrResponse_status response == 200
-                then Right responseText
-                else Left responseText
-            _ -> Left "NoKey"
+postJson
+  :: forall t m a. (MonadWidget t m, ToJSON a)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text Text))
+postJson url input =
+  fmap getResult <$>
+    R.performRequestAsync (R.postJson url <$> input)
+
+delete
+  :: forall t m. MonadWidget t m
+  => Dynamic t Text
+  -> Event t ()
+  -> m (Event t (Either Text Text))
+delete url fire =
+  fmap getResult <$>
+    R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+
+getResult :: XhrResponse -> Either Text Text
+getResult response =
+  case R._xhrResponse_responseText response of
+    Just responseText ->
+      if R._xhrResponse_status response == 200
+        then Right responseText
+        else Left responseText
+    _ -> Left "NoKey"
+
+request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a
+request method url sendData =
+  let
+    config = XhrRequestConfig
+      { _xhrRequestConfig_headers = def
+      , _xhrRequestConfig_user = def
+      , _xhrRequestConfig_password = def
+      , _xhrRequestConfig_responseType = def
+      , _xhrRequestConfig_responseHeaders = def
+      , _xhrRequestConfig_withCredentials = False
+      , _xhrRequestConfig_sendData = sendData
+      }
+  in
+    R.xhrRequest method url config