fswatch (empty) → 0.1.0.0

raw patch · 8 files changed

+499/−0 lines, 8 filesdep +basedep +directorydep +fsnotifysetup-changed

Dependencies added: base, directory, fsnotify, fswatch, haskeline, optparse-applicative, process

Files

ChangeLog.md +5/−0
LICENSE +30/−0
Setup.hs +2/−0
fswatch.cabal +41/−0
src/Main.hs +9/−0
src/System/FSWatch.hs +254/−0
src/System/FSWatch/Repr.hs +80/−0
src/System/FSWatch/Slave.hs +78/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for fswatch
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2017, -
+
+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 - 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.

+ Setup.hs view

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

+ fswatch.cabal view

@@ -0,0 +1,41 @@+
+name:                fswatch
+version:             0.1.0.0
+synopsis:            File System watching tool with cli and slave functionalities.
+description:         File System watching tool with cli and slave lib (with os process) functionalities.
+category:            Filesystem
+homepage:            https://github.com/kelemzol/watch
+license:             BSD3
+license-file:        LICENSE
+author:              Zoltan Kelemen
+maintainer:          -
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     System.FSWatch
+                     , System.FSWatch.Repr
+                     , System.FSWatch.Slave
+  build-depends:       base >=4.9 && <4.10
+                     , haskeline >=0.7 && <0.8
+                     , directory >=1.3.0
+                     , fsnotify >=0.2.1
+                     , optparse-applicative >= 0.13.2
+                     , process >=1.4.3
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+
+executable hfswatch
+  ghc-options:         -threaded
+  main-is:             Main.hs
+  other-extensions:    ViewPatterns, RecordWildCards
+  build-depends:       base >=4.9 && <4.10
+                     , haskeline >=0.7 && <0.8
+                     , directory >=1.3.0
+                     , fsnotify >=0.2.1
+                     , optparse-applicative >= 0.13.2
+                     , process >=1.4.3
+                     , fswatch
+  hs-source-dirs:      src
+  default-language:    Haskell2010

+ src/Main.hs view

@@ -0,0 +1,9 @@+
+module Main where
+
+import System.FSWatch (watchMain)
+
+
+main :: IO ()
+main = watchMain
+

+ src/System/FSWatch.hs view

