Message.hs

{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Server.Message where

import Control.Applicative ((<|>))
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 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
  { messageType :: Text
  , event :: Event TargetViewId Encoded Encoded
  , requestId :: RequestId
  , metadata :: Metadata
  , body :: MessageBody
  }
  deriving (Show)


newtype MessageBody = MessageBody {value :: BL.ByteString}
  deriving newtype (Show)


data MessageError
  = InvalidMessage String Text
  | InvalidCookie BS.ByteString String
  | MissingMeta String
  deriving (Show, Exception)


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

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


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

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

  body :: Parser MessageBody
  body = do
    MessageBody . cs . T.strip <$> takeText

  event :: Parser (Event TargetViewId Encoded Encoded)
  event = do
    vid <- targetViewId
    act <- encodedAction
    st <- encodedState <|> pure mempty
    pure $ Event vid act st
   where
    targetViewId :: Parser TargetViewId
    targetViewId = do
      _ <- string "ViewId: "
      line <- takeLine
      v <- case encodedParseText line of
        Left e -> fail $ "Parse Encoded ViewId failed: " <> cs e <> " from " <> cs line
        Right a -> pure $ TargetViewId a
      endOfLine
      pure v

    encodedAction :: Parser Encoded
    encodedAction = do
      _ <- string "Action: "
      inp <- takeLine
      v <- case encodedParseText inp of
        Left e -> fail $ "Parse Encoded ViewAction failed: " <> cs e <> " from " <> cs inp
        Right a -> pure a
      endOfLine
      pure v

    encodedState :: Parser Encoded
    encodedState = do
      _ <- string "State: "
      inp <- takeLine
      v <- case encodedParseText inp of
        Left e -> fail $ "Parse Encoded ViewState failed: " <> cs e <> " from " <> cs inp
        Right a -> pure a
      endOfLine
      pure v

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

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

  metaKey :: Parser MetaKey
  metaKey = do
    key <- takeWhile1 (/= ':')
    _ <- string ": "
    pure key

  takeLine :: Parser Text
  takeLine = do
    takeTill isEndOfLine


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

renderMetadata :: Metadata -> Text
renderMetadata (Metadata m) = T.intercalate "\n" $ fmap (uncurry metaLine) m


metaLine :: MetaKey -> Text -> Text
metaLine name value = name <> ": " <> cs value


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

type MetaKey = Text


newtype Metadata = Metadata [(Text, Text)]
  deriving newtype (Semigroup, Monoid)
  deriving (Show, Generic)
  deriving anyclass (ViewId)


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

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


lookupMetadata :: MetaKey -> Metadata -> Maybe Text
lookupMetadata key (Metadata kvs) = L.lookup key kvs


requestMetadata :: Request -> Metadata
requestMetadata req =
  maybe mempty eventMetadata req.event <> metaRequestId req.requestId
 where
  metaRequestId :: RequestId -> Metadata
  metaRequestId (RequestId "") = mempty
  metaRequestId (RequestId reqId) =
    metadata "RequestId" (cs reqId)

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


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


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


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

  metaQuery :: Maybe QueryData -> Metadata
  metaQuery Nothing = mempty
  metaQuery (Just q) =
    Metadata [("Query", cs $ QueryData.render q)]

  metaSession :: Cookies -> Metadata
  metaSession cookies = mconcat $ fmap metaCookie $ Cookie.toList cookies
   where
    metaCookie :: Cookie -> Metadata
    metaCookie cookie =
      Metadata [("Cookie", cs (Cookie.render reqPath cookie))]


metaRemotes :: [Remote] -> Metadata
metaRemotes rs = mconcat $ fmap meta rs
 where
  meta = \case
    RemoteAction (TargetViewId vid) act ->
      metadata "Trigger" $ encodedToText vid <> "|" <> encodedToText act
    RemoteEvent ev dat ->
      metadata "Event" $ T.intercalate "|" [ev, cs $ Aeson.encode dat]


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


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

data ContentType
  = ContentHtml
  | ContentText


data RenderedMessage
  = MessageHtml BL.ByteString
  | MessageText Text