{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Server.Message where

import Control.Applicative ((<|>))
import Control.Exception (Exception)
import Data.Aeson (Value (Null))
import Data.Aeson qualified as Aeson
import Data.Aeson.Parser (json)
import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfLine, isEndOfLine, parseOnly, sepBy, string, takeLazyByteString, takeWhile1)
import Data.Attoparsec.ByteString.Lazy (takeTill)
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 GHC.Generics (Generic)
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)
import Web.Hyperbole.Effect.Hyperbole (Remote (..))
import Web.Hyperbole.Types.Client (Client (..))
import Web.Hyperbole.Types.Event
import Web.Hyperbole.Types.Request
import Web.Hyperbole.View (ViewId)


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

 body
 body
 body
-}

data Message = Message
  { Message -> Text
messageType :: Text
  , Message -> Event TargetViewId Encoded Value
event :: Event TargetViewId Encoded Value
  , 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)
-> (MessageError -> Bool)
-> Exception MessageError
SomeException -> Maybe MessageError
MessageError -> Bool
MessageError -> String
MessageError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: MessageError -> SomeException
toException :: MessageError -> SomeException
$cfromException :: SomeException -> Maybe MessageError
fromException :: SomeException -> Maybe MessageError
$cdisplayException :: MessageError -> String
displayException :: MessageError -> String
$cbacktraceDesired :: MessageError -> Bool
backtraceDesired :: MessageError -> Bool
Exception)


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

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


parseActionMessage :: BS.ByteString -> Either String Message
parseActionMessage :: ByteString -> Either String Message
parseActionMessage = Parser Message -> ByteString -> Either String Message
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser Message
parser
 where
  parser :: Parser Message
  parser :: Parser Message
parser = do
    mt <- Parser Text
messageType
    ev <- event
    rq <- requestId
    ms <- meta `sepBy` endOfLine
    bd <- body
    pure $ Message mt ev rq (mconcat ms) bd

  messageType :: Parser Text
  messageType :: Parser Text
messageType = do
    _ <- Char -> Parser Char
char Char
'|'
    t <- takeWhile1 (/= '|')
    _ <- char '|'
    endOfLine
    pure $ cs t

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

  event :: Parser (Event TargetViewId Encoded Value)
  event :: Parser (Event TargetViewId Encoded Value)
event = do
    vid <- Parser TargetViewId
targetViewId
    act <- encodedAction
    st <- encodedState <|> pure Null
    pure $ Event vid act st
   where
    targetViewId :: Parser TargetViewId
    targetViewId :: Parser TargetViewId
targetViewId = do
      _ <- ByteString -> Parser ByteString
string ByteString
"ViewId: "
      line <- takeLine
      v <- case encodedParseText line of
        Left String
e -> String -> Parser TargetViewId
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser TargetViewId) -> String -> Parser TargetViewId
forall a b. (a -> b) -> a -> b
$ String
"Parse Encoded ViewId 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
line
        Right Encoded
a -> TargetViewId -> Parser TargetViewId
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TargetViewId -> Parser TargetViewId)
-> TargetViewId -> Parser TargetViewId
forall a b. (a -> b) -> a -> b
$ Encoded -> TargetViewId
TargetViewId Encoded
a
      endOfLine
      pure v

    encodedAction :: Parser Encoded
    encodedAction :: Parser Encoded
encodedAction = do
      _ <- ByteString -> Parser ByteString
string ByteString
"Action: "
      inp <- takeLine
      v <- case encodedParseText inp of
        Left String
e -> String -> Parser Encoded
forall a. String -> Parser ByteString 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 ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Encoded
a
      endOfLine
      pure v

    encodedState :: Parser Value
    encodedState :: Parser Value
encodedState = do
      _ <- ByteString -> Parser ByteString
string ByteString
"State: "
      v <- json
      endOfLine
      pure v

  requestId :: Parser RequestId
  requestId :: Parser RequestId
requestId = do
    _ <- ByteString -> Parser ByteString
string ByteString
"RequestId: "
    r <- RequestId <$> takeLine
    endOfLine
    pure r

  meta :: Parser Metadata
  meta :: Parser Metadata
meta = do
    key <- Parser Text
metaKey
    value <- takeLine
    pure $ metadata (cs key) value

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

  takeLine :: Parser Text
  takeLine :: Parser Text
takeLine = do
    ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> Parser ByteString -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
takeTill Word8 -> 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, (forall x. Metadata -> Rep Metadata x)
-> (forall x. Rep Metadata x -> Metadata) -> Generic Metadata
forall x. Rep Metadata x -> Metadata
forall x. Metadata -> Rep Metadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Metadata -> Rep Metadata x
from :: forall x. Metadata -> Rep Metadata x
$cto :: forall x. Rep Metadata x -> Metadata
to :: forall x. Rep Metadata x -> Metadata
Generic)
  deriving anyclass (Encoded -> Either String Metadata
Metadata -> Encoded
(Metadata -> Encoded)
-> (Encoded -> Either String Metadata) -> ViewId Metadata
forall a.
(a -> Encoded) -> (Encoded -> Either String a) -> ViewId a
$ctoViewId :: Metadata -> Encoded
toViewId :: Metadata -> Encoded
$cparseViewId :: Encoded -> Either String Metadata
parseViewId :: Encoded -> Either String Metadata
ViewId)


-- instance HyperView Metadata es where
--   data Action Metadata = MetaNone
--     deriving (Generic, ViewAction)
--   update _ = pure none

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 Value -> Metadata)
-> Maybe (Event TargetViewId Encoded Value)
-> Metadata
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Metadata
forall a. Monoid a => a
mempty Event TargetViewId Encoded Value -> Metadata
forall state. Event TargetViewId Encoded state -> 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 state -> Metadata
  eventMetadata :: forall state. Event TargetViewId Encoded state -> Metadata
eventMetadata Event TargetViewId Encoded state
event =
    [(Text, Text)] -> Metadata
Metadata
      [ (Text
"ViewId", Encoded -> Text
encodedToText Event TargetViewId Encoded state
event.viewId.encoded)
      , (Text
"Action", Encoded -> Text
encodedToText Event TargetViewId Encoded state
event.action)
      ]


targetViewMetadata :: TargetViewId -> Metadata
targetViewMetadata :: TargetViewId -> Metadata
targetViewMetadata (TargetViewId Encoded
vid) = [(Text, Text)] -> Metadata
Metadata [(Text
"TargetViewId", Encoded -> Text
encodedToText Encoded
vid)]


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", Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ QueryData -> Text
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 = [Metadata] -> Metadata
forall a. Monoid a => [a] -> a
mconcat ([Metadata] -> Metadata)
-> ([Remote] -> [Metadata]) -> [Remote] -> Metadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
metaRemote


metaRemote :: Remote -> Metadata
metaRemote :: Remote -> Metadata
metaRemote = \case
  RemoteAction (TargetViewId Encoded
vid) Encoded
act ->
    Text -> Text -> Metadata
metadata Text
"Trigger" (Text -> Metadata) -> Text -> Metadata
forall a b. (a -> b) -> a -> b
$ Encoded -> Text
encodedToText Encoded
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 u = metadata "Redirect" (uriToText u)

data ContentType
  = ContentHtml
  | ContentText


data RenderedMessage
  = MessageHtml BL.ByteString
  | MessageText Text
  | MessageNone