{-# 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 :: 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 <- Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
appFnS <- ((Request, PendingWebRequest) -> Sem rInitial ResponseReceived)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Request, PendingWebRequest)
      -> Sem (WebServer : r) (f ResponseReceived))
forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: [Effect]).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT (((Request, PendingWebRequest) -> Sem rInitial ResponseReceived)
 -> Sem
      (WithTactics WebServer f (Sem rInitial) r)
      (f (Request, PendingWebRequest)
       -> Sem (WebServer : r) (f ResponseReceived)))
-> ((Request, PendingWebRequest) -> Sem rInitial ResponseReceived)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Request, PendingWebRequest)
      -> Sem (WebServer : r) (f ResponseReceived))
forall a b. (a -> b) -> a -> b
$ (Request -> PendingWebRequest -> Sem rInitial ResponseReceived)
-> (Request, PendingWebRequest) -> Sem rInitial ResponseReceived
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app
  Inspector f
ins <- Sem (WithTactics WebServer f (Sem rInitial) r) (Inspector f)
forall (e :: Effect) (f :: * -> *) (m :: * -> *) (r :: [Effect]).
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 = Sem (WebServer : r) (Maybe ResponseReceived)
-> Sem r (Maybe ResponseReceived)
forall (r :: [Effect]) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal (Sem (WebServer : r) (Maybe ResponseReceived)
 -> Sem r (Maybe ResponseReceived))
-> ((Request, PendingWebRequest)
    -> Sem (WebServer : r) (Maybe ResponseReceived))
-> (Request, PendingWebRequest)
-> Sem r (Maybe ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((f ResponseReceived -> Maybe ResponseReceived)
-> Sem (WebServer : r) (f ResponseReceived)
-> Sem (WebServer : r) (Maybe ResponseReceived)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins)) (Sem (WebServer : r) (f ResponseReceived)
 -> Sem (WebServer : r) (Maybe ResponseReceived))
-> ((Request, PendingWebRequest)
    -> Sem (WebServer : r) (f ResponseReceived))
-> (Request, PendingWebRequest)
-> Sem (WebServer : r) (Maybe ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
appFnS (f (Request, PendingWebRequest)
 -> Sem (WebServer : r) (f ResponseReceived))
-> ((Request, PendingWebRequest) -> f (Request, PendingWebRequest))
-> (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
s0 f ()
-> (Request, PendingWebRequest) -> f (Request, PendingWebRequest)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
  Strategic
  IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f ())
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall (m :: * -> *) (r :: [Effect]) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal (Strategic
   IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f ())
 -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ()))
-> Strategic
     IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f ())
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall a b. (a -> b) -> a -> b
$ do
    f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived))
appFnS' <- ((Request, PendingWebRequest)
 -> Sem
      (WithTactics WebServer f (Sem rInitial) r)
      (Maybe ResponseReceived))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived)))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS (Sem r (Maybe ResponseReceived)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (Maybe ResponseReceived)
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise (Sem r (Maybe ResponseReceived)
 -> Sem
      (WithTactics WebServer f (Sem rInitial) r)
      (Maybe ResponseReceived))
-> ((Request, PendingWebRequest) -> Sem r (Maybe ResponseReceived))
-> (Request, PendingWebRequest)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (Maybe ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request, PendingWebRequest) -> Sem r (Maybe ResponseReceived)
appFn)
    Inspector f
ins' <- Sem
  (WithStrategy
     IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
  (Inspector f)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    f ()
s1 <- Sem
  (WithStrategy
     IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
  (f ())
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' = ((f (Maybe ResponseReceived) -> Maybe ResponseReceived)
-> IO (f (Maybe ResponseReceived)) -> IO (Maybe ResponseReceived)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (Maybe ResponseReceived) -> Maybe ResponseReceived
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ResponseReceived) -> Maybe ResponseReceived)
-> (f (Maybe ResponseReceived) -> Maybe (Maybe ResponseReceived))
-> f (Maybe ResponseReceived)
-> Maybe ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins')) (IO (f (Maybe ResponseReceived)) -> IO (Maybe ResponseReceived))
-> ((Request, PendingWebRequest)
    -> IO (f (Maybe ResponseReceived)))
