{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}

module Web.Hyperbole.Application
  ( waiApp
  , websocketsOr
  , defaultConnectionOptions
  , liveApp
  , socketApp
  , basicDocument
  , routeRequest
  ) where

import Control.Monad (forever)
import Data.ByteString.Lazy qualified as BL
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import Data.String.Interpolate (i)
import Data.Text (Text)
import Data.Text qualified as T
import Effectful
import Effectful.Concurrent.Async
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Network.HTTP.Types (parseQueryText)
import Network.Wai qualified as Wai
import Network.Wai.Handler.WebSockets (websocketsOr)
import Network.WebSockets (Connection, PendingConnection, defaultConnectionOptions)
import Network.WebSockets qualified as WS
import Web.Cookie (parseCookies)
import Web.Hyperbole.Effect.Hyperbole
import Web.Hyperbole.Effect.Request (reqPath)
import Web.Hyperbole.Effect.Server (Host (..), Request (..), Response (..), Server, SocketError (..), runServerSockets, runServerWai)
import Web.Hyperbole.Route
import Web.Hyperbole.View.Embed (cssResetEmbed, scriptEmbed)


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

> main = do
>   run 3000 $ do
>     liveApp (basicDocument "Example") (runPage messagePage)
-}
liveApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, Concurrent, IOE] Response -> Wai.Application
liveApp :: (ByteString -> ByteString)
-> Eff '[Hyperbole, Server, Concurrent, IOE] Response
-> Application
liveApp ByteString -> ByteString
toDoc Eff '[Hyperbole, Server, Concurrent, IOE] Response
app =
  ConnectionOptions -> ServerApp -> Application -> Application
websocketsOr
    ConnectionOptions
defaultConnectionOptions
    (Eff '[IOE] () -> IO ()
forall a. HasCallStack => Eff '[IOE] a -> IO a
runEff (Eff '[IOE] () -> IO ())
-> (PendingConnection -> Eff '[IOE] ()) -> ServerApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[Concurrent, IOE] () -> Eff '[IOE] ()
forall (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, IOE :> es) =>
Eff (Concurrent : es) a -> Eff es a
runConcurrent (Eff '[Concurrent, IOE] () -> Eff '[IOE] ())
-> (PendingConnection -> Eff '[Concurrent, IOE] ())
-> PendingConnection
-> Eff '[IOE] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[Hyperbole, Server, Concurrent, IOE] Response
-> PendingConnection -> Eff '[Concurrent, IOE] ()
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Concurrent :> es) =>
Eff (Hyperbole : Server : es) Response
-> PendingConnection -> Eff es ()
socketApp Eff '[Hyperbole, Server, Concurrent, IOE] Response
app)
    ((ByteString -> ByteString)
-> Eff '[Hyperbole, Server, Concurrent, IOE] Response
-> Application
waiApp ByteString -> ByteString
toDoc Eff '[Hyperbole, Server, Concurrent, IOE] Response
app)


waiApp :: (BL.ByteString -> BL.ByteString) -> Eff '[Hyperbole, Server, Concurrent, IOE] Response -> Wai.Application
waiApp :: (ByteString -> ByteString)
-> Eff '[Hyperbole, Server, Concurrent, IOE] Response
-> Application
waiApp ByteString -> ByteString
toDoc Eff '[Hyperbole, Server, Concurrent, IOE] Response
actions Request
req Response -> IO ResponseReceived
res = do
  Maybe ResponseReceived
rr <- Eff '[IOE] (Maybe ResponseReceived) -> IO (Maybe ResponseReceived)
forall a. HasCallStack => Eff '[IOE] a -> IO a
runEff (Eff '[IOE] (Maybe ResponseReceived)
 -> IO (Maybe ResponseReceived))
-> Eff '[IOE] (Maybe ResponseReceived)
-> IO (Maybe ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Eff '[Concurrent, IOE] (Maybe ResponseReceived)
-> Eff '[IOE] (Maybe ResponseReceived)
forall (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, IOE :> es) =>
Eff (Concurrent : es) a -> Eff es a
runConcurrent (Eff '[Concurrent, IOE] (Maybe ResponseReceived)
 -> Eff '[IOE] (Maybe ResponseReceived))
-> Eff '[Concurrent, IOE] (Maybe ResponseReceived)
-> Eff '[IOE] (Maybe ResponseReceived)
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString)
-> Request
-> (Response -> IO ResponseReceived)
-> Eff '[Server, Concurrent, IOE] Response
-> Eff '[Concurrent, IOE] (Maybe ResponseReceived)
forall (es :: [(* -> *) -> * -> *]) a.
(IOE :> es) =>
(ByteString -> ByteString)
-> Request
-> (Response -> IO ResponseReceived)
-> Eff (Server : es) a
-> Eff es (Maybe ResponseReceived)
runServerWai ByteString -> ByteString
toDoc Request
req Response -> IO ResponseReceived
res (Eff '[Server, Concurrent, IOE] Response
 -> Eff '[Concurrent, IOE] (Maybe ResponseReceived))
-> Eff '[Server, Concurrent, IOE] Response
-> Eff '[Concurrent, IOE] (Maybe ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Eff '[Hyperbole, Server, Concurrent, IOE] Response
-> Eff '[Server, Concurrent, IOE] Response
forall (es :: [(* -> *) -> * -> *]).
(Server :> es) =>
Eff (Hyperbole : es) Response -> Eff es Response
runHyperbole Eff '[Hyperbole, Server, Concurrent, IOE] Response
actions
  case Maybe ResponseReceived
rr of
    Maybe ResponseReceived
Nothing -> [Char] -> IO ResponseReceived
forall a. HasCallStack => [Char] -> a
error [Char]
"Missing required response in handler"
    Just ResponseReceived
r -> ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
r


socketApp :: (IOE :> es, Concurrent :> es) => Eff (Hyperbole : Server : es) Response -> PendingConnection -> Eff es ()
socketApp :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Concurrent :> es) =>
Eff (Hyperbole : Server : es) Response
-> PendingConnection -> Eff es ()
socketApp Eff (Hyperbole : Server : es) Response
actions PendingConnection
pend = do
  Connection
conn <- IO Connection -> Eff es Connection
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> Eff es Connection)
-> IO Connection -> Eff es Connection
forall a b. (a -> b) -> a -> b
$ PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pend
  Eff es () -> Eff es ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Eff es () -> Eff es ()) -> Eff es () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ do
    Either SocketError Request
ereq <- forall e (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @SocketError (Eff (Error SocketError : es) Request
 -> Eff es (Either SocketError Request))
-> Eff (Error SocketError : es) Request
-> Eff es (Either SocketError Request)
forall a b. (a -> b) -> a -> b
$ Connection -> Eff (Error SocketError : es) Request
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Error SocketError :> es) =>
Connection -> Eff es Request
receiveRequest Connection
conn
    case Either SocketError Request
ereq of
      Left SocketError
e -> IO () -> Eff es ()
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff es ()) -> IO () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"SOCKET ERROR " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SocketError -> [Char]
forall a. Show a => a -> [Char]
show SocketError
e
      Right Request
