module Web.Hyperbole.Application
  ( waiApp
  , websocketsOr
  , defaultConnectionOptions
  , liveApp
  , liveAppWith
  , ServerOptions (..)
  , defaultErrorMessage
  , defaultError
  , socketApp
  , quickStartDocument
  , routeRequest
  ) where

import Control.Exception
import Control.Monad (forever)
import Data.ByteString.Lazy qualified as BL
import Effectful
import Effectful.Concurrent.Async
import Network.Wai qualified as Wai
import Network.Wai.Handler.WebSockets (websocketsOr)
import Network.WebSockets (ConnectionException (..), PendingConnection, defaultConnectionOptions, withPingThread)
import Network.WebSockets qualified as WS
import Web.Hyperbole.Document
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.Request (reqPath)
import Web.Hyperbole.Effect.Response (notFound)
import Web.Hyperbole.Route
import Web.Hyperbole.Server.Options
import Web.Hyperbole.Server.Socket (handleRequestSocket)
import Web.Hyperbole.Server.Wai (handleRequestWai)
import Web.Hyperbole.Types.Response


{- | Turn one or more 'Page's into a Wai Application. Respond using both HTTP and WebSockets

> main :: IO ()
> main = do
>   run 3000 $ do
>     liveApp quickStartDocument (runPage page)
-}
liveApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Concurrent, IOE] Response -> Wai.Application
liveApp :: (ByteString -> ByteString)
-> Eff '[Hyperbole, Concurrent, IOE] Response -> Application
liveApp ByteString -> ByteString
doc =
  ServerOptions