-> (Request, PendingWebRequest)
-> IO (Maybe ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived))
appFnS' (f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived)))
-> ((Request, PendingWebRequest) -> f (Request, PendingWebRequest))
-> (Request, PendingWebRequest)
-> IO (f (Maybe ResponseReceived))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
s1 f ()
-> (Request, PendingWebRequest) -> f (Request, PendingWebRequest)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
    IO (f (f ()))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f ())))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (f (f ()))
 -> Sem
      (WithStrategy
         IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
      (IO (f (f ()))))
-> IO (f (f ()))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f ())))
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 -> ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
rr
            Maybe ResponseReceived
Nothing -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 ((Request
  -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
 -> IO ())
-> (Request
    -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
-> IO ()
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
      f (f ()) -> IO (f (f ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (f ()) -> IO (f (f ()))) -> f (f ()) -> IO (f (f ()))
forall a b. (a -> b) -> a -> b
$ f ()
s1 f () -> f () -> f (f ())
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 :: 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 <- Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
appFnS <- ((Request, PendingWebRequest) -> Sem rInitial ResponseReceived)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Request, PendingWebRequest)
      -> Sem (WebServer : r) (f ResponseReceived))
forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: [Effect]).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT (((Request, PendingWebRequest) -> Sem rInitial ResponseReceived)
 -> Sem
      (WithTactics WebServer f (Sem rInitial) r)
      (f (Request, PendingWebRequest)
       -> Sem (WebServer : r) (f ResponseReceived)))
-> ((Request, PendingWebRequest) -> Sem rInitial ResponseReceived)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Request, PendingWebRequest)
      -> Sem (WebServer : r) (f ResponseReceived))
forall a b. (a -> b) -> a -> b
$ (Request -> PendingWebRequest -> Sem rInitial ResponseReceived)
-> (Request, PendingWebRequest) -> Sem rInitial ResponseReceived
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Request -> PendingWebRequest -> Sem rInitial ResponseReceived
app
  Inspector f
ins <- Sem (WithTactics WebServer f (Sem rInitial) r) (Inspector f)
forall (e :: Effect) (f :: * -> *) (m :: * -> *) (r :: [Effect]).
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 = Sem (WebServer : r) (Maybe ResponseReceived)
-> Sem r (Maybe ResponseReceived)
forall (r :: [Effect]) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal (Sem (WebServer : r) (Maybe ResponseReceived)
 -> Sem r (Maybe ResponseReceived))
-> ((Request, PendingWebRequest)
    -> Sem (WebServer : r) (Maybe ResponseReceived))
-> (Request, PendingWebRequest)
-> Sem r (Maybe ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((f ResponseReceived -> Maybe ResponseReceived)
-> Sem (WebServer : r) (f ResponseReceived)
-> Sem (WebServer : r) (Maybe ResponseReceived)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins)) (Sem (WebServer : r) (f ResponseReceived)
 -> Sem (WebServer : r) (Maybe ResponseReceived))
-> ((Request, PendingWebRequest)
    -> Sem (WebServer : r) (f ResponseReceived))
-> (Request, PendingWebRequest)
-> Sem (WebServer : r) (Maybe ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
appFnS (f (Request, PendingWebRequest)
 -> Sem (WebServer : r) (f ResponseReceived))
-> ((Request, PendingWebRequest) -> f (Request, PendingWebRequest))
-> (Request, PendingWebRequest)
-> Sem (WebServer : r) (f ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
s0 f ()
-> (Request, PendingWebRequest) -> f (Request, PendingWebRequest)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
  Strategic
  IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f ())
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall (m :: * -> *) (r :: [Effect]) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal (Strategic
   IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f ())
 -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ()))
