-
Notifications
You must be signed in to change notification settings - Fork 0
/
hreact.hs
194 lines (169 loc) · 6.63 KB
/
hreact.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
import Control.Concurrent (forkIO)
import Control.Concurrent.STM.TVar (newTVar, TVar, readTVar, writeTVar)
import Control.Monad.STM (atomically)
import Control.Monad (when)
import Data.Char (ord)
import Data.List (intercalate)
import Data.Time (getCurrentTime)
import Prelude hiding (filter)
import System.Console.GetOpt
import System.Environment (getArgs, getProgName)
import System.Exit (exitWith, ExitCode (ExitSuccess, ExitFailure))
import System.FilePath ((</>))
import System.FilePath.Find
import System.FilePath.GlobPattern ((~~))
import System.INotify
import System.IO
import System.Process
import Text.Regex.Posix ((=~))
data State = State {
stRunning :: Bool,
stCounter :: Int
}
data OptError = OptError Int String
data Options = Options {
optPath :: FilePath
, optCommand :: String
, optRegex :: Maybe String
, optGlobPattern :: Maybe String
, optMerge :: Bool
, optHelp :: Bool
, optVersion :: Bool
} deriving Show
defaultOptions :: Options
defaultOptions = Options {
optPath = ""
, optCommand = ""
, optRegex = Nothing
, optGlobPattern = Nothing
, optMerge = False
, optHelp = False
, optVersion = False
}
options :: [ OptDescr (Options -> Options) ]
options =
[ Option ['r'] ["regex"] (OptArg (\arg opt -> opt { optRegex = arg }) "REGEX") "regex"
, Option ['p'] ["pattern"] (OptArg (\arg opt -> opt { optGlobPattern = arg }) "PATTERN") "shell glob pattern"
, Option ['m'] ["merge"] (NoArg (\opt -> opt { optMerge = True })) "merge intermediate events"
, Option ['V'] ["version"] (NoArg $ \opt -> opt { optVersion = True} ) "print version"
, Option ['h'] ["help"] (NoArg $ \opt -> opt { optHelp = True } ) "show help"
]
version :: String
version = "hreact version 0.01"
usage :: String -> String
usage prg =
let header = "usage: " ++ prg ++ " [OPTIONS] directory command"
in usageInfo header options
parseArgs :: String -> [String] -> Either OptError Options
parseArgs prg args =
case getOpt Permute options args of
(o, no, []) -> checkOptions o no
(_, _, err) -> Left $ OptError 1 $ intercalate "\n" (err ++ [use])
where use = usage prg
checkOptions opts noOpts
| optHelp o = Left $ OptError 1 $ use
| optVersion o = Left $ OptError 1 $ version
| otherwise = x noOpts
where o = foldl (flip id) defaultOptions opts
x (path:command:[]) = Right $ o { optPath = path, optCommand = command }
x _ = Left $ OptError 1 $ "please specify directory and command\n\n" ++ use
watch :: Options -> IO ()
watch opts = do
state <- atomically $ newTVar $ State False 0
let handler = (if optMerge opts then executeActionMerged state else executeActionSingle) cmd
inotify <- initINotify
dirs <- getAllDirectories
mapM_ (watchSingle inotify handler) (path : dirs)
putStrLn "Listens to your home directory. Hit enter to terminate."
loop (handler Nothing)
{- removeWatch inotify wd -}
where path = optPath opts
cmd = optCommand opts
filter = filterPath opts
getAllDirectories :: IO [FilePath]
getAllDirectories = find always (fileType ==? Directory) path
watchSingle :: INotify -> (Maybe FilePath -> IO ()) -> FilePath -> IO WatchDescriptor
watchSingle inotify handler path' = addWatch inotify [ Create, Delete, Modify, Move ] path' $ handleEvent path' filter handler
loop :: IO () -> IO ()
loop handler = do
key <- getChar
when ((ord key) == 10) $ do
handler
loop handler
when (key == 'q') $ exitWith ExitSuccess
handleEvent :: FilePath -> (FilePath -> Bool) -> (Maybe FilePath -> IO ()) -> Event -> IO ()
handleEvent path filter handler event = do
when (shouldExecute event filter) $ handler $ getFile event >>= \f -> return (path </> f)
shouldExecute :: Event -> (FilePath -> Bool) -> Bool
shouldExecute (Opened False (Just path)) f = f path
shouldExecute (Closed False (Just path) _) f = f path
shouldExecute (Created False path) f = f path
shouldExecute (Deleted False path) f = f path
shouldExecute (Modified False (Just path)) f = f path
shouldExecute (MovedIn False path _) f = f path
shouldExecute (MovedOut False path _) f = f path
shouldExecute (MovedSelf _) _ = True
shouldExecute _ _ = False
getFile :: Event -> Maybe FilePath
getFile (Opened _ jpath) = jpath
getFile (Closed _ jpath _) = jpath
getFile (Created _ path) = Just path
getFile (Deleted _ path) = Just path
getFile (Modified _ jpath) = jpath
getFile (MovedIn _ path _) = Just path
getFile (MovedOut _ path _) = Just path
getFile _ = Nothing
substitute :: String -> String -> String
substitute p ('\\':'$':'f':rest) = "\\$f" ++ substitute p rest
substitute p ('$':'f':rest) = p ++ substitute p rest
substitute p (x:rest) = x : substitute p rest
substitute _ [] = []
executeAction :: String -> Maybe FilePath -> IO ()
executeAction cmd path = do
_ <- system cmd'
putStr $ take 20 $ repeat '-'
putStr " "
time <- getCurrentTime
putStr $ show time
where
cmd' = case path of
Nothing -> substitute "'<<unknown>>'" cmd
Just p -> substitute p cmd
executeActionSingle :: String -> Maybe FilePath -> IO ()
executeActionSingle cmd path = executeAction cmd path >> putStrLn ""
executeActionMerged :: TVar State -> String -> Maybe FilePath -> IO ()
executeActionMerged state cmd path = fork action
where
fork a = forkIO a >> return ()
action = do
continue <- atomically $ do
s <- readTVar state
if stRunning s
then writeTVar state (s {stCounter = stCounter s + 1}) >> return False
else writeTVar state (s {stRunning = True}) >> return True
when continue $ do
executeAction cmd path
counter <- atomically $ do
s <- readTVar state
writeTVar state (s {stRunning = False, stCounter = 0})
return $ stCounter s
when (counter > 0) $ putStr $ " (" ++ show counter ++ ")"
putStrLn ""
filterPath :: Options -> FilePath -> Bool
filterPath o path = or $ [filterRegex $ optRegex o, filterGlob $ optGlobPattern o]
where filterRegex :: Maybe String -> Bool
filterRegex (Just regex) = path =~ regex
filterRegex _ = False
filterGlob :: Maybe String -> Bool
filterGlob (Just glob) = path ~~ glob
filterGlob _ = False
main :: IO ()
main = do
hSetBuffering stdin NoBuffering
args <- getArgs
prg <- getProgName
opts <- exitOnError $ parseArgs prg args
watch opts
exitOnError :: Either OptError a -> IO a
exitOnError (Left (OptError code msg)) = hPutStrLn stderr (msg) >> exitWith (ExitFailure code)
exitOnError (Right x) = return x