ztail 1.1 → 1.2
raw patch · 7 files changed
+449/−410 lines, 7 filesdep +bytestringdep +regex-posixdep +unordered-containersdep −containersdep −old-localedep −regex-compatdep ~arraydep ~basedep ~filepath
Dependencies added: bytestring, regex-posix, unordered-containers
Dependencies removed: containers, old-locale, regex-compat
Dependency ranges changed: array, base, filepath, hinotify, process, time, unix
Files
- Display.hs +88/−54
- Main.hs +95/−95
- Tail.hs +55/−61
- TailHandle.hs +111/−107
- TailTypes.hs +57/−35
- Util.hs +27/−53
- ztail.cabal +16/−5
Display.hs view
@@ -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
Main.hs view
@@ -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
Tail.hs view
@@ -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
TailHandle.hs view
@@ -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
TailTypes.hs view
@@ -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
Util.hs view
@@ -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
ztail.cabal view
@@ -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