Delete payment

2 files changed, 82 insertions, 21 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
diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
index f3e9c88..55b8521 100644
--- a/client/src/Util/Dom.hs
+++ b/client/src/Util/Dom.hs
@@ -1,12 +1,31 @@
 module Util.Dom
-  ( divVisibleIf
+  ( divIfDyn
+  , divIfEvent
+  , divVisibleIf
   , divClassVisibleIf
+  , getBody
   ) where
 
-import qualified Data.Map   as M
-import           Data.Text  (Text)
-import           Reflex.Dom (Dynamic, MonadWidget)
-import qualified Reflex.Dom as R
+import qualified Data.Map                 as M
+import           Data.Text                (Text)
+import qualified GHCJS.DOM                as Dom
+import qualified GHCJS.DOM.Document       as Document
+import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
+import           GHCJS.DOM.Types          (Element)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom               as R
+
+divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a)
+divIfDyn cond = divIfEvent (R.updated cond)
+
+divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
+divIfEvent cond empty content =
+  R.widgetHold empty (flip fmap cond (\show ->
+    if show
+      then
+        content
+      else
+        empty))
 
 divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
 divVisibleIf cond content = divClassVisibleIf cond "" content
@@ -17,3 +36,10 @@ divClassVisibleIf cond className content =
     "div"
     (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
     content
+
+getBody :: forall t m. MonadWidget t m => m Element
+getBody = do
+  document <- Dom.currentDocumentUnchecked
+  nodelist <- Document.getElementsByTagName document ("body" :: String)
+  Just body <- nodelist `HTMLCollection.item` 0
+  return body