{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Reflex.Dom.GadtApi.XHR where

import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson
import qualified Data.ByteString.Lazy as LBS
import Data.Constraint.Extras (Has, has)
import Data.Functor (void)
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import Language.Javascript.JSaddle (MonadJSM)
import Language.Javascript.JSaddle.Monad (runJSM, askJSM)
import Reflex.Dom.Core

type ApiEndpoint = Text

-- | Takes the output of a 'RequesterT' widget and issues that
-- output as API requests. The result of this function can be
-- fed back into the requester as responses. For example:
--
-- @
-- rec (appResult, requests) <- runRequesterT myApplication responses
--     responses <- performXhrRequests myApiEndpoint requests
-- @
--
performXhrRequests
  :: forall t m api.
     ( Has FromJSON api
     , forall a. ToJSON (api a)
     , Prerender t m
     , Applicative m
     )
  => ApiEndpoint
  -> Event t (RequesterData api)
  -> m (Event t (RequesterData (Either Text)))
performXhrRequests :: forall t (m :: * -> *) (api :: * -> *).
(Has FromJSON api, forall a. ToJSON (api a), Prerender t m,
 Applicative m) =>
ApiEndpoint
-> Event t (RequesterData api)
-> m (Event t (RequesterData (Either ApiEndpoint)))
performXhrRequests ApiEndpoint
apiUrl Event t (RequesterData api)
req = (Dynamic t (Event t (RequesterData (Either ApiEndpoint)))
 -> Event t (RequesterData (Either ApiEndpoint)))
-> m (Dynamic t (Event t (RequesterData (Either ApiEndpoint))))
-> m (Event t (RequesterData (Either ApiEndpoint)))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dynamic t (Event t (RequesterData (Either ApiEndpoint)))
-> Event t (RequesterData (Either ApiEndpoint))
forall {k} (t :: k) a.
Reflex t =>
Dynamic t (Event t a) -> Event t a
switchPromptlyDyn (m (Dynamic t (Event t (RequesterData (Either ApiEndpoint))))
 -> m (Event t (RequesterData (Either ApiEndpoint))))
-> m (Dynamic t (Event t (RequesterData (Either ApiEndpoint))))
-> m (Event t (RequesterData (Either ApiEndpoint)))
forall a b. (a -> b) -> a -> b
$ m (Event t (RequesterData (Either ApiEndpoint)))
-> Client m (Event t (RequesterData (Either ApiEndpoint)))
-> m (Dynamic t (Event t (RequesterData (Either ApiEndpoint))))
forall a. m a -> Client m a -> m (Dynamic t a)
forall t (m :: * -> *) a.
Prerender t m =>
m a -> Client m a -> m (Dynamic t a)
prerender (Event t (RequesterData (Either ApiEndpoint))
-> m (Event t (RequesterData (Either ApiEndpoint)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Event t (RequesterData (Either ApiEndpoint))
forall a. Event t a
forall {k} (t :: k) a. Reflex t => Event t a
never) (Client m (Event t (RequesterData (Either ApiEndpoint)))
 -> m (Dynamic t (Event t (RequesterData (Either ApiEndpoint)))))
-> Client m (Event t (RequesterData (Either ApiEndpoint)))
-> m (Dynamic t (Event t (RequesterData (Either ApiEndpoint))))
forall a b. (a -> b) -> a -> b
$ do
  Event
  t
  ((RequesterData (Either ApiEndpoint) -> IO ())
   -> Performable (Client m) ())
-> Client m (Event t (RequesterData (Either ApiEndpoint)))
forall t (m :: * -> *) a.
(TriggerEvent t m, PerformEvent t m) =>
Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)
performEventAsync (Event
   t
   ((RequesterData (Either ApiEndpoint) -> IO ())
    -> Performable (Client m) ())
 -> Client m (Event t (RequesterData (Either ApiEndpoint))))
-> Event
     t
     ((RequesterData (Either ApiEndpoint) -> IO ())
      -> Performable (Client m) ())
-> Client m (Event t (RequesterData (Either ApiEndpoint)))
forall a b. (a -> b) -> a -> b
$ Event t (RequesterData api)
-> (RequesterData api
    -> (RequesterData (Either ApiEndpoint) -> IO ())
    -> Performable (Client m) ())
-> Event
     t
     ((RequesterData (Either ApiEndpoint) -> IO ())
      -> Performable (Client m) ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Event t (RequesterData api)
req ((RequesterData api
  -> (RequesterData (Either ApiEndpoint) -> IO ())
  -> Performable (Client m) ())
 -> Event
      t
      ((RequesterData (Either ApiEndpoint) -> IO ())
       -> Performable (Client m) ()))
-> (RequesterData api
    -> (RequesterData (Either ApiEndpoint) -> IO ())
    -> Performable (Client m) ())
-> Event
     t
     ((RequesterData (Either ApiEndpoint) -> IO ())
      -> Performable (Client m) ())
forall a b. (a -> b) -> a -> b
$ \RequesterData api
r RequesterData (Either ApiEndpoint) -> IO ()
yield -> do
    ctx <- Performable (Client m) JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
    void $ liftIO $ forkIO $ flip runJSM ctx $
      liftIO . yield =<< apiRequestXhr apiUrl r

-- | Encodes an API request as JSON and issues an 'XhrRequest',
-- and attempts to decode the response.
apiRequestXhr
  :: forall api m.
     ( MonadIO m
     , MonadJSM m
     , Has FromJSON api
     , forall a. ToJSON (api a)
     )
  => ApiEndpoint
  -> RequesterData api
  -> m (RequesterData (Either Text))
apiRequestXhr :: forall (api :: * -> *) (m :: * -> *).
(MonadIO m, MonadJSM m, Has FromJSON api,
 forall a. ToJSON (api a)) =>
ApiEndpoint
-> RequesterData api -> m (RequesterData (Either ApiEndpoint))
apiRequestXhr ApiEndpoint
apiUrl = (forall a. api a -> m (Either ApiEndpoint a))
-> RequesterData api -> m (RequesterData (Either ApiEndpoint))
forall (m :: * -> *) (request :: * -> *) (response :: * -> *).
Applicative m =>
(forall a. request a -> m (response a))
-> RequesterData request -> m (RequesterData response)
traverseRequesterData ((forall a. api a -> m (Either ApiEndpoint a))
 -> RequesterData api -> m (RequesterData (Either ApiEndpoint)))
-> (forall a. api a -> m (Either ApiEndpoint a))
-> RequesterData api
-> m (RequesterData (Either ApiEndpoint))
forall a b. (a -> b) -> a -> b
$ \api a
x ->
  forall {k} (c :: k -> Constraint) (f :: k -> *) (a :: k) r.
Has c f =>
f a -> (c a => r) -> r
forall (c :: * -> Constraint) (f :: * -> *) a r.
Has c f =>
f a -> (c a => r) -> r
has @FromJSON @api api a
x ((FromJSON a => m (Either ApiEndpoint a))
 -> m (Either ApiEndpoint a))
-> (FromJSON a => m (Either ApiEndpoint a))
-> m (Either ApiEndpoint a)
forall a b. (a -> b) -> a -> b
$ api a -> m (Either ApiEndpoint a)
forall b.
(MonadJSM m, FromJSON b) =>
api b -> m (Either ApiEndpoint b)
mkRequest api a
x
  where
    mkRequest
      :: (MonadJSM m, FromJSON b)
      => api b
      -> m (Either Text b)
    mkRequest :: forall b.
(MonadJSM m, FromJSON b) =>
api b -> m (Either ApiEndpoint b)
mkRequest api b
req = do
      response <- IO (MVar XhrResponse) -> m (MVar XhrResponse)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar XhrResponse)
forall a. IO (MVar a)
newEmptyMVar
      _ <- newXMLHttpRequest (postJson apiUrl req) $
        liftIO . putMVar response
      xhrResp <- liftIO $ takeMVar response
      case decodeXhrResponse xhrResp of
        Maybe b
Nothing -> Either ApiEndpoint b -> m (Either ApiEndpoint b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ApiEndpoint b -> m (Either ApiEndpoint b))
-> Either ApiEndpoint b -> m (Either ApiEndpoint b)
forall a b. (a -> b) -> a -> b
$ ApiEndpoint -> Either ApiEndpoint b
forall a b. a -> Either a b
Left (ApiEndpoint -> Either ApiEndpoint b)
-> ApiEndpoint -> Either ApiEndpoint b
forall a b. (a -> b) -> a -> b
$
          ApiEndpoint
"Response could not be decoded for request: " ApiEndpoint -> ApiEndpoint -> ApiEndpoint
forall a. Semigroup a => a -> a -> a
<>
            ByteString -> ApiEndpoint
T.decodeUtf8 (LazyByteString -> ByteString
LBS.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ api b -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode api b
req)
        Just b
r -> Either ApiEndpoint b -> m (Either ApiEndpoint b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ApiEndpoint b -> m (Either ApiEndpoint b))
-> Either ApiEndpoint b -> m (Either ApiEndpoint b)
forall a b. (a -> b) -> a -> b
$ b -> Either ApiEndpoint b
forall a b. b -> Either a b
Right b
r