{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}

module Polysemy.WebServer (WebServer(..), PendingWebRequest, startWebServer,
  startWebServerSettings,
  respondWebRequest, getBody, upgradeToWebSocketsResponse,
  acceptPendingWebSocketConnection, rejectPendingWebSocketConnection,
  whilePingingWebSocket, sendWebSocketDataMessages, receiveWebSocketDataMessage,
  sendWebSocketCloseCode, runWebServerFinal) where
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WaiWs
import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.WebSockets.Connection as WS
import qualified Network.WebSockets as WS
import Polysemy
import Polysemy.Final
import Data.Functor
import Control.Monad
import Control.Exception (catch)
import Data.Word (Word16)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS

newtype PendingWebRequest =
  PendingWebRequest (Wai.Response -> IO Wai.ResponseReceived)

data WebServer m a where
  -- |Starts a new web-server listening on a port, sending all requests to the provided
  --  function.
  StartWebServer :: Warp.Port -> (
    Wai.Request -> PendingWebRequest -> m Wai.ResponseReceived) ->
    WebServer m ()
  StartWebServerSettings :: Warp.Settings -> (
    Wai.Request -> PendingWebRequest -> m Wai.ResponseReceived) ->
    WebServer m ()
  -- | Responds to a web request (usually called from the callback to
  --   StartWebServer.
  RespondWebRequest :: PendingWebRequest -> Wai.Response ->
                       WebServer m Wai.ResponseReceived
  -- | Reads the entire body of a request into memory. Takes a maximum length
  --   to read - if the body length exceeds this length, returns Nothing.
  GetBody :: Int -> Wai.Request -> WebServer m (Maybe BS.ByteString)
  -- | Builds a response to upgrade a connection to a web socket.
  --   Returns Nothing if the request is not appropriate to upgrade.
  UpgradeToWebSocketsResponse :: WS.ConnectionOptions ->
    (WS.PendingConnection -> m ()) -> Wai.Request -> WebServer m (Maybe Wai.Response)
  -- | Accepts a pending WebSockets connection.
  AcceptPendingWebSocketConnection :: WS.PendingConnection -> WS.AcceptRequest ->
    WebServer m (Either (Either WS.HandshakeException WS.ConnectionException) WS.Connection)
  -- | Rejects a pending WebSockets connection.
  RejectPendingWebSocketConnection :: WS.PendingConnection -> WS.RejectRequest ->
    WebServer m ()
  -- | Runs an app, and sends a ping message over the WebSockets connection
  --   every n seconds while the app is executing. When the app completes,
  --   the pings will also stop.
  WhilePingingWebSocket :: WS.Connection -> Int -> m a -> WebServer m (Maybe a)
  -- | Sends some data messages over the WebSockets connection.
  SendWebSocketDataMessages :: WS.Connection -> [WS.DataMessage] -> WebServer m ()
  -- | Receives a data message from the WebSockets connection. Returns a
  --   Left @WS.CloseRequest if the connection is closed cleanly. Returns a
  --   Left @WS.ConnectionClosed if the
  --   connection is closed uncleanly.
  ReceiveWebSocketDataMessage :: WS.Connection -> WebServer m (Either WS.ConnectionException WS.DataMessage)
  -- | Sends a friendly close message and close code on a WebSocket.
  --   See http://tools.ietf.org/html/rfc6455#section-7.4 for a list of close
  --   codes.
  SendWebSocketCloseCode :: WS.WebSocketsData a => WS.Connection -> Word16 -> a -> WebServer m ()

makeSem ''WebServer

runStartWebServer :: forall rInitial r f.
  ((Final IO) `Member` r, Functor f) =>
  Warp.Port -> (
    Wai.Request -> PendingWebRequest ->
    Sem rInitial Wai.ResponseReceived) ->
  Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
runStartWebServer :: forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Int
-> (Request -> PendingWebRequest -> Sem rInitial ResponseReceived)
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
runStartWebServer Int
port Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app = do
  f ()
s0 <- forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
appFnS <- forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: EffectRow).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app
  Inspector f
ins <- forall (e :: Effect) (f :: * -> *) (m :: * -> *) (r :: EffectRow).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
  let
    appFn :: (Wai.Request, PendingWebRequest) ->
             Sem r (Maybe Wai.ResponseReceived)
    appFn :: (Request, PendingWebRequest) -> Sem r (Maybe ResponseReceived)
appFn = forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
appFnS forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
s0 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
  forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal forall a b. (a -> b) -> a -> b
$ do
    f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived))
appFnS' <- forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS (forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request, PendingWebRequest) -> Sem r (Maybe ResponseReceived)
appFn)
    Inspector f
