{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Reflex.Dom.Xhr.FormData
  ( postForms
  , postForms'
  , FormValue (..)
  , fileToFormValue
  )
  where

import Control.Lens
import Data.Default
import Data.Map (Map)
import Data.Text (Text)
import Data.Traversable
import qualified GHCJS.DOM.FormData as FD
import GHCJS.DOM.File (getName)
import GHCJS.DOM.Types (File, IsBlob)
import Language.Javascript.JSaddle.Monad (MonadJSM, liftJSM)
import Reflex
import Reflex.Dom.Xhr

-- | A FormData value may be a blob/file or a string. The file can optionally be provided with filename.
data FormValue blob = FormValue_Text Text
                    | FormValue_File blob (Maybe Text) -- maybe filename

-- | Performs a POST request with the provided FormData payload
postForms
  :: ( IsBlob blob, MonadJSM (Performable m)
     , PerformEvent t m, TriggerEvent t m
     , Traversable f)
  => Text -- ^ The target url
  -> Event t (f (Map Text (FormValue blob))) -- ^ Maps of text keys and values that will be sent as "FormData"
  -> m (Event t (f XhrResponse))
postForms :: forall blob (m :: * -> *) t (f :: * -> *).
(IsBlob blob, MonadJSM (Performable m), PerformEvent t m,
 TriggerEvent t m, Traversable f) =>
Text
-> Event t (f (Map Text (FormValue blob)))
-> m (Event t (f XhrResponse))
postForms Text
t = Text
-> XhrRequestConfig ()
-> Event t (f (Map Text (FormValue blob)))
-> m (Event t (f XhrResponse))
forall blob (m :: * -> *) t (f :: * -> *) a.
(IsBlob blob, MonadJSM (Performable m), PerformEvent t m,
 TriggerEvent t m, Traversable f) =>
Text
-> XhrRequestConfig a
-> Event t (f (Map Text (FormValue blob)))
-> m (Event t (f XhrResponse))
postForms' Text
t XhrRequestConfig ()
forall a. Default a => a
def

-- | Like 'postForms' but doesn't use a default 'XhrRequestConfig', so a custom one can be provided.
postForms'
  :: ( IsBlob blob, MonadJSM (Performable m)
     , PerformEvent t m, TriggerEvent t m
     , Traversable f)
  => Text -- ^ The target url
  -> XhrRequestConfig a
  -> Event t (f (Map Text (FormValue blob))) -- ^ Maps of text keys and values that will be sent as "FormData"
  -> m (Event t (f XhrResponse))
postForms' :: forall blob (m :: * -> *) t (f :: * -> *) a.
(IsBlob blob, MonadJSM (Performable m), PerformEvent t m,
 TriggerEvent t m, Traversable f) =>
Text
-> XhrRequestConfig a
-> Event t (f (Map Text (FormValue blob)))
-> m (Event t (f XhrResponse))
postForms' Text
url XhrRequestConfig a
cfg Event t (f (Map Text (FormValue blob)))
payload = do
  Event t (Performable m (f (XhrRequest FormData)))
-> m (Event t (f XhrResponse))
forall (m :: * -> *) t (f :: * -> *) a.
(MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m,
 Traversable f, IsXhrPayload a) =>
Event t (Performable m (f (XhrRequest a)))
-> m (Event t (f XhrResponse))
performMkRequestsAsync (Event t (Performable m (f (XhrRequest FormData)))
 -> m (Event t (f XhrResponse)))
-> Event t (Performable m (f (XhrRequest FormData)))
-> m (Event t (f XhrResponse))
forall a b. (a -> b) -> a -> b
$ Event t (f (Map Text (FormValue blob)))
-> (f (Map Text (FormValue blob))
    -> Performable m (f (XhrRequest FormData)))
-> Event t (Performable m (f (XhrRequest FormData)))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t (f (Map Text (FormValue blob)))
payload ((f (Map Text (FormValue blob))
  -> Performable m (f (XhrRequest FormData)))
 -> Event t (Performable m (f (XhrRequest FormData))))
-> (f (Map Text (FormValue blob))
    -> Performable m (f (XhrRequest FormData)))
-> Event t (Performable m (f (XhrRequest FormData)))
forall a b. (a -> b) -> a -> b
$ \f (Map Text (FormValue blob))
fs -> f (Map Text (FormValue blob))
-> (Map Text (FormValue blob)
    -> Performable m (XhrRequest FormData))
-> Performable m (f (XhrRequest FormData))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for f (Map Text (FormValue blob))
fs ((Map Text (FormValue blob) -> Performable m (XhrRequest FormData))
 -> Performable m (f (XhrRequest FormData)))
-> (Map Text (FormValue blob)
    -> Performable m (XhrRequest FormData))
-> Performable m (f (XhrRequest FormData))
forall a b. (a -> b) -> a -> b
$ \Map Text (FormValue blob)
u -> JSM (XhrRequest FormData) -> Performable m (XhrRequest FormData)
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM (XhrRequest FormData) -> Performable m (XhrRequest FormData))
-> JSM (XhrRequest FormData) -> Performable m (XhrRequest FormData)
forall a b. (a -> b) -> a -> b
$ do
    fd <- Maybe HTMLFormElement -> JSM FormData
forall (m :: * -> *).
MonadDOM m =>
Maybe HTMLFormElement -> m FormData
FD.newFormData Maybe HTMLFormElement
forall a. Maybe a
Nothing
    iforM_ u $ \Text
k FormValue blob
v -> case FormValue blob
v of
      FormValue_Text Text
t -> FormData -> Text -> Text -> JSM ()
forall (m :: * -> *) name value.
(MonadDOM m, ToJSString name, ToJSString value) =>
FormData -> name -> value -> m ()
FD.append FormData
fd Text
k Text
t
      FormValue_File blob
b Maybe Text
fn -> FormData -> Text -> blob -> Maybe Text -> JSM ()
forall (m :: * -> *) name value filename.
(MonadDOM m, ToJSString name, IsBlob value, ToJSString filename) =>
FormData -> name -> value -> Maybe filename -> m ()
FD.appendBlob FormData
fd Text
k blob
b Maybe Text
fn
    return $ xhrRequest "POST" url $ cfg & xhrRequestConfig_sendData .~ fd

-- | Converts a File (e.g., the output of a 'FileInput') into a 'FormValue'. The filename will be included if it is available.
fileToFormValue :: MonadJSM m => File -> m (FormValue File)
fileToFormValue :: forall (m :: * -> *). MonadJSM m => File -> m (FormValue File)
fileToFormValue File
f = do
  fn <- File -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
File -> m result
getName File
f
  return $ FormValue_File f $ Just fn