module Web.Hyperbole.Application
  ( waiApplication
  -- , webSocketApplication
  , application
  , websocketsOr
  ) where

import Control.Monad (forever)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as L
import Data.String.Conversions (cs)
import Data.Text (Text, pack)
import Data.Text qualified as T
import Effectful
import Effectful.Error.Static
import Effectful.Reader.Static
import Network.HTTP.Types (Method, Query, parseQuery, status200, status400, status404)
import Network.HTTP.Types.Header (HeaderName)
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.Hyperbole.Effect
import Web.Hyperbole.Route
import Web.View (View, renderLazyByteString)


{- | Start both a websockets and a WAI server. Wai app serves initial pages, and attempt to process actions via sockets
  If the socket connection is unavailable, will fall back to the WAI app to process actions
-}
application :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff '[Hyperbole, IOE] ()) -> Wai.Application
application :: forall route.
Route route =>
(ByteString -> ByteString)
-> (route -> Eff '[Hyperbole, IOE] ()) -> Application
application ByteString -> ByteString
toDoc route -> Eff '[Hyperbole, IOE] ()
actions =
  ConnectionOptions -> ServerApp -> Application -> Application
websocketsOr
    ConnectionOptions
defaultConnectionOptions
    ((route -> Eff '[Hyperbole, IOE] ()) -> ServerApp
forall route.
Route route =>
(route -> Eff '[Hyperbole, IOE] ()) -> ServerApp
socketApplication route -> Eff '[Hyperbole, IOE] ()
actions)
    ((ByteString -> ByteString)
-> (route -> Eff '[Hyperbole, IOE] ()) -> Application
forall route.
Route route =>
(ByteString -> ByteString)
-> (route -> Eff '[Hyperbole, IOE] ()) -> Application
waiApplication ByteString -> ByteString
toDoc route -> Eff '[Hyperbole, IOE] ()
actions)


waiApplication :: (Route route) => (L.ByteString -> L.ByteString) -> (route -> Eff '[Hyperbole, IOE] ()) -> Wai.Application
waiApplication :: forall route.
Route route =>
(ByteString -> ByteString)
-> (route -> Eff '[Hyperbole, IOE] ()) -> Application
waiApplication ByteString -> ByteString
toDoc route -> Eff '[Hyperbole, IOE] ()
actions Request
request Response -> IO ResponseReceived
respond = do
  Request
req <- Request -> IO Request
forall {m :: * -> *}. MonadIO m => Request -> m Request
fromWaiRequest Request
request
  Response
res <- Eff '[IOE] Response -> IO Response
forall a. Eff '[IOE] a -> IO a
runEff (Eff '[IOE] Response -> IO Response)
-> Eff '[IOE] Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Request
-> (route -> Eff '[Hyperbole, IOE] ()) -> Eff '[IOE] Response
forall route (es :: [(* -> *) -> * -> *]).
Route route =>
Request -> (route -> Eff (Hyperbole : es) ()) -> Eff es Response
runHyperboleRoute Request
req route -> Eff '[Hyperbole, IOE] ()
actions
  Response -> IO ResponseReceived
sendResponse Response
res
 where
  fromWaiRequest :: Request -> m Request
fromWaiRequest Request
wr = do
    ByteString
bd <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.consumeRequestBodyLazy Request
wr
    Request -> m Request
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ [Text] -> Query -> ByteString -> Request
Request (Request -> [Text]
Wai.pathInfo Request
wr) (Request -> Query
Wai.queryString Request
wr) ByteString
bd

  -- TODO: logging?
  sendResponse :: Response -> IO Wai.ResponseReceived
  sendResponse :: Response -> IO ResponseReceived
sendResponse (ErrParse Text
e) = ByteString -> IO ResponseReceived
respBadRequest (ByteString
"Parse Error: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
e)
  sendResponse Response
ErrNoHandler = ByteString -> IO ResponseReceived
respBadRequest ByteString
"No Handler Found"
  sendResponse Response
NotFound = IO ResponseReceived
respNotFound
  sendResponse (Response View () ()
vw) = do
    let body :: ByteString
body = Method -> ByteString -> ByteString
addDocument (Request -> Method
Wai.requestMethod Request
request) (View () () -> ByteString
renderLazyByteString View () ()
vw)
    ByteString -> IO ResponseReceived
respHtml ByteString
body

  respBadRequest :: ByteString -> IO ResponseReceived
respBadRequest ByteString
e =
    Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status400 [ContentType -> (HeaderName, Method)
contentType ContentType
ContentText] ByteString
e

  respNotFound :: IO ResponseReceived
respNotFound =
    Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status404 [ContentType -> (HeaderName, Method)
contentType ContentType
ContentText] ByteString
"Not Found"

  respHtml :: ByteString -> IO ResponseReceived
respHtml ByteString
body = do
    let headers :: ResponseHeaders
headers = [ContentType -> (HeaderName, Method)
contentType ContentType
ContentHtml]
    Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status200 ResponseHeaders
headers ByteString
body

  -- convert to document if GET. Subsequent POST requests will only include fragments
  addDocument :: Method -> L.ByteString -> L.ByteString
  addDocument :: Method -> ByteString -> ByteString
addDocument Method
"GET" ByteString
bd = ByteString -> ByteString
toDoc ByteString
bd
  addDocument Method
_ ByteString
bd = ByteString
bd


data ContentType
  = ContentHtml
  | ContentText


contentType :: ContentType -> (HeaderName, ByteString)
contentType :: ContentType -> (HeaderName, Method)
contentType ContentType
ContentHtml = (HeaderName
"Content-Type", Method
"text/html; charset=utf-8")
contentType ContentType
ContentText = (HeaderName
"Content-Type", Method
"text/plain; charset=utf-8")


socketApplication :: (Route route) => (route -> Eff '[Hyperbole, IOE] ()) -> PendingConnection -> IO ()
socketApplication :: forall route.
Route route =>
(route -> Eff '[Hyperbole, IOE] ()) -> ServerApp
socketApplication route -> Eff '[Hyperbole, IOE] ()
actions PendingConnection
pending = do
  Connection
conn <- PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pending
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> IO ()
talk Connection
conn
 where
  talk :: Connection -> IO ()
  talk :: Connection -> IO ()
talk Connection
conn = do
    Either SocketError Response
res <- Eff '[Error SocketError, Reader Connection, IOE] Response
-> IO (Either SocketError Response)
runSocket (Eff '[Error SocketError, Reader Connection, IOE] Response
 -> IO (Either SocketError Response))
-> Eff '[Error SocketError, Reader Connection, IOE] Response
-> IO (Either SocketError Response)
forall a b. (a -> b) -> a -> b
$ do
      Request
req <- Eff '[Error SocketError, Reader Connection, IOE] Request
forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Reader Connection :> es, Error SocketError :> es) =>
Eff es Request
request
      IO () -> Eff '[Error SocketError, Reader Connection, IOE] ()
forall a.
IO a -> Eff '[Error SocketError, Reader Connection, IOE] a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff '[Error SocketError, Reader Connection, IOE] ())
-> IO () -> Eff '[Error SocketError, Reader Connection, IOE] ()
forall a b. (a -> b) -> a -> b
$ ([Text], Query, ByteString) -> IO ()
forall a. Show a => a -> IO ()
print (Request
req.path, Request
req.query, Request
req.body)
      IO Response
-> Eff '[Error SocketError, Reader Connection, IOE] Response
forall a.
IO a -> Eff '[Error SocketError, Reader Connection, IOE] a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response
 -> Eff '[Error SocketError, Reader Connection, IOE] Response)
-> IO Response
-> Eff '[Error SocketError, Reader Connection, IOE] Response
forall a b. (a -> b) -> a -> b
$ Eff '[IOE] Response -> IO Response
forall a. Eff '[IOE] a -> IO a
runEff (Eff '[IOE] Response -> IO Response)
-> Eff '[IOE] Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Request
-> (route -> Eff '[Hyperbole, IOE] ()) -> Eff '[IOE] Response
forall route (es :: [(* -> *) -> * -> *]).
Route route =>
Request -> (route -> Eff (Hyperbole : es) ()) -> Eff es Response
runHyperboleRoute Request
req route -> Eff '[Hyperbole, IOE] ()
actions

    case Either SocketError Response
res of
      Right (Response View () ()
vw) -> View () () -> IO ()
sendView View () ()
vw
      Right (ErrParse Text
t) -> Text -> IO ()
forall a. Show a => a -> IO ()
sendError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"ErrParse " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
      Right Response
ErrNoHandler -> forall a. Show a => a -> IO ()
sendError @Text Text
"ErrNoHandler"
      Right Response
NotFound -> forall a. Show a => a -> IO ()
sendError @Text Text
"NotFound"
      Left SocketError
err -> SocketError -> IO ()
forall a. Show a => a -> IO ()
sendError SocketError
err
   where
    runSocket :: Eff '[Error SocketError, Reader Connection, IOE] Response -> IO (Either SocketError Response)
    runSocket :: Eff '[Error SocketError, Reader Connection, IOE] Response
-> IO (Either SocketError Response)
runSocket = Eff '[IOE] (Either SocketError Response)
-> IO (Either SocketError Response)
forall a. Eff '[IOE] a -> IO a
runEff (Eff '[IOE] (Either SocketError Response)
 -> IO (Either SocketError Response))
-> (Eff '[Error SocketError, Reader Connection, IOE] Response
    -> Eff '[IOE] (Either SocketError Response))
-> Eff '[Error SocketError, Reader Connection, IOE] Response
-> IO (Either SocketError Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> Eff '[Reader Connection, IOE] (Either SocketError Response)
-> Eff '[IOE] (Either SocketError Response)
forall r (es :: [(* -> *) -> * -> *]) a.
r -> Eff (Reader r : es) a -> Eff es a
runReader Connection
conn (Eff '[Reader Connection, IOE] (Either SocketError Response)
 -> Eff '[IOE] (Either SocketError Response))
-> (Eff '[Error SocketError, Reader Connection, IOE] Response
    -> Eff '[Reader Connection, IOE] (Either SocketError Response))
-> Eff '[Error SocketError, Reader Connection, IOE] Response
-> Eff '[IOE] (Either SocketError Response)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es :: [(* -> *) -> * -> *]) a.
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @SocketError

    request :: (IOE :> es, Reader Connection :> es, Error SocketError :> es) => Eff es Request
    request :: forall (es :: [(* -> *) -> * -> *]).
(IOE :> es, Reader Connection :> es, Error SocketError :> es) =>
Eff es Request
request = do
      Text
t <- Eff es Text
forall (es :: [(* -> *) -> * -> *]).
(Reader Connection :> es, IOE :> es) =>
Eff es Text
receive
      case Text -> Either SocketError Request
parseMessage Text
t of
        Left SocketError
e -> SocketError -> Eff es Request
forall e (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Error e :> es) =>
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

    receive :: (Reader Connection :> es, IOE :> es) => Eff es Text
    receive :: forall (es :: [(* -> *) -> * -> *]).
(Reader Connection :> es, IOE :> es) =>
Eff es Text
receive = do
      Connection
c <- forall r (es :: [(* -> *) -> * -> *]). (Reader r :> es) => Eff es r
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
c

    parseMessage :: Text -> Either SocketError Request
    parseMessage :: Text -> Either SocketError Request
parseMessage Text
t = do
      ([Text]
path, Query
query, Text
body) <- Text -> Either SocketError ([Text], Query, Text)
messageParts Text
t
      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
$ [Text] -> Query -> ByteString -> Request
Request [Text]
path Query
query (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
body)

    messageParts :: Text -> Either SocketError ([Text], Query, Text)
    messageParts :: Text -> Either SocketError ([Text], Query, Text)
messageParts Text
t = do
      case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\n" Text
t of
        [Text
url, Text
q, Text
body] -> ([Text], Query, Text) -> Either SocketError ([Text], Query, Text)
forall a. a -> Either SocketError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]
paths Text
url, Text -> Query
forall {a}. ConvertibleStrings a Method => a -> Query
query Text
q, Text
body)
        [Text
url, Text
q] -> ([Text], Query, Text) -> Either SocketError ([Text], Query, Text)
forall a. a -> Either SocketError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]
paths Text
url, Text -> Query
forall {a}. ConvertibleStrings a Method => a -> Query
query Text
q, Text
"")
        [Text]
_ -> SocketError -> Either SocketError ([Text], Query, Text)
forall a b. a -> Either a b
Left (SocketError -> Either SocketError ([Text], Query, Text))
-> SocketError -> Either SocketError ([Text], Query, Text)
forall a b. (a -> b) -> a -> b
$ Text -> SocketError
InvalidMessage Text
t
     where
      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
      query :: a -> Query
query a
q = Method -> Query
parseQuery (a -> Method
forall a b. ConvertibleStrings a b => a -> b
cs a
q)

    sendView :: View () () -> IO ()
    sendView :: View () () -> IO ()
sendView View () ()
vw = Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ View () () -> ByteString
renderLazyByteString View () ()
vw

    sendError :: (Show e) => e -> IO ()
    sendError :: forall a. Show a => a -> IO ()
sendError e
e = Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (e -> String
forall a. Show a => a -> String
show e
e)


data SocketError
  = InvalidMessage Text
  deriving (Int -> SocketError -> ShowS
[SocketError] -> ShowS
SocketError -> String
(Int -> SocketError -> ShowS)
-> (SocketError -> String)
-> ([SocketError] -> ShowS)
-> Show SocketError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketError -> ShowS
showsPrec :: Int -> SocketError -> ShowS
$cshow :: SocketError -> String
show :: SocketError -> String
$cshowList :: [SocketError] -> ShowS
showList :: [SocketError] -> ShowS
Show, SocketError -> SocketError -> Bool
(SocketError -> SocketError -> Bool)
-> (SocketError -> SocketError -> Bool) -> Eq SocketError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketError -> SocketError -> Bool
== :: SocketError -> SocketError -> Bool
$c/= :: SocketError -> SocketError -> Bool
/= :: SocketError -> SocketError -> Bool
Eq)