{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Server.Message where

import Control.Exception (Exception)
import Data.Aeson qualified as Aeson
import Data.Attoparsec.Text (Parser, char, endOfLine, isEndOfLine, parseOnly, sepBy, string, takeText, takeTill, takeWhile1)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.List qualified as L
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import Web.Hyperbole.Data.Cookie (Cookie, Cookies)
import Web.Hyperbole.Data.Cookie qualified as Cookie
import Web.Hyperbole.Data.Encoded
import Web.Hyperbole.Data.QueryData (QueryData)
import Web.Hyperbole.Data.QueryData qualified as QueryData
import Web.Hyperbole.Data.URI (Path, URI, uriToText)
import Web.Hyperbole.Effect.Hyperbole (Remote (..))
import Web.Hyperbole.Types.Client (Client (..))
import Web.Hyperbole.Types.Event
import Web.Hyperbole.Types.Request


{-
 |UPDATE|
 viewId: wahoo
 action: hello
 requestId: ipgeim

 body
 body
 body
-}

data Message = Message
  { Message -> Text
messageType :: Text
  , Message -> Event TargetViewId Encoded
event :: Event TargetViewId Encoded
  , Message -> RequestId
requestId :: RequestId
  , Message -> Metadata
metadata :: Metadata
  , Message -> MessageBody
body :: MessageBody
  }
  deriving (Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Message -> ShowS
showsPrec :: Int -> Message -> ShowS
$cshow :: Message -> String
show :: Message -> String
$cshowList :: [Message] -> ShowS
showList :: [Message] -> ShowS
Show)


newtype MessageBody = MessageBody {MessageBody -> ByteString
value :: BL.ByteString}
  deriving newtype (Int -> MessageBody -> ShowS
[MessageBody] -> ShowS
MessageBody -> String
(Int -> MessageBody -> ShowS)
-> (MessageBody -> String)
-> ([MessageBody] -> ShowS)
-> Show MessageBody
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MessageBody -> ShowS
showsPrec :: Int -> MessageBody -> ShowS
$cshow :: MessageBody -> String
show :: MessageBody -> String
$cshowList :: [MessageBody] -> ShowS
showList :: [MessageBody] -> ShowS
Show)


data MessageError
  = InvalidMessage String Text
  | InvalidCookie BS.ByteString String
  | MissingMeta String
  deriving (Int -> MessageError -> ShowS
[MessageError] -> ShowS
MessageError -> String
(Int -> MessageError -> ShowS)
-> (MessageError -> String)
-> ([MessageError] -> ShowS)
-> Show MessageError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MessageError -> ShowS
showsPrec :: Int -> MessageError -> ShowS
$cshow :: MessageError -> String
show :: MessageError -> String
$cshowList :: [MessageError] -> ShowS
showList :: [MessageError] -> ShowS
Show, Show MessageError
Typeable MessageError
(Typeable MessageError, Show MessageError) =>
(MessageError -> SomeException)
-> (SomeException -> Maybe MessageError)
-> (MessageError -> String)
-> Exception MessageError
SomeException -> Maybe MessageError
MessageError -> String
MessageError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: MessageError -> SomeException
toException :: MessageError -> SomeException
$cfromException :: SomeException -> Maybe MessageError
fromException :: SomeException -> Maybe MessageError
$cdisplayException :: MessageError -> String
displayException :: MessageError -> String
Exception)


-- Read Messages -------------------------------------

mimeType :: Text
mimeType :: Text
mimeType = Text
"application/hyperbole.message"


parseActionMessage :: Text -> Either String Message
parseActionMessage :: Text -> Either String Message
parseActionMessage = Parser Message -> Text -> Either String Message
forall a. Parser a -> Text -> Either String a
parseOnly Parser Message
parser
 where
  parser :: Parser Message
  parser :: Parser Message
parser = do
    Text
mt <- Parser Text
messageType
    Event TargetViewId Encoded
ev <- Parser (Event TargetViewId Encoded)
event
    RequestId
rq <- Parser RequestId
requestId
    [Metadata]
ms <- Parser Metadata
meta Parser Metadata -> Parser Text () -> Parser Text [Metadata]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Parser Text ()
endOfLine
    MessageBody
bd <- Parser MessageBody
body
    Message -> Parser Message
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message -> Parser Message) -> Message -> Parser Message
forall a b. (a -> b) -> a -> b
$ Text
-> Event TargetViewId Encoded
-> RequestId
-> Metadata
-> MessageBody
-> Message
Message Text
mt Event TargetViewId Encoded
ev RequestId
rq ([Metadata] -> Metadata
forall a. Monoid a => [a] -> a
mconcat [Metadata]
ms) MessageBody
bd

  messageType :: Parser Text
  messageType :: Parser Text
