module Web.Hyperbole.Application
  ( waiApp
  , websocketsOr
  , defaultConnectionOptions
  , liveApp
  , liveAppWith
  , ServerOptions (..)
  , defaultErrorMessage
  , defaultParseRequestBodyOptions
  , 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 Effectful.Concurrent.STM (TVar)
import GHC.Conc (newTVarIO)
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.Response (notFound)
import Web.Hyperbole.Route
import Web.Hyperbole.Server.Options
import Web.Hyperbole.Server.Socket (RunningActions, handleRequestSocket)
import Web.Hyperbole.Server.Wai (handleRequestWai)
import Web.Hyperbole.Types.Request
import Web.Hyperbole.Types.Response


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

> #EMBED Example.Docs.BasicPage main
-}

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

> main :: IO ()
> main = do
>   run 3000 $ 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
      { toDocument :: ByteString -> ByteString
toDocument = ByteString -> ByteString
doc
      , serverError :: ResponseError -> ServerError
serverError = ResponseError -> ServerError
defaultError
      , parseRequestBody :: ParseRequestBodyOptions
parseRequestBody = ParseRequestBodyOptions
defaultParseRequestBodyOptions
      }


-- | 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
eff Request
req = do
  ConnectionOptions -> ServerApp -> Application -> Application
websocketsOr
    ConnectionOptions
defaultConnectionOptions
    (\PendingConnection
pend -> ServerOptions
-> Request
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> ServerApp
forall (m :: * -> *).
MonadIO m =>
ServerOptions
-> Request
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> PendingConnection
-> m ()
socketApp ServerOptions
opts Request
req Eff '[Hyperbole, Concurrent, IOE] Response
eff 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
eff)
    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
eff 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
eff


socketApp :: (MonadIO m) => ServerOptions -> Wai.Request -> Eff '[Hyperbole, Concurrent, IOE] Response -> PendingConnection -> m ()
socketApp :: forall (m :: * -> *).
MonadIO m =>
ServerOptions
-> Request
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> PendingConnection
-> m ()
socketApp ServerOptions
opts Request
req Eff '[Hyperbole, Concurrent, IOE] Response
eff PendingConnection
pend = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  -- private TVar for each client
  actions :: TVar RunningActions <- IO (TVar RunningActions) -> IO (TVar RunningActions)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar RunningActions) -> IO (TVar RunningActions))
-> IO (TVar RunningActions) -> IO (TVar RunningActions)
forall a b. (a -> b) -> a -> b
$ RunningActions -> IO (TVar RunningActions)
forall a. a -> IO (TVar a)
newTVarIO RunningActions
forall a. Monoid a => a
mempty
  conn <- WS.acceptRequest pend
  withPingThread conn 25 (pure ()) $ do
    forever $ do
      runEff $ runConcurrent $ handleRequestSocket opts actions req conn eff


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. (HasCallStack, Exception e) => e -> IO a
throwIO ConnectionException
other


{- ! Route URL patterns to different pages

@
#EMBED Example.Docs.App type UserId

#EMBED Example.Docs.App data AppRoute

#EMBED Example.Docs.App instance Route

#EMBED Example.Docs.App router

#EMBED Example.Docs.App app
@
-}

{- | Route URL patterns to different pages

@
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\"

app :: Application
app = 'liveApp' (document documentHead) ('routeRequest' router)
@
-}
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
  r <- Eff es Request
forall (es :: [(* -> *) -> * -> *]).
(Hyperbole :> es) =>
Eff es Request
request
  maybe notFound actions $ matchRoute r.path