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

-- | A request tagged with an identifier
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

-- | A response tagged with an identifier matching the one in the 'TaggedRequest'. The identifier is the first argument.
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

-- | Opens a websockets connection, takes the output of a 'RequesterT' widget
-- and issues that output as API requests over the socket. The result of this
-- function can be fed back into the requester as responses. For example:
--
-- @
-- rec (appResult, requests) <- runRequesterT myApplication responses
--     responses <- performWebSocketRequests myEndpoint requests
-- @
--
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

-- | Constructs a response for a given request, and handles the
-- decoding/encoding and tagging steps internal to TaggedRequest and
-- TaggedResponse.
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

-- | This function transforms a request 'Event' into an 'Event' of
-- 'TaggedRequest's (the indexed wire format used to transmit requests). It
-- expects to receive an 'Event' of 'TaggedResponse', the corresponding
-- response wire format, which it will transform into an "untagged" response.
--
-- @
--   requests  --> |-------------| --> tagged requests
--     ↗           |             |                 ↘
-- Client          | tagRequests |                Server
--     ↖           |             |                 ↙
--   responses <-- |-------------| <-- tagged responses
-- @
--
-- This function is provided so that you can use a single websocket for
-- multiple purposes without reimplementing the functionality of
-- 'performWebSocketRequests'. For instance, you might have a websocket split
-- into two "channels," one for these tagged API requests and another for data
-- being pushed from the server.
--
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
      )