-> Strategic
     IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f ())
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall a b. (a -> b) -> a -> b
$ do
    f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived))
appFnS' <- ((Request, PendingWebRequest)
 -> Sem
      (WithTactics WebServer f (Sem rInitial) r)
      (Maybe ResponseReceived))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived)))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS (Sem r (Maybe ResponseReceived)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (Maybe ResponseReceived)
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise (Sem r (Maybe ResponseReceived)
 -> Sem
      (WithTactics WebServer f (Sem rInitial) r)
      (Maybe ResponseReceived))
-> ((Request, PendingWebRequest) -> Sem r (Maybe ResponseReceived))
-> (Request, PendingWebRequest)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (Maybe ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request, PendingWebRequest) -> Sem r (Maybe ResponseReceived)
appFn)
    Inspector f
ins' <- Sem
  (WithStrategy
     IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
  (Inspector f)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    f ()
s1 <- Sem
  (WithStrategy
     IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
  (f ())
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' = ((f (Maybe ResponseReceived) -> Maybe ResponseReceived)
-> IO (f (Maybe ResponseReceived)) -> IO (Maybe ResponseReceived)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (Maybe ResponseReceived) -> Maybe ResponseReceived
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ResponseReceived) -> Maybe ResponseReceived)
-> (f (Maybe ResponseReceived) -> Maybe (Maybe ResponseReceived))
-> f (Maybe ResponseReceived)
-> Maybe ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins')) (IO (f (Maybe ResponseReceived)) -> IO (Maybe ResponseReceived))
-> ((Request, PendingWebRequest)
    -> IO (f (Maybe ResponseReceived)))
-> (Request, PendingWebRequest)
-> IO (Maybe ResponseReceived)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived))
appFnS' (f (Request, PendingWebRequest) -> IO (f (Maybe ResponseReceived)))
-> ((Request, PendingWebRequest) -> f (Request, PendingWebRequest))
-> (Request, PendingWebRequest)
-> IO (f (Maybe ResponseReceived))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
s1 f ()
-> (Request, PendingWebRequest) -> f (Request, PendingWebRequest)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
    IO (f (f ()))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f ())))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (f (f ()))
 -> Sem
      (WithStrategy
         IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
      (IO (f (f ()))))
-> IO (f (f ()))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f ())))
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 -> ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
rr
            Maybe ResponseReceived
Nothing -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
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 ((Request
  -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
 -> IO ())
-> (Request
    -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
-> IO ()
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
      f (f ()) -> IO (f (f ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (f ()) -> IO (f (f ()))) -> f (f ()) -> IO (f (f ()))
forall a b. (a -> b) -> a -> b
$ f ()
s1 f () -> f () -> f (f ())
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 :: IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics IO a
action = a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
forall (f :: * -> *) a (e :: Effect) (m :: * -> *) (r :: [Effect]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a))
-> Sem (WithTactics WebServer f (Sem rInitial) r) a
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) a
forall (m :: * -> *) (r :: [Effect]) 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 :: PendingWebRequest
-> Response
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f ResponseReceived)
runRespondWebRequest (PendingWebRequest Response -> IO ResponseReceived
respond) Response
resp =
  IO ResponseReceived
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f ResponseReceived)
forall a (rInitial :: [Effect]) (r :: [Effect]) (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 :: Int
-> Request
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe ByteString))
runGetBody Int
maxLen Request
req = do
  ByteString
body <- IO ByteString
-> Sem (WithTactics WebServer f (Sem rInitial) r) ByteString
forall (m :: * -> *) (r :: [Effect]) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal (IO ByteString
 -> Sem (WithTactics WebServer f (Sem rInitial) r) ByteString)
-> IO ByteString
-> Sem (WithTactics WebServer f (Sem rInitial) r) ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.lazyRequestBody Request
req
  let strictBody :: ByteString
