{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Reflex.Dom.GadtApi.WebSocket
( performWebSocketRequests
, TaggedRequest (..)
, TaggedResponse (..)
, mkTaggedResponse
, WebSocketEndpoint
, tagRequests
) where
import Control.Monad.Fix (MonadFix)
import Data.Constraint.Extras
import Data.Aeson
import Data.Default
import qualified Data.Text as T
import GHC.Generics
import qualified Data.Map as Map
import Data.Some
import Data.Text (Text)
import Reflex
import Reflex.Dom.Core (Prerender, prerender)
import Reflex.Dom.WebSocket
data TaggedRequest = TaggedRequest Int Value
deriving (forall x. TaggedRequest -> Rep TaggedRequest x)
-> (forall x. Rep TaggedRequest x -> TaggedRequest)
-> Generic TaggedRequest
forall x. Rep TaggedRequest x -> TaggedRequest
forall x. TaggedRequest -> Rep TaggedRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TaggedRequest -> Rep TaggedRequest x
from :: forall x. TaggedRequest -> Rep TaggedRequest x
$cto :: forall x. Rep TaggedRequest x -> TaggedRequest
to :: forall x. Rep TaggedRequest x -> TaggedRequest
Generic
instance FromJSON TaggedRequest
instance ToJSON TaggedRequest
data TaggedResponse = TaggedResponse Int Value
deriving (forall x. TaggedResponse -> Rep TaggedResponse x)
-> (forall x. Rep TaggedResponse x -> TaggedResponse)
-> Generic TaggedResponse
forall x. Rep TaggedResponse x -> TaggedResponse
forall x. TaggedResponse -> Rep TaggedResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TaggedResponse -> Rep TaggedResponse x
from :: forall x. TaggedResponse -> Rep TaggedResponse x
$cto :: forall x. Rep TaggedResponse x -> TaggedResponse
to :: forall x. Rep TaggedResponse x -> TaggedResponse
Generic
instance FromJSON TaggedResponse
instance ToJSON TaggedResponse
type WebSocketEndpoint = Text
performWebSocketRequests
:: forall req t m.
( Prerender t m, Applicative m
, FromJSON (Some req)
, forall a. ToJSON (req a)
, Has FromJSON req
)
=> WebSocketEndpoint
-> Event t (RequesterData req)
-> m (Event t (RequesterData (Either Text)))
performWebSocketRequests :: forall (req :: * -> *) t (m :: * -> *).
(Prerender t m, Applicative m, FromJSON (Some req),
forall a. ToJSON (req a), Has FromJSON req) =>
WebSocketEndpoint
-> Event t (RequesterData req)
-> m (Event t (RequesterData (Either WebSocketEndpoint)))
performWebSocketRequests WebSocketEndpoint
url Event t (RequesterData req)
req = (Dynamic t (Event t (RequesterData (Either WebSocketEndpoint)))
-> Event t (RequesterData (Either WebSocketEndpoint)))
-> m (Dynamic
t (Event t (RequesterData (Either WebSocketEndpoint))))
-> m (Event t (RequesterData (Either WebSocketEndpoint)))
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 WebSocketEndpoint)))
-> Event t (RequesterData (Either WebSocketEndpoint))
forall {k} (t :: k) a.
Reflex t =>
Dynamic t (Event t a) -> Event t a
switchPromptlyDyn (m (Dynamic t (Event t (RequesterData (Either WebSocketEndpoint))))
-> m (Event t (RequesterData (Either WebSocketEndpoint))))
-> m (Dynamic
t (Event t (RequesterData (Either WebSocketEndpoint))))
-> m (Event t (RequesterData (Either WebSocketEndpoint)))
forall a b. (a -> b) -> a -> b
$ m (Event t (RequesterData (Either WebSocketEndpoint)))
-> Client m (Event t (RequesterData (Either WebSocketEndpoint)))
-> m (Dynamic
t (Event t (RequesterData (Either WebSocketEndpoint))))
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 WebSocketEndpoint))
-> m (Event t (RequesterData (Either WebSocketEndpoint)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Event t (RequesterData (Either WebSocketEndpoint))
forall a. Event t a
forall {k} (t :: k) a. Reflex t => Event t a
never) (Client m (Event t (RequesterData (Either WebSocketEndpoint)))
-> m (Dynamic
t (Event t (RequesterData (Either WebSocketEndpoint)))))
-> Client m (Event t (RequesterData (Either WebSocketEndpoint)))
-> m (Dynamic
t (Event t (RequesterData (Either WebSocketEndpoint))))
forall a b. (a -> b) -> a -> b
$ do
rec w <- webSocket url $ def
{ _webSocketConfig_send = fmap encode <$> reqs
}
let rsp = (ByteString -> Maybe TaggedResponse)
-> Event t ByteString -> Event t TaggedResponse
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
fmapMaybe ByteString -> Maybe TaggedResponse
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict (Event t ByteString -> Event t TaggedResponse)
-> Event t ByteString -> Event t TaggedResponse
forall a b. (a -> b) -> a -> b
$ WebSocket t -> Event t ByteString
forall {k} (t :: k) a. RawWebSocket t a -> Event t a
_webSocket_recv WebSocket t
w
(reqs, rsps) <- tagRequests req rsp
pure rsps
mkTaggedResponse
:: (Monad m, FromJSON (Some f), Has ToJSON f)
=> TaggedRequest
-> (forall a. f a -> m a)
-> m (Either String TaggedResponse)
mkTaggedResponse :: forall (m :: * -> *) (f :: * -> *).
(Monad m, FromJSON (Some f), Has ToJSON f) =>
TaggedRequest
-> (forall a. f a -> m a) -> m (Either String TaggedResponse)
mkTaggedResponse (TaggedRequest Int
reqId Value
v) forall a. f a -> m a
f = case Value -> Result (Some f)
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Success (Some f a
a) -> do
rsp <- f a -> m a
forall a. f a -> m a
f f a
a
pure $ Right $ TaggedResponse reqId (has @ToJSON a $ toJSON rsp)
Error String
err -> Either String TaggedResponse -> m (Either String TaggedResponse)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String TaggedResponse -> m (Either String TaggedResponse))
-> Either String TaggedResponse -> m (Either String TaggedResponse)
forall a b. (a -> b) -> a -> b
$ String -> Either String TaggedResponse
forall a b. a -> Either a b
Left String
err
tagRequests
:: forall req t m.
( Applicative m
, FromJSON (Some req)
, forall a. ToJSON (req a)
, Has FromJSON req
, Monad m
, MonadFix m
, Reflex t
, MonadHold t m
)
=> Event t (RequesterData req)
-> Event t TaggedResponse
-> m ( Event t [TaggedRequest]
, Event t (RequesterData (Either Text))
)
tagRequests :: forall (req :: * -> *) t (m :: * -> *).
(Applicative m, FromJSON (Some req), forall a. ToJSON (req a),
Has FromJSON req, Monad m, MonadFix m, Reflex t, MonadHold t m) =>
Event t (RequesterData req)
-> Event t TaggedResponse
-> m (Event t [TaggedRequest],
Event t (RequesterData (Either WebSocketEndpoint)))
tagRequests Event t (RequesterData req)
req Event t TaggedResponse
rsp = do
rec (matchedReq, matchedRsp) <- matchResponsesWithRequests enc req $
ffor rsp $ \(TaggedResponse Int
t Value
v) -> (Int
t, Value
v)
let wireReq = (Map Int Value -> [TaggedRequest])
-> Event t (Map Int Value) -> Event t [TaggedRequest]
forall a b. (a -> b) -> Event t a -> Event t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Int TaggedRequest -> [TaggedRequest]
forall k a. Map k a -> [a]
Map.elems (Map Int TaggedRequest -> [TaggedRequest])
-> (Map Int Value -> Map Int TaggedRequest)
-> Map Int Value
-> [TaggedRequest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Value -> Maybe TaggedRequest)
-> Map Int Value -> Map Int TaggedRequest
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey (\Int
t Value
v -> case Value -> Result Value
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
Success (Value
r :: Value) -> TaggedRequest -> Maybe TaggedRequest
forall a. a -> Maybe a
Just (TaggedRequest -> Maybe TaggedRequest)
-> TaggedRequest -> Maybe TaggedRequest
forall a b. (a -> b) -> a -> b
$ Int -> Value -> TaggedRequest
TaggedRequest Int
t Value
r
Result Value
_ -> Maybe TaggedRequest
forall a. Maybe a
Nothing)) Event t (Map Int Value)
matchedReq
pure (wireReq, matchedRsp)
where
enc :: forall a. req a -> (Value, Value -> Either Text a)
enc :: forall a. req a -> (Value, Value -> Either WebSocketEndpoint a)
enc req a
r =
( req a -> Value
forall a. ToJSON a => a -> Value
toJSON req a
r
, \Value
x -> case 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 req a
r ((FromJSON a => Result a) -> Result a)
-> (FromJSON a => Result a) -> Result a
forall a b. (a -> b) -> a -> b
$ Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
x of
Success a
s-> a -> Either WebSocketEndpoint a
forall a b. b -> Either a b
Right a
s
Error String
e -> WebSocketEndpoint -> Either WebSocketEndpoint a
forall a b. a -> Either a b
Left (WebSocketEndpoint -> Either WebSocketEndpoint a)
-> WebSocketEndpoint -> Either WebSocketEndpoint a
forall a b. (a -> b) -> a -> b
$ String -> WebSocketEndpoint
T.pack String
e
)