ins' <- forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    f ()
s1 <- forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    let
      appFn' :: (Wai.Request, PendingWebRequest) ->
                IO (Maybe Wai.ResponseReceived)
      appFn' :: (Request, PendingWebRequest) -> IO (Maybe ResponseReceived)
appFn' = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived))
appFnS' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
s1 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      let
        doRequestIO :: Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) ->
                       IO Wai.ResponseReceived
        doRequestIO :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
doRequestIO Request
req Response -> IO ResponseReceived
respond = do
          Maybe ResponseReceived
maybeRR <- (Request, PendingWebRequest) -> IO (Maybe ResponseReceived)
appFn' (Request
req, (Response -> IO ResponseReceived) -> PendingWebRequest
PendingWebRequest Response -> IO ResponseReceived
respond)
          case Maybe ResponseReceived
maybeRR of
            Just ResponseReceived
rr -> forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
rr
            Maybe ResponseReceived
Nothing -> Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$
              Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS (Status
HTTP.status500) [] ByteString
"Internal server error"
          
      Int
-> (Request
    -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
-> IO ()
Warp.run Int
port forall a b. (a -> b) -> a -> b
$ \Request
req Response -> IO ResponseReceived
reply -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
doRequestIO Request
req Response -> IO ResponseReceived
reply
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ f ()
s1 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> f ()
s0

runStartWebServerSettings :: forall rInitial r f.
  ((Final IO) `Member` r, Functor f) =>
  Warp.Settings -> (
    Wai.Request -> PendingWebRequest ->
    Sem rInitial Wai.ResponseReceived) ->
  Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
runStartWebServerSettings :: forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Settings
-> (Request -> PendingWebRequest -> Sem rInitial ResponseReceived)
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
runStartWebServerSettings Settings
settings Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app = do
  f ()
s0 <- forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
appFnS <- forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: EffectRow).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app
  Inspector f
ins <- forall (e :: Effect) (f :: * -> *) (m :: * -> *) (r :: EffectRow).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
  let
    appFn :: (Wai.Request, PendingWebRequest) ->
             Sem r (Maybe Wai.ResponseReceived)
    appFn :: (Request, PendingWebRequest) -> Sem r (Maybe ResponseReceived)
appFn = forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
appFnS forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
s0 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
  forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal forall a b. (a -> b) -> a -> b
$ do
    f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived))
appFnS' <- forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS (forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request, PendingWebRequest) -> Sem r (Maybe ResponseReceived)
appFn)
    Inspector f
ins' <- forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    f ()
s1 <- forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    let
      appFn' :: (Wai.Request, PendingWebRequest) ->
                IO (Maybe Wai.ResponseReceived)
      appFn' :: (Request, PendingWebRequest) -> IO (Maybe ResponseReceived)
appFn' = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived))
appFnS' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
s1 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
      let
        doRequestIO :: Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) ->
                       IO Wai.ResponseReceived
        doRequestIO :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
doRequestIO Request
req Response -> IO ResponseReceived
respond = do
          Maybe ResponseReceived
maybeRR <- (Request, PendingWebRequest) -> IO (Maybe ResponseReceived)
appFn' (Request
req, (Response -> IO ResponseReceived) -> PendingWebRequest
PendingWebRequest Response -> IO ResponseReceived
respond)
          case Maybe ResponseReceived
maybeRR of
            Just ResponseReceived
rr -> forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
rr
            Maybe ResponseReceived
Nothing -> Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$
              Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS (Status
HTTP.status500) [] ByteString
"Internal server error"
          
      Settings
-> (Request
    -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
-> IO ()
Warp.runSettings Settings
settings forall a b. (a -> b) -> a -> b
$ \Request
req Response -> IO ResponseReceived
reply -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
doRequestIO Request
req Response -> IO ResponseReceived
reply
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ f ()
s1 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> f ()
s0

ioToWebServerTactics ::
  forall a rInitial r f. (Functor f, Final IO `Member` r) =>
  IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics :: forall a (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics IO a
action = forall (f :: * -> *) a (e :: Effect) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal IO a
action

runRespondWebRequest :: forall rInitial r f.
  ((Final IO) `Member` r, Functor f) =>
  PendingWebRequest -> Wai.Response ->
  Sem (WithTactics WebServer f (Sem rInitial) r) (f Wai.ResponseReceived)
runRespondWebRequest :: forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
PendingWebRequest
-> Response
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f ResponseReceived)
runRespondWebRequest (PendingWebRequest Response -> IO ResponseReceived
respond) Response
resp =
  forall a (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics (Response -> IO ResponseReceived
respond Response
resp)

runGetBody :: forall rInitial r f.
  ((Final IO) `Member` r, Functor f) =>
  Int -> Wai.Request ->
  Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe BS.ByteString))