messageType = do
    Char
_ <- Char -> Parser Char
char Char
'|'
    Text
t <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|')
    Char
_ <- Char -> Parser Char
char Char
'|'
    Parser Text ()
endOfLine
    Text -> Parser Text
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t

  body :: Parser MessageBody
  body :: Parser MessageBody
body = do
    ByteString -> MessageBody
MessageBody (ByteString -> MessageBody)
-> (Text -> ByteString) -> Text -> MessageBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> MessageBody) -> Parser Text -> Parser MessageBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText

  event :: Parser (Event TargetViewId Encoded)
  event :: Parser (Event TargetViewId Encoded)
event = do
    TargetViewId
vid <- Parser TargetViewId
targetViewId
    Parser Text ()
endOfLine
    Encoded
act <- Parser Encoded
encodedAction
    Parser Text ()
endOfLine
    Event TargetViewId Encoded -> Parser (Event TargetViewId Encoded)
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event TargetViewId Encoded -> Parser (Event TargetViewId Encoded))
-> Event TargetViewId Encoded
-> Parser (Event TargetViewId Encoded)
forall a b. (a -> b) -> a -> b
$ TargetViewId -> Encoded -> Event TargetViewId Encoded
forall id act. id -> act -> Event id act
Event TargetViewId
vid Encoded
act
   where
    targetViewId :: Parser TargetViewId
    targetViewId :: Parser TargetViewId
targetViewId = do
      Text
_ <- Text -> Parser Text
string Text
"ViewId: "
      Text -> TargetViewId
TargetViewId (Text -> TargetViewId) -> Parser Text -> Parser TargetViewId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeLine

    encodedAction :: Parser Encoded
    encodedAction :: Parser Encoded
encodedAction = do
      Text
_ <- Text -> Parser Text
string Text
"Action: "
      Text
inp <- Parser Text
takeLine
      case Text -> Either String Encoded
encodedParseText Text
inp of
        Left String
e -> String -> Parser Encoded
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Encoded) -> String -> Parser Encoded
forall a b. (a -> b) -> a -> b
$ String
"Parse Encoded ViewAction failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a b. ConvertibleStrings a b => a -> b
cs String
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
inp
        Right Encoded
a -> Encoded -> Parser Encoded
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Encoded
a

  requestId :: Parser RequestId
  requestId :: Parser RequestId
requestId = do
    Text
_ <- Text -> Parser Text
string Text
"RequestId: "
    RequestId
r <- Text -> RequestId
RequestId (Text -> RequestId) -> Parser Text -> Parser RequestId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeLine
    Parser Text ()
endOfLine
    RequestId -> Parser RequestId
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RequestId
r

  meta :: Parser Metadata
  meta :: Parser Metadata
meta = do
    Text
key <- Parser Text
metaKey
    Text
value <- Parser Text
takeLine
    Metadata -> Parser Metadata
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Metadata -> Parser Metadata) -> Metadata -> Parser Metadata
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Metadata
metadata (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
key) Text
value

  metaKey :: Parser MetaKey
  metaKey :: Parser Text
metaKey = do
    Text
key <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')
    Text
_ <- Text -> Parser Text
string Text
": "
    Text -> Parser Text
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
key

  takeLine :: Parser Text
  takeLine :: Parser Text
takeLine = do
    (Char -> Bool) -> Parser Text
takeTill Char -> Bool
isEndOfLine


-- Render ---------------------------------------------

renderMetadata :: Metadata -> Text
renderMetadata :: Metadata -> Text
renderMetadata (Metadata [(Text, Text)]
m) = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text -> Text) -> (Text, Text) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Text
metaLine) [(Text, Text)]
m


metaLine :: MetaKey -> Text -> Text
metaLine :: Text -> Text -> Text
metaLine Text
name Text
value = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
value


-- Metadata --------------------------------------------

type MetaKey = Text


