{-# LANGUAGE OverloadedStrings #-}

-- | Generic JSONL logs with YAML-frontmattered bodies.
--
-- Each line in the log is a JSON envelope
-- @{ "id": N, "ts": "...", "from": "...", "to": [], "thread": ["...", ...], "body": "..." }@.
-- The body is expected to be a markdown string with optional YAML frontmatter.
--
-- @from@ is the card basename; @thread@ is the raw @residual-of@ names the
-- card depends on (backward edges, stamped verbatim — no id resolution).
-- @to@ is always empty: forward edges (@feeds-into@) are banned.
--
-- The reader tolerates the historical mixed schema: entries written before
-- 19 Aug 2026 carry @from@/@to@/@thread@; entries written between 19 Aug
-- 2026 and the envelope restore carry only @id@/@ts@/@body@. A missing
-- @from@/@thread@ defaults to @\"\"@/@[]@ on read.
module Circuit.Log
  ( -- * Configuration
    LogConfig (..),
    defaultLogConfig,

    -- * Entries
    LogEntry (..),
    readLog,
    readLogEither,
    nextId,
    renderEntry,
    appendEntry,
    formatUtc,
  )
where

import Circuit.Parser.Json (Json (..), decodeJson, encodeJson)
import Data.ByteString.Lazy qualified as BL
import Data.Maybe (fromMaybe)
import Data.Scientific (toBoundedInteger)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8, decodeUtf8', encodeUtf8)
import Data.Text.IO qualified as TIO
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Vector qualified as V
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (takeDirectory)

-- | Configuration for a log file.
newtype LogConfig = LogConfig
  { -- | Path to the JSONL log file.
    LogConfig -> String
logPath :: FilePath
  }
  deriving (Int -> LogConfig -> ShowS
[LogConfig] -> ShowS
LogConfig -> String
(Int -> LogConfig -> ShowS)
-> (LogConfig -> String)
-> ([LogConfig] -> ShowS)
-> Show LogConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogConfig -> ShowS
showsPrec :: Int -> LogConfig -> ShowS
$cshow :: LogConfig -> String
show :: LogConfig -> String
$cshowList :: [LogConfig] -> ShowS
showList :: [LogConfig] -> ShowS
Show)

-- | Default log configuration.
--
-- Points at the coffee permanent archive. Override 'logPath' for other logs.
defaultLogConfig :: LogConfig
defaultLogConfig :: LogConfig
defaultLogConfig =
  LogConfig
    { logPath :: String
logPath = String
"/Users/tonyday567/archive/coffee-permanent.jsonl"
    }

-- | One log entry.
data LogEntry = LogEntry
  { LogEntry -> Int
entryId :: Int,
    -- | ISO-8601 timestamp stored as text so legacy offsets (e.g.
    -- @+10:00@) and clean UTC stamps (e.g. @Z@) coexist.
    LogEntry -> Text
entryTs :: Text,
    LogEntry -> Text
entryFrom :: Text,
    LogEntry -> [Text]
entryThread :: [Text],
    LogEntry -> Text
entryBody :: Text
  }
  deriving (Int -> LogEntry -> ShowS
[LogEntry] -> ShowS
LogEntry -> String
(Int -> LogEntry -> ShowS)
-> (LogEntry -> String) -> ([LogEntry] -> ShowS) -> Show LogEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogEntry -> ShowS
showsPrec :: Int -> LogEntry -> ShowS
$cshow :: LogEntry -> String
show :: LogEntry -> String
$cshowList :: [LogEntry] -> ShowS
showList :: [LogEntry] -> ShowS
Show)

entryToJson :: LogEntry -> Json
entryToJson :: LogEntry -> Json
entryToJson LogEntry
e =
  [(Text, Json)] -> Json
JObject
    [ (Text
"id", Scientific -> Json
JNumber (Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LogEntry -> Int
entryId LogEntry
e))),
      (Text
"ts", Text -> Json
JString (LogEntry -> Text
entryTs LogEntry
e)),
      (Text
"from", Text -> Json
JString (LogEntry -> Text
entryFrom LogEntry
e)),
      (Text
"to", Vector Json -> Json
JArray Vector Json
forall a. Vector a
V.empty),
      (Text
"thread", Vector Json -> Json
JArray ([Json] -> Vector Json
forall a. [a] -> Vector a
V.fromList (Text -> Json
JString (Text -> Json) -> [Text] -> [Json]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogEntry -> [Text]
entryThread LogEntry
e))),
      (Text
"body", Text -> Json
JString (LogEntry -> Text
entryBody LogEntry
e))
    ]

entryFromJson :: Json -> Either String LogEntry
entryFromJson :: Json -> Either String LogEntry
entryFromJson (JObject [(Text, Json)]
pairs) = do
  i <- Text -> [(Text, Json)] -> Either String Json
lookupField Text
"id" [(Text, Json)]
pairs Either String Json
-> (Json -> Either String Int) -> Either String Int
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Json -> Either String Int
asInt
  t <- lookupField "ts" pairs >>= asText
  b <- lookupField "body" pairs >>= asText
  let f = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"from" [(Text, Json)]
pairs Maybe Json -> (Json -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Json -> Maybe Text
asTextMaybe)
      thr = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"thread" [(Text, Json)]
pairs Maybe Json -> (Json -> Maybe [Text]) -> Maybe [Text]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Json -> Maybe [Text]
asTextsMaybe)
  pure (LogEntry i t f thr b)
entryFromJson Json
_ = String -> Either String LogEntry
forall a b. a -> Either a b
Left String
"log entry must be a JSON object"

