{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

-- | free-agent bus CLI.
--
-- Subcommands:
--
--   post [ROOT] [--from NAME] [--to NAME]... [--body TEXT]
--   watch [ROOT] NAME [NAME...]
--   read [ROOT] NAME [NAME...] [--since ID | --cursor NAME]
--   cursor [ROOT] get NAME
--   cursor [ROOT] set NAME ID
--   ping-watch [ROOT] NAME
--   status [ROOT] [--threshold SECS]
module Free.Agent.Bus.Cli
  ( BusCommand (..),
    busParser,
    runBusCommand,
    runStatus,
  )
where

import Circuit.Agent (Name, Post (..), PostId, deliversTo, mkPost)
import Circuit.Agent.Framing (Stamped, frameStored, parsePost, stamp, stamped, unframeStored)
import Circuit.Agent.Mark (isHalt, markOf)
import Control.Applicative ((<|>))
import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar, threadDelay)
import Control.Monad (forever, guard, unless, when)
import Data.Foldable (traverse_)
import Data.List (isPrefixOf, sort, sortOn)
import Data.Maybe (listToMaybe, mapMaybe, maybe)
import Data.Ord (Down (..))
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time (LocalTime, NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime, localTimeToUTC, utc)
import Data.Time.Format.ISO8601 (iso8601ParseM)
import Free.Agent.Bus (postLocal)
import Free.Agent.Bus.Daemon (fifoPath, postViaDaemon, runDaemon)
import Free.Agent.Bus.File (readCursor, writeCursor)
import Options.Applicative
import System.Directory (doesFileExist, listDirectory)
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
import System.FSNotify (Event (..), watchDir, withManager)
import System.FilePath (takeDirectory, takeFileName, (</>))
import System.IO
  ( BufferMode (LineBuffering),
    Handle,
    IOMode (AppendMode, ReadMode),
    SeekMode (AbsoluteSeek),
    hFileSize,
    hIsEOF,
    hSeek,
    hSetBuffering,
    openFile,
    stdout,
    withFile,
  )
import Text.Read (readMaybe)

data Since = SinceId PostId | SinceCursor Text
  deriving (Int -> Since -> ShowS
[Since] -> ShowS
Since -> FilePath
(Int -> Since -> ShowS)
-> (Since -> FilePath) -> ([Since] -> ShowS) -> Show Since
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Since -> ShowS
showsPrec :: Int -> Since -> ShowS
$cshow :: Since -> FilePath
show :: Since -> FilePath
$cshowList :: [Since] -> ShowS
showList :: [Since] -> ShowS
Show)

data BusCommand
  = PostCommand FilePath (Maybe Text) [Text] (Maybe Text) Bool
  | WatchCommand FilePath [Text]
  | ReadCommand FilePath [Text] (Maybe Since)
  | CursorGetCommand FilePath Text
  | CursorSetCommand FilePath Text PostId
  | PingWatchCommand FilePath Text
  | StatusCommand FilePath NominalDiffTime
  | DaemonCommand FilePath
  deriving (Int -> BusCommand -> ShowS
[BusCommand] -> ShowS
BusCommand -> FilePath
(Int -> BusCommand -> ShowS)
-> (BusCommand -> FilePath)
-> ([BusCommand] -> ShowS)
-> Show BusCommand
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BusCommand -> ShowS
showsPrec :: Int -> BusCommand -> ShowS
$cshow :: BusCommand -> FilePath
show :: BusCommand -> FilePath
$cshowList :: [BusCommand] -> ShowS
showList :: [BusCommand] -> ShowS
Show)

-- ---------------------------------------------------------------------------
-- Parsers
-- ---------------------------------------------------------------------------

rootOpt :: Parser FilePath
rootOpt :: Parser FilePath
rootOpt =
  ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
    ReadM FilePath
forall s. IsString s => ReadM s
str
    ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"root"
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'r'
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"ROOT"
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"."
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields FilePath
forall a (f :: * -> *). Show a => Mod f a
showDefault
        Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Bus root directory"
    )