strictBody = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
LBS.take (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Int
maxLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
body
  if ByteString -> Int
BS.length ByteString
strictBody Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLen
    then Maybe ByteString
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe ByteString))
forall (f :: * -> *) a (e :: Effect) (m :: * -> *) (r :: [Effect]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT Maybe ByteString
forall a. Maybe a
Nothing
    else Maybe ByteString
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe ByteString))
forall (f :: * -> *) a (e :: Effect) (m :: * -> *) (r :: [Effect]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (ByteString -> Maybe ByteString
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 :: 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 <- Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  f PendingConnection -> Sem (WebServer : r) (f ())
boundTApp' <- (PendingConnection -> Sem rInitial ())
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f PendingConnection -> Sem (WebServer : r) (f ()))
forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: [Effect]).
(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 = Sem (WebServer : r) () -> Sem r ()
forall (r :: [Effect]) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal (Sem (WebServer : r) () -> Sem r ())
-> (PendingConnection -> Sem (WebServer : r) ())
-> PendingConnection
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sem (WebServer : r) (f ()) -> () -> Sem (WebServer : r) ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()) (Sem (WebServer : r) (f ()) -> Sem (WebServer : r) ())
-> (PendingConnection -> Sem (WebServer : r) (f ()))
-> PendingConnection
-> Sem (WebServer : r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f PendingConnection -> Sem (WebServer : r) (f ())
boundTApp' (f PendingConnection -> Sem (WebServer : r) (f ()))
-> (PendingConnection -> f PendingConnection)
-> PendingConnection
-> Sem (WebServer : r) (f ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
stT f () -> PendingConnection -> f PendingConnection
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
  Strategic
  IO
  (Sem (WithTactics WebServer f (Sem rInitial) r))
  (f (Maybe Response))
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe Response))
forall (m :: * -> *) (r :: [Effect]) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal (Strategic
   IO
   (Sem (WithTactics WebServer f (Sem rInitial) r))
   (f (Maybe Response))
 -> Sem
      (WithTactics WebServer f (Sem rInitial) r) (f (Maybe Response)))
-> Strategic
     IO
     (Sem (WithTactics WebServer f (Sem rInitial) r))
     (f (Maybe Response))
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe Response))
forall a b. (a -> b) -> a -> b
$ do
    f ()
stS <- Sem
  (WithStrategy
     IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
  (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    f PendingConnection -> IO (f ())
boundTSApp' <- (PendingConnection
 -> Sem (WithTactics WebServer f (Sem rInitial) r) ())
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (f PendingConnection -> IO (f ()))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS (Sem r () -> Sem (WithTactics WebServer f (Sem rInitial) r) ()
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise (Sem r () -> Sem (WithTactics WebServer f (Sem rInitial) r) ())
-> (PendingConnection -> Sem r ())
-> PendingConnection
-> Sem (WithTactics WebServer f (Sem rInitial) r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PendingConnection -> Sem r ()
boundTApp)
    let boundTSApp :: WS.PendingConnection -> IO ()
        boundTSApp :: PendingConnection -> IO ()
boundTSApp = (IO (f ()) -> () -> IO ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()) (IO (f ()) -> IO ())
-> (PendingConnection -> IO (f ())) -> PendingConnection -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f PendingConnection -> IO (f ())
boundTSApp' (f PendingConnection -> IO (f ()))
-> (PendingConnection -> f PendingConnection)
-> PendingConnection
-> IO (f ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
stS f () -> PendingConnection -> f PendingConnection
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
    IO (f (f (Maybe Response)))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f (Maybe Response))))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (f (f (Maybe Response)))
 -> Sem
      (WithStrategy
         IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
      (IO (f (f (Maybe Response)))))
