ztail-1.2: Tail.hs

{-# LANGUAGE OverloadedStrings #-}
module Tail
  ( tailText
  ) where

import Data.Array (Array, array, (//), (!))
import qualified Data.ByteString.Char8 as BS
import Data.Foldable (foldlM)
import Data.Monoid ((<>))
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getTimeZone, utcToLocalTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Text.Regex.Posix (matchM, matchTest)
import System.Exit (ExitCode)
import System.Process (system)

import Util
import TailTypes

type Substitutions = Array Char BS.ByteString
default_subst :: Substitutions
default_subst = array ('\0','\127') [('\\',BS.singleton '\\')]

timeFmt :: String -> IO String
timeFmt f = do
  t <- getCurrentTime
  z <- getTimeZone t
  return $ formatTime defaultTimeLocale f (utcToLocalTime z t)

shellEscape :: BS.ByteString -> BS.ByteString
-- shellEscape = BS.concatMap $ \c -> if isAlphaNum c then BS.singleton c else BS.pack ['\\',c]
shellEscape s
  | BS.null s = s
  | otherwise = '\\' `BS.cons` BS.intersperse '\\' s

substText :: Substitutions -> (BS.ByteString -> BS.ByteString) -> BS.ByteString -> BS.ByteString
substText sub f = BS.concat . go . BS.split '\\' where
  go (h:t) = h : rep t
  go l = l
  rep (p:l)
    | Just (c, r) <- BS.uncons p = f (sub!c) : r : rep l
    | otherwise = f (sub!'\\') : go l
  rep [] = []

matchText :: Substitutions -> TailMatch -> BS.ByteString -> Maybe Substitutions
matchText sub MatchAll t = Just (sub // [('_',t)])
matchText sub (MatchRegex m) t =
  (\(pre, mat, post, exps) ->
    (sub
      // [('_',t), ('`',pre), ('&',mat), ('\'',post)]
      // zip ['1'..'9'] exps))
    <$> matchM m t
matchText sub (MatchNotRegex m) t =
  not (matchTest m t) ?> (sub // [('_',t)])

execute :: TailRuntime -> Tail -> BS.ByteString -> IO ExitCode
execute tr th e = do
  tailErrMsg tr th ("execute: " <> e)
  system $ BS.unpack e

tailText :: TailRuntime -> Tail -> BS.ByteString -> IO ()
tailText tr t x = do
  now <- timeFmt $ tailTimeFmt t
  mapM_ proc $ foldlM mact (x, default_subst // [('0',tailName t),('@',BS.pack now)], mempty, []) (tailMatches t)
  where
  proc (out, _, color, exec) = do
    tailOutput tr color out
    mapM_ (execute tr t) exec
  mact r@(s, sub, cl, el) (m, a)
    | Just sub' <- matchText sub m s = case a of
        ActionNone -> return (s, sub', cl, el)
        ActionHide -> Nothing
        ActionColor c -> return (s, sub', c <> cl, el)
        ActionSubst s' -> return (substText sub' id s', sub', cl, el)
        ActionExecute e -> return (s, sub', cl, (substText sub' shellEscape e) : el)
    | otherwise = return r