nameArg :: Parser Text
nameArg :: Parser Text
nameArg = ReadM Text -> Mod ArgumentFields Text -> Parser Text
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (FilePath -> Text
T.pack (FilePath -> Text) -> ReadM FilePath -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM FilePath
forall s. IsString s => ReadM s
str) (FilePath -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME" Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod ArgumentFields Text
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Agent name")

namesArg :: Parser [Text]
namesArg :: Parser [Text]
namesArg =
  Parser Text -> Parser [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some
    ( ReadM Text -> Mod ArgumentFields Text -> Parser Text
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument
        (FilePath -> Text
T.pack (FilePath -> Text) -> ReadM FilePath -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM FilePath
forall s. IsString s => ReadM s
str)
        (FilePath -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME..." Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod ArgumentFields Text
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Subscriber name(s)")
    )

postCmd :: Parser BusCommand
postCmd :: Parser BusCommand
postCmd = do
  FilePath
root <- Parser FilePath
rootOpt
  Maybe Text
fromName <-
    Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
      ( ReadM Text -> Mod OptionFields Text -> Parser Text
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
          (FilePath -> Text
T.pack (FilePath -> Text) -> ReadM FilePath -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM FilePath
forall s. IsString s => ReadM s
str)
          (FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"from" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Sender name")
      )
  [Text]
toNames <-
    Parser Text -> Parser [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
      ( ReadM Text -> Mod OptionFields Text -> Parser Text
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
          (FilePath -> Text
T.pack (FilePath -> Text) -> ReadM FilePath -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM FilePath
forall s. IsString s => ReadM s
str)
          (FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"to" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Recipient name (repeatable)")
      )
  Maybe Text
bodyText <-
    Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
      ( ReadM Text -> Mod OptionFields Text -> Parser Text
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
          (FilePath -> Text
T.pack (FilePath -> Text) -> ReadM FilePath -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM FilePath
forall s. IsString s => ReadM s
str)
          (FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"body" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"TEXT" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Text
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Post body")
      )
  Bool
viaDaemon <-
    Mod FlagFields Bool -> Parser Bool
switch
      ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"via-daemon"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Submit to the stamping daemon instead of self-stamping"
      )
  pure (FilePath
-> Maybe Text -> [Text] -> Maybe Text -> Bool -> BusCommand
PostCommand FilePath
root Maybe Text
fromName [Text]
toNames Maybe Text
bodyText Bool
viaDaemon)

watchCmd :: Parser BusCommand
watchCmd :: Parser BusCommand
watchCmd = FilePath -> [Text] -> BusCommand
WatchCommand (FilePath -> [Text] -> BusCommand)
-> Parser FilePath -> Parser ([Text] -> BusCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FilePath
rootOpt Parser ([Text] -> BusCommand) -> Parser [Text] -> Parser BusCommand
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Text]
namesArg

readCmd :: Parser BusCommand
readCmd :: Parser BusCommand
readCmd = do
  FilePath
root <- Parser FilePath
rootOpt
  [Text]
names <- Parser [Text]
namesArg
  Maybe Since
since <- Parser Since -> Parser (Maybe Since)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Since
sinceParser
  pure (FilePath -> [Text] -> Maybe Since -> BusCommand
ReadCommand FilePath
root [Text]
names Maybe Since
since)

sinceParser :: Parser Since
sinceParser :: Parser Since
sinceParser =
  (PostId -> Since
SinceId (PostId -> Since) -> Parser PostId -> Parser Since
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM PostId -> Mod OptionFields PostId -> Parser PostId
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM PostId
forall a. Read a => ReadM a
auto (FilePath -> Mod OptionFields PostId
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"since" Mod OptionFields PostId
-> Mod OptionFields PostId -> Mod OptionFields PostId
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields PostId
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"ID" Mod OptionFields PostId
-> Mod OptionFields PostId -> Mod OptionFields PostId
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields PostId
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Only posts with id >= ID"))
    Parser Since -> Parser Since -> Parser Since
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Since
SinceCursor (Text -> Since) -> (FilePath -> Text) -> FilePath -> Since
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Since) -> Parser FilePath -> Parser Since
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"cursor" Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME" Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Only posts at or after .cursor-NAME"))

cursorGetCmd :: Parser BusCommand
cursorGetCmd :: Parser BusCommand
cursorGetCmd = FilePath -> Text -> BusCommand
CursorGetCommand (FilePath -> Text -> BusCommand)
-> Parser FilePath -> Parser (Text -> BusCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FilePath
rootOpt Parser (Text -> BusCommand) -> Parser Text -> Parser BusCommand
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
nameArg

cursorSetCmd :: Parser BusCommand
cursorSetCmd :: Parser BusCommand
cursorSetCmd = FilePath -> Text -> PostId -> BusCommand
CursorSetCommand (FilePath -> Text -> PostId -> BusCommand)
-> Parser FilePath -> Parser (Text -> PostId -> BusCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FilePath
rootOpt Parser (Text -> PostId -> BusCommand)
-> Parser Text -> Parser (PostId -> BusCommand)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
nameArg Parser (PostId -> BusCommand) -> Parser PostId -> Parser BusCommand
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser PostId
idArg
  where
    idArg :: Parser PostId
idArg = ReadM PostId -> Mod ArgumentFields PostId -> Parser PostId
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM PostId
forall a. Read a => ReadM a
auto (FilePath -> Mod ArgumentFields PostId
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"ID" Mod ArgumentFields PostId
-> Mod ArgumentFields PostId -> Mod ArgumentFields PostId
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod ArgumentFields PostId
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Cursor value (next post id)")

cursorCmd :: Parser BusCommand
cursorCmd :: Parser BusCommand
cursorCmd =
  Mod CommandFields BusCommand -> Parser BusCommand
forall a. Mod CommandFields a -> Parser a
subparser
    ( FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"get" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
cursorGetCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Print current cursor"))
        Mod CommandFields BusCommand
-> Mod CommandFields BusCommand -> Mod CommandFields BusCommand
forall a. Semigroup a => a -> a -> a
<> FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"set" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
cursorSetCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Set cursor"))
    )

pingWatchCmd :: Parser BusCommand
pingWatchCmd :: Parser BusCommand
pingWatchCmd = FilePath -> Text -> BusCommand
PingWatchCommand (FilePath -> Text -> BusCommand)
-> Parser FilePath -> Parser (Text -> BusCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FilePath
rootOpt Parser (Text -> BusCommand) -> Parser Text -> Parser BusCommand
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
nameArg

thresholdOpt :: Parser NominalDiffTime
thresholdOpt :: Parser NominalDiffTime
thresholdOpt =
  ReadM NominalDiffTime
-> Mod OptionFields NominalDiffTime -> Parser NominalDiffTime
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
    ((FilePath -> Either FilePath NominalDiffTime)
-> ReadM NominalDiffTime
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader FilePath -> Either FilePath NominalDiffTime
readSeconds)
    ( FilePath -> Mod OptionFields NominalDiffTime
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"threshold"
        Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields NominalDiffTime
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
't'
        Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields NominalDiffTime
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"SECS"
        Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Mod OptionFields NominalDiffTime
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value NominalDiffTime
900
        Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields NominalDiffTime
forall a (f :: * -> *). Show a => Mod f a
showDefault
        Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
-> Mod OptionFields NominalDiffTime
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields NominalDiffTime
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Seconds since last post for the bus to be considered live"
    )
  where
    readSeconds :: FilePath -> Either FilePath NominalDiffTime
readSeconds FilePath
s =
      case ReadS Integer
forall a. Read a => ReadS a
reads FilePath
s of
        [(Integer
n, FilePath
"")] -> NominalDiffTime -> Either FilePath NominalDiffTime
forall a b. b -> Either a b
Right (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger Integer
n :: NominalDiffTime)
        [(Integer, FilePath)]
_ -> FilePath -> Either FilePath NominalDiffTime
forall a b. a -> Either a b
Left (FilePath
"expected a whole number of seconds, got: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
s)

statusCmd :: Parser BusCommand
statusCmd :: Parser BusCommand
statusCmd = FilePath -> NominalDiffTime -> BusCommand
StatusCommand (FilePath -> NominalDiffTime -> BusCommand)
-> Parser FilePath -> Parser (NominalDiffTime -> BusCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FilePath
rootOpt Parser (NominalDiffTime -> BusCommand)
-> Parser NominalDiffTime -> Parser BusCommand
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser NominalDiffTime
thresholdOpt

daemonCmd :: Parser BusCommand
daemonCmd :: Parser BusCommand
daemonCmd = FilePath -> BusCommand
DaemonCommand (FilePath -> BusCommand) -> Parser FilePath -> Parser BusCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FilePath
rootOpt

busParser :: Parser BusCommand
busParser :: Parser BusCommand
busParser =
  Mod CommandFields BusCommand -> Parser BusCommand
forall a. Mod CommandFields a -> Parser a
subparser
    ( FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"post" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
postCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Post a message to the bus"))
        Mod CommandFields BusCommand
-> Mod CommandFields BusCommand -> Mod CommandFields BusCommand
forall a. Semigroup a => a -> a -> a
<> FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"watch" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
watchCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Watch the log for posts addressed to NAMEs"))
        Mod CommandFields BusCommand
-> Mod CommandFields BusCommand -> Mod CommandFields BusCommand
forall a. Semigroup a => a -> a -> a
<> FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"read" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
readCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Read posts addressed to NAMEs"))
        Mod CommandFields BusCommand
-> Mod CommandFields BusCommand -> Mod CommandFields BusCommand
forall a. Semigroup a => a -> a -> a
<> FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"cursor" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
cursorCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Read or write agent cursor"))
        Mod CommandFields BusCommand
-> Mod CommandFields BusCommand -> Mod CommandFields BusCommand
forall a. Semigroup a => a -> a -> a
<> FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"ping-watch" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
pingWatchCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Watch the ping file for NAME and exit on change"))
        Mod CommandFields BusCommand
-> Mod CommandFields BusCommand -> Mod CommandFields BusCommand
forall a. Semigroup a => a -> a -> a
<> FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"status" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
statusCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Bus health: post count, last post, seats"))
        Mod CommandFields BusCommand
-> Mod CommandFields BusCommand -> Mod CommandFields BusCommand
forall a. Semigroup a => a -> a -> a
<> FilePath -> ParserInfo BusCommand -> Mod CommandFields BusCommand
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"daemon" (Parser BusCommand -> InfoMod BusCommand -> ParserInfo BusCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser BusCommand
daemonCmd Parser BusCommand
-> Parser (BusCommand -> BusCommand) -> Parser BusCommand
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (BusCommand -> BusCommand)
forall a. Parser (a -> a)
helper) (FilePath -> InfoMod BusCommand
forall a. FilePath -> InfoMod a
progDesc FilePath
"Run the single-writer stamping daemon"))
    )

-- ---------------------------------------------------------------------------
-- Main dispatch
-- ---------------------------------------------------------------------------

runBusCommand :: BusCommand -> IO ()
runBusCommand :: BusCommand -> IO ()
runBusCommand (PostCommand FilePath
root Maybe Text
mfrom [Text]
mto Maybe Text
mbody Bool
viaDaemon) = FilePath -> Maybe Text -> [Text] -> Maybe Text -> Bool -> IO ()
runPost FilePath
root Maybe Text
mfrom [Text]
mto Maybe Text
mbody Bool
viaDaemon
runBusCommand (WatchCommand FilePath
root [Text]
names) = FilePath -> [Text] -> IO ()
runWatch FilePath
root [Text]
names
runBusCommand (ReadCommand FilePath
root [Text]
names Maybe Since
since) = FilePath -> [Text] -> Maybe Since -> IO ()
runRead FilePath
root [Text]
names Maybe Since
since
runBusCommand (CursorGetCommand FilePath
root Text
name) = FilePath -> Text -> IO ()
runCursorGet FilePath
root Text
name
runBusCommand (CursorSetCommand FilePath
root Text
name PostId
pid) = FilePath -> Text -> PostId -> IO ()
runCursorSet FilePath
root Text
name PostId
pid
runBusCommand (PingWatchCommand FilePath
root Text
name) = FilePath -> Text -> IO ()
runPingWatch FilePath
root Text
name
runBusCommand (StatusCommand FilePath
root NominalDiffTime
threshold) = FilePath -> NominalDiffTime -> IO ()
runStatus FilePath
root NominalDiffTime
threshold
runBusCommand (DaemonCommand FilePath
root) = forall a. PostBody a => FilePath -> IO ()
runDaemon @Text FilePath
root

-- ---------------------------------------------------------------------------
-- post
-- ---------------------------------------------------------------------------

runPost :: FilePath -> Maybe Text -> [Text] -> Maybe Text -> Bool -> IO ()
runPost :: FilePath -> Maybe Text -> [Text] -> Maybe Text -> Bool -> IO ()
runPost FilePath
root Maybe Text
mfrom [Text]
mto Maybe Text
mbody Bool
viaDaemon = do
  -- Honour FREE_AGENT_BUS_ROOT env var when --root is the default "."
  Maybe FilePath
envRoot <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"FREE_AGENT_BUS_ROOT"
  let root' :: FilePath
root' = case Maybe FilePath
envRoot of
        Just FilePath
r | FilePath
root FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." -> FilePath
r
        Maybe FilePath
_ -> FilePath
root
  Post Text
p <- case (Maybe Text
mfrom, Maybe Text
mbody) of
    (Just Text
fromName, Just Text
bodyText) -> Post Text -> IO (Post Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text] -> Text -> Post Text
forall a. Text -> [Text] -> a -> Post a
mkPost Text
fromName [Text]
mto Text
bodyText)
    (Maybe Text
Nothing, Maybe Text
Nothing) -> do
      Text
line <- IO Text
TIO.getLine
      case Text -> Maybe (Post Text)
forall a. PostBody a => Text -> Maybe (Post a)
parsePost Text
line of
        Maybe (Post Text)
Nothing -> do
          Text -> IO ()
TIO.putStrLn Text
"🔴 invalid post JSON"
          IO (Post Text)
forall a. IO a
exitFailure
        Just Post Text
p -> Post Text -> IO (Post Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Post Text
p
    (Maybe Text, Maybe Text)
_ -> do
      Text -> IO ()
TIO.putStrLn Text
"🔴 post requires either --from and --body flags or JSON on stdin"
      IO (Post Text)
forall a. IO a
exitFailure
  Stamped Text
stored <-
    if Bool
viaDaemon
      then do
        let fifo :: FilePath
fifo = ShowS
fifoPath FilePath
root'
        Bool
fifoExists <- FilePath -> IO Bool
doesFileExist FilePath
fifo
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fifoExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
TIO.putStrLn (Text
"🔴 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fifo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" — no bus.fifo; is the daemon running?")
          IO ()
forall a. IO a
exitFailure
        FilePath -> Post Text -> IO (Stamped Text)
postViaDaemon FilePath
root' Post Text
p
      else do
        let logPath :: FilePath
logPath = FilePath
root' FilePath -> ShowS
</> FilePath
"log.jsonl"
        Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
logPath
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
TIO.putStrLn
            ( Text
"🔴 "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
root'
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" — no log.jsonl; not a bus. Set FREE_AGENT_BUS_ROOT or use --root."
            )
          IO ()
forall a. IO a
exitFailure
        FilePath -> Post Text -> IO (Stamped Text)
forall a. PostBody a => FilePath -> Post a -> IO (Stamped a)
postLocal FilePath
root' Post Text
p
  Text -> IO ()
TIO.putStrLn (Stamped Text -> Text
forall a. PostBody a => Stamped a -> Text
frameStored Stamped Text
stored)

-- ---------------------------------------------------------------------------
-- watch
-- ---------------------------------------------------------------------------

runWatch :: FilePath -> [Text] -> IO ()
runWatch :: FilePath -> [Text] -> IO ()
runWatch FilePath
root [Text]
names = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
names) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> IO ()
TIO.putStrLn Text
"🔴 watch requires at least one name"
    IO ()
forall a. IO a
exitFailure
  let path :: FilePath
path = FilePath
root FilePath -> ShowS
</> FilePath
"log.jsonl"
      logName :: FilePath
logName = ShowS
takeFileName FilePath
path
      dir :: FilePath
dir = ShowS
takeDirectory FilePath
path
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
path IOMode
AppendMode (\Handle
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
path IOMode
ReadMode
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
0
  -- Skip existing content; agents start watching from now.
  Integer
size <- Handle -> IO Integer
hFileSize Handle
h
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
size
  (WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
    IO ()
_ <- WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
mgr FilePath
dir (\Event
ev -> ShowS
takeFileName (Event -> FilePath
eventPath Event
ev) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
logName) (Action -> IO (IO ())) -> Action -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Event
_ev -> do
      Handle -> [Text] -> IO ()
drain Handle
h [Text]
names
    -- Block forever; the watch listener runs in the background.
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Int -> IO ()
threadDelay Int
1000000)
  where
    drain :: Handle -> [Text] -> IO ()
    drain :: Handle -> [Text] -> IO ()
drain Handle
h [Text]
names' = do
      Bool
eof <- Handle -> IO Bool
hIsEOF Handle
h
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
eof (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Text
line <- Handle -> IO Text
TIO.hGetLine Handle
h
        (Text -> IO ()) -> Maybe Text -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Text -> IO ()
TIO.putStrLn ([Text] -> Text -> Maybe Text
filterStored [Text]
names' Text
line)
        Handle -> [Text] -> IO ()
drain Handle
h [Text]
names'

filterStored :: [Name] -> Text -> Maybe Text
filterStored :: [Text] -> Text -> Maybe Text
filterStored [Text]
names Text
line = do
  Stamped Text
stored <- forall a. PostBody a => Text -> Maybe (Stamped a)
unframeStored @Text Text
line
  let p :: Post Text
p = Stamped Text -> Post Text
forall r a. Stamped r a -> a
stamped Stamped Text
stored
  if Post Text -> [Text] -> Bool
forall a. Post a -> [Text] -> Bool
deliversTo Post Text
p [Text]
names then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
line else Maybe Text
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------------
-- read
-- ---------------------------------------------------------------------------

runRead :: FilePath -> [Text] -> Maybe Since -> IO ()
runRead :: FilePath -> [Text] -> Maybe Since -> IO ()
runRead FilePath
root [Text]
names Maybe Since
since = do
  PostId
sinceId <- case Maybe Since
since of
    Maybe Since
Nothing -> PostId -> IO PostId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PostId
0
    Just (SinceId PostId
pid) -> PostId -> IO PostId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PostId
pid
    Just (SinceCursor Text
name) -> FilePath -> Text -> IO PostId
readCursor FilePath
root Text
name
  let path :: FilePath
path = FilePath
root FilePath -> ShowS
</> FilePath
"log.jsonl"
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text
content <- FilePath -> IO Text
TIO.readFile FilePath
path
    let lines' :: [Text]
lines' = Text -> [Text]
T.lines Text
content
    (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Text -> IO ()
TIO.putStrLn ((Text -> Maybe Text) -> [Text] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> PostId -> Text -> Maybe Text
filterStoredSince [Text]
names PostId
sinceId) [Text]
lines')

filterStoredSince :: [Name] -> PostId -> Text -> Maybe Text
filterStoredSince :: [Text] -> PostId -> Text -> Maybe Text
filterStoredSince [Text]
names PostId
sinceId Text
line = do
  Stamped Text
stored <- forall a. PostBody a => Text -> Maybe (Stamped a)
unframeStored @Text Text
line
  let p :: Post Text
p = Stamped Text -> Post Text
forall r a. Stamped r a -> a
stamped Stamped Text
stored
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((UTCTime, PostId) -> PostId
forall a b. (a, b) -> b
snd (Stamped Text -> (UTCTime, PostId)
forall r a. Stamped r a -> r
stamp Stamped Text
stored) PostId -> PostId -> Bool
forall a. Ord a => a -> a -> Bool
>= PostId
sinceId)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Post Text -> [Text] -> Bool
forall a. Post a -> [Text] -> Bool
deliversTo Post Text
p [Text]
names)
  pure Text
line

-- ---------------------------------------------------------------------------
-- cursor
-- ---------------------------------------------------------------------------

runCursorGet :: FilePath -> Text -> IO ()
runCursorGet :: FilePath -> Text -> IO ()
runCursorGet FilePath
root Text
name = do
  PostId
pid <- FilePath -> Text -> IO PostId
readCursor FilePath
root Text
name
  Text -> IO ()
TIO.putStrLn (FilePath -> Text
T.pack (PostId -> FilePath
forall a. Show a => a -> FilePath
show PostId
pid))

runCursorSet :: FilePath -> Text -> PostId -> IO ()
runCursorSet :: FilePath -> Text -> PostId -> IO ()
runCursorSet FilePath
root Text
name PostId
pid = FilePath -> Text -> PostId -> IO ()
writeCursor FilePath
root Text
name PostId
pid

-- ---------------------------------------------------------------------------
-- ping-watch
-- ---------------------------------------------------------------------------

runPingWatch :: FilePath -> Text -> IO ()
runPingWatch :: FilePath -> Text -> IO ()
runPingWatch FilePath
root Text
name = do
  let pingPath :: FilePath
pingPath = FilePath
root FilePath -> ShowS
</> (FilePath
".ping-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
name)
      pingName :: FilePath
pingName = ShowS
takeFileName FilePath
pingPath
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
pingPath
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
pingPath IOMode
AppendMode (\Handle
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  (WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
    MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    IO ()
_ <- WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
mgr FilePath
root (\Event
ev -> ShowS
takeFileName (Event -> FilePath
eventPath Event
ev) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
pingName) (Action -> IO (IO ())) -> Action -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Event
_ev -> do
      Text
txt <- FilePath -> IO Text
TIO.readFile FilePath
pingPath
      Text -> IO ()
TIO.putStrLn Text
txt
      MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- ---------------------------------------------------------------------------
-- status
-- ---------------------------------------------------------------------------

-- | Seat status classification for the cursor report.
data SeatStatus = CaughtUp | Done | Behind Integer

-- | Print a bus status report.
--
-- A seat whose latest own post is a halt mark (🟢/🔵) is reported as @done@
-- rather than @behind@: decided quiet is a read, not an inference.
runStatus :: FilePath -> NominalDiffTime -> IO ()
runStatus :: FilePath -> NominalDiffTime -> IO ()
runStatus FilePath
root NominalDiffTime
threshold = do
  let path :: FilePath
path = FilePath
root FilePath -> ShowS
</> FilePath
"log.jsonl"
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> IO ()
TIO.putStrLn (Text
"🔴 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
root Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" — no log.jsonl; not a bus")
    IO ()
forall a. IO a
exitFailure
  Text
content <- FilePath -> IO Text
TIO.readFile FilePath
path
  let ls :: [Text]
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)
      posts :: [Stamped Text]
posts = (Text -> Maybe (Stamped Text)) -> [Text] -> [Stamped Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. PostBody a => Text -> Maybe (Stamped a)
unframeStored @Text) [Text]
ls
      idless :: Int
idless = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ls Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Stamped Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stamped Text]
posts
      maxId :: PostId
maxId = [PostId] -> PostId
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (PostId
0 PostId -> [PostId] -> [PostId]
forall a. a -> [a] -> [a]
: (Stamped Text -> PostId) -> [Stamped Text] -> [PostId]
forall a b. (a -> b) -> [a] -> [b]
map ((UTCTime, PostId) -> PostId
forall a b. (a, b) -> b
snd ((UTCTime, PostId) -> PostId)
-> (Stamped Text -> (UTCTime, PostId)) -> Stamped Text -> PostId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stamped Text -> (UTCTime, PostId)
forall r a. Stamped r a -> r
stamp) [Stamped Text]
posts)
  UTCTime
now <- IO UTCTime
getCurrentTime
  case [Stamped Text]
posts of
    [] ->
      Text -> IO ()
TIO.putStrLn (Text
"🟡 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
root Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" — empty bus (0 posts)")
    [Stamped Text]
_ -> do
      let lastPost :: Stamped Text
lastPost = [Stamped Text] -> Stamped Text
forall a. HasCallStack => [a] -> a
last [Stamped Text]
posts
          age :: NominalDiffTime
age = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now ((UTCTime, PostId) -> UTCTime
forall a b. (a, b) -> a
fst (Stamped Text -> (UTCTime, PostId)
forall r a. Stamped r a -> r
stamp Stamped Text
lastPost))
          live :: Bool
live = NominalDiffTime
age NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
threshold
      Text -> IO ()
TIO.putStrLn
        ( (if Bool
live then Text
"🟢 " else Text
"🟡 ")
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
root
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Bool
live then Text
" — live; " else Text
" — quiet; ")
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show ([Stamped Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Stamped Text]
posts))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" posts"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Int
idless Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idless) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" id-less)" else Text
"")
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; last id="
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (PostId -> FilePath
forall a. Show a => a -> FilePath
show ((UTCTime, PostId) -> PostId
forall a b. (a, b) -> b
snd (Stamped Text -> (UTCTime, PostId)
forall r a. Stamped r a -> r
stamp Stamped Text
lastPost)))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from="
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Post Text -> Text
forall a. Post a -> Text
from (Stamped Text -> Post Text
forall r a. Stamped r a -> a
stamped Stamped Text
lastPost)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" at "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (UTCTime -> FilePath
forall a. Show a => a -> FilePath
show ((UTCTime, PostId) -> UTCTime
forall a b. (a, b) -> a
fst (Stamped Text -> (UTCTime, PostId)
forall r a. Stamped r a -> r
stamp Stamped Text
lastPost)))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
fmtAge NominalDiffTime
age
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ago)"
        )
  [FilePath]
entries <- FilePath -> IO [FilePath]
listDirectory FilePath
root
  let names :: [Text]
names = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text
n | FilePath
e <- [FilePath]
entries, Just Text
n <- [Text -> Text -> Maybe Text
T.stripPrefix Text
".cursor-" (FilePath -> Text
T.pack FilePath
e)]]
  [(Text, PostId)]
cursors <- (Text -> IO (Text, PostId)) -> [Text] -> IO [(Text, PostId)]
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 (\Text
n -> (Text
n,) (PostId -> (Text, PostId)) -> IO PostId -> IO (Text, PostId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Text -> IO PostId
readCursor FilePath
root Text
n) [Text]
names
  let statuses :: [(Text, PostId, SeatStatus)]
statuses = ((Text, PostId) -> (Text, PostId, SeatStatus))
-> [(Text, PostId)] -> [(Text, PostId, SeatStatus)]
forall a b. (a -> b) -> [a] -> [b]
map ([Stamped Text]
-> PostId -> (Text, PostId) -> (Text, PostId, SeatStatus)
seatStatus [Stamped Text]
posts PostId
maxId) [(Text, PostId)]
cursors
      behinds :: [(Text, PostId, Integer)]
behinds = [(Text
n, PostId
c, Integer
u) | (Text
n, PostId
c, Behind Integer
u) <- [(Text, PostId, SeatStatus)]
statuses]
      dones :: [(Text, PostId)]
dones = [(Text
n, PostId
c) | (Text
n, PostId
c, SeatStatus
Done) <- [(Text, PostId, SeatStatus)]
statuses]
      caughtUps :: [(Text, PostId)]
caughtUps = [(Text
n, PostId
c) | (Text
n, PostId
c, SeatStatus
CaughtUp) <- [(Text, PostId, SeatStatus)]
statuses]
  if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
names
    then Text -> IO ()
TIO.putStrLn Text
"seats: no cursors — nothing has ever read this bus"
    else do
      Text -> IO ()
TIO.putStrLn
        ( Text
"seats: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
names))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" cursors, "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show ([(Text, PostId, Integer)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, PostId, Integer)]
behinds))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" behind, "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show ([(Text, PostId)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, PostId)]
dones))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" done, "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show ([(Text, PostId)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, PostId)]
caughtUps))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" caught up"
        )
      ((Text, PostId, Integer) -> IO ())