r -> do
        Async Response
a <- Eff es Response -> Eff es (Async Response)
forall (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Concurrent :> es) =>
Eff es a -> Eff es (Async a)
async (Connection
-> Request -> Eff (Server : es) Response -> Eff es Response
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
Connection
-> Request -> Eff (Server : es) Response -> Eff es Response
runServerSockets Connection
conn Request
r (Eff (Server : es) Response -> Eff es Response)
-> Eff (Server : es) Response -> Eff es Response
forall a b. (a -> b) -> a -> b
$ Eff (Hyperbole : Server : es) Response
-> Eff (Server : es) Response
forall (es :: [(* -> *) -> * -> *]).
(Server :> es) =>
Eff (Hyperbole : es) Response -> Eff es Response
runHyperbole Eff (Hyperbole : Server : es) Response
actions)
        -- throw exceptions in this thread
        Async Response -> Eff es ()
forall (es :: [(* -> *) -> * -> *]) a.
(Concurrent :> es) =>
Async a -> Eff es ()
link Async Response
a
        () -> Eff es ()
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  receiveRequest :: (IOE :> es, Error SocketError :> es) => Connection -> Eff es Request
  receiveRequest :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Error SocketError :> es) =>
Connection -> Eff es Request
receiveRequest Connection
conn = do
    Text
t <- Connection -> Eff es Text
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
Connection -> Eff es Text
receiveText Connection
conn
    case Text -> Either SocketError Request
parseMessage Text
t of
      Left SocketError
e -> SocketError -> Eff es Request
forall e (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError SocketError
e
      Right Request
r -> Request -> Eff es Request
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
r

  receiveText :: (IOE :> es) => Connection -> Eff es Text
  receiveText :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es) =>
Connection -> Eff es Text
receiveText Connection
conn = do
    -- c <- ask @Connection
    IO Text -> Eff es Text
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Eff es Text) -> IO Text -> Eff es Text
forall a b. (a -> b) -> a -> b
$ Connection -> IO Text
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
conn

  parseMessage :: Text -> Either SocketError Request
  parseMessage :: Text -> Either SocketError Request
parseMessage Text
t = do
    case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\n" Text
t of
      [Text
url, Text
host, Text
cook, Text
body] -> Text -> Text -> Text -> Maybe Text -> Either SocketError Request
parse Text
url Text
cook Text
host (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
body)
      [Text
url, Text
host, Text
cook] -> Text -> Text -> Text -> Maybe Text -> Either SocketError Request
parse Text
url Text
cook Text
host Maybe Text
forall a. Maybe a
Nothing
      [Text]
