aboutsummaryrefslogtreecommitdiff
path: root/client/src/Util/Ajax.hs
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/Util/Ajax.hs')
-rw-r--r--client/src/Util/Ajax.hs139
1 files changed, 0 insertions, 139 deletions
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
deleted file mode 100644
index dcfd402..0000000
--- a/client/src/Util/Ajax.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-module Util.Ajax
- ( getNow
- , get
- , post
- , postAndParseResult
- , put
- , putAndParseResult
- , delete
- ) where
-
-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 Data.Time.Clock (NominalDiffTime)
-import Reflex.Dom (Dynamic, Event, IsXhrPayload,
- MonadWidget, XhrRequest,
- XhrRequestConfig (..), XhrResponse,
- XhrResponseHeaders (..))
-import qualified Reflex.Dom as R
-
-import Loadable (Loadable)
-import qualified Loadable
-
-getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a))
-getNow url = do
- postBuild <- R.getPostBuild
- get (url <$ postBuild)
- >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise
- >>= Loadable.fromEvent
-
-get
- :: forall t m a. (MonadWidget t m, FromJSON a)
- => Event t Text
- -> m (Event t (Either Text a))
-get url =
- fmap getJsonResult <$>
- R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String ""))
-
-post
- :: forall t m a. (MonadWidget t m, ToJSON a)
- => Text
- -> Event t a
- -> m (Event t (Either Text ()))
-post url input =
- fmap checkResult <$>
- R.performRequestAsync (jsonRequest "POST" url <$> input)
-
-postAndParseResult
- :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
- => Text
- -> Event t a
- -> m (Event t (Either Text b))
-postAndParseResult url input =
- fmap getJsonResult <$>
- R.performRequestAsync (jsonRequest "POST" url <$> input)
-
-put
- :: forall t m a. (MonadWidget t m, ToJSON a)
- => Text
- -> Event t a
- -> m (Event t (Either Text ()))
-put url input =
- fmap checkResult <$>
- R.performRequestAsync (jsonRequest "PUT" url <$> input)
-
-putAndParseResult
- :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
- => Text
- -> Event t a
- -> m (Event t (Either Text b))
-putAndParseResult url input =
- fmap getJsonResult <$>
- R.performRequestAsync (jsonRequest "PUT" url <$> input)
-
-delete
- :: forall t m a. (MonadWidget t m)
- => Dynamic t Text
- -> Event t ()
- -> m (Event t (Either Text Text))
-delete url fire = do
- fmap getResult <$>
- (R.performRequestAsync $
- R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
-
-checkResult :: XhrResponse -> Either Text ()
-checkResult response =
- () <$ getResult response
-
-getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
-getJsonResult response =
- case getResult response of
- Left l -> Left l
- Right r -> left T.pack . Aeson.eitherDecodeStrict $ (T.encodeUtf8 r)
-
-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 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
- , _xhrRequestConfig_user = def
- , _xhrRequestConfig_password = def
- , _xhrRequestConfig_responseType = def
- , _xhrRequestConfig_responseHeaders = def
- , _xhrRequestConfig_withCredentials = False
- , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload
- }
- in
- R.xhrRequest method url config