newtype Metadata = Metadata [(Text, Text)]
  deriving newtype (NonEmpty Metadata -> Metadata
Metadata -> Metadata -> Metadata
(Metadata -> Metadata -> Metadata)
-> (NonEmpty Metadata -> Metadata)
-> (forall b. Integral b => b -> Metadata -> Metadata)
-> Semigroup Metadata
forall b. Integral b => b -> Metadata -> Metadata
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Metadata -> Metadata -> Metadata
<> :: Metadata -> Metadata -> Metadata
$csconcat :: NonEmpty Metadata -> Metadata
sconcat :: NonEmpty Metadata -> Metadata
$cstimes :: forall b. Integral b => b -> Metadata -> Metadata
stimes :: forall b. Integral b => b -> Metadata -> Metadata
Semigroup, Semigroup Metadata
Metadata
Semigroup Metadata =>
Metadata
-> (Metadata -> Metadata -> Metadata)
-> ([Metadata] -> Metadata)
-> Monoid Metadata
[Metadata] -> Metadata
Metadata -> Metadata -> Metadata
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Metadata
mempty :: Metadata
$cmappend :: Metadata -> Metadata -> Metadata
mappend :: Metadata -> Metadata -> Metadata
$cmconcat :: [Metadata] -> Metadata
mconcat :: [Metadata] -> Metadata
Monoid)
  deriving (Int -> Metadata -> ShowS
[Metadata] -> ShowS
Metadata -> String
(Int -> Metadata -> ShowS)
-> (Metadata -> String) -> ([Metadata] -> ShowS) -> Show Metadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Metadata -> ShowS
showsPrec :: Int -> Metadata -> ShowS
$cshow :: Metadata -> String
show :: Metadata -> String
$cshowList :: [Metadata] -> ShowS
showList :: [Metadata] -> ShowS
Show)


metadata :: MetaKey -> Text -> Metadata
metadata :: Text -> Text -> Metadata
metadata Text
key Text
value = [(Text, Text)] -> Metadata
Metadata [(Text
key, Text
value)]


lookupMetadata :: MetaKey -> Metadata -> Maybe Text
lookupMetadata :: Text -> Metadata -> Maybe Text
lookupMetadata Text
key (Metadata [(Text, Text)]
kvs) = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
key [(Text, Text)]
kvs


requestMetadata :: Request -> Metadata
requestMetadata :: Request -> Metadata
requestMetadata Request
req =
  Metadata
-> (Event TargetViewId Encoded -> Metadata)
-> Maybe (Event TargetViewId Encoded)
-> Metadata
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Metadata
forall a. Monoid a => a
mempty Event TargetViewId Encoded -> Metadata
eventMetadata Request
req.event Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> RequestId -> Metadata
metaRequestId Request
req.requestId
 where
  metaRequestId :: RequestId -> Metadata
  metaRequestId :: RequestId -> Metadata
metaRequestId (RequestId Text
"") = Metadata
forall a. Monoid a => a
mempty
  metaRequestId (RequestId Text
reqId) =
    Text -> Text -> Metadata
metadata Text
"RequestId" (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
reqId)

  eventMetadata :: Event TargetViewId Encoded -> Metadata
  eventMetadata :: Event TargetViewId Encoded -> Metadata
eventMetadata Event TargetViewId Encoded
event =
    [(Text, Text)] -> Metadata
Metadata
      [ (Text
"ViewId", Event TargetViewId Encoded
event.viewId.text)
      , (Text
"Action", Encoded -> Text
encodedToText Event TargetViewId Encoded
event.action)
      ]


responseMetadata :: Path -> Client -> [Remote] -> Metadata
responseMetadata :: Path -> Client -> [Remote] -> Metadata
responseMetadata Path
reqPath Client
client [Remote]
remotes =
  Path -> Client -> Metadata
clientMetadata Path
reqPath Client
client Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> [Remote] -> Metadata
metaRemotes [Remote]
remotes


clientMetadata :: Path -> Client -> Metadata
clientMetadata :: Path -> Client -> Metadata
clientMetadata Path
reqPath Client
client =
  Cookies -> Metadata
metaSession Client
client.session Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Maybe QueryData -> Metadata
metaQuery Client
client.query Metadata -> Metadata -> Metadata
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Metadata
metaPageTitle Client
client.pageTitle
 where
  metaPageTitle :: Maybe Text -> Metadata
  metaPageTitle :: Maybe Text -> Metadata
metaPageTitle = \case
    Maybe Text
Nothing -> Metadata
forall a. Monoid a => a
mempty
    Just Text
pt -> Text -> Text -> Metadata
metadata Text
"PageTitle" Text
pt

  metaQuery :: Maybe QueryData -> Metadata
  metaQuery :: Maybe QueryData -> Metadata