-> Eff '[Hyperbole, Concurrent, IOE] Response -> Application
liveAppWith (ServerOptions
 -> Eff '[Hyperbole, Concurrent, IOE] Response -> Application)
-> ServerOptions
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> Application
forall a b. (a -> b) -> a -> b
$
    ServerOptions
      { $sel:toDocument:ServerOptions :: ByteString -> ByteString
toDocument = ByteString -> ByteString
doc
      , $sel:serverError:ServerOptions :: ResponseError -> ServerError
serverError = ResponseError -> ServerError
defaultError
      }


-- | Run a Hyperbole application, customizing both the document and the format of server errors
liveAppWith :: ServerOptions -> Eff '[Hyperbole, Concurrent, IOE] Response -> Wai.Application
liveAppWith :: ServerOptions
-> Eff '[Hyperbole, Concurrent, IOE] Response -> Application
liveAppWith ServerOptions
opts Eff '[Hyperbole, Concurrent, IOE] Response
app Request
req =
  ConnectionOptions -> ServerApp -> Application -> Application
websocketsOr
    ConnectionOptions
defaultConnectionOptions
    (\PendingConnection
pend -> ServerOptions
-> Request
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> ServerApp
socketApp ServerOptions
opts Request
req Eff '[Hyperbole, Concurrent, IOE] Response
app PendingConnection
pend IO () -> (ConnectionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` ConnectionException -> IO ()
forall a. ConnectionException -> IO a
suppressMessages)
    (ServerOptions
-> Eff '[Hyperbole, Concurrent, IOE] Response -> Application
waiApp ServerOptions
opts Eff '[Hyperbole, Concurrent, IOE] Response
app)
    Request
req


waiApp :: ServerOptions -> Eff '[Hyperbole, Concurrent, IOE] Response -> Wai.Application
waiApp :: ServerOptions
-> Eff '[Hyperbole, Concurrent, IOE] Response -> Application
waiApp ServerOptions
opts Eff '[Hyperbole, Concurrent, IOE] Response
actions Request
req Response -> IO ResponseReceived
res = do
  Eff '[IOE] ResponseReceived -> IO ResponseReceived
forall a. HasCallStack => Eff '[IOE] a -> IO a
runEff (Eff '[IOE] ResponseReceived -> IO ResponseReceived)
-> Eff '[IOE] ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Eff '[Concurrent, IOE] ResponseReceived
-> Eff '[IOE] ResponseReceived
forall (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, IOE :> es) =>
Eff (Concurrent : es) a -> Eff es a
runConcurrent (Eff '[Concurrent, IOE] ResponseReceived
 -> Eff '[IOE] ResponseReceived)
-> Eff '[Concurrent, IOE] ResponseReceived
-> Eff '[IOE] ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerOptions
-> Request
-> (Response -> IO ResponseReceived)
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> Eff '[Concurrent, IOE] ResponseReceived
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
ServerOptions
-> Request
-> (Response -> IO ResponseReceived)
-> Eff (Hyperbole : es) Response
-> Eff es ResponseReceived
handleRequestWai ServerOptions
opts Request
req Response -> IO ResponseReceived
res Eff '[Hyperbole, Concurrent, IOE] Response
actions


socketApp :: ServerOptions -> Wai.Request -> Eff '[Hyperbole, Concurrent, IOE] Response -> PendingConnection -> IO ()
socketApp :: ServerOptions
-> Request
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> ServerApp
socketApp ServerOptions
opts Request
req Eff '[Hyperbole, Concurrent, IOE] Response
actions PendingConnection
pend = do
  Connection
conn <- IO Connection -> IO Connection
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> IO Connection) -> IO Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pend
  -- ping to keep the socket alive
  Connection -> Int -> IO () -> IO () -> IO ()
forall a. Connection -> Int -> IO () -> IO a -> IO a
withPingThread Connection
conn Int
25 (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Eff '[IOE] () -> IO ()
forall a. HasCallStack => Eff '[IOE] a -> IO a
runEff (Eff '[IOE] () -> IO ()) -> Eff '[IOE] () -> IO ()
forall a b. (a -> b) -> a -> b
$ Eff '[Concurrent, IOE] () -> Eff '[IOE] ()
forall (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, IOE :> es) =>
Eff (Concurrent : es) a -> Eff es a
runConcurrent (Eff '[Concurrent, IOE] () -> Eff '[IOE] ())
-> Eff '[Concurrent, IOE] () -> Eff '[IOE] ()
forall a b. (a -> b) -> a -> b
$ ServerOptions
-> Request
-> Connection
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> Eff '[Concurrent, IOE] ()
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Concurrent :> es) =>
ServerOptions
-> Request
-> Connection
-> Eff (Hyperbole : es) Response
-> Eff es ()
handleRequestSocket ServerOptions
opts Request
req Connection
conn Eff '[Hyperbole, Concurrent, IOE] Response
actions


suppressMessages :: ConnectionException -> IO a
suppressMessages :: forall a. ConnectionException -> IO a
suppressMessages ConnectionException
ex = do
  -- The default version of Network.Websockets prints out CloseRequest and ConnectionClosed errors
  -- it's like they're using these as events instead of exceptions
  case ConnectionException
ex of
    ConnectionException
ConnectionClosed -> do
      -- putStrLn "CAUGHT ConnectionClosed"
      a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. HasCallStack => a
undefined
    CloseRequest Word16
_cd ByteString
_msg -> do
      -- putStrLn "CAUGHT CloseRequest"
      a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. HasCallStack => a
undefined
    ConnectionException
other -> ConnectionException -> IO a
forall e a. Exception e => e -> IO a
throwIO ConnectionException
other


{- | Route URL patterns to different pages


@
import Example.Docs.'Page'.Messages qualified as Messages
import Example.Docs.'Page'.Users qualified as Users

type UserId = Int

data AppRoute
  = Main
  | Messages
  | User UserId
  deriving (Eq, Generic)

instance 'Route' AppRoute where
  baseRoute = Just Main

router :: ('Hyperbole' :> es) => AppRoute -> 'Eff' es 'Response'
router Messages = 'runPage' Messages.page
router (User cid) = 'runPage' $ Users.page cid
router Main = do
  pure $ view $ do
    'el' \"click a link below to visit a page\"
    'route' Messages \"Messages\"
    'route' (User 1) \"User 1\"
    'route' (User 2) \"User 2\"
@
-}
routeRequest :: (Hyperbole :> es, Route route) => (route -> Eff es Response) -> Eff es Response
routeRequest :: forall (es :: [(* -> *) -> * -> *]) route.
(Hyperbole :> es, Route route) =>
(route -> Eff es Response) -> Eff es Response
routeRequest route -> Eff es Response
actions = do
  Path
pth <- Eff es Path
forall (es :: [(* -> *) -> * -> *]).
(Hyperbole :> es) =>
Eff es Path
reqPath
  Eff es Response
-> (route -> Eff es Response) -> Maybe route -> Eff es Response
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Eff es Response
forall (es :: [(* -> *) -> * -> *]) a.
(Hyperbole :> es) =>
Eff es a
notFound route -> Eff es Response
actions (Maybe route -> Eff es Response) -> Maybe route -> Eff es Response
forall a b. (a -> b) -> a -> b
$ Path -> Maybe route
forall a. Route a => Path -> Maybe a
matchRoute Path
pth