{-# 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 :: 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 (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 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 (f :: * -> *) a. Applicative f => a -> f a
pure Event t (RequesterData (Either ApiEndpoint))
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
    JSContextRef
ctx <- Performable (Client m) JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
    Performable (Client m) ThreadId -> Performable (Client m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Performable (Client m) ThreadId -> Performable (Client m) ())
-> Performable (Client m) ThreadId -> Performable (Client m) ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> Performable (Client m) ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Performable (Client m) ThreadId)
-> IO ThreadId -> Performable (Client m) ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (JSM () -> JSContextRef -> IO ())
-> JSContextRef -> JSM () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip JSM () -> JSContextRef -> IO ()
forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM JSContextRef
ctx (JSM () -> IO ()) -> JSM () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ())
-> (RequesterData (Either ApiEndpoint) -> IO ())
-> RequesterData (Either ApiEndpoint)
-> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequesterData (Either ApiEndpoint) -> IO ()
yield (RequesterData (Either ApiEndpoint) -> JSM ())
-> JSM (RequesterData (Either ApiEndpoint)) -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ApiEndpoint
-> RequesterData api -> JSM (RequesterData (Either ApiEndpoint))
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 RequesterData api
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 :: 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 ->
  api a
-> (FromJSON a => m (Either ApiEndpoint a))
-> m (Either ApiEndpoint a)
forall k (c :: k -> Constraint) (f :: k -> *) (a :: k) 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 :: api b -> m (Either ApiEndpoint b)
mkRequest api b
req = do
      MVar XhrResponse
response <- IO (MVar XhrResponse) -> m (MVar XhrResponse)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar XhrResponse)
forall a. IO (MVar a)
newEmptyMVar
      XMLHttpRequest
_ <- XhrRequest ApiEndpoint
-> (XhrResponse -> JSM ()) -> m XMLHttpRequest
forall (m :: * -> *) a.
(MonadJSM m, IsXhrPayload a) =>
XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest
newXMLHttpRequest (ApiEndpoint -> api b -> XhrRequest ApiEndpoint
forall a. ToJSON a => ApiEndpoint -> a -> XhrRequest ApiEndpoint
postJson ApiEndpoint
apiUrl api b
req) ((XhrResponse -> JSM ()) -> m XMLHttpRequest)
-> (XhrResponse -> JSM ()) -> m XMLHttpRequest
forall a b. (a -> b) -> a -> b
$
        IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ())
-> (XhrResponse -> IO ()) -> XhrResponse -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar XhrResponse -> XhrResponse -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar XhrResponse
response
      XhrResponse
xhrResp <- IO XhrResponse -> m XhrResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO XhrResponse -> m XhrResponse)
-> IO XhrResponse -> m XhrResponse
forall a b. (a -> b) -> a -> b
$ MVar XhrResponse -> IO XhrResponse
forall a. MVar a -> IO a
takeMVar MVar XhrResponse
response
      case XhrResponse -> Maybe b
forall a. FromJSON a => XhrResponse -> Maybe a
decodeXhrResponse XhrResponse
xhrResp of
        Maybe b
Nothing -> Either ApiEndpoint b -> m (Either ApiEndpoint b)
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 (ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ api b -> ByteString
forall a. ToJSON a => a -> ByteString
encode api b
req)
        Just b
r -> Either ApiEndpoint b -> m (Either ApiEndpoint b)
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