metaQuery Maybe QueryData
Nothing = Metadata
forall a. Monoid a => a
mempty
  metaQuery (Just QueryData
q) =
    [(Text, Text)] -> Metadata
Metadata [(Text
"Query", ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ QueryData -> ByteString
QueryData.render QueryData
q)]

  metaSession :: Cookies -> Metadata
  metaSession :: Cookies -> Metadata
metaSession Cookies
cookies = [Metadata] -> Metadata
forall a. Monoid a => [a] -> a
mconcat ([Metadata] -> Metadata) -> [Metadata] -> Metadata
forall a b. (a -> b) -> a -> b
$ (Cookie -> Metadata) -> [Cookie] -> [Metadata]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> Metadata
metaCookie ([Cookie] -> [Metadata]) -> [Cookie] -> [Metadata]
forall a b. (a -> b) -> a -> b
$ Cookies -> [Cookie]
Cookie.toList Cookies
cookies
   where
    metaCookie :: Cookie -> Metadata
    metaCookie :: Cookie -> Metadata
metaCookie Cookie
cookie =
      [(Text, Text)] -> Metadata
Metadata [(Text
"Cookie", ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Path -> Cookie -> ByteString
Cookie.render Path
reqPath Cookie
cookie))]


metaRemotes :: [Remote] -> Metadata
metaRemotes :: [Remote] -> Metadata
metaRemotes [Remote]
rs = [Metadata] -> Metadata
forall a. Monoid a => [a] -> a
mconcat ([Metadata] -> Metadata) -> [Metadata] -> Metadata
forall a b. (a -> b) -> a -> b
$ (Remote -> Metadata) -> [Remote] -> [Metadata]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Remote -> Metadata
meta [Remote]
rs
 where
  meta :: Remote -> Metadata
meta = \case
    RemoteAction (TargetViewId Text
vid) Encoded
act ->
      Text -> Text -> Metadata
metadata Text
"Trigger" (Text -> Metadata) -> Text -> Metadata
forall a b. (a -> b) -> a -> b
$ Text
vid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Encoded -> Text
encodedToText Encoded
act
    RemoteEvent Text
ev Value
dat ->
      Text -> Text -> Metadata
metadata Text
"Event" (Text -> Metadata) -> Text -> Metadata
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"|" [Text
ev, ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
dat]


metaError :: Text -> Metadata
metaError :: Text -> Metadata
metaError = Text -> Text -> Metadata
metadata Text
"Error"


metaRedirect :: URI -> Metadata
metaRedirect :: URI -> Metadata
metaRedirect URI
u = Text -> Text -> Metadata
metadata Text
"Redirect" (URI -> Text
uriToText URI
u)


data ContentType
  = ContentHtml
  | ContentText


newtype RenderedHtml = RenderedHtml BL.ByteString
  deriving newtype (NonEmpty RenderedHtml -> RenderedHtml
RenderedHtml -> RenderedHtml -> RenderedHtml
(RenderedHtml -> RenderedHtml -> RenderedHtml)
-> (NonEmpty RenderedHtml -> RenderedHtml)
-> (forall b. Integral b => b -> RenderedHtml -> RenderedHtml)
-> Semigroup RenderedHtml
forall b. Integral b => b -> RenderedHtml -> RenderedHtml
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: RenderedHtml -> RenderedHtml -> RenderedHtml
<> :: RenderedHtml -> RenderedHtml -> RenderedHtml
$csconcat :: NonEmpty RenderedHtml -> RenderedHtml
sconcat :: NonEmpty RenderedHtml -> RenderedHtml
$cstimes :: forall b. Integral b => b -> RenderedHtml -> RenderedHtml
stimes :: forall b. Integral b => b -> RenderedHtml -> RenderedHtml
Semigroup, Semigroup RenderedHtml
RenderedHtml
Semigroup RenderedHtml =>
RenderedHtml
-> (RenderedHtml -> RenderedHtml -> RenderedHtml)
-> ([RenderedHtml] -> RenderedHtml)
-> Monoid RenderedHtml
[RenderedHtml] -> RenderedHtml
RenderedHtml -> RenderedHtml -> RenderedHtml
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: RenderedHtml
mempty :: RenderedHtml
$cmappend :: RenderedHtml -> RenderedHtml -> RenderedHtml
mappend :: RenderedHtml -> RenderedHtml -> RenderedHtml
$cmconcat :: [RenderedHtml] -> RenderedHtml
mconcat :: [RenderedHtml] -> RenderedHtml
Monoid)