{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Morpheus.Server
( webSocketsApp,
httpPubApp,
subscriptionApp,
ServerConstraint,
httpPlayground,
compileTimeSchemaValidation,
)
where
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift
( MonadUnliftIO,
withRunInIO,
)
import Data.Morpheus.Server.Deriving.Introspect
( compileTimeSchemaValidation,
)
import Data.Morpheus.Server.Playground
( httpPlayground,
)
import Data.Morpheus.Types.IO (MapAPI (..))
import Data.Morpheus.Types.Internal.Resolving
( Event,
)
import Data.Morpheus.Types.Internal.Subscription
( HTTP,
Input (..),
Scope (..),
Store (..),
Stream,
WS,
acceptApolloRequest,
connectionThread,
initDefaultStore,
publishEventWith,
runStreamHTTP,
)
import Network.WebSockets
( Connection,
ServerApp,
receiveData,
sendTextData,
)
import qualified Network.WebSockets as WS
type ServerConstraint e m =
( MonadIO m,
MonadUnliftIO m
)
pingThread :: Connection -> IO () -> IO ()
#if MIN_VERSION_websockets(0,12,6)
pingThread connection = WS.withPingThread connection 30 (return ())
#else
pingThread connection = (WS.forkPingThread connection 30 >>)
#endif
defaultWSScope :: MonadIO m => Store e m -> Connection -> Scope WS e m
defaultWSScope Store {writeStore} connection =
ScopeWS
{ listener = liftIO (receiveData connection),
callback = liftIO . sendTextData connection,
update = writeStore
}
httpPubApp ::
( MonadIO m,
MapAPI a b
) =>
(Input HTTP -> Stream HTTP e m) ->
(e -> m ()) ->
a ->
m b
httpPubApp api httpCallback =
mapAPI $
runStreamHTTP ScopeHTTP {httpCallback}
. api
. Request
subscriptionApp ::
( MonadUnliftIO m,
Eq channel
) =>
( Store (Event channel a) m ->
(Scope WS (Event channel a) m -> m ()) ->
m app
) ->
(Input WS -> Stream WS (Event channel a) m) ->
m (app, Event channel a -> m ())
subscriptionApp appWrapper api =
do
store <- initDefaultStore
app <- appWrapper store (connectionThread api)
pure
( app,
publishEventWith store
)
webSocketsWrapper ::
(MonadUnliftIO m, MonadIO m) =>
Store e m ->
(Scope WS e m -> m ()) ->
m ServerApp
webSocketsWrapper store handler =
withRunInIO $
\runIO ->
pure $
\pending -> do
conn <- acceptApolloRequest pending
pingThread
conn
$ runIO (handler (defaultWSScope store conn))
webSocketsApp ::
( MonadIO m,
MonadUnliftIO m,
Eq channel
) =>
(Input WS -> Stream WS (Event channel a) m) ->
m (ServerApp, Event channel a -> m ())
webSocketsApp = subscriptionApp webSocketsWrapper