lookupField :: Text -> [(Text, Json)] -> Either String Json
lookupField :: Text -> [(Text, Json)] -> Either String Json
lookupField Text
key [(Text, Json)]
pairs = case Text -> [(Text, Json)] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
key [(Text, Json)]
pairs of
  Just Json
v -> Json -> Either String Json
forall a b. b -> Either a b
Right Json
v
  Maybe Json
Nothing -> String -> Either String Json
forall a b. a -> Either a b
Left (String
"missing field: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
key)

asInt :: Json -> Either String Int
asInt :: Json -> Either String Int
asInt (JNumber Scientific
n) = case Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
n of
  Just Int
i -> Int -> Either String Int
forall a b. b -> Either a b
Right Int
i
  Maybe Int
Nothing -> String -> Either String Int
forall a b. a -> Either a b
Left (String
"id out of int range: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Scientific -> String
forall a. Show a => a -> String
show Scientific
n)
asInt Json
_ = String -> Either String Int
forall a b. a -> Either a b
Left String
"id must be a number"

asText :: Json -> Either String Text
asText :: Json -> Either String Text
asText (JString Text
t) = Text -> Either String Text
forall a b. b -> Either a b
Right Text
t
asText Json
_ = String -> Either String Text
forall a b. a -> Either a b
Left String
"timestamp and body must be strings"

asTextMaybe :: Json -> Maybe Text
asTextMaybe :: Json -> Maybe Text
asTextMaybe (JString Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
asTextMaybe Json
_ = Maybe Text
forall a. Maybe a
Nothing

asTextsMaybe :: Json -> Maybe [Text]
asTextsMaybe :: Json -> Maybe [Text]
asTextsMaybe (JArray Vector Json
vs) = (Json -> Maybe Text) -> [Json] -> Maybe [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Json -> Maybe Text
asTextMaybe (Vector Json -> [Json]
forall a. Vector a -> [a]
V.toList Vector Json
vs)
asTextsMaybe Json
_ = Maybe [Text]
forall a. Maybe a
Nothing

-- | Format a UTC time as @YYYY-MM-DDTHH:MM:SSZ@.
formatUtc :: UTCTime -> Text
formatUtc :: UTCTime -> Text
formatUtc = 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
"%FT%TZ"

-- | Read all entries from the log.
--
-- Fails on the first parse error. For fault-tolerant reading, use
-- 'readLogEither'.
readLog :: LogConfig -> IO [LogEntry]
readLog :: LogConfig -> IO [LogEntry]
readLog LogConfig
cfg = do
  es <- LogConfig -> IO [Either String LogEntry]
readLogEither LogConfig
cfg
  case sequence es of
    Left String
err -> String -> IO [LogEntry]
forall a. HasCallStack => String -> a
error (String
"readLog: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err)
    Right [LogEntry]
entries -> [LogEntry] -> IO [LogEntry]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LogEntry]
entries

-- | Read all entries, preserving parse errors.
readLogEither :: LogConfig -> IO [Either String LogEntry]
readLogEither :: LogConfig -> IO [Either String LogEntry]
readLogEither LogConfig
cfg = do
  exists <- String -> IO Bool
doesFileExist (LogConfig -> String
logPath LogConfig
cfg)
  if not exists
    then pure []
    else do
      contents <- BL.readFile (logPath cfg)
      case decodeUtf8' (BL.toStrict contents) of
        Left UnicodeException
err -> [Either String LogEntry] -> IO [Either String LogEntry]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> Either String LogEntry
forall a b. a -> Either a b
Left (String
"UTF-8 decode error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err)]
        Right Text
text -> [Either String LogEntry] -> IO [Either String LogEntry]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either String LogEntry
parseLine (Text -> Either String LogEntry)
-> [Text] -> [Either String LogEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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
text))
  where
    parseLine :: Text -> Either String LogEntry
parseLine Text
line =
      case ByteString -> Either String Json
decodeJson (Text -> ByteString
encodeUtf8 Text
line) of
        Left String
err -> String -> Either String LogEntry
forall a b. a -> Either a b
Left (String
"parse error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err)
        Right Json
j -> Json -> Either String LogEntry
entryFromJson Json
j

-- | Next id for a log: one greater than the maximum existing id, or 1.
nextId :: [LogEntry] -> Int
nextId :: [LogEntry] -> Int
nextId [LogEntry]
entries =
  case LogEntry -> Int
entryId (LogEntry -> Int) -> [LogEntry] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LogEntry]
entries of
    [] -> Int
1
    [Int]
ids -> [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ids Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- | Render one entry as a single JSONL line.
renderEntry :: LogEntry -> Text
renderEntry :: LogEntry -> Text
renderEntry = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (LogEntry -> ByteString) -> LogEntry -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Json -> ByteString
encodeJson (Json -> ByteString)
-> (LogEntry -> Json) -> LogEntry -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogEntry -> Json
entryToJson

-- | Append a new entry with the given @from@, @thread@, and body to the log.
appendEntry :: LogConfig -> Text -> [Text] -> Text -> IO ()
appendEntry :: LogConfig -> Text -> [Text] -> Text -> IO ()
appendEntry LogConfig
cfg Text
from [Text]
thread Text
body = do
  entries <- LogConfig -> IO [LogEntry]
readLog LogConfig
cfg
  now <- getCurrentTime
  let entry = Int -> Text -> Text -> [Text] -> Text -> LogEntry
LogEntry ([LogEntry] -> Int
nextId [LogEntry]
entries) (UTCTime -> Text
formatUtc UTCTime
now) Text
from [Text]
thread Text
body
      line = LogEntry -> Text
renderEntry LogEntry
entry Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  createDirectoryIfMissing True (takeDirectory (logPath cfg))
  TIO.appendFile (logPath cfg) line