@@ -0,0 +1,254 @@+
+{-# LANGUAGE ViewPatterns
+           , RecordWildCards
+           #-}
+
+module System.FSWatch where
+
+import Data.List
+import Data.Semigroup ((<>))
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Concurrent.MVar
+import Options.Applicative hiding (defaultPrefs)
+
+import System.Console.Haskeline
+import System.Console.Haskeline.History
+import System.Console.Haskeline.Completion
+import System.Directory
+import System.FSNotify
+import System.IO
+
+import System.FSWatch.Repr
+
+optParser :: Parser Opts
+optParser = Opts
+    <$> switch
+        ( long "slave"
+       <> help "cli - normal mode; slave - no buffering on std in/out, no prompt, one line records")
+    <*> option auto
+        ( long "fix-buffering"
+       <> metavar "NUMBER"
+       <> help "fix time loop; NUMBER in ms"
+       <> showDefault
+       <> value 0)
+    <*> option auto
+        ( long "delayed-buffering"
+       <> metavar "NUMBER"
+       <> help "delayed bufferint from last; NUMBER in ms"
+       <> showDefault
+       <> value 0)
+
+getOpts :: IO Opts
+getOpts = execParser opts
+  where
+    opts = info (optParser <**> helper)
+      ( fullDesc
+     <> progDesc "File watching tool"
+     <> header "[header]" )
+
+watchMain :: IO ()
+watchMain = do
+    opts <- getOpts
+    ch <- newChan
+    prompt <- newMVar "% "
+    printFormat <- newMVar MultiRecord
+    buffering <- newMVar $ case (oFixBufferMode opts, oDelayedBufferMode opts) of
+      (0,0) -> NoNotifyBuffer
+      (i,0) -> FixTimeBuffer i
+      (0,i) -> DelayedBuffer i
+    mode <- newMVar CLI
+    case oSlave opts of
+        True -> do
+            hSetNewlineMode stdin (NewlineMode LF LF)
+            hSetNewlineMode stdout (NewlineMode LF LF)
+            hSetNewlineMode stderr (NewlineMode LF LF)
+            hSetBuffering stdin NoBuffering
+            hSetBuffering stdout NoBuffering
+            hSetBuffering stderr NoBuffering
+            liftIO $ modifyMVarMasked_ prompt (\ _ -> return "")
+            liftIO $ modifyMVarMasked_ printFormat (\ _ -> return SingleRecord)
+            liftIO $ modifyMVarMasked_ mode (\ _ -> return SLAVE)
+        False -> return ()
+    killPrinter <- startPrinter (State {..}) printFormat ch
+    runInputTWithPrefs
+      defaultPrefs
+      Settings { complete = compl, historyFile = Nothing, autoAddHistory = False }
+      (loop (State {..}) (killPrinter, ch) [])
+  where
+    loop :: State -> P -> DB -> InputT IO ()
+    loop state@(State {..}) p db = do
+        promptStr <- liftIO $ readMVar prompt
+        minput <- getInputLine promptStr
+        case minput of
+            Nothing -> return ()
+            Just "" -> loop state p db
+            Just (words -> ["exit"])    -> do
+                liftIO (fst p)
+                printP p ""
+                return ()
+            Just (words -> ["watch", wfn]) -> do
+                wman <- watch p wfn
+                printP p ""
+                loop state p (DBE{..}:db)
+            Just (words -> ["list"]) -> do
+                list db
+                loop state p db
+            Just (words -> ["stop", fn]) -> do
+                stop p fn db
+                loop state p (filter (\ DBE{..} -> fn /= wfn) db)
+            Just (words -> ["history"]) -> getHistory >>= mapM_ outputStrLn . historyLines >> loop state p db
+            Just ('e':'c':'h':'o':' ':strs) -> do
+                printP p strs
+                loop state p db
+            Just (words -> ["buffering", "fix", parseInt -> (Just i)]) -> do
+                liftIO $ modifyMVarMasked_ buffering (\_-> return (FixTimeBuffer i))
+                loop state p db
+            Just (words -> ["buffering", "delayed", parseInt -> (Just i)]) -> do
+                liftIO $ modifyMVarMasked_ buffering (\_-> return (DelayedBuffer i))
+                loop state p db
+            Just (words -> ["no", "buffering"]) -> do
+                liftIO $ modifyMVarMasked_ buffering (\_-> return NoNotifyBuffer)
+                loop state p db
+            Just input -> do
+                printP p $ "not found command: `" ++ input ++ "`"
+                loop state p db
+
+parseInt :: String -> Maybe Int
+parseInt (reads -> [(i, _)]) = Just i
+parseInt _ = Nothing
+
+compl :: CompletionFunc IO
+compl = {- compl' -} completeWord Nothing {- (Just '\t') -} [] h
+  where
+    h "" = return [histC, exitC, wathC, listC, stopC, echoC, buffC, bufdC, nobuffC]
+    h ((`isPrefixOf` "history") -> True)    = return [histC]
+    h ((`isPrefixOf` "exit") -> True)       = return [exitC]
+    h ((`isPrefixOf` "watch") -> True)      = return [wathC]
+    h ((`isPrefixOf` "list") -> True)       = return [listC]
+    h ((`isPrefixOf` "stop") -> True)       = return [stopC]
+    h ((`isPrefixOf` "echo") -> True)       = return [echoC]
+    h (words -> [(`isPrefixOf` "buffering") -> True])                = return [buffC, bufdC]
+    h (words -> ["buffering", (`isPrefixOf` "fix") -> True])         = return [fixC]
+    h (words -> ["buffering", (`isPrefixOf` "delayed") -> True])     = return [delayedC]
+    h (words -> [(`isPrefixOf` "no") -> True])                       = return [nobuffC]
+    h (words -> ["no", (`isPrefixOf` "buffering") -> True])          = return [nobuff_C]
+    h _ = return []
+    histC =    Completion "history"            "history                    - display history" False
+    exitC =    Completion "exit"               "exit                       - exit" False
+    wathC =    Completion "watch"              "watch dir                  - starting watch the dir" True
+    listC =    Completion "list"               "list                       - list watched dirs" False
+    stopC =    Completion "stop"               "stop                       - stop whatching" True
+    echoC =    Completion "echo"               "echo                       - echo" True
+    buffC =    Completion "buffering "         "buffering fix [number]     - notify buffering in fix time (ms)" True
+    bufdC =    Completion "buffering "         "buffering delayed [number] - notify buffering in delayed time from last notify (ms)" True
+    nobuffC =  Completion "no"                 "no buffering               - no notify buffering" True
+    nobuff_C = Completion "no buffering"       "no buffering               - no notify buffering" False
+    fixC =     Completion "buffering fix"      "buffering fix [number]     - notify buffering in fix time (ms)" True
+    delayedC = Completion "buffering delayed"  "buffering delayed [number] - notify buffering in delayed time from last notify (ms)" True
+
+
+list :: DB -> InputT IO ()
+list = liftIO . putStrLn . unlines . map wfn
+
+watch :: P -> String -> InputT IO WatchManager
+watch p fn = liftIO $ do
+    man <- startManager
+    fn' <- canonicalizePath fn
+    watchTree
+        man
+        fn'
+        (const True)
+        (writeChan (snd p) . event2PE)
+    return man
+
+event2PE :: Event -> PE
+event2PE (Added str _) = Add str
+event2PE (Modified str _) = Mod str
+event2PE (Removed str _) = Rem str
+
+stop :: P -> String -> DB -> InputT IO ()
+stop p fn [] = printP p "no whatching this"
+stop p fn (DBE{..}:dbo) = if wfn /= fn then stop p fn dbo else liftIO (stopManager wman)
+
+startPrinter :: State -> MVar PrintFormat -> Chan PE -> IO (IO ())
+startPrinter (State {..}) pfm ch = do
+    mv <- newMVar []
+    noBufferClock <- newEmptyMVar
+    fixBufferClock <- newEmptyMVar
+    delayedBufferClock <- newEmptyMVar
+    bf <- readMVar buffering
+    lastBufferMode <- newMVar bf
+
+    t1 <- forkIO $ void $ forever $ do
+        e <- readChan ch
+        tryTakeMVar noBufferClock
+        tryTakeMVar fixBufferClock
+        tryTakeMVar delayedBufferClock
+        bf <- readMVar buffering
+        case bf of
+            NoNotifyBuffer -> putMVar noBufferClock ()
+            (FixTimeBuffer _) -> putMVar fixBufferClock ()
+            (DelayedBuffer _) -> putMVar delayedBufferClock ()
+        modifyMVarMasked_ mv (\ l -> return (e:l))
+
+    t2 <- forkIO $ void $ forever $ do
+        readMVar fixBufferClock
+        bf <- readMVar buffering
+        case bf of
+            (FixTimeBuffer i) -> do
+                threadDelay (1000*i)
+                printerOut (State {..}) pfm mv
+            _ -> return ()
+
+    t3 <- forkIO $ void $ forever $ do
+        takeMVar noBufferClock
+        bf <- readMVar buffering
+        case bf of
+            (NoNotifyBuffer) -> do
+                printerOut (State {..}) pfm mv
+            _ -> return ()
+
+    t4 <- forkIO $ void $ forever $ do
+        readMVar delayedBufferClock
+        bf <- readMVar buffering
+        case bf of
+            (DelayedBuffer i) -> do
+                printerOut (State {..}) pfm mv
+                elems <- readMVar mv
+                let loop elems = do
+                      threadDelay (1000*i)
+                      elems' <- readMVar mv
+                      if elems == elems'
+                        then printerOut (State {..}) pfm mv
+                        else loop elems'
+                loop elems
+            _ -> return ()
+
+    return $ do
+        killThread t1
+        killThread t2
+        killThread t3
+        killThread t4
+
+printerOut (State {..}) pfm mv = do
+    pf <- readMVar pfm
+    m <- readMVar mode
+    modifyMVarMasked_ mv $ \ l -> do
+        let prts = filter isPrt l
+            signals = nub (filter (not . isPrt) l)
+        case m of
+            CLI -> forM_ prts (hPutStr stdout . (++"\n") . fromPrt)
+            SLAVE -> return ()
+        case pf of
+            MultiRecord  -> forM_ signals (hPutStr stdout . (++"\n") . show)
+            SingleRecord -> if null signals then return () else hPutStr stdout ((show signals) ++"\n")
+        hFlush stdout
+        return []
+
+
+printP :: P -> String -> InputT IO ()
+printP (_,ch) = liftIO . writeChan ch . Prt

+ src/System/FSWatch/Repr.hs view

@@ -0,0 +1,80 @@+module System.FSWatch.Repr where
+
+import Data.List
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Concurrent.MVar
+
+import System.Console.Haskeline
+import System.Console.Haskeline.History
+import System.Console.Haskeline.Completion
+import System.Directory
+import System.FSNotify
+import System.IO
+import System.Environment
+import System.Process
+
+
+data WatchProcess = WatchProcess
+  { wPath :: String
+  , wProcessHandle :: ProcessHandle
+  , wStdin :: Handle
+  , wStdout :: Handle
+  , wNotifyMVar :: MVar [PE]
+  , wShutdown :: IO ()
+  }
+
+type Listener = PE -> IO ()
+
+data Opts = Opts
+  { oSlave :: Bool
+  , oFixBufferMode :: Int
+  , oDelayedBufferMode :: Int
+  }
+
+data State = State
+  { prompt :: MVar String
+  , printFormat :: MVar PrintFormat
+  , buffering :: MVar NotifyBuffering
+  , mode :: MVar Mode
+  }
+
+
+data DBE = DBE
+  { wman :: WatchManager
+  , wfn :: String
+  }
+
+type DB = [DBE]
+type P = (IO (), Chan PE)
+
+
+data PE
+  = Mod String
+  | Add String
+  | Rem String
+  | Prt { fromPrt :: String }
+  deriving (Eq, Show, Read)
+
+isPrt :: PE -> Bool
+isPrt (Prt _) = True
+isPrt _ = False
+
+data PrintFormat
+  = MultiRecord
+  | SingleRecord
+  deriving (Eq, Show)
+
+data Mode
+  = CLI
+  | SLAVE
+  deriving (Eq, Show)
+
+data NotifyBuffering
+  = NoNotifyBuffer
+  | FixTimeBuffer Int
+  | DelayedBuffer Int
+  deriving (Eq, Show)

+ src/System/FSWatch/Slave.hs view

@@ -0,0 +1,78 @@+
+
+{-# LANGUAGE ViewPatterns
+           , RecordWildCards
+           #-}
+
+module System.FSWatch.Slave where
+
+import Data.List
+import Data.Semigroup ((<>))
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Concurrent.MVar
+import Options.Applicative hiding (defaultPrefs)
+
+import System.Console.Haskeline
+import System.Console.Haskeline.History
+import System.Console.Haskeline.Completion
+import System.Directory
+import System.FSNotify
+import System.IO
+import System.Process
+
+import System.FSWatch.Repr
+
+
+createWatchProcess :: (MonadIO m) => String -> Int -> m WatchProcess
+createWatchProcess wPath dbi = createWatchProcessWL wPath dbi Nothing
+
+createWatchProcessWithListener :: (MonadIO m) => String -> Int -> Listener -> m WatchProcess
+createWatchProcessWithListener wPath dbi listener =createWatchProcessWL wPath dbi (Just listener)
+
+
+createWatchProcessWL :: (MonadIO m) => String -> Int -> Maybe Listener -> m WatchProcess
+createWatchProcessWL wPath dbi listener = liftIO $ do
+    (Just wStdin, Just wStdout, _, wProcessHandle)
+      <- createProcess (proc wPath ["--slave", "--delayed-buffering", show dbi]) { std_in = CreatePipe, std_out = CreatePipe }
+    hSetBuffering wStdin NoBuffering
+    hSetBuffering wStdout NoBuffering
+    hSetNewlineMode wStdin (NewlineMode LF LF)
+    hSetNewlineMode wStdout (NewlineMode LF LF)
+    wNotifyMVar <- newEmptyMVar
+    wPollerThreadId <- forkIO $ void $ forever $ do
+        line <- hGetLine wStdout
+        let recs = read line
+        case listener of
+            (Just lsnr) -> forM_ recs lsnr
+            _ -> return ()
+        ns <- tryTakeMVar wNotifyMVar
+        case ns of
+            (Just ns') -> putMVar wNotifyMVar (ns' ++ recs)
+            Nothing -> putMVar wNotifyMVar recs
+    let wShutdown = do
+            killThread wPollerThreadId
+            terminateProcess wProcessHandle
+    return WatchProcess {..}
+
+watch :: (MonadIO m) => WatchProcess -> FilePath -> m ()
+watch (WatchProcess {..}) fn = void $ liftIO $ do
+    hPutStrLn wStdin ("watch " ++ fn)
+
+stop :: (MonadIO m) => WatchProcess -> FilePath -> m ()
+stop (WatchProcess {..}) fn = void $ liftIO $ do
+    hPutStrLn wStdin ("stop " ++ fn)
+
+getNotifies :: WatchProcess -> IO [PE]
+getNotifies (WatchProcess {..}) = do
+    jpes <- tryTakeMVar wNotifyMVar
+    case jpes of
+        (Just pes) -> return pes
+        _ -> return []
+
+waitNotifies :: WatchProcess -> IO [PE]
+waitNotifies (WatchProcess {..}) = do
+    takeMVar wNotifyMVar