{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Reflex.Dom.Xhr.FormData
  ( 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 Foreign.JavaScript.TH
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, HasJSContext (Performable m), 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 :: Text
-> Event t (f (Map Text (FormValue blob)))
-> m (Event t (f XhrResponse))
postForms Text
url 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), HasJSContext (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
    FormData
fd <- Maybe HTMLFormElement -> JSM FormData
forall (m :: * -> *).
MonadDOM m =>
Maybe HTMLFormElement -> m FormData
FD.newFormData Maybe HTMLFormElement
forall a. Maybe a
Nothing
    Map Text (FormValue blob)
-> (Text -> FormValue blob -> JSM ()) -> JSM ()
forall i (t :: * -> *) (m :: * -> *) a b.
(FoldableWithIndex i t, Monad m) =>
t a -> (i -> a -> m b) -> m ()
iforM_ Map Text (FormValue blob)
u ((Text -> FormValue blob -> JSM ()) -> JSM ())
-> (Text -> FormValue blob -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \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
    XhrRequest FormData -> JSM (XhrRequest FormData)
forall (m :: * -> *) a. Monad m => a -> m a
return (XhrRequest FormData -> JSM (XhrRequest FormData))
-> XhrRequest FormData -> JSM (XhrRequest FormData)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> XhrRequestConfig FormData -> XhrRequest FormData
forall a. Text -> Text -> XhrRequestConfig a -> XhrRequest a
xhrRequest Text
"POST" Text
url (XhrRequestConfig FormData -> XhrRequest FormData)
-> XhrRequestConfig FormData -> XhrRequest FormData
forall a b. (a -> b) -> a -> b
$ XhrRequestConfig ()
forall a. Default a => a
def XhrRequestConfig ()
-> (XhrRequestConfig () -> XhrRequestConfig FormData)
-> XhrRequestConfig FormData
forall a b. a -> (a -> b) -> b
& (() -> Identity FormData)
-> XhrRequestConfig () -> Identity (XhrRequestConfig FormData)
forall a1 a2.
Lens (XhrRequestConfig a1) (XhrRequestConfig a2) a1 a2
xhrRequestConfig_sendData ((() -> Identity FormData)
 -> XhrRequestConfig () -> Identity (XhrRequestConfig FormData))
-> FormData -> XhrRequestConfig () -> XhrRequestConfig FormData
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FormData
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 :: File -> m (FormValue File)
fileToFormValue File
f = do
  Text
fn <- File -> m Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
File -> m result
getName File
f
  FormValue File -> m (FormValue File)
forall (m :: * -> *) a. Monad m => a -> m a
return (FormValue File -> m (FormValue File))
-> FormValue File -> m (FormValue File)
forall a b. (a -> b) -> a -> b
$ File -> Maybe Text -> FormValue File
forall blob. blob -> Maybe Text -> FormValue blob
FormValue_File File
f (Maybe Text -> FormValue File) -> Maybe Text -> FormValue File
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
fn