_ -> SocketError -> Either SocketError Request
forall a b. a -> Either a b
Left (SocketError -> Either SocketError Request)
-> SocketError -> Either SocketError Request
forall a b. (a -> b) -> a -> b
$ Text -> SocketError
InvalidMessage Text
t
   where
    parseUrl :: Text -> Either SocketError (Text, Text)
    parseUrl :: Text -> Either SocketError (Text, Text)
parseUrl Text
u =
      case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"?" Text
u of
        [Text
url, Text
query] -> (Text, Text) -> Either SocketError (Text, Text)
forall a. a -> Either SocketError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
url, Text
query)
        [Text]
_ -> SocketError -> Either SocketError (Text, Text)
forall a b. a -> Either a b
Left (SocketError -> Either SocketError (Text, Text))
-> SocketError -> Either SocketError (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> SocketError
InvalidMessage Text
u

    parse :: Text -> Text -> Text -> Maybe Text -> Either SocketError Request
    parse :: Text -> Text -> Text -> Maybe Text -> Either SocketError Request
parse Text
url Text
cook Text
hst Maybe Text
mbody = do
      (Text
u, Text
q) <- Text -> Either SocketError (Text, Text)
parseUrl Text
url
      let path :: [Text]
path = Text -> [Text]
paths Text
u
          query :: QueryText
query = ByteString -> QueryText
parseQueryText (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
q)
          cookies :: Cookies
cookies = ByteString -> Cookies
parseCookies (ByteString -> Cookies) -> ByteString -> Cookies
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
header Text
cook
          host :: Host
host = ByteString -> Host
Host (ByteString -> Host) -> ByteString -> Host
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
header Text
hst
          method :: ByteString
method = ByteString
"POST"
          body :: ByteString
body = Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mbody
      Request -> Either SocketError Request
forall a. a -> Either SocketError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> Either SocketError Request)
-> Request -> Either SocketError Request
forall a b. (a -> b) -> a -> b
$ Request{[Text]
path :: [Text]
path :: [Text]
path, Host
host :: Host
host :: Host
host, QueryText
query :: QueryText
query :: QueryText
query, ByteString
body :: ByteString
body :: ByteString
body, ByteString
method :: ByteString
method :: ByteString
method, Cookies
cookies :: Cookies
cookies :: Cookies
cookies}

    paths :: Text -> [Text]
paths Text
p = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
p

    -- drop up to the colon, then ': '
    header :: Text -> Text
header = Int -> Text -> Text
T.drop Int
2 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')


{- | wrap HTML fragments in a simple document with a custom title and include required embeds

@
'liveApp' (basicDocument "App Title") ('routeRequest' router)
@

You may want to specify a custom document function instead:

> myDocument :: ByteString -> ByteString
> myDocument content =
>   [i|<html>
>     <head>
>       <title>#{title}</title>
>       <script type="text/javascript">#{scriptEmbed}</script>
>       <style type="text/css">#{cssResetEmbed}</style>
>     </head>
>     <body>#{content}</body>
>   </html>|]
-}
basicDocument :: Text -> BL.ByteString -> BL.ByteString
basicDocument :: Text -> ByteString -> ByteString
basicDocument Text
title ByteString
cnt =
  [i|<html>
      <head>
        <title>#{title}</title>
        <script type="text/javascript">#{scriptEmbed}</script>
        <style type="text/css">#{cssResetEmbed}</style>
      </head>
      <body>#{cnt}</body>
  </html>|]


{- | Route URL patterns to different pages


@
import Page.Messages qualified as Messages
import Page.Users qualified as Users

data AppRoute
  = Main
  | Messages
  | Users UserId
  deriving (Eq, Generic, 'Route')

router :: ('Hyperbole' :> es) => AppRoute -> 'Eff' es 'Response'
router Messages = 'page' Messages.page
router (Users uid) = 'page' $ Users.page uid
router Main = do
  'view' $ do
    'el_' "click a link below to visit a page"
    'route' Messages id \"Messages\"

main = do
  'run' 3000 $ do
    'liveApp' ('basicDocument' \"Example\") (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
  [Text]
path <- Eff es [Text]
forall (es :: [(* -> *) -> * -> *]).
(Hyperbole :> es) =>
Eff es [Text]
reqPath
  case [Text] -> Maybe route
forall a. Route a => [Text] -> Maybe a
findRoute [Text]
path of
    Maybe route
Nothing -> Hyperbole (Eff es) Response -> Eff es Response
forall (e :: (* -> *) -> * -> *) (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Hyperbole (Eff es) Response -> Eff es Response)
-> Hyperbole (Eff es) Response -> Eff es Response
forall a b. (a -> b) -> a -> b
$ Response -> Hyperbole (Eff es) Response
forall (a :: * -> *) b. Response -> Hyperbole a b
RespondEarly Response
NotFound
    Just route
rt -> route -> Eff es Response
actions route
rt