{- |
Module      : Hypermedia.Datastar.WAI
Description : SSE streaming and request handling for WAI

This module connects Datastar to WAI (Web Application Interface), Haskell's
standard HTTP server interface. It provides:

* 'sseResponse' — create a streaming SSE response with a
  'ServerSentEventGenerator' callback
* 'sendPatchElements', 'sendPatchSignals', 'sendExecuteScript' — send
  Datastar events through the open connection
* 'readSignals' — decode signals sent by the browser (from query params on
  GET, or from the request body on POST)
* 'isDatastarRequest' — distinguish Datastar SSE requests from normal
  page loads

=== Streaming architecture

'sseResponse' uses WAI's @responseStream@ to hold the HTTP connection open.
You receive a 'ServerSentEventGenerator' and call @send*@ functions as many
times as needed. The connection stays open until your callback returns (or
the client disconnects).

=== Thread safety

The 'ServerSentEventGenerator' uses an internal 'Control.Concurrent.MVar.MVar'
lock, so it is safe to call @send*@ functions from multiple threads
concurrently.

=== How signals flow from browser to server

When the browser makes a Datastar request, signals are sent as JSON:

* __GET requests__: signals are URL-encoded in the @datastar@ query parameter
* __POST requests__: signals are in the request body as JSON

Use 'readSignals' with any 'Data.Aeson.FromJSON' instance to decode them.
-}
module Hypermedia.Datastar.WAI where

import Control.Concurrent.MVar
import Control.Exception

import Data.Text (Text)
import Data.Text.Encoding qualified as TE

import Data.Aeson (FromJSON)
import Data.Aeson qualified as A

import Data.ByteString.Builder qualified as BSB

import Network.HTTP.Types qualified as WAI
import Network.Wai qualified as WAI

import Hypermedia.Datastar.Types

import Hypermedia.Datastar.ExecuteScript qualified as ES
import Hypermedia.Datastar.PatchElements qualified as PE
import Hypermedia.Datastar.PatchSignals qualified as PS
import Hypermedia.Datastar.Logger qualified as Logger
import qualified Hypermedia.Datastar.Logger as Logger

{- | An opaque handle for sending SSE events to the browser.

Obtain one from the callback passed to 'sseResponse'. The handle is
thread-safe — you can send events from multiple threads concurrently.

You don't construct these directly; 'sseResponse' creates one for you.
-}
data ServerSentEventGenerator = ServerSentEventGenerator
  { ServerSentEventGenerator -> Builder -> IO ()
sseWrite :: BSB.Builder -> IO ()
  , ServerSentEventGenerator -> IO ()
sseFlush :: IO ()
  , ServerSentEventGenerator -> MVar ()
sseLock :: MVar ()
  , ServerSentEventGenerator -> DatastarLogger
sseLogger :: Logger.DatastarLogger 
  }

{- | Create a WAI 'WAI.Response' that streams SSE events.

The callback receives a 'ServerSentEventGenerator' for sending events.
The SSE connection stays open until the callback returns.

@
app :: WAI.Request -> (WAI.Response -> IO b) -> IO b
app req respond =
  respond $ sseResponse $ \\gen -> do
    sendPatchElements gen (patchElements "\<div id=\\\"msg\\\"\>Hello\<\/div\>")
@
-}
sseResponse :: Logger.DatastarLogger -> (ServerSentEventGenerator -> IO ()) -> WAI.Response
sseResponse :: DatastarLogger -> (ServerSentEventGenerator -> IO ()) -> Response
sseResponse DatastarLogger
logger ServerSentEventGenerator -> IO ()
callback =
  Status -> ResponseHeaders -> StreamingBody -> Response
WAI.responseStream
    Status
WAI.status200
    ResponseHeaders
headers
    StreamingBody
action
 where
  headers :: ResponseHeaders
headers =
    [ (HeaderName
"Cache-Control", ByteString
"no-cache")
    , (HeaderName
"Content-Type", ByteString
"text/event-stream")
    , (HeaderName
"Connection", ByteString
"keep-alive")
    ]

  action :: StreamingBody
action Builder -> IO ()
write IO ()
flush = do
    MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    ServerSentEventGenerator -> IO ()
callback (ServerSentEventGenerator -> IO ())
-> ServerSentEventGenerator -> IO ()
forall a b. (a -> b) -> a -> b
$
      ServerSentEventGenerator
        { sseWrite :: Builder -> IO ()
sseWrite = Builder -> IO ()
write
        , sseFlush :: IO ()
sseFlush = IO ()
flush
        , sseLock :: MVar ()
sseLock = MVar ()
lock
        , sseLogger :: DatastarLogger
sseLogger = DatastarLogger
logger
        }

send :: ServerSentEventGenerator -> DatastarEvent -> IO ()
send :: ServerSentEventGenerator -> DatastarEvent -> IO ()
send ServerSentEventGenerator
gen DatastarEvent
event = do
  let rendered :: Builder
rendered = DatastarEvent -> Builder
renderEvent DatastarEvent
event

  IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_
    (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (MVar () -> IO ()) -> MVar () -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerSentEventGenerator -> MVar ()
sseLock ServerSentEventGenerator
gen)
    (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (ServerSentEventGenerator -> MVar ()
sseLock ServerSentEventGenerator
gen) ())
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ServerSentEventGenerator -> Builder -> IO ()
sseWrite ServerSentEventGenerator
gen Builder
rendered
      ServerSentEventGenerator -> IO ()
sseFlush ServerSentEventGenerator
gen

