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 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.Request (reqPath)
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.Response


{- | 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 hello)
-}
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
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
  TVar RunningActions
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
  Connection
conn <- PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pend
  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
-> TVar RunningActions
-> Request
-> Connection
-> Eff '[Hyperbole, Concurrent, IOE] Response
-> Eff '[Concurrent, IOE] ()
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Concurrent :> es) =>
ServerOptions
-> TVar RunningActions
-> Request
-> Connection
-> Eff (Hyperbole : es) Response
-> Eff es ()
handleRequestSocket ServerOptions
opts TVar RunningActions
actions Request
req Connection
conn Eff '[Hyperbole, Concurrent, IOE] Response
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. Exception e => e -> IO a
throwIO ConnectionException
other


{- | 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
  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