module Util.Ajax
  ( postJson
  , putJson
  , 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           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)
  => Text
  -> Event t a
  -> m (Event t (Either Text b))
postJson url input =
  fmap getJsonResult <$>
    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)
  => 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)

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