diff --git a/Display.hs b/Display.hs --- a/Display.hs +++ b/Display.hs @@ -1,62 +1,71 @@ -{-# LANGUAGE PatternGuards #-} -module Display ( - TermColor, - parseColor, - errMsg, - output, - reset +{-# LANGUAGE PatternGuards, ViewPatterns, GeneralizedNewtypeDeriving #-} +module Display + ( TermColor + , parseColor + , rawErrMsg + , Output(..) + , runOutput ) where -import System.IO -import Data.Char -import Util +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan (newChan, readChan, writeChan) +import qualified Data.ByteString.Char8 as BS +import Data.Char (isDigit, isAlphaNum) +import Data.List (stripPrefix) +import Data.Monoid ((<>)) +import System.IO (stdout, stderr, hPutStrLn) -type TermColor = [Int] +newtype TermColor = TermColor [Int] deriving (Monoid) -displayColor :: TermColor -> String -displayColor [] = "" -displayColor c = - "\ESC[" ++ (join ';' (map show c)) ++ "m" +displayColor :: TermColor -> BS.ByteString +displayColor (TermColor []) = BS.empty +displayColor (TermColor c) = esc <> BS.intercalate semi (map (BS.pack . show) c) `BS.snoc` 'm' where + esc = BS.pack "\ESC[" + semi = BS.singleton ';' +displayResetColor :: BS.ByteString displayResetColor = displayColor colorReset isInteger :: String -> Bool isInteger [] = False isInteger x = all isDigit x +colorReset :: TermColor colorReset = colorValue "reset" + +-- TODO: use terminfo! colorValue :: String -> TermColor -colorValue "reset" = [0] -colorValue "bo" = [1] ---colorValue "dark" = [2] -colorValue "so" = [3] -colorValue "hl" = [3] -colorValue "ul" = [4] -colorValue "bl" = [5] -colorValue "rev" = [7] -colorValue "hidden" = [8] -colorValue "nobo" = [22]--[21] ---colorValue "nodark" = [22] -colorValue "noso" = [23] -colorValue "nohl" = [23] -colorValue "noul" = [24] -colorValue "nobl" = [25] -colorValue "norev" = [27] -colorValue "nohidden" = [28] -colorValue "black" = [30] -colorValue "red" = [31] -colorValue "green" = [32] -colorValue "yellow" = [33] -colorValue "blue" = [34] -colorValue "magenta" = [35] -colorValue "cyan" = [36] -colorValue "white" = [37] -colorValue "default" = [39] -colorValue ('c':'o':'l':'o':'r':n) | isInteger n = [38,5,read n] -colorValue ('m':'o':'d':'e':n) | isInteger n = [read n] -colorValue ('b':'r':'i':'g':'h':'t':c) | [n] <- colorValue c, n >= 30 && n < 40 = [60 + n] -colorValue ('b':'r':c) | [n] <- colorValue c, n >= 30 && n < 40 = [60 + n] -colorValue ('/':c) | (n:r) <- colorValue c = 10+n:r +colorValue "reset" = TermColor [0] +colorValue "bo" = TermColor [1] +--colorValue "dark" = TermColor [2] +colorValue "so" = TermColor [3] +colorValue "hl" = TermColor [3] +colorValue "ul" = TermColor [4] +colorValue "bl" = TermColor [5] +colorValue "rev" = TermColor [7] +colorValue "hidden" = TermColor [8] +colorValue "nobo" = TermColor [22]--[21] +--colorValue "nodark" = TermColor [22] +colorValue "noso" = TermColor [23] +colorValue "nohl" = TermColor [23] +colorValue "noul" = TermColor [24] +colorValue "nobl" = TermColor [25] +colorValue "norev" = TermColor [27] +colorValue "nohidden" = TermColor [28] +colorValue "black" = TermColor [30] +colorValue "red" = TermColor [31] +colorValue "green" = TermColor [32] +colorValue "yellow" = TermColor [33] +colorValue "blue" = TermColor [34] +colorValue "magenta" = TermColor [35] +colorValue "cyan" = TermColor [36] +colorValue "white" = TermColor [37] +colorValue "default" = TermColor [39] +colorValue ('c':'o':'l':'o':'r':n) | isInteger n = TermColor [38,5,read n] +colorValue ('m':'o':'d':'e':n) | isInteger n = TermColor [read n] +colorValue ('b':'r':'i':'g':'h':'t':(colorValue -> TermColor [n])) | n >= 30 && n < 40 = TermColor [60 + n] +colorValue ('b':'r':(colorValue -> TermColor [n])) | n >= 30 && n < 40 = TermColor [60 + n] +colorValue ('/':(colorValue -> TermColor (n:r))) = TermColor $ 10+n:r colorValue "normal" = colorValue "reset" colorValue "bold" = colorValue "bo" @@ -76,21 +85,46 @@ colorValue x = error ("unknown color name: " ++ x) +colorSep :: Char -> Bool colorSep = not . isAlphaNum parseColor :: String -> TermColor -parseColor [] = [] +parseColor [] = mempty parseColor s@(c:s') | colorSep c = parseColor s' - | otherwise = colorValue x ++ parseColor r + | otherwise = colorValue x <> parseColor r where (x, r) = break colorSep s -errMsg :: String -> IO () -errMsg m = hPutStrLn stderr (displayResetColor ++ m) +displayColorFrom :: TermColor -> TermColor -> BS.ByteString +displayColorFrom (TermColor o) c@(TermColor n) + | Just d <- stripPrefix o n = displayColor $ TermColor d + | otherwise = displayColor $ colorReset <> c -output :: TermColor -> String -> IO () -output c m = putStrLn (displayColor (colorReset ++ c) ++ m) +rawErrMsg :: String -> IO () +rawErrMsg m = BS.hPutStr stderr displayResetColor >> hPutStrLn stderr m -reset :: IO () -reset = putStr displayResetColor +data Output + = OutputLine + { outputColor :: !TermColor + , outputText :: !BS.ByteString + } + | OutputError + { outputText :: !BS.ByteString + } + +runOutput :: IO (Output -> IO ()) +runOutput = do + chan <- newChan + let + loop p = do + o <- readChan chan + let (h, c, t) = case o of + OutputLine{ outputColor = c', outputText = t' } -> (stdout, c', t') + OutputError{ outputText = t' } -> (stderr, mempty, t') + BS.hPutStr h $ displayColorFrom p c + BS.hPutStrLn h t + loop c + + _ <- forkIO $ loop mempty + return $ writeChan chan diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,23 +1,26 @@ -{-# LANGUAGE CPP #-} -import System.Exit -import Control.Monad -import qualified System.Environment -import qualified System.Console.GetOpt as GetOpt -import System.Posix.Signals (installHandler, sigINT, Handler(..)) -import qualified GHC.IO.Exception -import qualified System.IO.Error -import qualified Control.Concurrent -import qualified Control.Exception -import Data.IORef -import qualified Text.Regex +{-# LANGUAGE CPP, TupleSections, OverloadedStrings #-} +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Exception (AsyncException(UserInterrupt), fromException, handle) +import Control.Monad (void, when, join) +import Data.Bits ((.|.)) +import qualified Data.ByteString.Char8 as BS +import Data.IORef (newIORef, readIORef, atomicModifyIORef') +import Data.List (foldl') +import Data.Monoid ((<>)) +import GHC.IO.Exception (IOErrorType(UnsupportedOperation)) +import qualified System.Console.GetOpt as Opt +import System.Environment (getArgs) +import System.Exit (ExitCode(..), exitSuccess, exitFailure, exitWith) #ifdef INOTIFY import qualified System.INotify as INotify #endif +import System.IO.Error (ioeGetErrorType) +import System.Posix.Signals (installHandler, sigINT, Handler(..)) +import Text.Regex.Posix (makeRegexOpts, compExtended, compIgnoreCase, compNoSub, defaultExecOpt) import Util import Display import TailTypes -import Tail import TailHandle data Options = Options @@ -26,6 +29,7 @@ , optionMatch :: TailMatch } +defaultTail :: Tail defaultTail = Tail { tailTarg = undefined -- read "-" , tailPollInterval = 5 @@ -43,6 +47,7 @@ , tailMatches = [] } +defaultOptions :: Options defaultOptions = Options { optionTails = [] , optionTail = defaultTail @@ -59,29 +64,31 @@ add_action a o = set_opt add o where add t = t{ tailMatches = (optionMatch o, a) : (tailMatches t) } +prog_header, prog_usage :: String prog_header = "Usage: ztail [OPTIONS] FILE ...\n\ Follow the specified files (ala tail -f). FILE may be a path, '-' for stdin,\n\ or '&N' for file descriptor N. OPTIONS apply only to the following FILE\n\ -except those marked *, and match options (-amn) apply to all following actions\n\ -(-hcdse). Actions involving TEXT can contain the following \\-escapes:\n\ +except those marked '*' which apply to all following FILEs. Match options\n\ +(-amn) apply to all following actions (-hcdse). Actions involving TEXT can\n\ +contain the following \\-escapes:\n\ \\0 current file \\@ current time (from -t)\n\ \\_ current line \\` \\' pre- and post-matching text\n\ \\& matching text \\N (1-9) group in match\n\ \&" --" -prog_usage = GetOpt.usageInfo prog_header prog_options +prog_usage = Opt.usageInfo prog_header prog_options -prog_options :: [GetOpt.OptDescr (Options -> Options)] +prog_options :: [Opt.OptDescr (Options -> Options)] prog_options = - [ GetOpt.Option "i" ["interval"] - (GetOpt.ReqArg (\i -> set_opt $ \p -> p + [ Opt.Option "i" ["interval"] + (Opt.ReqArg (\i -> set_opt $ \p -> p { tailPollInterval = read i #ifdef INOTIFY , tailPollINotify = False #endif }) "INT") ("*poll for data every INT seconds [" ++ show (tailPollInterval defaultTail) ++ "]") - , GetOpt.Option "r" ["reopen"] - (GetOpt.OptArg (\i -> set_opt $ \p -> p + , Opt.Option "r" ["reopen"] + (Opt.OptArg (\i -> set_opt $ \p -> p { tailReopenInterval = maybe (tailPollInterval p) read i #ifdef INOTIFY , tailReopenINotify = False @@ -89,74 +96,75 @@ }) "INT") ("*check file name (like tail -F) every INT seconds or every poll [" ++ show (tailReopenInterval defaultTail) ++ "]") #ifdef INOTIFY - , GetOpt.Option "I" ["inotify"] - (GetOpt.OptArg (\i -> set_opt $ \p -> p + , Opt.Option "I" ["inotify"] + (Opt.OptArg (\i -> set_opt $ \p -> p { tailPollINotify = True , tailPollInterval = maybe 0 read i }) "INT") ("*use inotify to poll for new data (and also poll every INT)") - , GetOpt.Option "R" ["ireopen"] - (GetOpt.NoArg (set_opt $ \p -> p + , Opt.Option "R" ["ireopen"] + (Opt.NoArg (set_opt $ \p -> p { tailReopenINotify = True })) ("*use inotify to monitor file renames (only for preexisting, leaf files)") #endif - , GetOpt.Option "b" ["begin"] - (GetOpt.NoArg (set_opt $ \p -> p + , Opt.Option "b" ["begin"] + (Opt.NoArg (set_opt $ \p -> p { tailBegin = True })) (" start reading at the beginning of the file (rather than only new lines at the end)") - , GetOpt.Option "l" ["dirlist"] - (GetOpt.NoArg (set_opt $ \p -> p + , Opt.Option "l" ["dirlist"] + (Opt.NoArg (set_opt $ \p -> p { tailDirList = True })) (" watch the contents of a directory, reporting when files are added or removed") - , GetOpt.Option "D" ["dirtail"] - (GetOpt.NoArg (set_opt $ \p -> p + , Opt.Option "D" ["dirtail"] + (Opt.NoArg (set_opt $ \p -> p { tailDirTail = True })) (" tail all the files in a directory") - , GetOpt.Option "A" ["recursive"] - (GetOpt.NoArg (set_opt $ \p -> p + , Opt.Option "A" ["recursive"] + (Opt.NoArg (set_opt $ \p -> p { tailDirRecursive = True })) (" apply the above directory modifiers recursively") - , GetOpt.Option "t" ["timefmt"] - (GetOpt.ReqArg (\t -> set_opt $ \p -> p + , Opt.Option "t" ["timefmt"] + (Opt.ReqArg (\t -> set_opt $ \p -> p { tailTimeFmt = t }) "FMT") ("*set time format for \\@ substitution (in strftime(3)) [" ++ tailTimeFmt defaultTail ++ "]") - , GetOpt.Option "T" ["timestamp"] - (GetOpt.OptArg (maybe id $ \t -> add_action (ActionSubst "\\@ \\_") . set_opt (\p -> p + , Opt.Option "T" ["timestamp"] + (Opt.OptArg (maybe id $ \t -> add_action (ActionSubst "\\@ \\_") . set_opt (\p -> p { tailTimeFmt = t })) "FMT") (" timestamp with FMT; equivalent to: [-t FMT] -h '\\@ '") - , GetOpt.Option "a" ["all"] - (GetOpt.NoArg (set_match MatchAll)) + , Opt.Option "a" ["all"] + (Opt.NoArg (set_match MatchAll)) (" perform following action for every line from this FILE (default)") - , GetOpt.Option "m" ["match"] - (GetOpt.ReqArg (\m -> set_match $ MatchRegex $ Text.Regex.mkRegexWithOpts m False True) "REGEX") + , Opt.Option "m" ["match"] + (Opt.ReqArg (set_match . MatchRegex . makeRegexOpts compExtended defaultExecOpt) "REGEX") (" perform following action for each line matching REGEX") - , GetOpt.Option "M" ["imatch"] - (GetOpt.ReqArg (\m -> set_match $ MatchRegex $ Text.Regex.mkRegexWithOpts m False False) "REGEX") + , Opt.Option "M" ["imatch"] + (Opt.ReqArg (set_match . MatchRegex . makeRegexOpts (compExtended .|. compIgnoreCase) defaultExecOpt) "REGEX") (" perform following action for each line matching REGEX (case-insensitive)") - , GetOpt.Option "n" ["no-match"] - (GetOpt.ReqArg (\m -> set_match $ MatchNotRegex $ Text.Regex.mkRegexWithOpts m False True) "REGEX") + , Opt.Option "n" ["no-match"] + (Opt.ReqArg (set_match . MatchNotRegex . makeRegexOpts (compExtended .|. compNoSub) defaultExecOpt) "REGEX") (" perform following action for each line not matching REGEX") - , GetOpt.Option "N" ["no-imatch"] - (GetOpt.ReqArg (\m -> set_match $ MatchNotRegex $ Text.Regex.mkRegexWithOpts m False False) "REGEX") + , Opt.Option "N" ["no-imatch"] + (Opt.ReqArg (set_match . MatchNotRegex . makeRegexOpts (compExtended .|. compNoSub .|. compIgnoreCase) defaultExecOpt) "REGEX") (" perform following action for each line not matching REGEX (case-insensitive)") - , GetOpt.Option "h" ["header"] - (GetOpt.ReqArg (\h -> add_action $ ActionSubst (h ++ "\\_")) "TEXT") + , Opt.Option "h" ["header"] + (Opt.ReqArg (add_action . ActionSubst . (<> "\\_") . BS.pack) "TEXT") (" display TEXT header before (matching) lines (same as -s 'TEXT\\_')") - , GetOpt.Option "c" ["color"] - (GetOpt.ReqArg (\c -> add_action $ ActionColor $ parseColor c) "COLOR") + , Opt.Option "c" ["color"] + (Opt.ReqArg (add_action . ActionColor . parseColor) "COLOR") (" display (matching) lines in COLOR (valid colors are: normal, bo,ul,bl,rev, nobo,noul..., black,red,green,yellow,blue,magenta,cyan,white, /black,/red,...)") - , GetOpt.Option "d" ["hide"] - (GetOpt.NoArg (add_action ActionHide)) + , Opt.Option "d" ["hide"] + (Opt.NoArg (add_action ActionHide)) (" hide (matching) lines") - , GetOpt.Option "s" ["substitute"] - (GetOpt.ReqArg (\s -> add_action $ ActionSubst s) "TEXT") + , Opt.Option "s" ["substitute"] + (Opt.ReqArg (add_action . ActionSubst . BS.pack) "TEXT") (" substitute (matching) lines with TEXT") - , GetOpt.Option "e" ["execute"] - (GetOpt.ReqArg (\e -> add_action $ ActionExecute e) "PROG") + , Opt.Option "e" ["execute"] + (Opt.ReqArg (add_action . ActionExecute . BS.pack) "PROG") (" execute PROG for every (matching) line") ] +prog_arg :: String -> Options -> Options prog_arg a Options{ optionTails = l, optionTail = t } = Options { optionTails = t { tailTarg = read a @@ -172,64 +180,56 @@ , optionMatch = MatchAll } -run :: [Tail] -> IO (Control.Concurrent.MVar ExitCode) +run :: [Tail] -> IO (MVar ExitCode) run tails = do - emv <- Control.Concurrent.newEmptyMVar - let exit = Control.Concurrent.putMVar emv - exit0 = exit ExitSuccess - exit1 = exit (ExitFailure 1) - installHandler sigINT (CatchOnce exit0) Nothing - - lockv <- Control.Concurrent.newQSem 0 - let lock = Control.Exception.bracket_ (Control.Concurrent.waitQSem lockv) (Control.Concurrent.signalQSem lockv) - unlock = Control.Exception.bracket_ (Control.Concurrent.signalQSem lockv) (Control.Concurrent.waitQSem lockv) - incr r = atomicModifyIORef r (\i -> (succ i, ())) - + emv <- newEmptyMVar count <- newIORef (length tails) - errors <- newIORef 0 + errors <- newIORef False #ifdef INOTIFY inotify <- - catchWhen ((GHC.IO.Exception.UnsupportedOperation ==) . System.IO.Error.ioeGetErrorType) - (Just =.< INotify.initINotify) + catchWhen ((UnsupportedOperation ==) . ioeGetErrorType) + (Just <$> INotify.initINotify) (return Nothing) #endif - - let error t e = case Control.Exception.fromException e of - Just Control.Exception.UserInterrupt -> exit0 - _ -> tailErrMsg t (show e) >> incr errors + out <- runOutput + let done = do + e <- readIORef errors + putMVar emv $ if e + then ExitFailure 1 + else ExitSuccess + err t e = case fromException e of + Just UserInterrupt -> done + _ -> tailErrMsg tr t (BS.pack $ show e) >> atomicModifyIORef' errors (const (True, ())) tr = TailRuntime - { trText = tailText - , trAddTail = (incr count >>) . runt - , trUnlock = unlock + { trOutput = out + , trAddTail = (atomicModifyIORef' count ((, ()) . succ) >>) . runt #ifdef INOTIFY , trINotify = inotify #endif } - runt t = void $ Control.Concurrent.forkIO $ lock $ do - Control.Exception.handle (error t) $ runTail tr t - i <- atomicModifyIORef count (\i -> (pred i, i)) - when (i == 1) $ do - e <- readIORef errors - if e > 0 - then exit1 - else exit0 + runt t = void $ forkIOUnmasked $ do + handle (err t) $ runTail tr t + i <- atomicModifyIORef' count (join (,) . pred) + when (i == 0) $ done + + _ <- installHandler sigINT (CatchOnce done) Nothing mapM_ runt tails - Control.Concurrent.signalQSem lockv return emv +main :: IO () main = do - args <- System.Environment.getArgs - tails <- case (GetOpt.getOpt (GetOpt.ReturnInOrder prog_arg) prog_options args) of - (s, [], []) -> case optionTails $ foldl (\s t -> t s) defaultOptions s of + args <- getArgs + tails <- case Opt.getOpt (Opt.ReturnInOrder prog_arg) prog_options args of + (s, [], []) -> case optionTails $ foldl' (flip ($)) defaultOptions s of [] -> do putStrLn prog_usage - exitWith ExitSuccess - t -> return t + exitSuccess + t -> return $ reverse t (_, _, err) -> do mapM_ putStrLn err putStrLn prog_usage exitFailure - e <- run tails >>= Control.Concurrent.takeMVar + e <- run tails >>= takeMVar when (e == ExitSuccess) $ - errMsg "ztail: done" + rawErrMsg "ztail: done" exitWith e diff --git a/Tail.hs b/Tail.hs --- a/Tail.hs +++ b/Tail.hs @@ -1,82 +1,76 @@ -module Tail ( - tailText +{-# LANGUAGE OverloadedStrings #-} +module Tail + ( tailText ) where import Data.Array (Array, array, (//), (!)) -import Text.Regex -import qualified Data.Char -import qualified System.Exit -import qualified System.Cmd -import qualified Data.Time.Clock -import qualified Data.Time.LocalTime -import qualified Data.Time.Format -import qualified System.Locale +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 Display import TailTypes -type Substitutions = Array Char String +type Substitutions = Array Char BS.ByteString default_subst :: Substitutions -default_subst = array ('\0','\127') [('\\',"\\")] +default_subst = array ('\0','\127') [('\\',BS.singleton '\\')] timeFmt :: String -> IO String timeFmt f = do - t <- Data.Time.Clock.getCurrentTime - z <- Data.Time.LocalTime.getCurrentTimeZone - return $ Data.Time.Format.formatTime System.Locale.defaultTimeLocale f (Data.Time.LocalTime.utcToLocalTime z t) + t <- getCurrentTime + z <- getTimeZone t + return $ formatTime defaultTimeLocale f (utcToLocalTime z t) -shellEscape :: String -> String -shellEscape [] = [] -shellEscape (c:l) - | Data.Char.isAlphaNum c = c: shellEscape l - | otherwise = '\\':c: shellEscape l +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 -> (String -> String) -> String -> String -substText sub f str = go str - where - go ('\\':x:l) = f (sub!x) ++ go l - go (x:l) = x : go l - go [] = [] +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 -> String -> Maybe Substitutions +matchText :: Substitutions -> TailMatch -> BS.ByteString -> Maybe Substitutions matchText sub MatchAll t = Just (sub // [('_',t)]) matchText sub (MatchRegex m) t = - case matchRegexAll m t of - Nothing -> Nothing - Just (pre, mat, post, exps) -> - Just (sub - // [('_',t), ('`',pre), ('&',mat), ('\'',post)] - // zip ['1'..'9'] exps) + (\(pre, mat, post, exps) -> + (sub + // [('_',t), ('`',pre), ('&',mat), ('\'',post)] + // zip ['1'..'9'] exps)) + <$> matchM m t matchText sub (MatchNotRegex m) t = - case matchRegex m t of - Nothing -> Just (sub // [('_',t)]) - Just _ -> Nothing + not (matchTest m t) ?> (sub // [('_',t)]) -execute :: Tail -> String -> IO System.Exit.ExitCode -execute th e = - tailErrMsg th ("execute: " ++ e) >> - System.Cmd.system e +execute :: TailRuntime -> Tail -> BS.ByteString -> IO ExitCode +execute tr th e = do + tailErrMsg tr th ("execute: " <> e) + system $ BS.unpack e -processText :: Tail -> String -> IO () -processText t x = do +tailText :: TailRuntime -> Tail -> BS.ByteString -> IO () +tailText tr t x = do now <- timeFmt $ tailTimeFmt t - let init_sub = default_subst // [('0',tailName t),('@',now)] - case foldl mact (Just x, init_sub, [], []) (tailMatches t) of - (Nothing, _, _, _) -> nop - (Just out, _, color, exec) -> - output color out >> - mapM_ (execute t) exec + mapM_ proc $ foldlM mact (x, default_subst // [('0',tailName t),('@',BS.pack now)], mempty, []) (tailMatches t) where - mact r@(Nothing, _, _, _) _ = r - mact r@(Just s, sub, cl, el) (m, a) = - case matchText sub m s of - Nothing -> r - Just sub -> case a of - ActionNone -> (Just s, sub, cl, el) - ActionHide -> (Nothing, sub, cl, el) - ActionColor c -> (Just s, sub, c ++ cl, el) - ActionSubst s' -> (Just (substText sub id s'), sub, cl, el) - ActionExecute e -> (Just s, sub, cl, (substText sub shellEscape e) : el) - -tailText = processText + 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 diff --git a/TailHandle.hs b/TailHandle.hs --- a/TailHandle.hs +++ b/TailHandle.hs @@ -1,33 +1,38 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, ForeignFunctionInterface #-} -module TailHandle ( - runTail +{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings, ForeignFunctionInterface #-} +module TailHandle + ( runTail ) where -import Control.Monad -import System.Posix.Types -import System.Posix.Files -import System.Posix.Directory -import System.Posix.IO -import System.IO.Error +import Control.Concurrent (ThreadId, myThreadId, threadWaitRead, yield, killThread) +import Control.Concurrent.MVar (newEmptyMVar, readMVar) +import Control.Exception (Exception(..), asyncExceptionToException, asyncExceptionFromException, catch, throwTo, mask) +import Control.Monad ((>=>), guard, when, unless, forever) +import qualified Data.ByteString.Char8 as BS +import Data.Functor (($>)) +import qualified Data.HashSet as Set import Data.List (genericTake, genericLength) -import Data.Maybe -import qualified Data.Set as Set -import GHC.IO.Handle (SeekMode(AbsoluteSeek)) -import Control.Concurrent -import qualified Control.Exception -import qualified Data.Typeable -#ifdef INOTIFY -import qualified System.INotify as INotify -#endif -import Data.IORef -import Foreign.Ptr (Ptr) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import Data.Typeable (Typeable) import Foreign.C.Types (CInt(..)) import Foreign.C.Error (throwErrnoIfNull) -import qualified Unsafe.Coerce +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr, castPtr) import System.FilePath (()) +#ifdef INOTIFY +import qualified System.INotify as INotify +#endif +import System.IO.Error (isDoesNotExistError, isEOFError, isFullError) +import System.IO (SeekMode(AbsoluteSeek)) +import System.Posix.Directory (DirStream, readDirStream, rewindDirStream) +import System.Posix.Files (getFileStatus, getFdStatus, isRegularFile, isNamedPipe, isSocket, isCharacterDevice, isDirectory, fileID, fileSize) +import System.Posix.IO (openFd, OpenMode(ReadOnly), OpenFileFlags(..), fdReadBuf, fdSeek, setFdOption, FdOption(NonBlockingRead), closeFd) +import System.Posix.Types (Fd(..), FileOffset, FileID) +import Unsafe.Coerce (unsafeCoerce) import Util import TailTypes +import Tail data TailHandle = TailHandle { thTail :: Tail @@ -37,9 +42,9 @@ , thFd :: Maybe Fd , thPos :: FileOffset -- or -1 for blocking fd , thIno :: Maybe FileID - , thBuf :: String + , thBuf :: BS.ByteString , thDirStream :: Maybe DirStream - , thDirList :: Set.Set FilePath + , thDirList :: Set.HashSet FilePath , thAgain :: Bool #ifdef INOTIFY , thPollWatch :: Maybe INotify.WatchDescriptor @@ -52,42 +57,42 @@ | SignalReopen | SignalInsert String Bool | SignalDelete String - deriving (Show, Data.Typeable.Typeable, Eq, Ord) -instance Control.Exception.Exception TailSignal + deriving (Show, Typeable, Eq, Ord) +instance Exception TailSignal where + toException = asyncExceptionToException + fromException = asyncExceptionFromException -thErrMsg = tailErrMsg . thTail +thErrMsg :: TailHandle -> BS.ByteString -> IO () +thErrMsg t = tailErrMsg (thRuntime t) (thTail t) catchDoesNotExist :: IO a -> IO (Maybe a) -catchDoesNotExist f = catchWhen isDoesNotExistError (liftM Just f) (return Nothing) +catchDoesNotExist f = catchWhen isDoesNotExistError (Just <$> f) (return Nothing) +bad :: String -> IO a bad = ioError . userError closeTail :: TailHandle -> IO TailHandle closeTail th@TailHandle{ thFd = Nothing } = return th closeTail th@TailHandle{ thFd = Just fd } = do #ifdef INOTIFY - whenJust rm_watch (thPollWatch th) - whenJust rm_watch (thReopenWatch th) + mapM_ INotify.removeWatch (thPollWatch th) + mapM_ INotify.removeWatch (thReopenWatch th) #endif closeFd fd - return th{ - thFd = Nothing - , thPos = 0 - , thIno = Nothing -#ifdef INOTIFY - , thPollWatch = Nothing - , thReopenWatch = Nothing -#endif - } + return th + { thFd = Nothing + , thPos = 0 + , thIno = Nothing #ifdef INOTIFY - where - rm_watch = INotify.removeWatch + , thPollWatch = Nothing + , thReopenWatch = Nothing #endif + } seekTail :: FileOffset -> TailHandle -> IO TailHandle seekTail _ TailHandle{ thFd = Nothing } = bad "seek on closed fd" seekTail c th@TailHandle{ thFd = Just fd } = - fdSeek fd AbsoluteSeek c >. th{ thPos = c } + fdSeek fd AbsoluteSeek c $> th{ thPos = c } inotifyTail :: TailHandle -> IO TailHandle #ifdef INOTIFY @@ -110,31 +115,31 @@ notdot "" = False notdot ('.':_) = False notdot _ = True - add l = INotify.addWatch inotify l path (whenJust (Control.Exception.throwTo tid) . sig) + add l = INotify.addWatch inotify l path (mapM_ (throwTo tid) . sig) poll <- justWhen (ipoll && pos >= 0) $ if isJust (thDirStream th) then add [INotify.OnlyDir, INotify.Move, INotify.Create, INotify.Delete] else add [INotify.Modify] reopen <- justWhen ireopen $ add [INotify.MoveSelf, INotify.DeleteSelf] - return th{ - thPollWatch = poll, - thReopenWatch = reopen - } + return th + { thPollWatch = poll + , thReopenWatch = reopen + } #endif inotifyTail th = return th foreign import ccall unsafe fdopendir :: CInt -> IO (Ptr ()) fdOpenDirStream :: Fd -> IO DirStream -fdOpenDirStream (Fd d) = (Unsafe.Coerce.unsafeCoerce :: Ptr () -> DirStream) =.< throwErrnoIfNull "fdOpenDirStream" (fdopendir d) +fdOpenDirStream (Fd d) = (unsafeCoerce :: Ptr () -> DirStream) <$> throwErrnoIfNull "fdOpenDirStream" (fdopendir d) readDirStreamAll :: DirStream -> IO [FilePath] readDirStreamAll d = readDirStream d >>= c where c [] = return [] c ('.':_) = readDirStreamAll d - c f = (f :) =.< readDirStreamAll d + c f = (f :) <$> readDirStreamAll d subTail :: TailHandle -> Bool -> FilePath -> IO () -subTail th@TailHandle{ thRuntime = tr, thTail = t@Tail{ tailTarg = TailPath p } } new f | tailDirTail t || tailDirList t = +subTail TailHandle{ thRuntime = tr, thTail = t@Tail{ tailTarg = TailPath p } } new f | tailDirTail t || tailDirList t = trAddTail tr t { tailTarg = TailPath (p f) , tailFileTail = tailDirTail t @@ -152,9 +157,9 @@ openFd path ReadOnly Nothing OpenFileFlags{ append = False, exclusive = False, noctty = False, nonBlock = True, trunc = False }) - got Nothing = thErrMsg th "No such file or directory" >. th{ thPos = 0 } + got Nothing = thErrMsg th "No such file or directory" $> th{ thPos = 0 } got (Just fd) = do - setFdOption fd NonBlockingRead True + setFdOption fd NonBlockingRead True -- is this really necessary? inotifyTail =<< go fd =<< getFdStatus fd go fd stat | isRegularFile stat = @@ -169,7 +174,7 @@ mapM_ (subTail th'' False) nl return th'' | otherwise = - closeFd fd >> thErrMsg th "Unsupported file type" >. th + closeFd fd >> thErrMsg th "Unsupported file type" $> th where th' = th{ thFd = Just fd, thIno = Just (fileID stat), thAgain = True, thPos = 0 } sz = fileSize stat @@ -178,8 +183,8 @@ reopenTail :: TailHandle -> IO TailHandle reopenTail th@TailHandle{ thTail = Tail{ tailTarg = TailPath path }, thIno = ino } = do - stat <- catchDoesNotExist $ getFileStatus path - case stat of + fstat <- catchDoesNotExist $ getFileStatus path + case fstat of Nothing -> return th Just _ | ino == Nothing -> openTail th Just stat | ino == Just (fileID stat) -> return th @@ -189,68 +194,69 @@ closeTail th >>= openTail reopenTail th = return th -noRead :: TailHandle -> (TailHandle, [String]) +noRead :: TailHandle -> (TailHandle, [BS.ByteString]) noRead th = (th{ thAgain = False }, []) -bufsiz :: ByteCount +bufsiz :: Int bufsiz = 8192 -insertMsg :: String -> String -insertMsg = ('+':) - -deleteMsg :: String -> String -deleteMsg = ('-':) +insertMsg, deleteMsg :: FilePath -> BS.ByteString +insertMsg = BS.cons '+' . BS.pack +deleteMsg = BS.cons '-' . BS.pack -readTail :: TailHandle -> IO (TailHandle, [String]) +readTail :: TailHandle -> IO (TailHandle, [BS.ByteString]) readTail th@TailHandle{ thFd = Nothing } = return (noRead th) readTail th@TailHandle{ thDirStream = Just ds } = do dl <- rewindDirStream ds >> readDirStreamAll ds let df f (n, o, s) | Set.member f o = (n, Set.delete f o, s) | otherwise = (f : n, o, Set.insert f s) - (nl, os, ds) = foldr df ([], thDirList th, thDirList th) dl + let (nl, os, s) = foldr df ([], thDirList th, thDirList th) dl mapM_ (subTail th True) nl - return (th{ thDirList = Set.difference ds os, thAgain = False }, + return (th{ thDirList = Set.difference s os, thAgain = False }, guard (tailDirList (thTail th)) >> map insertMsg nl ++ map deleteMsg (Set.toList os)) readTail th@TailHandle{ thFd = Just fd, thPos = pos } = if pos == -1 then catchWhen isEOFError readsock $ do - checkbuf th >.= noRead + noRead <$> checkbuf th -- thErrMsg th "closed?" -- closeTail th >.= noRead th - else getFdStatus fd >.= fileSize >>= gotlen + else gotlen . fileSize =<< getFdStatus fd where - checkbuf th@TailHandle{ thBuf = buf } = do - when (buf /= "") $ - thErrMsg th ("Unterminated line: " ++ buf) - return th{ thBuf = "" } + checkbuf th'@TailHandle{ thBuf = buf } = do + unless (BS.null buf) $ + thErrMsg th' ("Unterminated line: " <> buf) + return th'{ thBuf = BS.empty } gotlen len | len < pos = do - thErrMsg th ("File truncated to " ++ show len) + thErrMsg th ("File truncated to " <> BS.pack (show len)) seekTail 0 th >>= readTail | len == pos = do - checkbuf th >.= noRead + noRead <$> checkbuf th | otherwise = do let count = min (fromIntegral (len - pos)) bufsiz - (buf, buflen) <- readit (fromIntegral count) + buf <- readit count + let buflen = BS.length buf when (buflen /= count) $ - thErrMsg th ("Short read (" ++ show buflen ++ "/" ++ show count ++ ")") + thErrMsg th ("Short read (" <> BS.pack (show buflen) <> BS.singleton '/' <> BS.pack (show count) <> BS.singleton ')') return $ gotbuf th{ thPos = pos + fromIntegral buflen, thAgain = buflen == bufsiz } buf readsock = - readit bufsiz >.= fst >.= gotbuf th{ thAgain = True } - gotbuf th "" = noRead th - gotbuf th@TailHandle{ thBuf = oldbuf } buf = - case initlast $ split (== '\n') buf of + gotbuf th{ thAgain = True } <$> readit bufsiz + gotbuf th'@TailHandle{ thBuf = oldbuf } buf + | BS.null buf = noRead th' + | otherwise = case initLast $ BS.split '\n' buf of ([], r) -> - (th{ thBuf = oldbuf ++ r }, []) + (th'{ thBuf = oldbuf <> r }, []) (l1 : l, r) -> - (th{ thBuf = r }, (oldbuf ++ l1) : l) + (th'{ thBuf = r }, (oldbuf <> l1) : l) readit len = catchWhen isFullError - (fdRead fd len) - (return ("", 0)) + (allocaBytes len $ \p -> do + l <- fdReadBuf fd p (fromIntegral len) + BS.packCStringLen (castPtr p, fromIntegral l)) + (return BS.empty) pause :: IO () -pause = threadDelay (30*60*1000000) -- fixme how? (-1) doesn't work +pause = readMVar =<< newEmptyMVar waitTail :: TailHandle -> IO () waitTail TailHandle{ thFd = Nothing } = pause @@ -258,26 +264,26 @@ waitTail TailHandle{ thAgain = True } = yield waitTail TailHandle{ thTail = Tail{ tailPollInterval = i } } | i == 0 = pause - | otherwise = threadDelay (fromInterval i) + | otherwise = threadDelayInterval i -reopenThread :: Int -> ThreadId -> IO () +reopenThread :: Interval -> ThreadId -> IO () reopenThread ri tid = forever $ do - threadDelay ri - Control.Exception.throwTo tid SignalReopen + threadDelayInterval ri + throwTo tid SignalReopen newTail :: TailRuntime -> Tail -> IO TailHandle -newTail tr tail = do +newTail tr t@Tail{ tailReopenInterval = ri } = do tid <- myThreadId - rid <- justWhen (ri /= 0) $ forkIO (reopenThread ri tid) + rid <- justWhen (ri /= 0) $ forkIOUnmasked $ reopenThread ri tid return TailHandle - { thTail = tail + { thTail = t , thRuntime = tr , thPoll = tid , thReopen = rid , thFd = Nothing - , thPos = if tailBegin tail then 0 else -1 + , thPos = if tailBegin t then 0 else -1 , thIno = Nothing - , thBuf = [] + , thBuf = BS.empty , thDirStream = Nothing , thDirList = Set.empty , thAgain = True @@ -286,33 +292,31 @@ , thReopenWatch = Nothing #endif } - where - ri = fromInterval (tailReopenInterval tail) runTail :: TailRuntime -> Tail -> IO () -runTail tr tail = Control.Exception.mask $ \unmask -> +runTail tr tl = mask $ \unmask -> let - catch th SignalReopen = reopenTail th -- >>= wait - catch th SignalPoll = return th{ thAgain = True } - catch th@TailHandle{ thDirStream = Just _, thDirList = l, thTail = t } (SignalInsert f new) = do + signal th SignalReopen = reopenTail th -- >>= wait + signal th SignalPoll = return th{ thAgain = True } + signal th@TailHandle{ thDirStream = ~(Just _), thDirList = l, thTail = t } (SignalInsert f new) = do subTail th new f if tailDirList t then proc th' [insertMsg f] else return th' where th' = th{ thDirList = Set.insert f l } - catch th@TailHandle{ thDirStream = Just _, thDirList = l, thTail = t } (SignalDelete f) = + signal th@TailHandle{ thDirStream = ~(Just _), thDirList = l, thTail = t } (SignalDelete f) = if tailDirList t then proc th' [deleteMsg f] else return th' where th' = th{ thDirList = Set.delete f l } - wait th = Control.Exception.catch - (trUnlock tr $ unmask $ waitTail th >. th) - (catch th >=> wait) + wait th = catch + (unmask $ waitTail th $> th) + (signal th >=> wait) poll th | thReopen th == Nothing && (thFd th == Nothing || (thAgain th == False && thPos th /= -1 - && fromInterval (tailPollInterval (thTail th)) == 0 + && tailPollInterval (thTail th) == 0 #ifdef INOTIFY && thPollWatch th == Nothing && thReopenWatch th == Nothing @@ -321,9 +325,9 @@ = return th | otherwise = wait th >>= go go th = readTail th >>= uncurry proc >>= poll - proc th s = mapM_ fun s >. th - fun = (trText tr) tail + proc th s = mapM_ fun s $> th + fun = tailText tr tl in - newTail tr tail >>= + newTail tr tl >>= openTail >>= go >>= - \TailHandle{ thReopen = wid } -> whenJust killThread wid + mapM_ killThread . thReopen diff --git a/TailTypes.hs b/TailTypes.hs --- a/TailTypes.hs +++ b/TailTypes.hs @@ -1,60 +1,82 @@ -{-# LANGUAGE CPP, Rank2Types #-} -module TailTypes ( - Interval, - fromInterval, - TailTarget(..), - TailRuntime(..), - TailMatch(..), TailAction(..), - TailMatches, - Tail(..), - tailName, tailErrMsg +{-# LANGUAGE CPP, Rank2Types, OverloadedStrings #-} +module TailTypes + ( Interval + , threadDelayInterval + , TailTarget(..) + , TailRuntime(..) + , TailMatch(..) + , TailAction(..) + , TailMatches + , Tail(..) + , tailName + , tailErrMsg + , tailOutput ) where -import qualified System.Posix.Types -import qualified System.Posix.IO -import qualified Text.Regex +import Control.Arrow (first) +import Control.Concurrent (threadDelay) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Fixed as Fixed +import Data.Monoid ((<>)) #ifdef INOTIFY import qualified System.INotify as INotify #endif +import System.Posix.Types (Fd) +import System.Posix.IO (stdInput) +import Text.Regex.Posix (Regex) import Display -newtype Interval = Interval { fromInterval :: Int } deriving (Eq, Ord) +newtype Interval = Interval { intervalMicroseconds :: Int } + deriving (Eq, Ord, Bounded) + +intervalToFixed :: Interval -> Fixed.Micro +intervalToFixed (Interval i) = Fixed.MkFixed (toInteger i) + +intervalFromFixed :: Fixed.Micro -> Interval +intervalFromFixed (Fixed.MkFixed i) + | i < 0 = error "intervalFromFixed: negative interval" + | i > toInteger (intervalMicroseconds maxBound) = error "intervalFromFixed: interval too large" + | otherwise = Interval (fromInteger i) + instance Show Interval where - show (Interval x) - | x `mod` 1000000 == 0 = show (x `div` 1000000) - | otherwise = show (fromIntegral x / 1000000.0) + show = Fixed.showFixed True . intervalToFixed instance Read Interval where - readsPrec n s = map (\(x,s) -> (Interval $ floor (1000000.0 * x), s)) $ readsPrec n s + readsPrec n s = map (first intervalFromFixed) $ readsPrec n s instance Num Interval where Interval x + Interval y = Interval (x + y) - Interval x * Interval y = Interval (x * y) + x * y = intervalFromFixed $ intervalToFixed x * intervalToFixed y Interval x - Interval y = Interval (x - y) negate (Interval x) = Interval (negate x) abs (Interval x) = Interval (abs x) signum (Interval x) = Interval (signum x) - fromInteger n = Interval (fromInteger $ 1000000 * n) + fromInteger = intervalFromFixed . fromInteger -data TailTarget = TailPath !FilePath | TailFd !System.Posix.Types.Fd +threadDelayInterval :: Interval -> IO () +threadDelayInterval (Interval i) = threadDelay i + +data TailTarget + = TailPath !FilePath + | TailFd !Fd instance Show TailTarget where show (TailFd 0) = "-" show (TailFd x) = '&':(show x) show (TailPath path) = path instance Read TailTarget where - readsPrec _ "-" = [(TailFd System.Posix.IO.stdInput, "")] - readsPrec n ('&':s) = map (\(f,s) -> (TailFd f, s)) $ readsPrec n s + readsPrec _ "-" = [(TailFd stdInput, "")] + readsPrec n ('&':s) = map (first TailFd) $ readsPrec n s readsPrec _ s = [(TailPath s, "")] data TailMatch = MatchAll - | MatchRegex !Text.Regex.Regex - | MatchNotRegex !Text.Regex.Regex + | MatchRegex !Regex + | MatchNotRegex !Regex data TailAction = ActionNone | ActionHide | ActionColor !TermColor - | ActionSubst !String - | ActionExecute !String + | ActionSubst !BS.ByteString + | ActionExecute !BS.ByteString type TailMatches = [(TailMatch, TailAction)] data Tail = Tail @@ -74,19 +96,19 @@ , tailMatches :: !TailMatches } -tailName :: Tail -> String -tailName = show . tailTarg - -tailErrMsg :: Tail -> String -> IO () -tailErrMsg t msg = - errMsg ("ztail " ++ tailName t ++ ": " ++ msg) +tailName :: Tail -> BS.ByteString +tailName = BS.pack . show . tailTarg data TailRuntime = TailRuntime - { trUnlock :: forall a. IO a -> IO a + { trOutput :: Output -> IO () , trAddTail :: Tail -> IO () - , trText :: Tail -> String -> IO () #ifdef INOTIFY , trINotify :: Maybe INotify.INotify #endif } +tailErrMsg :: TailRuntime -> Tail -> BS.ByteString -> IO () +tailErrMsg r t = trOutput r . OutputError . (("ztail " <> tailName t <> ": ") <>) + +tailOutput :: TailRuntime -> TermColor -> BS.ByteString -> IO () +tailOutput tr c = trOutput tr . OutputLine c diff --git a/Util.hs b/Util.hs --- a/Util.hs +++ b/Util.hs @@ -1,64 +1,38 @@ -module Util ( - split, - join, - initlast, - (>.=), (>.), (=.<), - nop, - justIf, - whenJust, justWhen, - catchWhen +module Util + ( initLast + , nop + , (?>) + , justWhen + , catchWhen + , forkIOUnmasked ) where -import qualified Control.Exception -import Control.Monad hiding (join) - -split :: (a -> Bool) -> [a] -> [[a]] -{-# SPECIALIZE split :: (Char -> Bool) -> String -> [String] #-} -split p = splitp where - splitp [] = [[]] - splitp (x:l) - | p x = [] : splitp l - | otherwise = (x:l1) : l' - where (l1:l') = splitp l - -join :: a -> [[a]] -> [a] -{-# SPECIALIZE join :: Char -> [String] -> String #-} -join p = joinp where - joinp [] = [] - joinp [x] = x - joinp (x:l) = x ++ p : joinp l - -initlast :: [a] -> ([a], a) -initlast [] = error "initlast: empty list" -initlast [x] = ([], x) -initlast (x:l) = (x:l1, r) where - (l1, r) = initlast l - -infixl 1 >., >.= -infixr 1 =.< -(>.) :: Monad m => m a -> b -> m b -(>.=) :: Monad m => m a -> (a -> b) -> m b -(=.<) :: Monad m => (a -> b) -> m a -> m b +import Control.Applicative (Alternative, empty) +import Control.Arrow (first) +import Control.Concurrent (ThreadId, forkIOWithUnmask) +import Control.Exception (Exception, catchJust) +import Control.Monad (guard) -(>.) e r = e >> return r -(>.=) e r = e >>= return . r -(=.<) r e = return . r =<< e -- fmap, <$>, liftM +initLast :: [a] -> ([a], a) +initLast [] = error "initlast: empty list" +initLast [x] = ([], x) +initLast (x:l) = first (x:) $ initLast l nop :: Monad m => m () nop = return () --- Data.Foldable.mapM_ -whenJust :: Monad m => (a -> m ()) -> Maybe a -> m () -whenJust = maybe nop - --- (>.) . guard -justIf :: Bool -> a -> Maybe a -justIf False = const Nothing -justIf True = Just +-- |@'($>)' . guard@ +(?>) :: Alternative f => Bool -> a -> f a +False ?> _ = empty +True ?> a = pure a +infixr 1 ?> justWhen :: Monad m => Bool -> m a -> m (Maybe a) justWhen False _ = return Nothing -justWhen True r = Just =.< r +justWhen True r = Just <$> r -catchWhen :: Control.Exception.Exception e => (e -> Bool) -> IO a -> IO a -> IO a -catchWhen t f h = Control.Exception.catchJust (guard . t) f (\() -> h) +catchWhen :: Exception e => (e -> Bool) -> IO a -> IO a -> IO a +catchWhen t f h = catchJust (guard . t) f (\() -> h) + +forkIOUnmasked :: IO () -> IO ThreadId +forkIOUnmasked f = forkIOWithUnmask $ \u -> u f diff --git a/ztail.cabal b/ztail.cabal --- a/ztail.cabal +++ b/ztail.cabal @@ -1,5 +1,5 @@ Name: ztail -Version: 1.1 +Version: 1.2 Author: Dylan Simon Maintainer: dylan@dylex.net License: BSD3 @@ -8,8 +8,8 @@ Description: An even more improved version of xtail/tail -f, including inotify support, full regex-based filtering, substitution, and colorization. Category: System,Console Build-Type: Simple -Cabal-Version: >= 1.6 -tested-with: GHC == 6.12.3 +Cabal-Version: >= 1.10 +tested-with: GHC == 7.10.3 extra-source-files: README Source-Repository head @@ -23,7 +23,18 @@ Executable ztail Main-is: Main.hs Other-Modules: Util, Display, TailTypes, TailHandle, Tail - Build-Depends: base == 4.*, regex-compat, unix, time, old-locale, process, array, containers, filepath + Default-Language: Haskell2010 + GHC-Options: -Wall -fno-warn-tabs + Build-Depends: + base == 4.8.*, + unix == 2.7.*, + time == 1.5.*, + process >= 1.2 && < 1.5, + array == 0.5.*, + filepath == 1.4.*, + bytestring == 0.10.*, + regex-posix < 1, + unordered-containers == 0.2.* if flag(inotify) - Build-Depends: hinotify >= 0.3.6 + Build-Depends: hinotify >= 0.3.6 && < 0.4 CPP-Options: -DINOTIFY