-> (f (f (Maybe Response)) -> IO (f (f (Maybe Response))))
-> f (f (Maybe Response))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f (Maybe Response))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (f (Maybe Response)) -> IO (f (f (Maybe Response)))
forall (m :: * -> *) a. Monad m => a -> m a
return (f (f (Maybe Response))
 -> Sem
      (WithStrategy
         IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
      (IO (f (f (Maybe Response)))))
-> f (f (Maybe Response))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f (Maybe Response))))
forall a b. (a -> b) -> a -> b
$ f ()
stS f () -> f (Maybe Response) -> f (f (Maybe Response))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (f ()
stT f () -> Maybe Response -> f (Maybe Response)
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 :: PendingConnection
-> AcceptRequest
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either
           (Either HandshakeException ConnectionException) Connection))
runAcceptPendingWebSocketConnection PendingConnection
conn AcceptRequest
opts =
  IO
  (Either (Either HandshakeException ConnectionException) Connection)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either
           (Either HandshakeException ConnectionException) Connection))
forall a (rInitial :: [Effect]) (r :: [Effect]) (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 = IO
  (Either (Either HandshakeException ConnectionException) Connection)
-> (HandshakeException
    -> IO
         (Either
            (Either HandshakeException ConnectionException) Connection))
-> IO
     (Either (Either HandshakeException ConnectionException) Connection)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (IO
  (Either (Either HandshakeException ConnectionException) Connection)
-> (ConnectionException
    -> IO
         (Either
            (Either HandshakeException ConnectionException) Connection))
-> IO
     (Either (Either HandshakeException ConnectionException) Connection)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Connection
-> Either
     (Either HandshakeException ConnectionException) Connection
forall a b. b -> Either a b
Right (Connection
 -> Either
      (Either HandshakeException ConnectionException) Connection)
-> IO Connection
-> IO
     (Either (Either HandshakeException ConnectionException) Connection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PendingConnection -> AcceptRequest -> IO Connection
WS.acceptRequestWith PendingConnection
conn AcceptRequest
opts)
                   (Either (Either HandshakeException ConnectionException) Connection
-> IO
     (Either (Either HandshakeException ConnectionException) Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Either HandshakeException ConnectionException) Connection
 -> IO
      (Either
         (Either HandshakeException ConnectionException) Connection))
-> (ConnectionException
    -> Either
         (Either HandshakeException ConnectionException) Connection)
-> ConnectionException
-> IO
     (Either (Either HandshakeException ConnectionException) Connection)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either HandshakeException ConnectionException
-> Either
     (Either HandshakeException ConnectionException) Connection
forall a b. a -> Either a b
Left (Either HandshakeException ConnectionException
 -> Either
      (Either HandshakeException ConnectionException) Connection)
-> (ConnectionException
    -> Either HandshakeException ConnectionException)
-> ConnectionException
-> Either
     (Either HandshakeException ConnectionException) Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionException
-> Either HandshakeException ConnectionException
forall a b. b -> Either a b
Right))
                 (Either (Either HandshakeException ConnectionException) Connection
-> IO
     (Either (Either HandshakeException ConnectionException) Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Either HandshakeException ConnectionException) Connection
 -> IO
      (Either
         (Either HandshakeException ConnectionException) Connection))
-> (HandshakeException
    -> Either
         (Either HandshakeException ConnectionException) Connection)
-> HandshakeException
-> IO
     (Either (Either HandshakeException ConnectionException) Connection)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either HandshakeException ConnectionException
-> Either
     (Either HandshakeException ConnectionException) Connection
forall a b. a -> Either a b
Left (Either HandshakeException ConnectionException
 -> Either
      (Either HandshakeException ConnectionException) Connection)
-> (HandshakeException
    -> Either HandshakeException ConnectionException)
-> HandshakeException
-> Either
     (Either HandshakeException ConnectionException) Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandshakeException -> Either HandshakeException ConnectionException
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 :: 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 <- Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall (f :: * -> *) (m :: * -> *) (r :: [Effect]) (e :: Effect).
Sem (WithTactics e f m r) (f ())
getInitialStateT
  Sem (WebServer : r) (f a)