-> [(Text, PostId, Integer)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
        (\(Text
n, PostId
c, Integer
u) -> Text -> IO ()
TIO.putStrLn (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (PostId -> FilePath
forall a. Show a => a -> FilePath
show PostId
c) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
u) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" unread)"))
        [(Text, PostId, Integer)]
behinds
      ((Text, PostId) -> IO ()) -> [(Text, PostId)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(Text
n, PostId
c) -> Text -> IO ()
TIO.putStrLn (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (PostId -> FilePath
forall a. Show a => a -> FilePath
show PostId
c) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" done")) [(Text, PostId)]
dones
      ((Text, PostId) -> IO ()) -> [(Text, PostId)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(Text
n, PostId
c) -> Text -> IO ()
TIO.putStrLn (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (PostId -> FilePath
forall a. Show a => a -> FilePath
show PostId
c) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" caught up")) [(Text, PostId)]
caughtUps
  where
    seatStatus :: [Stamped Text] -> PostId -> (Name, PostId) -> (Name, PostId, SeatStatus)
    seatStatus :: [Stamped Text]
-> PostId -> (Text, PostId) -> (Text, PostId, SeatStatus)
seatStatus [Stamped Text]
posts PostId
maxId (Text
n, PostId
c)
      | Bool
isDone = (Text
n, PostId
c, SeatStatus
Done)
      | PostId
