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