packages feed

codemonitor (empty) → 0.1

raw patch · 14 files changed

+539/−0 lines, 14 filesdep +basedep +cairodep +containerssetup-changed

Dependencies added: base, cairo, containers, directory, filepath, gtk, haskell98, hinotify, process, regex-posix, time

Files

+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2012, Rickard Lindberg+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 the author nor the names of its 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 HOLDER 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
+ codemonitor.cabal view
@@ -0,0 +1,44 @@+name:           codemonitor+version:        0.1+synopsis:       Tool that automatically runs arbitrary commands when files change on disk.+description:    Tool that automatically runs arbitrary commands when files change on disk.+category:       Tool+homepage:       http://github.com/rickardlindberg/codemonitor+author:         Rickard Lindberg <ricli85@gmail.com>+maintainer:     Rickard Lindberg <ricli85@gmail.com>+cabal-version:  >= 1.8+license:        BSD3+license-file:   LICENSE+build-type:     Simple++Flag dev+  Description: Enable warnings+  Default:     False++source-repository head+  type:     git+  location: http://github.com/rickardlindberg/codemonitor++executable codemonitor+  main-is:            Main.hs+  other-modules:      Config+               ,      Job+               ,      Layout+               ,      Monitor+               ,      Notifier+               ,      Rect+               ,      Render+  hs-source-dirs:     src+  if flag(dev)+    ghc-options:      -fwarn-unused-imports -Werror+  build-depends:      base >= 4 && <= 5+               ,      haskell98+               ,      regex-posix+               ,      process+               ,      containers+               ,      gtk+               ,      cairo+               ,      hinotify+               ,      filepath+               ,      directory+               ,      time
+ src/Config.hs view
@@ -0,0 +1,19 @@+module Config where++import Job+import Monitor++create :: FilePath -> IO (String, Jobs, [Monitor])+create configPath = do+    content <- readFile configPath+    let (watchDir:rest) = lines content+    let jobs = map jobDefToJob rest+    let monitors = map jobToMonitor jobs+    return (watchDir, createJobs jobs, monitors)++jobDefToJob :: String -> Job+jobDefToJob def =+    let (id:pattern:command:args) = words def+    in processJob id command args pattern++jobToMonitor job = JobMonitor (jobId job) 0 (fullName job) (status job)
+ src/Job.hs view
@@ -0,0 +1,74 @@+module Job where++import Control.Concurrent+import System.Exit+import System.Process+import Text.Regex.Posix++data Jobs = Jobs [Job]++createJobs :: [Job] -> Jobs+createJobs = Jobs++jobWithId :: Jobs -> String -> Job+jobWithId (Jobs jobs) id = find jobs+    where+        find [] = error "gaaah"+        find (x:xs) | jobId x == id = x+                    | otherwise     = find xs++data Job = Job+    { jobId     :: String+    , name      :: String+    , args      :: [String]+    , matchExpr :: String+    , status    :: Status+    , thread    :: Maybe ThreadId+    }++data Status = Idle | Working | Fail String deriving (Eq)++fullName :: Job -> String+fullName (Job { name = name, args = args }) = name ++ " " ++ unwords args++processJob :: String -> String -> [String] -> String -> Job+processJob jobId name args expr = Job jobId name args expr Idle Nothing++runAllJobs :: (String -> Status -> IO ()) -> Jobs -> IO Jobs+runAllJobs signalResult (Jobs jobs) = fmap Jobs (mapM (reRunJob signalResult) jobs)++reRunJobs :: FilePath -> (String -> Status -> IO ()) -> Jobs -> IO Jobs+reRunJobs fileChanged signalResult (Jobs jobs) = fmap Jobs (mapM reRunIfMatch jobs)+    where+        reRunIfMatch job =+            if fileChanged =~ matchExpr job+                then reRunJob signalResult job+                else return job++reRunJob :: (String -> Status -> IO ()) -> Job -> IO Job+reRunJob signalResult job = do+    cancel job+    -- NOTE: signalResult must be called asynchronoulsy, otherwise the lock for+    -- jobsRef will deadlock.+    threadId <- forkIO $ runThread job signalResult+    return $ job { thread = Just threadId, status = Working }++cancel :: Job -> IO ()+cancel Job { thread = Just id } = killThread id+cancel _                        = return ()++runThread :: Job -> (String -> Status -> IO ()) -> IO ()+runThread job signalResult = do+    -- NOTE: Is the process killed if this thread is killed? If not, is that+    -- the reason why we get resource exhaustion sometimes?+    (exit, stdout, stderr) <- readProcessWithExitCode (name job) (args job) ""+    if exit == ExitSuccess+        then signalResult (jobId job) Idle+        else signalResult (jobId job) (Fail $ stderr ++ stdout)++updateJobStatus :: String -> Status -> Jobs -> Jobs+updateJobStatus theId status (Jobs jobs) = Jobs (map updateJobInner jobs)+    where+        updateJobInner job+            | jobId job == theId = job { status = status, thread = Nothing }+            | otherwise          = job
+ src/Layout.hs view
@@ -0,0 +1,50 @@+module Layout where++import Data.Maybe+import Job+import Monitor+import qualified Data.Map as M+import Rect++data RectType = Small+              | Large+              deriving (Eq, Ord)++type RectMap = M.Map RectType [Rect]++findRects :: Rect -> [Monitor] -> [(Monitor, Rect)]+findRects originalRect monitors = match monitors rectMap+    where+        rectMap           = rectsForTypes originalRect monitors+        match []     _    = []+        match (m:ms) mmap = let (rect, restMap) = rectMapPop (rectType m) mmap+                            in (m, rect):match ms restMap++rectsForTypes :: Rect -> [Monitor] -> RectMap+rectsForTypes originalRect monitors =+    let types     = map rectType monitors+        numSmalle = length $ filter (==Small) types+        numLarge  = length $ filter (==Large) types+        smallArea = if numLarge == 0+                        then snd $ divideVertical originalRect 0.7+                        else snd $ divideVertical originalRect 0.9+        largeArea = if numSmalle == 0+                        then originalRect+                        else fst (divideVertical originalRect 0.9)+    in rectMapCreate+           [ (Small, splitHorizontal smallArea numSmalle)+           , (Large, splitVertical largeArea numLarge)+           ]++rectType :: Monitor -> RectType+rectType (JobMonitor { mJobStatus = Fail _ }) = Large+rectType _                                    = Small++rectMapPop :: RectType -> RectMap -> (Rect, RectMap)+rectMapPop t m = let rects     = fromJust $ M.lookup t m+                     firstRect = head rects+                     restRects = tail rects+                 in (firstRect, M.insert t restRects m)++rectMapCreate :: [(RectType, [Rect])] -> RectMap+rectMapCreate = M.fromList
+ src/Main.hs view
@@ -0,0 +1,86 @@+module Main (main) where++import Config+import Control.Concurrent+import Data.IORef+import Data.Time.Clock+import Graphics.UI.Gtk+import Job+import Monitor+import Notifier+import Render+import System++main :: IO ()+main = do+    initGUI+    showMainWindow+    mainGUI++showMainWindow :: IO ()+showMainWindow = do+    mainWindow <- windowNew+    canvas <- drawingAreaNew+    set mainWindow [ windowTitle := "Code Monitor", containerChild := canvas ]++    let forceRedraw = postGUIAsync $ widgetQueueDraw canvas++    args <- getArgs+    (watchDir, jobs, monitors) <- create (head args)++    lock <- newEmptyMVar+    jobsRef <- newIORef jobs+    let withJobLock = createWithJobLock lock jobsRef++    monitorsRef <- newIORef monitors++    t <- getCurrentTime+    timeRef <- newIORef t++    setupNotifications watchDir (onFileChanged withJobLock forceRedraw)+    onInit withJobLock forceRedraw++    timeoutAddFull (forceRedraw >> return True) priorityDefaultIdle 10++    mainWindow `onDestroy` mainQuit+    canvas     `onExpose`  redraw canvas timeRef jobsRef monitorsRef++    widgetShowAll mainWindow+    return ()++redraw canvas timeRef jobsRef monitorsRef event = do+    oldT <- readIORef timeRef+    t <- getCurrentTime+    writeIORef timeRef t+    let delta = realToFrac (diffUTCTime t oldT)++    (w, h) <- widgetGetSize canvas+    drawin <- widgetGetDrawWindow canvas+    jobs <- readIORef jobsRef+    modifyIORef monitorsRef (updateMonitors delta jobs)+    monitors <- readIORef monitorsRef+    renderWithDrawable drawin (renderScreen monitors (fromIntegral w) (fromIntegral h))+    return True++createWithJobLock :: MVar () -> IORef Jobs -> (Jobs -> IO Jobs) -> IO ()+createWithJobLock lock jobsRef fn = do+    putMVar lock ()+    jobs <- readIORef jobsRef+    newJobs <- fn jobs+    writeIORef jobsRef newJobs+    takeMVar lock++onInit :: ((Jobs -> IO Jobs) -> IO ()) -> IO () -> IO ()+onInit withJobLock forceRedraw = do+    withJobLock $ runAllJobs (onStatusChanged withJobLock forceRedraw)+    forceRedraw++onFileChanged :: ((Jobs -> IO Jobs) -> IO ()) -> IO () -> FilePath -> IO ()+onFileChanged withJobLock forceRedraw filePath = do+    withJobLock (reRunJobs filePath (onStatusChanged withJobLock forceRedraw))+    forceRedraw++onStatusChanged :: ((Jobs -> IO Jobs) -> IO ()) -> IO () -> String -> Status -> IO ()+onStatusChanged withJobLock forceRedraw id status = do+    withJobLock (return . updateJobStatus id status)+    forceRedraw
+ src/Monitor.hs view
@@ -0,0 +1,21 @@+module Monitor where++import Job++data Monitor = JobMonitor { mJobId          :: String+                          , mSecondsInState :: Double+                          , mJobName        :: String+                          , mJobStatus      :: Status+                          }++updateMonitors :: Double -> Jobs -> [Monitor] -> [Monitor]+updateMonitors secondsSinceLastUpdate jobs = map updateMonitor+    where+        updateMonitor monitor@(JobMonitor {}) =+            let newStatus  = status $ jobWithId jobs (mJobId monitor)+                newSeconds = if mJobStatus monitor == newStatus+                                then secondsSinceLastUpdate + mSecondsInState monitor+                                else 0+            in monitor { mJobStatus      = newStatus+                       , mSecondsInState = newSeconds+                       }
+ src/Notifier.hs view
@@ -0,0 +1,27 @@+module Notifier where++import Control.Monad+import System.Directory+import System.FilePath+import System.INotify++setupNotifications :: FilePath -> (String -> IO ()) -> IO ()+setupNotifications dir notifyFileChanged = do+    i <- initINotify+    allDirs <- getDirsRecursive dir+    forM_ allDirs $ \dir ->+        addWatch i [Modify] dir (handle dir)+    where+        handle rootDir (Modified _ (Just f)) = notifyFileChanged (makeRelative dir (rootDir </> f))+        handle rootDir _                     = return ()++getDirsRecursive :: FilePath -> IO [FilePath]+getDirsRecursive rootDir = do+    contents  <- getDirectoryContents rootDir+    innerDirs <- forM (filter (`notElem` [".", ".."]) contents) $ \path -> do+        let fullPath = rootDir </> path+        isDirectory <- doesDirectoryExist fullPath+        if isDirectory+            then getDirsRecursive fullPath+            else return []+    return $ rootDir:concat innerDirs
+ src/Rect.hs view
@@ -0,0 +1,22 @@+module Rect where++data Rect = Rect Double Double Double Double deriving (Eq, Show)++shrink :: Double -> Rect -> Rect+shrink by (Rect x y w h) = Rect (x+by) (y+by) (w-2*by) (h-2*by)++divideVertical :: Rect -> Double -> (Rect, Rect)+divideVertical (Rect x y w h) percent = (Rect x y w splitH, Rect x splitH w (h - splitH))+    where splitH = percent * h++splitVertical :: Rect -> Int -> [Rect]+splitVertical (Rect x y w h) n = map calcNew [1..n]+    where+        calcNew n = Rect x (y+(fromIntegral n-1)*newH) w newH+        newH = h / fromIntegral n++splitHorizontal :: Rect -> Int -> [Rect]+splitHorizontal (Rect x y w h) n = map calcNew [1..n]+    where+        calcNew n = Rect (x+(fromIntegral n -1)*newW) y newW h+        newW = w / fromIntegral n
+ src/Render.hs view
@@ -0,0 +1,91 @@+module Render where++import Control.Arrow+import Control.Monad+import Graphics.Rendering.Cairo hiding (status, Status)+import Job+import Layout+import Monitor+import Rect++boxRadius = 10.0+innerSpace = 2+outerSpace = innerSpace/2+fontName = "Monospace"+fontSize = 11.0++renderScreen :: [Monitor] -> Double -> Double -> Render ()+renderScreen monitors w h = do+    renderBackground+    renderMonitors monitors (shrink outerSpace $ Rect 0 0 w h)++renderBackground :: Render ()+renderBackground = do+    setSourceRGB 1 1 0.6+    paint++renderMonitors :: [Monitor] -> Rect -> Render ()+renderMonitors monitors rect = do+    let mr       = findRects rect monitors+    let mrShrunk = map (second $ shrink innerSpace) mr+    forM_ mrShrunk renderMonitor++renderMonitor :: (Monitor, Rect) -> Render ()+renderMonitor (monitor@JobMonitor {}, rect@(Rect x y w h)) = do+    -- Background+    let (r, g, b, a) = statusToBgColor (mSecondsInState monitor) (mJobStatus monitor)+    setSourceRGBA r g b a+    roundRectPath rect+    fillPreserve+    setSourceRGBA 0 0 0 0.4+    setLineWidth 1.5+    stroke+    -- Title+    selectFontFace fontName FontSlantNormal FontWeightBold+    setFontSize fontSize+    setSourceRGBA 0 0 0 0.7+    ex <- textExtents (mJobName monitor)+    moveTo (x + boxRadius - textExtentsXbearing ex) (y + boxRadius - textExtentsYbearing ex)+    showText (mJobName monitor)+    -- Additional text+    selectFontFace fontName FontSlantNormal FontWeightNormal+    setFontSize fontSize+    setSourceRGBA 0 0 0 0.8+    moveTo (x + 10) (y+20)+    ex2 <- fontExtents+    let errors = additionalLines (mJobStatus monitor)+    let ys = map (\x -> fromIntegral x*fontExtentsHeight ex2 + y + boxRadius + 2*textExtentsHeight ex) [1..length errors]+    forM_ (zip errors ys) $ \(e, y) -> do+        moveTo (x + boxRadius + boxRadius) y+        showText e+    return ()++statusToBgColor :: Double -> Status -> (Double, Double, Double, Double)+statusToBgColor t Idle     = (121/255, 245/255, 0, 1)+statusToBgColor t Working  = (0, 204/255, 245/255, circularMovement 1 0.5 2 t)+statusToBgColor t (Fail _) = (245/255, 36/255, 0, circularMovement 1 0.7 0.5 t)++circularMovement :: Double -> Double -> Double -> Double -> Double+circularMovement start end animationTime totalTime = res+    where+        rest    = totalTime - animationTime * fromIntegral (floor $ totalTime / animationTime)+        percent = rest / animationTime+        d1      = end - start+        d2      = start - end+        p2      = percent * 2+        res     = if p2 <= 1+                      then start + d1 * percent+                      else end   + d2 * percent++roundRectPath :: Rect -> Render ()+roundRectPath (Rect x y w h) = do+    newPath+    arc (x+w-boxRadius) (y+  boxRadius) boxRadius ((-90) * pi/180) (0   * pi/180)+    arc (x+w-boxRadius) (y+h-boxRadius) boxRadius (0     * pi/180) (90  * pi/180)+    arc (x+  boxRadius) (y+h-boxRadius) boxRadius (90    * pi/180) (180 * pi/180)+    arc (x+  boxRadius) (y+  boxRadius) boxRadius (180   * pi/180) (270 * pi/180)+    closePath++additionalLines :: Status -> [String]+additionalLines (Fail s) = lines s+additionalLines _        = []
+ tests/AllTests.hs view
@@ -0,0 +1,43 @@+import Fixtures+import Rect+import System.Directory+import System.FilePath+import Test.Hspec.HUnit()+import Test.Hspec.Monadic+import Test.Hspec.QuickCheck+import Test.QuickCheck++main = hspecX $ do++    describe "notification service:" $ do++        it "notifies when file modified in directory" $ withTmpDir $ \dir -> do+            assertNotified <- setupNotificationsTest dir+            modifyFile $ dir </> "foo"+            assertNotified "foo"++        it "notifies when file modified in subdirectory" $ withTmpDir $ \dir -> do+            createDirectory $ dir </> "subdir"+            assertNotified <- setupNotificationsTest dir+            modifyFile $ dir </> "subdir" </> "foo"+            assertNotified ("subdir" </> "foo")++    describe "rectangle operations:" $++        let area  (Rect x y w h) = w * h+            areas rects          = sum $ map area rects+            aboutSame d1 d2      = abs (d1 - d2) < 0.00000001+        in do++        prop "divideVertical preserves total area" $ forAll (choose (0, 1)) $ \percent ->+                                                     forAll arbitrary       $ \rect ->+            let (r1, r2) = divideVertical rect percent in+            area rect `aboutSame` areas [r1, r2]++        prop "splitVertical preserves total area" $ forAll arbitrary        $ \rect ->+                                                    forAll (choose (1, 10)) $ \numTimes ->+            area rect `aboutSame` areas (splitVertical rect numTimes)++        prop "splitHorizontal preserves total area" $ forAll arbitrary        $ \rect ->+                                                      forAll (choose (1, 10)) $ \numTimes ->+            area rect `aboutSame` areas (splitHorizontal rect numTimes)
+ tests/Asserts.hs view
@@ -0,0 +1,8 @@+module Asserts where++import Test.HUnit++assertElem :: String -> [String] -> Assertion+assertElem item list =+    assertBool ("expected item '" ++ item ++ "' to be in " ++ show list)+               (item `elem` list)
+ tests/Fixtures.hs view
@@ -0,0 +1,42 @@+module Fixtures where++import Asserts+import Control.Concurrent+import Control.Exception.Base (bracket)+import Data.IORef+import Notifier+import Rect+import System.Directory+import System.IO+import Test.HUnit+import Test.QuickCheck++setupNotificationsTest :: FilePath -> IO (FilePath -> Assertion)+setupNotificationsTest dir = do+    notificationsRef <- newIORef []+    setupNotifications dir (\f -> modifyIORef notificationsRef (f:))+    return $ \file -> do+        threadDelay 10000+        files <- readIORef notificationsRef+        file `assertElem` files++withTmpDir :: (FilePath -> IO a) -> IO a+withTmpDir = bracket setUp tearDown+    where+        tmpDir   = "/tmp/codemonitor-test"+        setUp    = createDirectory tmpDir >> return tmpDir+        tearDown = removeDirectoryRecursive++modifyFile :: FilePath -> IO ()+modifyFile path = do+    h <- openFile path AppendMode+    hPutStrLn h "a new line"+    hClose h++instance Arbitrary Rect where+    arbitrary = do+        x <- choose (0, 100)+        y <- choose (0, 100)+        w <- choose (0, 100)+        h <- choose (0, 100)+        return (Rect x y w h)