{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Subscriptions.Internal
  ( connect,
    disconnect,
    connectionThread,
    runStreamWS,
    runStreamHTTP,
    ApiContext (..),
    Input (..),
    PUB,
    SUB,
    Store (..),
    ClientConnectionStore,
    acceptApolloRequest,
    SessionID,
    publish,
    initDefaultStore,
    publishEventWith,
    empty,
    toList,
    connectionSessionIds,
    storedSessions,
    storedChannels,
    streamApp,
  )
where

import Control.Concurrent
  ( modifyMVar_,
  )
import Control.Exception (finally)
import Control.Monad.IO.Unlift
  ( MonadUnliftIO,
    withRunInIO,
  )
-- MORPHEUS

import Data.Morpheus.App
  ( App,
    runAppStream,
  )
import Data.Morpheus.Internal.Utils
  ( empty,
  )
import Data.Morpheus.Subscriptions.Apollo
  ( acceptApolloRequest,
  )
import Data.Morpheus.Subscriptions.ClientConnectionStore
  ( ClientConnectionStore,
    SessionID,
    connectionSessionIds,
    delete,
    publish,
    storedChannels,
    storedSessions,
    toList,
  )
import Data.Morpheus.Subscriptions.Event
  ( Event,
  )
import Data.Morpheus.Subscriptions.Stream
  ( ApiContext (..),
    Input (..),
    Output,
    PUB,
    SUB,
    runStreamHTTP,
    runStreamWS,
    toOutStream,
  )
import Data.UUID.V4 (nextRandom)
import Relude hiding (empty, toList)

connect :: MonadIO m => m (Input SUB)
connect :: m (Input SUB)
connect = UUID -> Input SUB
InitConnection (UUID -> Input SUB) -> m UUID -> m (Input SUB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> m UUID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
nextRandom

disconnect :: ApiContext SUB e m -> Input SUB -> m ()
disconnect :: ApiContext SUB e m -> Input SUB -> m ()
disconnect SubContext {(ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
updateStore :: forall event (m :: * -> *).
ApiContext SUB event m
-> (ClientConnectionStore event m -> ClientConnectionStore event m)
-> m ()
updateStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
updateStore} (InitConnection UUID
clientID) =
  (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
updateStore (UUID -> ClientConnectionStore e m -> ClientConnectionStore e m
forall e (m :: * -> *). UUID -> StoreMap e m
delete UUID
clientID)

-- | PubSubStore interface
-- shared GraphQL state between __websocket__ and __http__ server,
-- you can define your own store if you provide write and read methods
-- to work properly Morpheus needs all entries of ClientConnectionStore (+ client Callbacks)
-- that why it is recommended that you use many local ClientStores on every server node
-- rather then single centralized Store.
data Store e m = Store
  { Store e m -> m (ClientConnectionStore e m)
readStore :: m (ClientConnectionStore e m),
    Store e m
-> (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
writeStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
  }

publishEventWith ::
  ( MonadIO m,
    Eq channel,
    Hashable channel,
    Show channel
  ) =>
  Store (Event channel cont) m ->
  Event channel cont ->
  m ()
publishEventWith :: Store (Event channel cont) m -> Event channel cont -> m ()
publishEventWith Store (Event channel cont) m
store Event channel cont
event = Store (Event channel cont) m
-> m (ClientConnectionStore (Event channel cont) m)
forall e (m :: * -> *). Store e m -> m (ClientConnectionStore e m)
readStore Store (Event channel cont) m
store m (ClientConnectionStore (Event channel cont) m)
-> (ClientConnectionStore (Event channel cont) m -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Event channel cont
-> ClientConnectionStore (Event channel cont) m -> m ()
forall (m :: * -> *) channel content.
(Monad m, Eq channel, Hashable channel, Show channel) =>
Event channel content
-> ClientConnectionStore (Event channel content) m -> m ()
publish Event channel cont
event

-- | initializes empty GraphQL state
initDefaultStore ::
  ( MonadIO m,
    MonadIO m2
  ) =>
  m2 (Store (Event ch con) m)
initDefaultStore :: m2 (Store (Event ch con) m)
initDefaultStore = do
  MVar (ClientConnectionStore (Event ch con) m)
store <- IO (MVar (ClientConnectionStore (Event ch con) m))
-> m2 (MVar (ClientConnectionStore (Event ch con) m))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (ClientConnectionStore (Event ch con) m))
 -> m2 (MVar (ClientConnectionStore (Event ch con) m)))
-> IO (MVar (ClientConnectionStore (Event ch con) m))
-> m2 (MVar (ClientConnectionStore (Event ch con) m))
forall a b. (a -> b) -> a -> b
$ ClientConnectionStore (Event ch con) m
-> IO (MVar (ClientConnectionStore (Event ch con) m))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ClientConnectionStore (Event ch con) m
forall coll. Empty coll => coll
empty
  Store (Event ch con) m -> m2 (Store (Event ch con) m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Store :: forall e (m :: * -> *).
m (ClientConnectionStore e m)
-> ((ClientConnectionStore e m -> ClientConnectionStore e m)
    -> m ())
-> Store e m
Store
      { readStore :: m (ClientConnectionStore (Event ch con) m)
readStore = IO (ClientConnectionStore (Event ch con) m)
-> m (ClientConnectionStore (Event ch con) m)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ClientConnectionStore (Event ch con) m)
 -> m (ClientConnectionStore (Event ch con) m))
-> IO (ClientConnectionStore (Event ch con) m)
-> m (ClientConnectionStore (Event ch con) m)
forall a b. (a -> b) -> a -> b
$ MVar (ClientConnectionStore (Event ch con) m)
-> IO (ClientConnectionStore (Event ch con) m)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (ClientConnectionStore (Event ch con) m)
store,
        writeStore :: (ClientConnectionStore (Event ch con) m
 -> ClientConnectionStore (Event ch con) m)
-> m ()
writeStore = \ClientConnectionStore (Event ch con) m
-> ClientConnectionStore (Event ch con) m
changes -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (ClientConnectionStore (Event ch con) m)
-> (ClientConnectionStore (Event ch con) m
    -> IO (ClientConnectionStore (Event ch con) m))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (ClientConnectionStore (Event ch con) m)
store (ClientConnectionStore (Event ch con) m
-> IO (ClientConnectionStore (Event ch con) m)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientConnectionStore (Event ch con) m
 -> IO (ClientConnectionStore (Event ch con) m))
-> (ClientConnectionStore (Event ch con) m
    -> ClientConnectionStore (Event ch con) m)
-> ClientConnectionStore (Event ch con) m
-> IO (ClientConnectionStore (Event ch con) m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientConnectionStore (Event ch con) m
-> ClientConnectionStore (Event ch con) m
changes)
      }

finallyM :: MonadUnliftIO m => m () -> m () -> m ()
finallyM :: m () -> m () -> m ()
finallyM m ()
loop m ()
end = ((forall a. m a -> IO a) -> IO ()) -> m ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runIO -> IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (m () -> IO ()
forall a. m a -> IO a
runIO m ()
loop) (m () -> IO ()
forall a. m a -> IO a
runIO m ()
end)

connectionThread ::
  ( MonadUnliftIO m,
    Eq ch,
    Hashable ch
  ) =>
  App (Event ch con) m ->
  ApiContext SUB (Event ch con) m ->
  m ()
connectionThread :: App (Event ch con) m -> ApiContext SUB (Event ch con) m -> m ()
connectionThread App (Event ch con) m
api ApiContext SUB (Event ch con) m
scope = do
  Input SUB
input <- m (Input SUB)
forall (m :: * -> *). MonadIO m => m (Input SUB)
connect
  m () -> m () -> m ()
forall (m :: * -> *). MonadUnliftIO m => m () -> m () -> m ()
finallyM
    (App (Event ch con) m
-> ApiContext SUB (Event ch con) m -> Input SUB -> m ()
forall (m :: * -> *) ch con.
(Monad m, Eq ch, Hashable ch) =>
App (Event ch con) m
-> ApiContext SUB (Event ch con) m -> Input SUB -> m ()
connectionLoop App (Event ch con) m
api ApiContext SUB (Event ch con) m
scope Input SUB
input)
    (ApiContext SUB (Event ch con) m -> Input SUB -> m ()
forall e (m :: * -> *). ApiContext SUB e m -> Input SUB -> m ()
disconnect ApiContext SUB (Event ch con) m
scope Input SUB
input)

connectionLoop ::
  (Monad m, Eq ch, Hashable ch) =>
  App (Event ch con) m ->
  ApiContext SUB (Event ch con) m ->
  Input SUB ->
  m ()
connectionLoop :: App (Event ch con) m
-> ApiContext SUB (Event ch con) m -> Input SUB -> m ()
connectionLoop App (Event ch con) m
app ApiContext SUB (Event ch con) m
scope =
  m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever
    (m () -> m ()) -> (Input SUB -> m ()) -> Input SUB -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiContext SUB (Event ch con) m
-> Output SUB (Event ch con) m -> m ()
forall (m :: * -> *) e.
Monad m =>
ApiContext SUB e m -> Output SUB e m -> m ()
runStreamWS ApiContext SUB (Event ch con) m
scope
    (Output SUB (Event ch con) m -> m ())
-> (Input SUB -> Output SUB (Event ch con) m) -> Input SUB -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App (Event ch con) m -> Input SUB -> Output SUB (Event ch con) m
forall ch (m :: * -> *) con (api :: API).
(Eq ch, Monad m, Hashable ch) =>
App (Event ch con) m -> Input api -> Output api (Event ch con) m
streamApp App (Event ch con) m
app

streamApp ::
  (Eq ch, Monad m, Hashable ch) =>
  App (Event ch con) m ->
  Input api ->
  Output api (Event ch con) m
streamApp :: App (Event ch con) m -> Input api -> Output api (Event ch con) m
streamApp App (Event ch con) m
app = (GQLRequest -> ResponseStream (Event ch con) m (Value VALID))
-> Input api -> Output api (Event ch con) m
forall (m :: * -> *) ch con (api :: API).
(Monad m, Eq ch, Hashable ch) =>
(GQLRequest -> ResponseStream (Event ch con) m (Value VALID))
-> Input api -> Output api (Event ch con) m
toOutStream (App (Event ch con) m
-> GQLRequest -> ResponseStream (Event ch con) m (Value VALID)
forall (m :: * -> *) event.
Monad m =>
App event m -> GQLRequest -> ResponseStream event m (Value VALID)
runAppStream App (Event ch con) m
app)