appT' <- Sem rInitial a
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (Sem (WebServer : r) (f a))
forall (m :: * -> *) a (e :: Effect) (f :: * -> *) (r :: [Effect]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial a
app
  Inspector f
insT <- Sem (WithTactics WebServer f (Sem rInitial) r) (Inspector f)
forall (e :: Effect) (f :: * -> *) (m :: * -> *) (r :: [Effect]).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
  let
    appT :: Sem r (Maybe a)
    appT :: Sem r (Maybe a)
appT = (Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
insT) (f a -> Maybe a) -> Sem r (f a) -> Sem r (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem (WebServer : r) (f a) -> Sem r (f a)
forall (r :: [Effect]) a.
Member (Final IO) r =>
Sem (WebServer : r) a -> Sem r a
runWebServerFinal Sem (WebServer : r) (f a)
appT'
  Strategic
  IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f (Maybe a))
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe a))
forall (m :: * -> *) (r :: [Effect]) a.
Member (Final m) r =>
Strategic m (Sem r) a -> Sem r a
withStrategicToFinal (Strategic
   IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f (Maybe a))
 -> Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe a)))
-> Strategic
     IO (Sem (WithTactics WebServer f (Sem rInitial) r)) (f (Maybe a))
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe a))
forall a b. (a -> b) -> a -> b
$ do
    IO (f (Maybe a))
appTS' <- Sem (WithTactics WebServer f (Sem rInitial) r) (Maybe a)
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (Maybe a)))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS (Sem r (Maybe a)
-> Sem (WithTactics WebServer f (Sem rInitial) r) (Maybe a)
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise Sem r (Maybe a)
appT)
    f ()
stS <- Sem
  (WithStrategy
     IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
  (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    Inspector f
insS <- Sem
  (WithStrategy
     IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
  (Inspector f)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    let appTS :: IO (Maybe a)
        appTS :: IO (Maybe a)
appTS = (Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a)
-> (f (Maybe a) -> Maybe (Maybe a)) -> f (Maybe a) -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
insS) (f (Maybe a) -> Maybe a) -> IO (f (Maybe a)) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (f (Maybe a))
appTS'
    IO (f (f (Maybe a)))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f (Maybe a))))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (f (f (Maybe a)))
 -> Sem
      (WithStrategy
         IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
      (IO (f (f (Maybe a)))))
-> IO (f (f (Maybe a)))
-> Sem
     (WithStrategy
        IO f (Sem (WithTactics WebServer f (Sem rInitial) r)))
     (IO (f (f (Maybe a))))
