trackit (empty) → 0.1

raw patch · 6 files changed

+476/−0 lines, 6 filesdep +basedep +brickdep +fsnotifysetup-changed

Dependencies added: base, brick, fsnotify, mtl, optparse-generic, process, process-extras, stm, text, time, vty

Files

• LICENSE +30/−0
• README.md +46/−0
• Setup.hs +2/−0
• src/Main.hs +248/−0
• src/ParseANSI.hs +84/−0
• trackit.cabal +66/−0

@@ -0,0 +1,30 @@+Copyright (c) 2018, Emil Axelsson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Emil Axelsson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,46 @@+# trackit++`trackit` is a command-line tool that listens for changes in a user-supplied directory. Whenever there is a change, a custom command is executed and its standard output is shown live in the terminal.++## Examples++Show a live listing of the files in the current directory:++    > trackit --watch-dir=. --command="ls --color"++Show a live revision graph of a Git repository:++    > GIT_DIR=`git rev-parse --git-dir`+    > trackit --watch-tree=$GIT_DIR --command="git log --graph --all --oneline --decorate --color"++## Installation++`trackit` can be installed from [Hackage](https://hackage.haskell.org/package/trackit) using Cabal:++    > cabal install trackit++## Usage++Run `trackit -h` to get more information about available flags.++`trackit` starts a new buffer in the terminal and uses it to display the output of the command given as the `--command` flag. The display reacts to the following keyboard events:++  * **q** - Quit `trackit`.+  * **arrow keys** - Scroll the output buffer (also with PgUp/PgDown/Home/End).+  * **space key** - Re-run the command and update the buffer. This is useful if no watch directory is provided, or if the output is affected by events outside of the watch directory.++When multiple changes occur in a short time in the watched directory (e.g. when switching branches in a repository), it may not be desired to have `trackit` react to every single change. This is especially the case if the monitored command is expensive (e.g. `git log` in a large repository). For this reason, `trackit` requires a *stabilization period* before running an update. If an event occurs during that period, the period clock is restarted and the update is delayed further.++The stabilization period can be set in milliseconds using the `--stabilization` flag. A lower value gives quicker response times, but increases the risk of getting spurious updates when a tight sequence changes occurs in the watched directory. The default stabilization period is 200 ms.++## Comparison to `watch`++`trackit` offers two main advantages over the similar tool [watch](https://linux.die.net/man/1/watch):++  1. `trackit` only reacts to file system changes. This avoids having to run a potentially costly command periodically. For example, the following command can easily consume a substantial part of your processor's cycles when run in a large repository:++     ```+     > watch -c -t -n 0,5 -- git log --graph --all --oneline --decorate --color+     ```++  2. `trackit` supports scrolling, and keeps the scrolled view even if the output is updated.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,248 @@+module Main where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)+import Control.Monad (fail, forever, void, when)+import Control.Monad.STM (atomically)+import Control.Monad.Trans (liftIO)+import Data.Char (toLower)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Version (showVersion)+import qualified Data.Text.Lazy as LText+import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import System.Exit (exitSuccess)+import System.Process.ListLike (shell)+import qualified System.Process.Text as Text++import System.FSNotify (eventTime, watchTree, withManager)+import qualified System.FSNotify as FSNotify++import Options.Generic+       (ParseRecord (..), type (<?>) (..), getWithHelp, lispCaseModifiers,+        parseRecordWithModifiers, shortNameModifier)++import Brick+import Brick.BChan+import Graphics.Vty++import qualified Paths_trackit as Trackit+import ParseANSI++data CmdOptions = CmdOptions+  { _watchDir      :: Maybe FilePath <?> "Directory to watch for changes in (not sub-directories). Cannot be used together with '--watch-tree'."+  , _watchTree     :: Maybe FilePath <?> "Directory tree to watch for changes in (including sub-directories). Cannot be used together with '--watch-dir'."+  , _command       :: Maybe String   <?> "Command to run"+  , _maxLines      :: Maybe Int      <?> "Maximum number of lines to show (default: 400)"+  , _stabilization :: Maybe Int      <?> "Minimal time (milliseconds) between the any file event and command update (default: 200)"+  , _version       :: Bool           <?> "Print the version number"+  , _help          :: Bool+  } deriving (Show, Generic)++shortName :: String -> Maybe Char+shortName "_watchDir" = Just 'd'+shortName "_watchTree" = Just 't'+shortName (_:c:_) = Just c+shortName _ = Nothing++instance ParseRecord CmdOptions where+  parseRecord =+    parseRecordWithModifiers+      lispCaseModifiers {shortNameModifier = shortName}++data WatchDepth+  = Single+  | Recursive+  deriving (Eq, Show)++data Options = Options+  { watchDir      :: Maybe (FilePath, WatchDepth)+  , command       :: Maybe String+  , maxLines      :: Int+  , stabilization :: NominalDiffTime+  } deriving (Show, Generic)++watchDirError =+  "The flags '--watch-dir' and '--watch-tree' cannot be used together."++getOptions :: IO Options+getOptions = do+  (CmdOptions {..}, showHelp) <- getWithHelp "trackit"+  if | _help -> showHelp >> exitSuccess+     | unHelpful _version ->+       do putStrLn $ showVersion Trackit.version+          exitSuccess+     | otherwise ->+       do watchDir <- case (unHelpful _watchDir, unHelpful _watchTree) of+            (Nothing, Nothing) -> return Nothing+            (Just d, Nothing) -> return $ Just (d, Single)+            (Nothing, Just t) -> return $ Just (t, Recursive)+            _ -> fail watchDirError+          let command = unHelpful _command+              maxLines = fromMaybe 400 $ unHelpful _maxLines+              stabPerMs = fromMaybe 200 $ unHelpful _stabilization+              stabilization = fromIntegral stabPerMs / 1000+          return $ Options {..}++ansiImage :: Text -> Image+ansiImage = foldMap mkLine . map parseANSI . Text.lines+  where+    mkLine ss =+      foldr (<|>) mempty [text a $ LText.fromStrict s | Segment a s <- ss]++-- | Limit the text to @n@ lines (because large buffers make the app slow)+limit :: Int -> Text -> Text+limit n t+  | length ls > n = Text.unlines (take n ls ++ [pruningNotification])+  | otherwise = t <> eof+  where+    ls = Text.lines t+    eof = "\ESC[1m---------- End of output ----------\ESC[m"+    pruningNotification = Text.unwords+      [ "\ESC[1m---------- Lines beyond"+      , Text.pack (show n)+      , "pruned ----------\ESC[m"+      ]++getStdOut :: (a, stdout, b) -> stdout+getStdOut (_, o, _) = o++helpText :: Text+helpText = Text.concat+  [ "No command provided. Run 'trackit --help' for help.\n\n"+  , "Press 'q' to exit this window."+  ]++-- | Run the command provided by the user, or print a helpful text if no command+-- was given+runCMD :: Options -> IO Text+runCMD Options {..} =+  case command of+    Nothing -> return helpText+    Just cmd ->+      limit maxLines . getStdOut <$>+      Text.readCreateProcessWithExitCode (shell cmd) ""++-- | Case-insensitive key-press recognizer+keyPressed :: Char -> BrickEvent n e -> Bool+keyPressed c (VtyEvent (EvKey (KChar c') [])) = toLower c == toLower c'+keyPressed _ _ = False++data AppState = AppState+  { theText :: Text+  }++initState :: AppState+initState = AppState+  { theText = ""+  }++data View = TheView+  deriving (Eq, Ord, Show)++theView :: ViewportScroll View+theView = viewportScroll TheView++drawApp :: AppState -> [Widget View]+drawApp AppState {..} = pure $ viewport TheView Both $ raw $ ansiImage theText++withSize :: ((Int, Int) -> EventM View ()) -> EventM View ()+withSize k = mapM_ k . fmap extentSize =<< lookupExtent TheView++updateApp :: Options -> AppState -> EventM View (Next AppState)+updateApp opts s = do+  newText <- liftIO $ runCMD opts+  continue $ s {theText = newText}++stepApp :: Options -> AppState -> BrickEvent View () -> EventM View (Next AppState)+stepApp _ s (keyPressed 'q' -> True)        = halt s+stepApp _ s (VtyEvent (EvKey KDown []))     = theView `vScrollBy` 1 >> continue s+stepApp _ s (VtyEvent (EvKey KUp []))       = theView `vScrollBy` (-1) >> continue s+stepApp _ s (VtyEvent (EvKey KLeft []))     = withSize (\(w, _) -> theView `hScrollBy` (negate $ div w 2)) >> continue s+stepApp _ s (VtyEvent (EvKey KRight []))    = withSize (\(w, _) -> theView `hScrollBy` (div w 2)) >> continue s+stepApp _ s (VtyEvent (EvKey KHome _))      = vScrollToBeginning theView >> continue s+stepApp _ s (VtyEvent (EvKey KEnd _))       = vScrollToEnd theView >> continue s+stepApp _ s (VtyEvent (EvKey KPageUp []))   = withSize (\(_, h) -> theView `vScrollBy` (negate h)) >> continue s+stepApp _ s (VtyEvent (EvKey KPageDown [])) = withSize (\(_, h) -> theView `vScrollBy` h) >> continue s+stepApp opts s (VtyEvent (EvKey (KChar ' ') _)) = updateApp opts s+stepApp opts s (AppEvent ()) = updateApp opts s+stepApp _ s _ = continue s++myApp :: Options -> App AppState () View+myApp opts =+  App+  { appDraw = drawApp+  , appHandleEvent = stepApp opts+  , appStartEvent = return+  , appAttrMap = const $ attrMap defAttr []+  , appChooseCursor = neverShowCursor+  }++appMain :: Options -> BChan () -> IO AppState+appMain opts updEv =+  customMain (mkVty defaultConfig) (Just updEv) (myApp opts) initState++-- | A loop that continuously looks for events in the 'TVar' and runs the given+-- action whenever there's an event that occurred more than+-- 'stabilization' seconds ago. Then the 'TVar' is emptied. If the event+-- occurred less time ago, it will remain in the 'TVar' and processed in a later+-- iteration (unless overwritten by another event meanwhile).+delayedUpdate ::+     Options+  -> TVar (Maybe FSNotify.Event)+       -- ^ Variable holding the last file event that has not yet been processed+  -> IO () -- ^ Action to perform when the file event has stabilized+  -> IO ()+delayedUpdate Options {..} lastFSEv action =+  forever $ do+    threadDelay loopPeriod+    t <- getCurrentTime+    act <-+      atomically $ do+        mfsEv <- readTVar lastFSEv+        case mfsEv of+          Nothing -> return False+          Just fsEv -> do+            let stable = diffUTCTime t (eventTime fsEv) >= stabilization+            when stable $ writeTVar lastFSEv Nothing+            return stable+    when act action+  where+    loopPeriod = max 10000 $ round (stabilization * 1e6 / 5)+      -- Cap at 10 ms to avoid making the loop too busy when the stabilization+      -- period is small.++main = do+  opts@Options {..} <- getOptions+  lastFSEv <- newTVarIO Nothing -- Channel holding the last file event+  updEv <- newBChan 1 -- Channel for GUI update events+  let setEvent ev = atomically $ writeTVar lastFSEv $ Just ev+      update = writeBChan updEv ()+  update -- Force initial GUI update+  case watchDir of+    Nothing -> void $ appMain opts updEv+    Just (path, depth) -> do+      tid <- forkIO $ delayedUpdate opts lastFSEv update+      withManager $ \m -> do+        void $ case depth of+          Single -> FSNotify.watchDir m path (const True) setEvent+          Recursive -> watchTree m path (const True) setEvent+        void $ appMain opts updEv+      killThread tid++-- Note: The "debouncing" option of fsnotify makes it so that only the *first*+-- in a tight series of events is reported. However, this is problematic since+-- it means that the GUI may miss file events. This can happen if a Git command+-- performs multiple file system operations (which is usually the case) and the+-- command take more time than updating the GUI (e.g. due to the repository+-- being large). It can of course also happen if a Git command is issued just+-- after another one.+--+-- In contrast, the approach taken here is to react to the *last* in a tight+-- sequence of events. A tight sequence is defined as a sequence in which each+-- consecutive pair of events have a time distance of less than+-- `stabilization` seconds. And since `delayedUpdate` runs continuously, there's+-- never a risk that an event will be missed.