runGetBody :: forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Int
-> Request
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe ByteString))
runGetBody Int
maxLen Request
req = do
  ByteString
body <- forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.lazyRequestBody Request
req
  let strictBody :: ByteString
strictBody = ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
LBS.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
maxLen forall a. Num a => a -> a -> a
+ Int
1) ByteString
body
  if ByteString -> Int
BS.length ByteString
strictBody forall a. Ord a => a -> a -> Bool
> Int
maxLen
    then forall (f :: * -> *) a (e :: Effect) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT forall a. Maybe a
Nothing
    else forall (f :: * -> *) a (e :: Effect) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (forall a. a -> Maybe a
Just ByteString
strictBody)

runUpgradeToWebSocketsResponse :: forall rInitial r f. (Final IO `Member` r, Functor f) =>
  WS.ConnectionOptions ->
  (WS.PendingConnection -> Sem rInitial ()) ->
  Wai.Request ->
  Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe Wai.Response))
runUpgradeToWebSocketsResponse :: forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
ConnectionOptions
-> (PendingConnection -> Sem rInitial ())
-> Request
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe Response))
runUpgradeToWebSocketsResponse ConnectionOptions
opts PendingConnection -> Sem rInitial ()
app Request
req = do
  f ()
stT <- forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f PendingConnection -> Sem (WebServer : r) (f ())
boundTApp' <- forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: EffectRow).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT PendingConnection -> Sem rInitial ()
app
  let boundTApp :: WS.PendingConnection -> Sem r ()
      boundTApp :: PendingConnection -> Sem r ()
boundTApp = forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f PendingConnection -> Sem (WebServer : r) (f ())
boundTApp' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
stT forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
  forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal forall a b. (a -> b) -> a -> b
$ do
    f ()
stS <- forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    f PendingConnection -> IO (f ())
boundTSApp' <- forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS (forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingConnection -> Sem r ()
boundTApp)
    let boundTSApp :: WS.PendingConnection -> IO ()
        boundTSApp :: PendingConnection -> IO ()
boundTSApp = (forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f PendingConnection -> IO (f ())
boundTSApp' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
stS forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
        finalResp :: Maybe Wai.Response
        finalResp :: Maybe Response
finalResp = ConnectionOptions
-> (PendingConnection -> IO ()) -> Request -> Maybe Response
WaiWs.websocketsApp ConnectionOptions
opts PendingConnection -> IO ()
boundTSApp Request
req
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ f ()
stS forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (f ()
stT forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe Response
finalResp)

runAcceptPendingWebSocketConnection ::
  (Final IO `Member` r, Functor f) =>
  WS.PendingConnection ->
  WS.AcceptRequest ->
  Sem (WithTactics WebServer f (Sem rInitial) r) (
    f (Either (Either WS.HandshakeException WS.ConnectionException)
       WS.Connection))
runAcceptPendingWebSocketConnection :: forall (r :: EffectRow) (f :: * -> *) (rInitial :: EffectRow).
(Member (Final IO) r, Functor f) =>
PendingConnection
-> AcceptRequest
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either
           (Either HandshakeException ConnectionException) Connection))
runAcceptPendingWebSocketConnection PendingConnection
conn AcceptRequest
opts =
  forall a (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics IO
  (Either (Either HandshakeException ConnectionException) Connection)
inIO
  where
    inIO :: IO (Either
                (Either WS.HandshakeException WS.ConnectionException)
                WS.Connection)
    inIO :: IO
  (Either (Either HandshakeException ConnectionException) Connection)
inIO = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PendingConnection -> AcceptRequest -> IO Connection
WS.acceptRequestWith PendingConnection
conn AcceptRequest
opts)
                   (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right))
                 (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

runWhilePingingWebSocket :: forall rInitial a r f.
  (Final IO `Member` r, Functor f) =>
  WS.Connection -> Int -> Sem rInitial a ->
  Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe a))
runWhilePingingWebSocket :: forall (rInitial :: EffectRow) a (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Connection
-> Int
-> Sem rInitial a
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe a))
runWhilePingingWebSocket Connection
conn Int
n Sem rInitial a
app = do
  f ()
stT <- forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  Sem (WebServer : r) (f a)
appT' <- forall (m :: * -> *) a (e :: Effect) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial a
app
  Inspector f
insT <- forall (e :: Effect) (f :: * -> *) (m :: * -> *) (r :: EffectRow).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
  let
    appT :: Sem r (Maybe a)
    appT :: Sem r (Maybe a)