forall a b. (a -> b) -> a -> b
$ ((f ()
stS f () -> f (Maybe a) -> f (f (Maybe a))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) (f (Maybe a) -> f (f (Maybe a)))
-> (Maybe a -> f (Maybe a)) -> Maybe a -> f (f (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ()
stT f () -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)) (Maybe a -> f (f (Maybe a)))
-> IO (Maybe a) -> IO (f (f (Maybe a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Int -> IO () -> IO (Maybe a) -> IO (Maybe a)
forall a. Connection -> Int -> IO () -> IO a -> IO a
WS.withPingThread Connection
conn Int
n (() -> IO ()
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 :: Connection
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either ConnectionException DataMessage))
runReceiveWebSocketDataMessage Connection
conn =
  IO (Either ConnectionException DataMessage)
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either ConnectionException DataMessage))
forall a (rInitial :: [Effect]) (r :: [Effect]) (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 = IO (Either ConnectionException DataMessage)
-> (ConnectionException
    -> IO (Either ConnectionException DataMessage))
-> IO (Either ConnectionException DataMessage)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (DataMessage -> Either ConnectionException DataMessage
forall a b. b -> Either a b
Right (DataMessage -> Either ConnectionException DataMessage)
-> IO DataMessage -> IO (Either ConnectionException DataMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO DataMessage
WS.receiveDataMessage Connection
conn)
                 (Either ConnectionException DataMessage
-> IO (Either ConnectionException DataMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConnectionException DataMessage
 -> IO (Either ConnectionException DataMessage))
-> (ConnectionException -> Either ConnectionException DataMessage)
-> ConnectionException
-> IO (Either ConnectionException DataMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionException -> Either ConnectionException DataMessage
forall a b. a -> Either a b
Left)

runWebServerFinal :: ((Final IO) `Member` r) =>
                     Sem (WebServer ': r) a -> Sem r a
runWebServerFinal :: Sem (WebServer : r) a -> Sem r a
runWebServerFinal =
  (forall (rInitial :: [Effect]) x.
 WebServer (Sem rInitial) x
 -> Tactical WebServer (Sem rInitial) r x)
-> Sem (WebServer : r) a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
(forall (rInitial :: [Effect]) 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 port app -> Int
-> (Request -> PendingWebRequest -> Sem rInitial ResponseReceived)
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall (rInitial :: [Effect]) (r :: [Effect]) (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 app -> Settings
-> (Request -> PendingWebRequest -> Sem rInitial ResponseReceived)
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall (rInitial :: [Effect]) (r :: [Effect]) (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 reqId response -> PendingWebRequest
-> Response
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f ResponseReceived)
forall (rInitial :: [Effect]) (r :: [Effect]) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
PendingWebRequest
-> Response
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f ResponseReceived)
runRespondWebRequest PendingWebRequest
reqId Response
response
                 GetBody maxLen req -> Int
-> Request
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe ByteString))
forall (rInitial :: [Effect]) (r :: [Effect]) (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 opts app req ->
                   ConnectionOptions
-> (PendingConnection -> Sem rInitial ())
-> Request
-> Sem
     (WithTactics WebServer f (Sem rInitial) r) (f (Maybe Response))
forall (rInitial :: [Effect]) (r :: [Effect]) (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 conn opts ->
                   PendingConnection
-> AcceptRequest
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either
           (Either HandshakeException ConnectionException) Connection))
forall (r :: [Effect]) (f :: * -> *) (rInitial :: [Effect]).
(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 conn opts ->
                   IO () -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall a (rInitial :: [Effect]) (r :: [Effect]) (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 conn n app ->
                   Connection
-> Int
-> Sem rInitial a
-> Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe a))
forall (rInitial :: [Effect]) a (r :: [Effect]) (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 conn msgs ->
                   IO () -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall a (rInitial :: [Effect]) (r :: [Effect]) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics (IO () -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ()))
-> IO () -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall a b. (a -> b) -> a -> b
$ Connection -> [DataMessage] -> IO ()
WS.sendDataMessages Connection
conn [DataMessage]
msgs
                 ReceiveWebSocketDataMessage conn ->
                   Connection
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either ConnectionException DataMessage))
forall (rInitial :: [Effect]) (r :: [Effect]) (f :: * -> *).
(Member (Final IO) r, Functor f) =>
Connection
-> Sem
     (WithTactics WebServer f (Sem rInitial) r)
     (f (Either ConnectionException DataMessage))
runReceiveWebSocketDataMessage Connection
conn
                 SendWebSocketCloseCode conn code msg ->
                   IO () -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall a (rInitial :: [Effect]) (r :: [Effect]) (f :: * -> *).
(Functor f, Member (Final IO) r) =>
IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)
ioToWebServerTactics (IO () -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ()))
-> IO () -> Sem (WithTactics WebServer f (Sem rInitial) r) (f ())
forall a b. (a -> b) -> a -> b
$ Connection -> Word16 -> a -> IO ()
forall a. WebSocketsData a => Connection -> Word16 -> a -> IO ()
WS.sendCloseCode Connection
conn Word16
code a
msg
             )