@@ -0,0 +1,84 @@+-- | Parse text containing ANSI escape codes+--+-- The parser only handles colors and the \"bold\" property at the moment.+module ParseANSI where++-- Reference: <http://ascii-table.com/ansi-escape-sequences.php>++import Data.Monoid ((<>), Endo (..))+import Data.Text (Text)+import qualified Data.Text as Text++import Graphics.Vty.Attributes++readMay :: Read a => Text -> Maybe a+readMay t = case reads $ Text.unpack t of+  [(a, "")] -> Just a+  _ -> Nothing++onHead :: (a -> a) -> [a] -> [a]+onHead _ [] = []+onHead f (a:as) = f a : as++esc = "\ESC["+escm = "\ESC[m"++-- | Parse a text that has been preceded by an 'esc' sequence+--+-- The result contains the control codes and the rest of the text.+parseEsc :: Text -> Maybe ([Int], Text)+parseEsc t = case Text.uncons rest of+    Just ('m', rest') -> (, rest') <$> parseCodes codes+    _ -> Nothing+  where+    codes = Text.takeWhile (/= 'm') t+    rest = Text.dropWhile (/= 'm') t++    parseCodes :: Text -> Maybe [Int]+    parseCodes = mapM readMay . filter (not . Text.null) . Text.splitOn ";"++-- | Mapping from control code to 'Attr'+-- (reference: <http://ascii-table.com/ansi-escape-sequences.php>)+codeMap :: [(Int, Endo Attr)]+codeMap =+  [ (1,  Endo (`withStyle`     bold))+  , (30, Endo (`withForeColor` black))+  , (31, Endo (`withForeColor` red))+  , (32, Endo (`withForeColor` green))+  , (33, Endo (`withForeColor` yellow))+  , (34, Endo (`withForeColor` blue))+  , (35, Endo (`withForeColor` magenta))+  , (36, Endo (`withForeColor` cyan))+  , (37, Endo (`withForeColor` white))+  ]++-- | Lookup a code in 'codeMap' and return @`Endo` `id`@ if it's not present+lookCode :: Int -> Endo Attr+lookCode c = maybe (Endo id) id $ lookup c codeMap++-- | A text segment paired with some attribute+data Segment = Segment+  { attribute :: Attr+  , content :: Text+  } deriving (Eq, Show)++-- | Parse a segment that has been preceded by an 'esc' sequence and does not+-- have any other occurrences of 'esc' inside+parseSegment :: Text -> Segment+parseSegment s+  | Just (cs, rest) <- parseEsc s = Segment (mkAttr cs) rest+  | otherwise = Segment defAttr s+  where+    mkAttr cs = foldMap lookCode cs `appEndo` defAttr++-- | Parse a text containing ANSI control codes+parseANSI :: Text -> [Segment]+parseANSI = map parseSegment . onHead fixHead . Text.splitOn esc+  where+    -- Ensure that the text starts with an escape code+    fixHead :: Text -> Text+    fixHead h = case Text.breakOn esc h of+      ("", _) -> h -- Already starts with `esc`+      (h1, _empty) -> escm <> h1+        -- No `esc` in the string (because `splitOn` makes sure that the+        -- separator is either first in the segment or absent)

@@ -0,0 +1,66 @@+name:                trackit+version:             0.1+synopsis:            A command-line tool for live monitoring+description:         @trackit@ is a command-line tool that listens for changes+                     in a user-supplied directory. Whenever there is a change,+                     a custom command is executed and its standard output is+                     shown live in the terminal.+                     .+                     = Examples+                     .+                     Show a live listing of the files in the current directory:+                     .+                     >> trackit --watch-dir=. --command="ls --color"+                     .+                     Show a live revision graph of a Git repository:+                     .+                     >> GIT_DIR=`git rev-parse --git-dir`+                     >> trackit --watch-tree=$GIT_DIR --command="git log --graph --all --oneline --decorate --color"+                     .+                     For more information, see the+                     <https://github.com/emilaxelsson/trackit/blob/master/README.md README>.+license:             BSD3+license-file:        LICENSE+author:              Emil Axelsson+maintainer:          78emil@gmail.com+copyright:           2018 Emil Axelsson+category:            Development+build-type:          Simple+cabal-version:       >=1.10++extra-source-files:  README.md++source-repository head+  type:     git+  location: https://github.com/emilaxelsson/trackit.git++executable trackit+  main-is:             Main.hs+  other-modules:       Paths_trackit+                       ParseANSI+  build-depends:       base >=4.10 && <4.11,+                       brick,+                       fsnotify,+                       mtl,+                       optparse-generic,+                       process,+                       process-extras,+                       stm,+                       text,+                       time,+                       vty+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  BangPatterns+                       DataKinds+                       DeriveGeneric+                       ExplicitNamespaces+                       FlexibleInstances+                       MultiWayIf+                       NoMonomorphismRestriction+                       OverloadedStrings+                       RecordWildCards+                       TupleSections+                       TypeOperators+                       ViewPatterns+  ghc-options:         -Wall -Wno-missing-signatures -threaded