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