content: {-# 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
    { messageType :: Text
    , event :: Event TargetViewId 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)
    event = do
      vid <- targetViewId
      endOfLine
      act <- encodedAction
      endOfLine
      pure $ Event vid act
     where
      targetViewId :: Parser TargetViewId
      targetViewId = do
        _ <- string "ViewId: "
        TargetViewId <$> takeLine
  
      encodedAction :: Parser Encoded
      encodedAction = do
        _ <- string "Action: "
        inp <- takeLine
        case encodedParseText inp of
          Left e -> fail $ "Parse Encoded ViewAction failed: " <> cs e <> " from " <> cs inp
          Right a -> pure a
  
    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)
  
  
  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 -> Metadata
    eventMetadata event =
      Metadata
        [ ("ViewId", event.viewId.text)
        , ("Action", encodedToText event.action)
        ]
  
  
  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" $ 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
  
  
  newtype RenderedHtml = RenderedHtml BL.ByteString
    deriving newtype (Semigroup, Monoid)
  