c PostId -> PostId -> Bool
forall a. Ord a => a -> a -> Bool
> PostId
maxId = (Text
n, PostId
c, SeatStatus
CaughtUp)
      | Bool
otherwise = (Text
n, PostId
c, Integer -> SeatStatus
Behind (PostId -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral PostId
maxId Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- PostId -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral PostId
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 :: Integer))
      where
        isDone :: Bool
isDone =
          case Text -> [Stamped Text] -> Maybe (Stamped Text)
latestBy Text
n [Stamped Text]
posts of
            Maybe (Stamped Text)
Nothing -> Bool
False
            Just Stamped Text
stored -> Bool -> (Mark -> Bool) -> Maybe Mark -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Mark -> Bool
isHalt (Post Text -> Maybe Mark
markOf (Stamped Text -> Post Text
forall r a. Stamped r a -> a
stamped Stamped Text
stored))

    latestBy :: Name -> [Stamped Text] -> Maybe (Stamped Text)
    latestBy :: Text -> [Stamped Text] -> Maybe (Stamped Text)
latestBy Text
n = [Stamped Text] -> Maybe (Stamped Text)
forall a. [a] -> Maybe a
listToMaybe ([Stamped Text] -> Maybe (Stamped Text))
-> ([Stamped Text] -> [Stamped Text])
-> [Stamped Text]
-> Maybe (Stamped Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stamped Text -> Down PostId) -> [Stamped Text] -> [Stamped Text]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (PostId -> Down PostId
forall a. a -> Down a
Down (PostId -> Down PostId)
-> (Stamped Text -> PostId) -> Stamped Text -> Down PostId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime, PostId) -> PostId
forall a b. (a, b) -> b
snd ((UTCTime, PostId) -> PostId)
-> (Stamped Text -> (UTCTime, PostId)) -> Stamped Text -> PostId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stamped Text -> (UTCTime, PostId)
forall r a. Stamped r a -> r
stamp) ([Stamped Text] -> [Stamped Text])
-> ([Stamped Text] -> [Stamped Text])
-> [Stamped Text]
-> [Stamped Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stamped Text -> Bool) -> [Stamped Text] -> [Stamped Text]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
n) (Text -> Bool) -> (Stamped Text -> Text) -> Stamped Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Post Text -> Text
forall a. Post a -> Text
from (Post Text -> Text)
-> (Stamped Text -> Post Text) -> Stamped Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stamped Text -> Post Text
forall r a. Stamped r a -> a
stamped)

fmtAge :: NominalDiffTime -> Text
fmtAge :: NominalDiffTime -> Text
fmtAge NominalDiffTime
s
  | NominalDiffTime
s NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
120 = FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
s :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"s"
  | NominalDiffTime
s NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
7200 = FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime
s NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
60) :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"m"
  | NominalDiffTime
s NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
172800 = FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime
s NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
3600) :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"h"
  | Bool
otherwise = FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime
s NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
86400) :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"d"