appT = (forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
insT) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal Sem (WebServer : r) (f a)
appT'
  forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal forall a b. (a -> b) -> a -> b
$ do
    IO (f (Maybe a))
appTS' <- forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS (forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise Sem r (Maybe a)
appT)
    f ()
stS <- forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    Inspector f
insS <- forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    let appTS :: IO (Maybe a)
        appTS :: IO (Maybe a)
appTS = (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
insS) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (f (Maybe a))
appTS'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((f ()
stS forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
stT forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Connection -> Int -> IO () -> IO a -> IO a
WS.withPingThread Connection
conn Int
n (forall (m :: * -> *) a. Monad m => a -> m a
return ()) IO (Maybe a)
appTS

runReceiveWebSocketDataMessage :: forall rInitial r f.
  (Final IO `Member` r, Functor f) =>
  WS.Connection ->
  Sem (WithTactics WebServer f (Sem rInitial) r) (
  f (Either WS.ConnectionException WS.DataMessage))
runReceiveWebSocketDataMessage :: forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Connection
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either ConnectionException DataMessage))
runReceiveWebSocketDataMessage Connection
conn =
  forall a (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics IO (Either ConnectionException DataMessage)
inIO
  where
    inIO :: IO (Either WS.ConnectionException WS.DataMessage)
    inIO :: IO (Either ConnectionException DataMessage)
inIO = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO DataMessage
WS.receiveDataMessage Connection
conn)
                 (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

runWebServerFinal :: ((Final IO) `Member` r) =>
                     Sem (WebServer ': r) a -> Sem r a
runWebServerFinal :: forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal =
  forall (e :: Effect) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH (\WebServer (Sem rInitial) x
v -> case WebServer (Sem rInitial) x
v of
                 StartWebServer Int
port Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app -> forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Int
-> (Request -> PendingWebRequest -> Sem rInitial ResponseReceived)
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
runStartWebServer Int
port Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app
                 StartWebServerSettings Settings
settings Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app -> forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Settings
-> (Request -> PendingWebRequest -> Sem rInitial ResponseReceived)
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
runStartWebServerSettings Settings
settings Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app
                 RespondWebRequest PendingWebRequest
reqId Response
response -> forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
PendingWebRequest
-> Response
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f ResponseReceived)
runRespondWebRequest PendingWebRequest
reqId Response
response
                 GetBody Int
maxLen Request
req -> forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Int
-> Request
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe ByteString))
runGetBody Int
maxLen Request
req
                 UpgradeToWebSocketsResponse ConnectionOptions
opts PendingConnection -> Sem rInitial ()
app Request
req ->
                   forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
ConnectionOptions
-> (PendingConnection -> Sem rInitial ())
-> Request
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe Response))
runUpgradeToWebSocketsResponse ConnectionOptions
opts PendingConnection -> Sem rInitial ()
app Request
req
                 AcceptPendingWebSocketConnection PendingConnection
conn AcceptRequest
opts ->
                   forall (r :: EffectRow) (f :: * -> *) (rInitial :: EffectRow).
(Member (Final IO) r, Functor f) =>
PendingConnection
-> AcceptRequest
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either
           (Either HandshakeException ConnectionException) Connection))
runAcceptPendingWebSocketConnection PendingConnection
conn AcceptRequest
opts
                 RejectPendingWebSocketConnection PendingConnection
conn RejectRequest
opts ->
                   forall a (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics (PendingConnection -> RejectRequest -> IO ()
WS.rejectRequestWith PendingConnection
conn RejectRequest
opts)
                 WhilePingingWebSocket Connection
conn Int
n Sem rInitial a
app ->
                   forall (rInitial :: EffectRow) a (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Connection
-> Int
-> Sem rInitial a
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe a))
runWhilePingingWebSocket Connection
conn Int
n Sem rInitial a
app
                 SendWebSocketDataMessages Connection
conn [DataMessage]
msgs ->
                   forall a (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics forall a b. (a -> b) -> a -> b
$ Connection -> [DataMessage] -> IO ()
WS.sendDataMessages Connection
conn [DataMessage]
msgs
                 ReceiveWebSocketDataMessage Connection
conn ->
                   forall (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Connection
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either ConnectionException DataMessage))
runReceiveWebSocketDataMessage Connection
conn
                 SendWebSocketCloseCode Connection
conn Word16
code a
msg ->
                   forall a (rInitial :: EffectRow) (r :: EffectRow) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> Word16 -> a -> IO ()
WS.sendCloseCode Connection
conn Word16
code a
msg
             )