{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-pattern-namespace-specifier #-}

-- | Bus message framing.
--
-- Storage format is JSON Lines: one stamped 'Post' per line with fields
-- @id@, @ts@, @from@, @to@, @thread@ and @body@.  The body is never mutated
-- for framing; JSON string encoding handles newlines in the standard way.
--
-- The file image is a stream with the same 'Circuit.Stream' ends as the pure
-- log: 'Log' is oldest-first on disk, so append is 'snoc' and read is
-- 'uncons'.  The pure 'Log' is newest-first; that is the dual linearisation of
-- the same thread DAG, not a different algebra.
--
-- 'Log a' stores 'Stamped a' values in memory — no encoding in the hot path.
-- File persistence uses 'frameStored'/'unframeStored' via 'PostBody' at the
-- storage boundary.
--
-- Backwards compatibility: 'parseLineAt' also accepts the legacy flat triple
-- @{\"ts\":..., \"sender\":..., \"body\":...}@ and the bracket format
-- @[timestamp] sender: body@ so existing log files remain readable.  Those
-- legacy lines are assigned the supplied line index as their id and empty
-- @to@/@thread@ lists.
module Circuit.Agent.Framing
  ( -- * Types
    PostId,
    PostBody (..),
    Stamped,
    pattern Stamped,
    stamp,
    stamped,
    Log (..),

    -- * Stream ends (re-exported from Circuit.Stream)
    Cons (..),
    Snoc (..),
    Uncons (..),
    These (..),

    -- * Encoding
    frameStored,
    framePost,

    -- * Parsing
    unframeStored,
    parseLineAt,
    parsePost,
    parseMessage,
    parseMessageTs,

    -- * Rendering
    renderStored,
    renderMessage,

    -- * Time
    formatNow,
    parseTimeText,

    -- * File helpers
    readLogFile,
    encodeLog,
  )
where

import Circuit.Agent (Post (..), PostId)
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.Maybe (mapMaybe)
import Data.Scientific (Scientific, base10Exponent, coefficient)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.IO qualified as TIO
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime, parseTimeM)
import Data.Vector qualified as V
import Numeric.Natural (Natural)
import "circuits" Circuit.Stamped (stamp, stamped)
import "circuits" Circuit.Stamped qualified as Stamped
import "circuits" Circuit.Stream (Cons (..), Snoc (..), These (..), Uncons (..))
import "circuits-parser" Circuit.Parser.Json (Json (..), decodeJson, encodeJson)
import Prelude

-- | Encodable/decodable post body. Every body type in the bus must
-- support JSON round-trip through 'circuits-parser''s 'Json' type.
class PostBody a where
  encodePostBody :: a -> Json
  decodePostBody :: Json -> Maybe a

instance PostBody Text where
  encodePostBody :: Text -> Json
encodePostBody = Text -> Json
JString
  decodePostBody :: Json -> Maybe Text
decodePostBody (JString Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
  decodePostBody Json
_ = Maybe Text
forall a. Maybe a
Nothing

-- | Storage boundary: a post with its assigned id and timestamp.
--
-- This is the agent-side specialisation of 'Circuit.Stamped.Stamped' from
-- @circuits@ core: the occurrence token is the @(UTCTime, PostId)@ pair and
-- the payload is a @Post a@.  The core type carries the free theorem that
-- 'fmap' cannot touch the stamp, so the agent shares it rather than
-- duplicating it.
type Stamped a = Stamped.Stamped (UTCTime, PostId) (Post a)

-- | The core 'Circuit.Stamped.Stamped' constructor specialised to the agent's
-- occurrence token @(UTCTime, PostId)@.
pattern Stamped :: (UTCTime, PostId) -> Post a -> Stamped a
pattern $bStamped :: forall a. (UTCTime, Natural) -> Post a -> Stamped a
$mStamped :: forall {r} {a}.
Stamped a
-> ((UTCTime, Natural) -> Post a -> r) -> ((# #) -> r) -> r
Stamped tok post = Stamped.Stamped tok post

{-# COMPLETE Stamped #-}

-- | The log image: a stream of stamped posts, oldest first.
newtype Log a = Log {forall a. Log a -> [Stamped a]
unLog :: [Stamped a]}
  deriving (Int -> Log a -> ShowS
[Log a] -> ShowS
Log a -> String
(Int -> Log a -> ShowS)
-> (Log a -> String) -> ([Log a] -> ShowS) -> Show (Log a)
forall a. Show a => Int -> Log a -> ShowS
forall a. Show a => [Log a] -> ShowS
forall a. Show a => Log a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Log a -> ShowS
showsPrec :: Int -> Log a -> ShowS
$cshow :: forall a. Show a => Log a -> String
show :: Log a -> String
$cshowList :: forall a. Show a => [Log a] -> ShowS
showList :: [Log a] -> ShowS
Show, Log a -> Log a -> Bool
(Log a -> Log a -> Bool) -> (Log a -> Log a -> Bool) -> Eq (Log a)
forall a. Eq a => Log a -> Log a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Log a -> Log a -> Bool
== :: Log a -> Log a -> Bool
$c/= :: forall a. Eq a => Log a -> Log a -> Bool
/= :: Log a -> Log a -> Bool
Eq, (forall a b. (a -> b) -> Log a -> Log b)
-> (forall a b. a -> Log b -> Log a) -> Functor Log
forall a b. a -> Log b -> Log a
forall a b. (a -> b) -> Log a -> Log b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Log a -> Log b
fmap :: forall a b. (a -> b) -> Log a -> Log b
$c<$ :: forall a b. a -> Log b -> Log a
<$ :: forall a b. a -> Log b -> Log a
Functor)

-- | Append is the natural operation: one element at the end.
instance Snoc (Log a) (Stamped a) where
  snoc :: Log a -> Stamped a -> Log a
snoc (Log [Stamped a]
xs) Stamped a
p = [Stamped a] -> Log a
forall a. [Stamped a] -> Log a
Log ([Stamped a]
xs [Stamped a] -> [Stamped a] -> [Stamped a]
forall a. [a] -> [a] -> [a]
++ [Stamped a
p])
  snocNil :: Log a
snocNil = [Stamped a] -> Log a
forall a. [Stamped a] -> Log a
Log []

-- | Read peels the oldest element first.
instance Uncons (Log a) (Stamped a) where
  uncons :: Log a -> These (Stamped a) (Log a)
uncons (Log []) = Log a -> These (Stamped a) (Log a)
forall a b. b -> These a b
That ([Stamped a] -> Log a
forall a. [Stamped a] -> Log a
Log [])
  uncons (Log [Stamped a
x]) = Stamped a -> These (Stamped a) (Log a)
forall a b. a -> These a b
This Stamped a
x
  uncons (Log (Stamped a
x : [Stamped a]
xs)) = Stamped a -> Log a -> These (Stamped a) (Log a)
forall a b. a -> b -> These a b
These Stamped a
x ([Stamped a] -> Log a
forall a. [Stamped a] -> Log a
Log [Stamped a]
xs)
  nil :: Log a
nil = [Stamped a] -> Log a
forall a. [Stamped a] -> Log a
Log []

-- | Prepend is the dual view: a newest-first stream over the same image.
instance Cons (Log a) (Stamped a) where
  cons :: Stamped a -> Log a -> Log a
cons Stamped a
p (Log [Stamped a]
xs) = [Stamped a] -> Log a
forall a. [Stamped a] -> Log a
Log (Stamped a
p Stamped a -> [Stamped a] -> [Stamped a]
forall a. a -> [a] -> [a]
: [Stamped a]
xs)
  consNil :: Log a
consNil = [Stamped a] -> Log a
forall a. [Stamped a] -> Log a
Log []

-- | Current UTC time as an ISO-8601 string.
formatNow :: IO Text
formatNow :: IO Text
formatNow = String -> Text
T.pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S" (UTCTime -> Text) -> IO UTCTime -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime

-- | Parse an ISO-8601 string to UTCTime, accepting the format we write.
parseTimeText :: Text -> Maybe UTCTime
parseTimeText :: Text -> Maybe UTCTime
parseTimeText = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S" (String -> Maybe UTCTime)
-> (Text -> String) -> Text -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- | Encode a 'Stamped a' as a single canonical JSON Lines object.
frameStored :: (PostBody a) => Stamped a -> Text
frameStored :: forall a. PostBody a => Stamped a -> Text
frameStored (Stamped (UTCTime
ts, Natural
i) (Post Text
from' [Text]
to' [Natural]
thread' a
body')) =
  ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
    Json -> ByteString
encodeJson (Json -> ByteString) -> Json -> ByteString
forall a b. (a -> b) -> a -> b
$
      [(Text, Json)] -> Json
JObject
        [ (Text
"id", Scientific -> Json
JNumber (Natural -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i)),
          (Text
"ts", Text -> Json
JString (String -> Text
T.pack (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S" UTCTime
ts))),
          (Text
"from", Text -> Json
JString Text
from'),
          (Text
"to", Vector Json -> Json
JArray ([Json] -> Vector Json
forall a. [a] -> Vector a
V.fromList ((Text -> Json) -> [Text] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Json
JString [Text]
to'))),
          (Text
"thread", Vector Json -> Json
JArray ([Json] -> Vector Json
forall a. [a] -> Vector a
V.fromList ((Natural -> Json) -> [Natural] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map (Scientific -> Json
JNumber (Scientific -> Json) -> (Natural -> Scientific) -> Natural -> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Natural]
thread'))),
          (Text
"body", a -> Json
forall a. PostBody a => a -> Json
encodePostBody a
body')
        ]

-- | Encode a bare 'Post a' as a single JSON Lines object (the protocol
-- format sent to the stamping bus daemon).
framePost :: (PostBody a) => Post a -> Text
framePost :: forall a. PostBody a => Post a -> Text
framePost Post a
p =
  ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
    Json -> ByteString
encodeJson (Json -> ByteString) -> Json -> ByteString
forall a b. (a -> b) -> a -> b
$
      [(Text, Json)] -> Json
JObject
        [ (Text
"from", Text -> Json
JString (Post a -> Text
forall a. Post a -> Text
from Post a
p)),
          (Text
"to", Vector Json -> Json
JArray ([Json] -> Vector Json
forall a. [a] -> Vector a
V.fromList ((Text -> Json) -> [Text] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Json
JString (Post a -> [Text]
forall a. Post a -> [Text]
to Post a
p)))),
          (Text
"thread", Vector Json -> Json
JArray ([Json] -> Vector Json
forall a. [a] -> Vector a
V.fromList ((Natural -> Json) -> [Natural] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map (Scientific -> Json
JNumber (Scientific -> Json) -> (Natural -> Scientific) -> Natural -> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Post a -> [Natural]
forall a. Post a -> [Natural]
thread Post a
p)))),
          (Text
"body", a -> Json
forall a. PostBody a => a -> Json
encodePostBody (Post a -> a
forall a. Post a -> a
body Post a
p))
        ]

-- | Unframe a canonical stamped storage line (the inverse of 'frameStored').
-- Returns 'Nothing' if the line is not valid JSON with the expected fields.
unframeStored :: (PostBody a) => Text -> Maybe (Stamped a)
unframeStored :: forall a. PostBody a => Text -> Maybe (Stamped a)
unframeStored Text
line =
  case ByteString -> Either String Json
decodeJson (Text -> ByteString
encodeUtf8 Text
line) of
    Right (JObject [(Text, Json)]
o) -> do
      pid <- Text -> Json -> Maybe Scientific
lookupNumber Text
"id" ([(Text, Json)] -> Json
JObject [(Text, Json)]
o) Maybe Scientific -> (Scientific -> Maybe Natural) -> Maybe Natural
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Scientific -> Maybe Natural
naturalFromScientific
      JString tsStr <- lookup "ts" o
      ts <- parseTimeText tsStr
      JString from' <- lookup "from" o
      to' <- lookupStrings "to" (JObject o)
      thread' <- lookupPostIds "thread" (JObject o)
      bodyVal <- lookup "body" o
      body' <- decodePostBody bodyVal
      pure (Stamped (ts, pid) (Post from' to' thread' body'))
    Either String Json
_ -> Maybe (Stamped a)
forall a. Maybe a
Nothing

-- | Parse a bare 'Post a' line (no stamp).
parsePost :: (PostBody a) => Text -> Maybe (Post a)
parsePost :: forall a. PostBody a => Text -> Maybe (Post a)
parsePost Text
line =
  case ByteString -> Either String Json
decodeJson (Text -> ByteString
encodeUtf8 Text
line) of
    Right (JObject [(Text, Json)]
o) -> do
      JString from' <- Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"from" [(Text, Json)]
o
      to' <- lookupStrings "to" (JObject o)
      thread' <- lookupPostIds "thread" (JObject o)
      bodyVal <- lookup "body" o
      body' <- decodePostBody bodyVal
      pure (Post from' to' thread' body')
    Either String Json
_ -> Maybe (Post a)
forall a. Maybe a
Nothing

-- | Like 'unframeStored', but also accepts the legacy flat triple and bracket
-- formats, assigning the supplied line index as the id. Legacy-only, 'Text' body.
parseLineAt :: Int -> Text -> Maybe (Stamped Text)
parseLineAt :: Int -> Text -> Maybe (Stamped Text)
parseLineAt Int
idx Text
line =
  Text -> Maybe (Stamped Text)
forall a. PostBody a => Text -> Maybe (Stamped a)
unframeStored Text
line
    Maybe (Stamped Text)
-> Maybe (Stamped Text) -> Maybe (Stamped Text)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Text -> Maybe (Stamped Text)
parseLegacyTriple Int
idx Text
line
    Maybe (Stamped Text)
-> Maybe (Stamped Text) -> Maybe (Stamped Text)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Text -> Maybe (Stamped Text)
parseLegacyBracket Int
idx Text
line

-- | Parse a raw log line into @(from, body)@, accepting the stamped format
-- and both legacy formats.
parseMessage :: Text -> Maybe (Text, Text)
parseMessage :: Text -> Maybe (Text, Text)
parseMessage Text
line = do
  Stamped _ p <- Int -> Text -> Maybe (Stamped Text)
parseLineAt Int
0 Text
line
  pure (from p, body p)

-- | Extract just the timestamp from a raw log line.
parseMessageTs :: Text -> Maybe Text
parseMessageTs :: Text -> Maybe Text
parseMessageTs Text
line = do
  Stamped (ts, _) _ <- Int -> Text -> Maybe (Stamped Text)
parseLineAt Int
0 Text
line
  pure (T.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" ts))

-- | Render a 'Stamped a' for human display as @[id@ts] from: body@.
renderStored :: (PostBody a) => Stamped a -> Text
renderStored :: forall a. PostBody a => Stamped a -> Text
renderStored (Stamped (UTCTime
ts, Natural
i) (Post Text
from' [Text]
_to' [Natural]
_thread' a
body')) =
  [Text] -> Text
T.concat [Text
"[", String -> Text
T.pack (Natural -> String
forall a. Show a => a -> String
show Natural
i), Text
"@", String -> Text
T.pack (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S" UTCTime
ts), Text
"] ", Text
from', Text
": ", a -> Text
forall {a}. PostBody a => a -> Text
renderBody a
body']
  where
    renderBody :: a -> Text
renderBody a
b = case ByteString -> Text
decodeUtf8 (Json -> ByteString
encodeJson (a -> Json
forall a. PostBody a => a -> Json
encodePostBody a
b)) of
      Text
t -> Text -> Text
T.strip Text
t

-- | Render a raw log line for human display.
renderMessage :: Text -> Maybe Text
renderMessage :: Text -> Maybe Text
renderMessage Text
line = Stamped Text -> Text
forall a. PostBody a => Stamped a -> Text
renderStored (Stamped Text -> Text) -> Maybe (Stamped Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Text -> Maybe (Stamped Text)
parseLineAt Int
0 Text
line

-- | Read a log file into a 'Log a', oldest first. Malformed lines are skipped.
readLogFile :: (PostBody a) => FilePath -> IO (Log a)
readLogFile :: forall a. PostBody a => String -> IO (Log a)
readLogFile String
path = do
  content <- String -> IO Text
TIO.readFile String
path
  let ls = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) (Text -> [Text]
T.lines Text
content)
  pure (Log (mapMaybe unframeStored ls))

-- | Encode a 'Log a' to raw JSONL text for file persistence.
encodeLog :: (PostBody a) => Log a -> [Text]
encodeLog :: forall a. PostBody a => Log a -> [Text]
encodeLog = (Stamped a -> Text) -> [Stamped a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Stamped a -> Text
forall a. PostBody a => Stamped a -> Text
frameStored ([Stamped a] -> [Text])
-> (Log a -> [Stamped a]) -> Log a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stamped a] -> [Stamped a]
forall a. [a] -> [a]
reverse ([Stamped a] -> [Stamped a])
-> (Log a -> [Stamped a]) -> Log a -> [Stamped a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Log a -> [Stamped a]
forall a. Log a -> [Stamped a]
unLog

-- ---------------------------------------------------------------------------
-- Internal helpers
-- ---------------------------------------------------------------------------

naturalFromScientific :: Scientific -> Maybe Natural
naturalFromScientific :: Scientific -> Maybe Natural
naturalFromScientific Scientific
s
  | Scientific -> Int
base10Exponent Scientific
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Scientific -> Integer
coefficient Scientific
s) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
10 Natural -> Int -> Natural
forall a b. (Num a, Integral b) => a -> b -> a
^ Scientific -> Int
base10Exponent Scientific
s)
  | Bool
otherwise = Maybe Natural
forall a. Maybe a
Nothing

lookupNumber :: Text -> Json -> Maybe Scientific
lookupNumber :: Text -> Json -> Maybe Scientific
lookupNumber Text
k (JObject [(Text, Json)]
o) = case Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Json)]
o of
  Just (JNumber Scientific
n) -> Scientific -> Maybe Scientific
forall a. a -> Maybe a
Just Scientific
n
  Maybe Json
_ -> Maybe Scientific
forall a. Maybe a
Nothing
lookupNumber Text
_ Json
_ = Maybe Scientific
forall a. Maybe a
Nothing

lookupStrings :: Text -> Json -> Maybe [Text]
lookupStrings :: Text -> Json -> Maybe [Text]
lookupStrings Text
k (JObject [(Text, Json)]
o) = case Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Json)]
o of
  Just (JArray Vector Json
vs) -> [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
s | JString Text
s <- Vector Json -> [Json]
forall a. Vector a -> [a]
V.toList Vector Json
vs]
  Maybe Json
_ -> Maybe [Text]
forall a. Maybe a
Nothing
lookupStrings Text
_ Json
_ = Maybe [Text]
forall a. Maybe a
Nothing

lookupPostIds :: Text -> Json -> Maybe [PostId]
lookupPostIds :: Text -> Json -> Maybe [Natural]
lookupPostIds Text
k (JObject [(Text, Json)]
o) = case Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Json)]
o of
  Just (JArray Vector Json
vs) -> [Natural] -> Maybe [Natural]
forall a. a -> Maybe a
Just [Natural
i | JNumber Scientific
s <- Vector Json -> [Json]
forall a. Vector a -> [a]
V.toList Vector Json
vs, Just Natural
i <- [Scientific -> Maybe Natural
naturalFromScientific Scientific
s]]
  Maybe Json
_ -> Maybe [Natural]
forall a. Maybe a
Nothing
lookupPostIds Text
_ Json
_ = Maybe [Natural]
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------------
-- Legacy formats
-- ---------------------------------------------------------------------------

-- | Legacy flat triple: @{\"ts\":\"...\", \"sender\":\"...\", \"body\":\"...\"}@.
parseLegacyTriple :: Int -> Text -> Maybe (Stamped Text)
parseLegacyTriple :: Int -> Text -> Maybe (Stamped Text)
parseLegacyTriple Int
idx Text
line =
  case ByteString -> Either String Json
decodeJson (Text -> ByteString
encodeUtf8 Text
line) of
    Right (JObject [(Text, Json)]
o) -> do
      JString tsStr <- Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"ts" [(Text, Json)]
o
      ts <- parseTimeText tsStr
      JString sender' <- lookup "sender" o
      JString body' <- lookup "body" o
      pure (Stamped (ts, fromIntegral idx) (Post sender' [] [] body'))
    Either String Json
_ -> Maybe (Stamped Text)
forall a. Maybe a
Nothing

-- | Legacy bracket format: @[timestamp] sender: body@.
parseLegacyBracket :: Int -> Text -> Maybe (Stamped Text)
parseLegacyBracket :: Int -> Text -> Maybe (Stamped Text)
parseLegacyBracket Int
idx Text
line =
  case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"]" Text
line of
    (Text
pref, Text
rest)
      | Bool -> Bool
not (Text -> Bool
T.null Text
pref),
        let tsStr :: Text
tsStr = (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[') (HasCallStack => Text -> Text
Text -> Text
T.init Text
pref) -> do
          ts <- Text -> Maybe UTCTime
parseTimeText Text
tsStr
          let (sender', body') = T.breakOn ":" (T.strip rest)
          guard (not (T.null sender'))
          pure (Stamped (ts, fromIntegral idx) (Post (T.strip sender') [] [] (T.strip (T.drop 1 body'))))
    (Text, Text)
_ -> Maybe (Stamped Text)
forall a. Maybe a
Nothing