-- | Send a 'PE.PatchElements' event, morphing HTML into the browser's DOM.
sendPatchElements :: ServerSentEventGenerator -> PE.PatchElements -> IO ()
sendPatchElements :: ServerSentEventGenerator -> PatchElements -> IO ()
sendPatchElements ServerSentEventGenerator
gen PatchElements
pe = ServerSentEventGenerator -> DatastarEvent -> IO ()
send ServerSentEventGenerator
gen (DatastarEvent -> IO ()) -> DatastarEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ PatchElements -> DatastarEvent
PE.toDatastarEvent PatchElements
pe

-- | Send a 'PS.PatchSignals' event, updating the browser's reactive signal store.
sendPatchSignals :: ServerSentEventGenerator -> PS.PatchSignals -> IO ()
sendPatchSignals :: ServerSentEventGenerator -> PatchSignals -> IO ()
sendPatchSignals ServerSentEventGenerator
gen PatchSignals
ps = ServerSentEventGenerator -> DatastarEvent -> IO ()
send ServerSentEventGenerator
gen (DatastarEvent -> IO ()) -> DatastarEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ PatchSignals -> DatastarEvent
PS.toDatastarEvent PatchSignals
ps

-- | Send an 'ES.ExecuteScript' event, running JavaScript in the browser.
sendExecuteScript :: ServerSentEventGenerator -> ES.ExecuteScript -> IO ()
sendExecuteScript :: ServerSentEventGenerator -> ExecuteScript -> IO ()
sendExecuteScript ServerSentEventGenerator
gen ExecuteScript
es = ServerSentEventGenerator -> DatastarEvent -> IO ()
send ServerSentEventGenerator
gen (DatastarEvent -> IO ()) -> DatastarEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ ExecuteScript -> DatastarEvent
ES.toDatastarEvent ExecuteScript
es

{- | Decode signals sent by the browser in a Datastar request.

For GET requests, signals are URL-encoded in the @datastar@ query parameter.
For POST requests (and other methods), signals are read from the request
body as JSON.

Define a Haskell data type with a 'FromJSON' instance to decode into:

@
data MySignals = MySignals { count :: Int, label :: Text }
  deriving (Generic)
  deriving anyclass (FromJSON)

handler :: WAI.Request -> IO ()
handler req = do
  Right signals <- readSignals req
  putStrLn $ \"Count is: \" <> show (count signals)
@
-}
readSignals :: (FromJSON a) => WAI.Request -> IO (Either String a)
readSignals :: forall a. FromJSON a => Request -> IO (Either String a)
readSignals Request
req
  | Request -> ByteString
WAI.requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"GET" =
      Either String a -> IO (Either String a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ Request -> Either String a
forall a. FromJSON a => Request -> Either String a
parseFromQuery Request
req
  | Bool
otherwise =
      Request -> IO (Either String a)
forall a. FromJSON a => Request -> IO (Either String a)
parseFromBody Request
req

parseFromQuery :: (FromJSON a) => WAI.Request -> Either String a
parseFromQuery :: forall a. FromJSON a => Request -> Either String a
parseFromQuery Request
req =
  case ByteString
-> [(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"datastar" (Request -> [(ByteString, Maybe ByteString)]
WAI.queryString Request
req) of
    (Just (Just ByteString
val)) ->
      ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecodeStrict (ByteString -> Either String a) -> ByteString -> Either String a
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
WAI.urlDecode Bool
True ByteString
val
    Maybe (Maybe ByteString)
_ -> String -> Either String a
forall a b. a -> Either a b
Left String
"missing 'datastar' query parameter"

parseFromBody :: (FromJSON a) => WAI.Request -> IO (Either String a)
parseFromBody :: forall a. FromJSON a => Request -> IO (Either String a)
parseFromBody Request
req = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (ByteString -> Either String a)
-> IO ByteString -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> IO ByteString
WAI.strictRequestBody Request
req

{- | Check whether a request was initiated by Datastar.

Datastar adds a @datastar-request@ header to its SSE requests. Use this to
distinguish Datastar requests from normal page loads — for example, to
serve either an SSE stream or a full HTML page from the same route.

@
app req respond
  | isDatastarRequest req =
      respond $ sseResponse $ \\gen -> ...
  | otherwise =
      respond $ responseLBS status200 [] fullPageHtml
@
-}
isDatastarRequest :: WAI.Request -> Bool
isDatastarRequest :: Request -> Bool
isDatastarRequest Request
req = ((HeaderName, ByteString) -> Bool) -> ResponseHeaders -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"datastar-request") (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (Request -> ResponseHeaders
WAI.requestHeaders Request
req)

renderEvent :: DatastarEvent -> BSB.Builder
renderEvent :: DatastarEvent -> Builder
renderEvent DatastarEvent
event =
  [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ String -> Builder
BSB.stringUtf8 String
"event: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text (EventType -> Text
eventTypeToText (DatastarEvent -> EventType
eventType DatastarEvent
event)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
    , Builder -> (Text -> Builder) -> Maybe Text -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (\Text
eid -> String -> Builder
BSB.stringUtf8 String
"id: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text Text
eid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline) (DatastarEvent -> Maybe Text
eventId DatastarEvent
event)
    , if DatastarEvent -> Int
retry DatastarEvent
event Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
defaultRetryDuration
        then String -> Builder
BSB.stringUtf8 String
"retry: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
BSB.intDec (DatastarEvent -> Int
retry DatastarEvent
event) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
        else Builder
forall a. Monoid a => a
mempty
    , (Text -> Builder) -> [Text] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Text
line -> String -> Builder
BSB.stringUtf8 String
"data: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
text Text
line Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline) (DatastarEvent -> [Text]
dataLines DatastarEvent
event)
    , Builder
newline
    ]
 where
  text :: Text -> BSB.Builder
  text :: Text -> Builder
text = Text -> Builder
TE.encodeUtf8Builder

  newline :: BSB.Builder
  newline :: Builder
newline = Char -> Builder
BSB.charUtf8 Char
'\n'