{-# 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
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
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