packages feed

arbtt 0.4.4 → 0.4.5

raw patch · 17 files changed

+774/−134 lines, 17 filesdep +Win32setup-changed

Dependencies added: Win32

Files

README view
@@ -38,6 +38,30 @@ http://darcs.nomeata.de/arbtt/doc/users_guide/ Beware that this will also reflect the latest version. +Creating the Windows Installer+==============================++The file setup.iss contains an installer script for Inno Setup and can be used+to create the windows installer for arbtt. It can be used under wine. To build+arbtt under Windows, you need to install the Haskell Platform. Because the+Haskell Platform ships an older version of the w32api package from mingw, you+also need to download w32api-3.14-mingw32-dev.tar.gz and copy at least the files+include/psapi.h and lib/libpsapi.a over the files installed by the Haskell+Platform. For the pcre-light package, you need to install the pcre library.+Unless you run a German version of Windows, you’ll need to adjust the path to+the pcre3.dll file in setup.iss. Install Inno Setup. Create the documentation+(make -C doc) and configure arbtt with the --with-ISCC-flag:+$ wine runhaskell Setup.hs configure --with-ISCC='C:\Programme\Inno Setup 5\ISCC.exe'+again adjusting the path if you do not have a German version of Windows. This+will put the version name into setup.iss and create the output file as+dist/arbtt-setup-<version>.exe.++Download links:+ * http://hackage.haskell.org/platform/2009.2.0.2/HaskellPlatform-2009.2.0.2-setup.exe+ * http://sourceforge.net/projects/mingw/files/MinGW%20API%20for%20MS-Windows/+ * http://gnuwin32.sourceforge.net/downlinks/pcre.php+ * http://www.jrsoftware.org/download.php/is-unicode.exe+ Development ===========
Setup.hs view
@@ -1,3 +1,33 @@ module Main where+ import Distribution.Simple-main = defaultMain+import Distribution.Simple.Program+import Distribution.Simple.Setup+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils+import Distribution.PackageDescription+import Distribution.Text+import System.FilePath+import System.Directory++main = defaultMainWithHooks simpleUserHooks+	{ hookedPrograms = [isccProgram]+	, postBuild = myPostBuild+	}++isccProgram = simpleProgram "ISCC"++myPostBuild _ flags pd lbi = do+	case lookupProgram isccProgram (withPrograms lbi) of+	  Nothing -> warn verb $ "The INNO Setup compile ISCC was not found, skipping the " +++	                         "creation of the windows setup executable."+	  Just configuredProg -> do+	  	writeFile includeFilename $ "AppVerName=" ++ display (package pd) ++ "\n"+	  	rawSystemProgram verb configuredProg+		             	["/Odist","/F"++setupFilename,"setup.iss"]+		removeFile includeFilename+  where verb = fromFlag (buildVerbosity flags)+	setupFilename = display (pkgName (package pd)) +++	                "-setup-" +++			display (pkgVersion (package pd))+	includeFilename = "dist" </> "setup-app-ver-name.iss"
arbtt.cabal view
@@ -1,5 +1,5 @@ name:               arbtt-version:            0.4.4+version:            0.4.5 license:            GPL license-file:       LICENSE category:           Desktop@@ -23,23 +23,41 @@  extra-source-files:     categorize.cfg, arbtt-capture.desktop, README,-    doc/arbtt.xml, doc/fptools.css, doc/Makefile+    doc/arbtt.xml, doc/fptools.css, doc/Makefile,+    setup.iss, modpath.iss  executable arbtt-capture     main-is:            capture-main.hs     hs-source-dirs:     src     build-depends:-        base == 4.*, filepath, directory, mtl, time, unix,-        X11 > 1.4.4, bytestring, binary-    extra-libraries: Xss+        base == 4.*, filepath, directory, mtl, time,+        bytestring, binary     other-modules:         Data+        Data.Binary.StringRef         Capture         TimeLog         UpgradeLog1-        Graphics.X11.XScreenSaver-        System.Locale.SetLocale +    if os(windows) +        extra-libraries: psapi+        cpp-options:    -DWIN32+        ghc-options:    -optl-mwindows+        other-modules:+            Capture.Win32+            Graphics.Win32.Window.Extra+            System.Win32.Mutex+        build-depends:+             Win32+    else+        extra-libraries: Xss+        other-modules:+            Capture.X11+            Graphics.X11.XScreenSaver+            System.Locale.SetLocale+        build-depends:+            X11 > 1.4.4, unix+ executable arbtt-stats     main-is:            stats-main.hs     hs-source-dirs:     src@@ -47,10 +65,15 @@         base == 4.*, parsec == 2.*, containers, pcre-light     other-modules:         Data+        Data.Binary.StringRef         Categorize         TimeLog         Stats-        System.Locale.SetLocale+    if os(windows) +        cpp-options:    -DWIN32+    else+        other-modules:+            System.Locale.SetLocale  executable arbtt-dump     main-is:            dump-main.hs@@ -59,8 +82,13 @@         base == 4.*, parsec == 2.*, containers     other-modules:         Data+        Data.Binary.StringRef         TimeLog-        System.Locale.SetLocale+    if os(windows) +        cpp-options:    -DWIN32+    else+        other-modules:+            System.Locale.SetLocale  executable arbtt-recover     main-is:            recover-main.hs@@ -69,8 +97,13 @@         base == 4.*, parsec == 2.*, containers     other-modules:         Data+        Data.Binary.StringRef         TimeLog-        System.Locale.SetLocale+    if os(windows) +        cpp-options:    -DWIN32+    else+        other-modules:+            System.Locale.SetLocale  source-repository head     type:     darcs
+ modpath.iss view
@@ -0,0 +1,157 @@+// ----------------------------------------------------------------------------
+//
+// Inno Setup Ver:  5.2.1
+// Script Version:  1.3.1
+// Author:          Jared Breland <jbreland@legroom.net>
+// Homepage:		http://www.legroom.net/software
+//
+// Script Function:
+//	Enable modification of system path directly from Inno Setup installers
+//
+// Instructions:
+//	Copy modpath.iss to the same directory as your setup script
+//
+//	Add this statement to your [Setup] section
+//		ChangesEnvironment=yes
+//
+//	Add this statement to your [Tasks] section
+//	You can change the Description or Flags, but the Name must be modifypath
+//		Name: modifypath; Description: &Add application directory to your system path; Flags: unchecked
+//
+//	Add the following to the end of your [Code] section
+//	setArrayLength must specify the total number of dirs to be added
+//	Dir[0] contains first directory, Dir[1] contains second, etc.
+//		function ModPathDir(): TArrayOfString;
+//		var
+//			Dir:	TArrayOfString;
+//		begin
+//			setArrayLength(Dir, 1)
+//			Dir[0] := ExpandConstant('{app}');
+//			Result := Dir;
+//		end;
+//		#include "modpath.iss"
+// ----------------------------------------------------------------------------
+
+procedure ModPath();
+var
+	oldpath:	String;
+	newpath:	String;
+	pathArr:	TArrayOfString;
+	aExecFile:	String;
+	aExecArr:	TArrayOfString;
+	i, d:		Integer;
+	pathdir:	TArrayOfString;
+begin
+
+	// Get array of new directories and act on each individually
+	pathdir := ModPathDir();
+	for d := 0 to GetArrayLength(pathdir)-1 do begin
+
+		// Modify WinNT path
+		if UsingWinNT() = true then begin
+
+			// Get current path, split into an array
+			RegQueryStringValue(HKEY_LOCAL_MACHINE, 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment', 'Path', oldpath);
+			oldpath := oldpath + ';';
+			i := 0;
+			while (Pos(';', oldpath) > 0) do begin
+				SetArrayLength(pathArr, i+1);
+				pathArr[i] := Copy(oldpath, 0, Pos(';', oldpath)-1);
+				oldpath := Copy(oldpath, Pos(';', oldpath)+1, Length(oldpath));
+				i := i + 1;
+
+				// Check if current directory matches app dir
+				if pathdir[d] = pathArr[i-1] then begin
+					// if uninstalling, remove dir from path
+					if IsUninstaller() = true then begin
+						continue;
+					// if installing, abort because dir was already in path
+					end else begin
+						abort;
+					end;
+				end;
+
+				// Add current directory to new path
+				if i = 1 then begin
+					newpath := pathArr[i-1];
+				end else begin
+					newpath := newpath + ';' + pathArr[i-1];
+				end;
+			end;
+
+			// Append app dir to path if not already included
+			if IsUninstaller() = false then
+				newpath := newpath + ';' + pathdir[d];
+
+			// Write new path
+			RegWriteStringValue(HKEY_LOCAL_MACHINE, 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment', 'Path', newpath);
+
+		// Modify Win9x path
+		end else begin
+
+			// Convert to shortened dirname
+			pathdir[d] := GetShortName(pathdir[d]);
+
+			// If autoexec.bat exists, check if app dir already exists in path
+			aExecFile := 'C:\AUTOEXEC.BAT';
+			if FileExists(aExecFile) then begin
+				LoadStringsFromFile(aExecFile, aExecArr);
+				for i := 0 to GetArrayLength(aExecArr)-1 do begin
+					if IsUninstaller() = false then begin
+						// If app dir already exists while installing, abort add
+						if (Pos(pathdir[d], aExecArr[i]) > 0) then
+							abort;
+					end else begin
+						// If app dir exists and = what we originally set, then delete at uninstall
+						if aExecArr[i] = 'SET PATH=%PATH%;' + pathdir[d] then
+							aExecArr[i] := '';
+					end;
+				end;
+			end;
+
+			// If app dir not found, or autoexec.bat didn't exist, then (create and) append to current path
+			if IsUninstaller() = false then begin
+				SaveStringToFile(aExecFile, #13#10 + 'SET PATH=%PATH%;' + pathdir[d], True);
+
+			// If uninstalling, write the full autoexec out
+			end else begin
+				SaveStringsToFile(aExecFile, aExecArr, False);
+			end;
+		end;
+
+		// Write file to flag modifypath was selected
+		//   Workaround since IsTaskSelected() cannot be called at uninstall and AppName and AppId cannot be "read" in Code section
+		if IsUninstaller() = false then
+			SaveStringToFile(ExpandConstant('{app}') + '\uninsTasks.txt', WizardSelectedTasks(False), False);
+	end;
+end;
+
+procedure CurStepChanged(CurStep: TSetupStep);
+begin
+	if CurStep = ssPostInstall then
+		if IsTaskSelected('modifypath') then
+			ModPath();
+end;
+
+procedure CurUninstallStepChanged(CurUninstallStep: TUninstallStep);
+var
+	appdir:			String;
+	selectedTasks:	AnsiString;
+begin
+	appdir := ExpandConstant('{app}')
+	if CurUninstallStep = usUninstall then begin
+		if LoadStringFromFile(appdir + '\uninsTasks.txt', selectedTasks) then
+			if Pos('modifypath', selectedTasks) > 0 then
+				ModPath();
+		DeleteFile(appdir + '\uninsTasks.txt')
+	end;
+end;
+
+function NeedRestart(): Boolean;
+begin
+	if IsTaskSelected('modifypath') and not UsingWinNT() then begin
+		Result := True;
+	end else begin
+		Result := False;
+	end;
+end;
+ setup.iss view
@@ -0,0 +1,61 @@+[Setup]
+; NOTE: The value of AppId uniquely identifies this application.
+; Do not use the same AppId value in installers for other applications.
+; (To generate a new GUID, click Tools | Generate GUID inside the IDE.)
+AppId={{1DB6EA4F-D387-432D-A739-283E0E916AF6}
+AppName=arbtt
+;AppVerName=arbtt-0.4.4
+#include "dist\setup-app-ver-name.iss"
+AppPublisher=Joachim Breitner
+AppPublisherURL=http://www.joachim-breitner.de/projects#arbtt
+AppSupportURL=http://www.joachim-breitner.de/projects#arbtt
+AppUpdatesURL=http://www.joachim-breitner.de/projects#arbtt
+DefaultDirName={pf}\arbtt
+DefaultGroupName=arbtt
+AllowNoIcons=yes
+OutputBaseFilename=arbtt-setup
+Compression=lzma
+SolidCompression=yes
+; Is there a point in displaying the LICENSE file?
+; LicenseFile=LICENSE
+InfoBeforeFile=README.Win32
+ChangesEnvironment=yes
+
+[Tasks]
+Name: modifypath; Description: "Add arbtt binaries to the system path"
+Name: autorun; Description: "Start to capture data upon system start"
+Name: runcapture; Description: "Start to capture data after the installation"
+
+[Files]
+Source: "dist\build\arbtt-dump\arbtt-dump.exe"; DestDir: "{app}\bin"
+Source: "dist\build\arbtt-stats\arbtt-stats.exe"; DestDir: "{app}\bin"
+Source: "dist\build\arbtt-capture\arbtt-capture.exe"; DestDir: "{app}\bin"
+Source: "dist\build\arbtt-recover\arbtt-recover.exe"; DestDir: "{app}\bin"
+Source: "C:\Programme\GnuWin32\bin\pcre3.dll"; DestDir: "{app}\bin"
+Source: "categorize.cfg"; DestDir: "{userappdata}\arbtt"; Flags: onlyifdoesntexist uninsneveruninstall
+Source: "doc\users_guide\*.*"; DestDir: "{app}\doc";
+
+[Icons]
+Name: "{group}\Edit categorize.cfg"; Filename: "wordpad.exe"; Parameters: """{userappdata}\arbtt\categorize.cfg"""; Flags: useapppaths
+Name: "{group}\{cm:UninstallProgram,arbtt}"; Filename: "{uninstallexe}"
+Name: "{group}\arbtt documentation"; Filename: "{app}\doc\index.html"
+Name: "{commonstartup}\arbtt-capture"; Filename: "{app}\bin\arbtt-capture.exe"; Comment: "Collects data for computer useage statistics"; Tasks: autorun
+
+[Run]
+Filename: "{app}\bin\arbtt-capture.exe"; Description: "Start collecting usage data"; Flags: nowait; Tasks: runcapture
+
+[Languages]
+Name: "english"; MessagesFile: "compiler:Default.isl"
+Name: "german"; MessagesFile: "compiler:Languages\German.isl"
+
+[Code]
+function ModPathDir(): TArrayOfString;
+	var
+	Dir:	TArrayOfString;
+	begin
+	setArrayLength(Dir, 1)
+	Dir[0] := ExpandConstant('{app}\bin');
+	Result := Dir;
+end;
+#include "modpath.iss"
+
src/Capture.hs view
@@ -1,77 +1,15 @@-module Capture where--import Data-import Graphics.X11-import Graphics.X11.Xlib.Extras-import Graphics.X11.XScreenSaver (getXIdleTime)-import Control.Monad-import Control.Exception (bracket)-import Control.Applicative-import Data.Maybe-import Data.Time.Clock-import System.IO--setupChecks :: IO ()-setupChecks = do-	dpy <- openDisplay ""-        xSetErrorHandler-	let rwin = defaultRootWindow dpy-	a <- internAtom dpy "_NET_CLIENT_LIST" False-	p <- getWindowProperty32 dpy a rwin-	when (isNothing p) $ do-		hPutStrLn stderr "arbtt: ERROR: No _NET_CLIENT_LIST set for the root window"-	closeDisplay dpy--captureData :: IO CaptureData-captureData = do-	dpy <- openDisplay ""-        xSetErrorHandler-	let rwin = defaultRootWindow dpy--	a <- internAtom dpy "_NET_CLIENT_LIST" False-	p <- getWindowProperty32 dpy a rwin--	wins <- case p of-		Just wins -> return (map fromIntegral wins)-		Nothing   -> return []--	(fsubwin,_) <- getInputFocus dpy-	fwin <- followTreeUntil dpy (`elem` wins) fsubwin--	winData <- mapM (\w -> (,,) (w == fwin) <$> getWindowTitle dpy w <*> getProgramName dpy w) wins--	it <- fromIntegral `fmap` getXIdleTime dpy--	closeDisplay dpy-	return $ CaptureData winData it--getWindowTitle :: Display -> Window -> IO String-getWindowTitle dpy =  myFetchName dpy--getProgramName :: Display -> Window -> IO String-getProgramName dpy = fmap resName . getClassHint dpy---- | Follows the tree of windows up until the condition is met or the root--- window is reached.-followTreeUntil :: Display -> (Window -> Bool) -> Window -> IO Window -followTreeUntil dpy cond = go-  where go w | cond w    = return w-             | otherwise = do (r,p,_) <- queryTree dpy w-	                      if p == 0 then return w-			                else go p ---- | better than fetchName from X11, as it supports _NET_WM_NAME and unicode------ Code taken from XMonad.Managehook.title-myFetchName :: Display -> Window -> IO String-myFetchName d w = do-	let getProp =-	    	(internAtom d "_NET_WM_NAME" False >>= getTextProperty d w)-		`catch`-		(\_ -> getTextProperty d w wM_NAME)--	    extract prop = do l <- wcTextPropertyToTextList d prop-			      return $ if null l then "" else head l+{-# LANGUAGE CPP #-} -	bracket getProp (xFree . tp_value) extract `catch` \_ -> return ""+module Capture (+#ifdef WIN32+	module Capture.Win32+#else+	module Capture.X11+#endif+	) where +#ifdef WIN32+import Capture.Win32+#else+import Capture.X11+#endif
+ src/Capture/Win32.hs view
@@ -0,0 +1,28 @@+module Capture.Win32 where++import Data+import Control.Monad+import Control.Exception (bracket)+import Control.Applicative+import Data.Maybe+import Data.Time.Clock+import System.IO++import Graphics.Win32.Window.Extra++setupCapture :: IO ()+setupCapture = do+	return ()++captureData :: IO CaptureData+captureData = do+	titles <- fetchWindowTitles+	foreground <- getForegroundWindow++	let winData = map (+		\(h,t,p) -> (h == foreground, t, p)+		) titles++	it <- fromIntegral `fmap` getIdleTime++	return $ CaptureData winData it
+ src/Capture/X11.hs view
@@ -0,0 +1,81 @@+module Capture.X11 where++import Data+import Graphics.X11+import Graphics.X11.Xlib.Extras+import Control.Monad+import Control.Exception (bracket)+import Control.Applicative+import Data.Maybe+import Data.Time.Clock+import System.IO++import System.Locale.SetLocale+import Graphics.X11.XScreenSaver (getXIdleTime, compiledWithXScreenSaver)++setupCapture :: IO ()+setupCapture = do+        unless compiledWithXScreenSaver $+		hPutStrLn stderr "arbtt [Warning]: X11 was compiled without support for XScreenSaver"+	dpy <- openDisplay ""+        xSetErrorHandler+	let rwin = defaultRootWindow dpy+	a <- internAtom dpy "_NET_CLIENT_LIST" False+	p <- getWindowProperty32 dpy a rwin+	when (isNothing p) $ do+		hPutStrLn stderr "arbtt: ERROR: No _NET_CLIENT_LIST set for the root window"+	closeDisplay dpy++captureData :: IO CaptureData+captureData = do+	dpy <- openDisplay ""+        xSetErrorHandler+	let rwin = defaultRootWindow dpy++	a <- internAtom dpy "_NET_CLIENT_LIST" False+	p <- getWindowProperty32 dpy a rwin++	wins <- case p of+		Just wins -> return (map fromIntegral wins)+		Nothing   -> return []++	(fsubwin,_) <- getInputFocus dpy+	fwin <- followTreeUntil dpy (`elem` wins) fsubwin++	winData <- mapM (\w -> (,,) (w == fwin) <$> getWindowTitle dpy w <*> getProgramName dpy w) wins++	it <- fromIntegral `fmap` getXIdleTime dpy++	closeDisplay dpy+	return $ CaptureData winData it++getWindowTitle :: Display -> Window -> IO String+getWindowTitle dpy =  myFetchName dpy++getProgramName :: Display -> Window -> IO String+getProgramName dpy = fmap resName . getClassHint dpy++-- | Follows the tree of windows up until the condition is met or the root+-- window is reached.+followTreeUntil :: Display -> (Window -> Bool) -> Window -> IO Window +followTreeUntil dpy cond = go+  where go w | cond w    = return w+             | otherwise = do (r,p,_) <- queryTree dpy w+	                      if p == 0 then return w+			                else go p ++-- | better than fetchName from X11, as it supports _NET_WM_NAME and unicode+--+-- Code taken from XMonad.Managehook.title+myFetchName :: Display -> Window -> IO String+myFetchName d w = do+	let getProp =+	    	(internAtom d "_NET_WM_NAME" False >>= getTextProperty d w)+		`catch`+		(\_ -> getTextProperty d w wM_NAME)++	    extract prop = do l <- wcTextPropertyToTextList d prop+			      return $ if null l then "" else head l++	bracket getProp (xFree . tp_value) extract `catch` \_ -> return ""+
src/Data.hs view
@@ -8,6 +8,7 @@ import Data.Binary import Data.Binary.Put import Data.Binary.Get+import Data.Binary.StringRef import Control.Applicative import Control.Monad @@ -60,17 +61,18 @@  -- Data.Binary instances -instance Binary a => Binary (TimeLogEntry a) where- put tle = do+instance StringReferencingBinary a => StringReferencingBinary (TimeLogEntry a) where+ ls_put strs tle = do  	-- A version tag  	putWord8 1 	put (tlTime tle) 	put (tlRate tle)-	put (tlData tle)- get = do+	ls_put strs (tlData tle)+ ls_get strs = do  	v <- getWord8-	when (v /= 1) $ error $ "Wrong TimeLogEntry version tag " ++ show v-	TimeLogEntry <$> get <*> get <*> get+	case v of+	 1 -> TimeLogEntry <$> get <*> get <*> ls_get strs+	 _ -> error $ "Unsupported TimeLogEntry version tag " ++ show v  instance Binary UTCTime where  put (UTCTime (ModifiedJulianDay d) t) = do@@ -81,13 +83,34 @@ 	t <- get 	return $ UTCTime (ModifiedJulianDay d) (fromRational t) -instance Binary CaptureData where- put cd = do+instance ListOfStringable CaptureData where+  listOfStrings = concatMap (\(b,t,p) -> [t,p]) . cWindows++instance StringReferencingBinary CaptureData where+-- Versions:+-- 1 First version+-- 2 Using ListOfStringable+ ls_put strs cd = do  	-- A version tag- 	putWord8 1-	put (cWindows cd)-	put (cLastActivity cd)- get = do+ 	putWord8 2+	ls_put strs (cWindows cd)+	ls_put strs (cLastActivity cd)+ ls_get strs = do  	v <- getWord8-	when (v /= 1) $ error $ "Wrong CaptureData version tag " ++ show v-	CaptureData <$> get <*> get+	case v of+	 1 -> CaptureData <$> get <*> get+	 2 -> CaptureData <$> ls_get strs <*> ls_get strs+	 _ -> error $ "Unsupported CaptureData version tag " ++ show v++  -- | 'getMany n' get 'n' elements in order, without blowing the stack.+  --   From Data.Binary+getMany :: Binary a => Int -> Get [a]+getMany n = go [] n+ where+    go xs 0 = return $! reverse xs+    go xs i = do x <- get+                 -- we must seq x to avoid stack overflows due to laziness in+                 -- (>>=)+                 x `seq` go (x:xs) (i-1)+{-# INLINE getMany #-}+
+ src/Data/Binary/StringRef.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, TypeSynonymInstances, OverlappingInstances#-}++module Data.Binary.StringRef +	( ListOfStringable(..)+	, StringReferencingBinary(..)+	, ls_encode+	, ls_decode+	) where++import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Control.Monad+import Data.List+import Data.ByteString.Lazy (ByteString)++class StringReferencingBinary a => ListOfStringable a where+  listOfStrings :: a -> [String]++-- | An extended version of Binary that passes the list of strings of the+-- previous sample+class StringReferencingBinary a where+ ls_put :: [String] -> a -> Put+ ls_get :: [String] -> Get a++------------------------------------------------------------------------+-- Instances for the first few tuples++instance (StringReferencingBinary a, StringReferencingBinary b) => StringReferencingBinary (a,b) where+    ls_put strs (a,b)           = ls_put strs a >> ls_put strs b+    ls_get strs                 = liftM2 (,) (ls_get strs) (ls_get strs)++instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c) => StringReferencingBinary (a,b,c) where+    ls_put strs (a,b,c)         = ls_put strs a >> ls_put strs b >> ls_put strs c+    ls_get strs                 = liftM3 (,,) (ls_get strs) (ls_get strs) (ls_get strs)++instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d) => StringReferencingBinary (a,b,c,d) where+    ls_put strs (a,b,c,d)       = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d+    ls_get strs                 = liftM4 (,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs)++instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d, StringReferencingBinary e) => StringReferencingBinary (a,b,c,d,e) where+    ls_put strs (a,b,c,d,e)     = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d >> ls_put strs e+    ls_get strs                 = liftM5 (,,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs)+++instance StringReferencingBinary a => StringReferencingBinary [a] where+    ls_put strs l  = ls_put strs (length l) >> mapM_ (ls_put strs) l+    ls_get strs    = do n <- (ls_get strs) :: Get Int+                        ls_getMany strs n++-- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack.+ls_getMany :: StringReferencingBinary a => [String] -> Int -> Get [a]+ls_getMany strs n = go [] n+ where+    go xs 0 = return $! reverse xs+    go xs i = do x <- ls_get strs+                 -- we must seq x to avoid stack overflows due to laziness in+                 -- (>>=)+                 x `seq` go (x:xs) (i-1)+{-# INLINE ls_getMany #-}++instance StringReferencingBinary String where+	ls_put strs s = case elemIndex s strs of+		Just i | 0 <= i && i  < 255 - 2 ->+			put (fromIntegral (succ i) :: Word8)+		_ ->    put (0 :: Word8) >> put s+	ls_get strs = do+		tag <- get+		case tag :: Word8 of+		  0 -> get+		  i -> return $! strs !! fromIntegral (pred i)++{-+instance Binary a => StringReferencingBinary a where+	ls_put _ = put+	ls_get _ = get+-}++instance StringReferencingBinary Char where { ls_put _ = put; ls_get _ = get }+instance StringReferencingBinary Int  where { ls_put _ = put; ls_get _ = get }+instance StringReferencingBinary Integer  where { ls_put _ = put; ls_get _ = get }+instance StringReferencingBinary Bool  where { ls_put _ = put; ls_get _ = get }++ls_encode :: StringReferencingBinary a => [String] -> a -> ByteString+ls_encode strs = runPut . ls_put strs+{-# INLINE ls_encode #-}++-- | Decode a value from a lazy ByteString, reconstructing the original structure.+--+ls_decode :: StringReferencingBinary a => [String] -> ByteString -> a+ls_decode strs = runGet (ls_get strs)++
+ src/Graphics/Win32/Window/Extra.hsc view
@@ -0,0 +1,113 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module Graphics.Win32.Window.Extra+	( fetchWindowTitles+	, getForegroundWindow+	, getIdleTime+	) where++import Graphics.Win32.GDI.Types+import System.Win32.Types+import System.Win32.Process+import System.Win32.File    ( closeHandle )+import System.IO+import Control.Exception    ( bracket )+import Control.Monad++import Foreign++import Data.IORef ++#include <windows.h>++type EnumWindowsProc = HWND -> LPARAM -> IO Bool++foreign import ccall "wrapper"+  mkEnumWindowsProc :: EnumWindowsProc -> IO (FunPtr EnumWindowsProc)++foreign import stdcall safe "windows.h EnumWindows"+  c_EnumWindows :: (FunPtr EnumWindowsProc) -> LPARAM -> IO Bool++foreign import stdcall unsafe "windows.h GetWindowTextW"+  c_GetWindowText :: HWND -> LPWSTR -> Int -> IO Int++foreign import stdcall unsafe "windows.h GetWindowTextLengthW"+  c_GetWindowTextLength :: HWND -> IO Int++foreign import stdcall unsafe "windows.h GetForegroundWindow"+  c_GetForegroundWindow :: IO HWND++foreign import stdcall unsafe "windows.h GetLastInputInfo"+  c_GetLastInputInfo :: Ptr LASTINPUTINFO -> IO Bool++foreign import stdcall unsafe "windows.h GetTickCount"+  c_GetTickCount :: IO DWORD++foreign import stdcall unsafe "windows.h GetWindowThreadProcessId"+  c_GetWindowThreadProcessId :: HWND -> LPDWORD -> IO DWORD++foreign import stdcall unsafe "psapi.h GetProcessImageFileNameW"+  c_GetProcessImageFileName :: HANDLE -> LPTSTR -> DWORD -> IO DWORD++foreign import stdcall unsafe "windows.h SetLastError"+  c_SetLastError :: DWORD -> IO ()++foreign import stdcall unsafe "windows.h IsWindowVisible"+  c_IsWindowVisible :: HWND -> IO Bool++data LASTINPUTINFO = LASTINPUTINFO DWORD deriving (Show)++instance Storable LASTINPUTINFO where+    sizeOf = const (#size LASTINPUTINFO)+    alignment = sizeOf+    poke buf (LASTINPUTINFO t) = do+        (#poke LASTINPUTINFO, cbSize) buf ((#size LASTINPUTINFO) :: UINT)+        (#poke LASTINPUTINFO, dwTime) buf t+    peek buf = do+        t <- (#peek LASTINPUTINFO, dwTime) buf+        return $ LASTINPUTINFO t++fetchWindowTitles :: IO [(HWND, String,String)]+fetchWindowTitles = do+	resultRef <- newIORef []+	callback <- mkEnumWindowsProc $ \winh _ -> do+                v <- c_IsWindowVisible winh -- only consider visible windows+                if not v then return True else do+                proc <- alloca $ \pid_p -> do+                        c_GetWindowThreadProcessId winh pid_p +                        pid <- peek pid_p+                        bracket (openProcess pROCESS_QUERY_INFORMATION False pid) closeHandle $ \ph ->+                                allocaArray0 (#const MAX_PATH) $ \c_test -> do+                                        c_SetLastError (#const ERROR_SUCCESS)+                                        r <- c_GetProcessImageFileName ph c_test ((#const MAX_PATH)+1)+                                        err <- getLastError+                                        if r == 0 && err /= (#const ERROR_SUCCESS)+                                         then do hPutStrLn stderr $ "GetProcessImageFileName returned error " ++ show err ++ "."+                                                 return ""+                                         else peekTString c_test+                                         +		len <- c_GetWindowTextLength winh+		str <- allocaArray0 len  $ \c_test -> do+                        c_SetLastError (#const ERROR_SUCCESS)+			r <- c_GetWindowText winh c_test (len+1)+			err <- getLastError+			if r == 0 && err /= (#const ERROR_SUCCESS)+                         then do hPutStrLn stderr $ "GetWindowText returned error " ++ show err ++ "."+                                 return ""+			 else peekTString c_test+                unless (str `elem` ["", "Default IME"]) $ do -- Ignore some windows by default+                        modifyIORef resultRef ((winh,str,proc):)+                return True+	c_EnumWindows callback 0+	readIORef resultRef++getForegroundWindow :: IO HWND+getForegroundWindow = c_GetForegroundWindow++-- | Idle time in milliseconds+getIdleTime :: IO Integer+getIdleTime = with (LASTINPUTINFO 0) $ \lii_p -> do+		failIfFalse_ "GetLastInputInfo" $ c_GetLastInputInfo lii_p+		LASTINPUTINFO lii <- peek lii_p+		now <- c_GetTickCount+		return (fromIntegral (now - lii))
+ src/System/Win32/Mutex.hsc view
@@ -0,0 +1,32 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module System.Win32.Mutex +	( claimMutex+	) where++import System.Win32.Types+import Foreign++#include <windows.h>++type LPSECURITY_ATTRIBUTES = Ptr ()++foreign import stdcall unsafe "windows.h CreateMutexW"+  c_CreateMutex :: LPSECURITY_ATTRIBUTES -> Bool -> LPCTSTR -> IO HANDLE++foreign import stdcall unsafe "windows.h SetLastError"+  c_SetLastError :: DWORD -> IO ()++-- | Given a unique identifier in the string, this function tries to create+--   and claim a mutex based on that name. Returns 'True' if the mutex was claimed.+claimMutex :: String -> IO Bool+claimMutex lockfilename = do+	let name = "Local\\" ++ filter (/='\\') lockfilename+	withTString name $ \c_str -> do+	c_SetLastError (#const ERROR_SUCCESS)+	handle <- c_CreateMutex nullPtr True c_str+	err <- getLastError+	if handle == nullPtr+	  then errorWin "CreateMutex"+	  else return (err /= (#const ERROR_ALREADY_EXISTS))+
src/TimeLog.hs view
@@ -8,6 +8,7 @@ import Control.Monad import Data.Time import Data.Binary+import Data.Binary.StringRef import Data.Binary.Get import Data.Function import Data.Char@@ -22,28 +23,34 @@  -- | Runs the given action each delay milliseconds and appends the TimeLog to the -- given file.-runLogger :: Binary a => FilePath -> Integer -> IO a -> IO ()-runLogger filename delay action = forever $ do+runLogger :: ListOfStringable a => FilePath -> Integer -> IO a -> IO ()+runLogger filename delay action = flip fix Nothing $ \loop prev -> do 	entry <- action 	date <- getCurrentTime 	createTimeLog False filename-	appendTimeLog filename (TimeLogEntry date delay entry)+	appendTimeLog filename prev (TimeLogEntry date delay entry) 	threadDelay (fromIntegral delay * 1000)+	loop (Just entry)+ 	 createTimeLog :: Bool -> FilePath -> IO () createTimeLog force filename = do 	ex <- doesFileExist filename 	when (not ex || force) $ BS.writeFile filename magic -appendTimeLog :: Binary a => FilePath -> TimeLogEntry a -> IO ()-appendTimeLog filename = BS.appendFile filename . encode+appendTimeLog :: ListOfStringable a => FilePath -> Maybe a -> TimeLogEntry a -> IO ()+appendTimeLog filename prev = BS.appendFile filename . ls_encode strs+  where strs = maybe [] listOfStrings prev -writeTimeLog :: Binary a => FilePath -> TimeLog a -> IO ()-writeTimeLog filename tl = do createTimeLog True filename-			      mapM_ (appendTimeLog filename) tl+writeTimeLog :: ListOfStringable a => FilePath -> TimeLog a -> IO ()+writeTimeLog filename tl = do+	createTimeLog True filename+	foldM_ go  Nothing tl+  where go prev v = do appendTimeLog filename prev v+  		       return (Just (tlData v))  -- | This might be very bad style, and it hogs memory, but it might help in some situations...-recoverTimeLog :: Binary a => FilePath -> IO (TimeLog a)+recoverTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a) recoverTimeLog filename = do 	content <- BS.readFile filename         start content@@ -53,15 +60,16 @@ 		  then do putStrLn $ "WARNING: Timelog starts with unknown marker " ++ 				show (map (chr.fromIntegral) (BS.unpack startString)) 		  else do putStrLn $ "Found header, continuing... (" ++ show (BS.length rest) ++ " bytes to go)"-		go rest off-        go input off = do mb <- tryGet False input off-	 	          flip (maybe (return [])) mb $-		     	  	\(v,rest,off') -> if BS.null rest-			                          then return [v]-			                          else (v :) <$> go rest off'-	tryGet retrying input off = catch (+		go Nothing rest off+        go prev input off = do+		mb <- tryGet prev False input off+		flip (maybe (return [])) mb $ \(v,rest,off') ->+			if BS.null rest+			then return [v]+			else (v :) <$> go (Just (tlData v)) rest off'+	tryGet prev retrying input off = catch ( 			do -- putStrLn $ "Trying value at offset " ++ show off-			   let (v,rest,off') = runGetState get input off+			   let (v,rest,off') = runGetState (ls_get strs) input off 			   evaluate rest 			   when retrying $ 			   	putStrLn $ "Succesfully read value at position " ++ show off@@ -74,21 +82,24 @@ 			     then do putStrLn $ "End of file reached" 			             return Nothing 			     else do putStrLn $ "Trying at position " ++ show (off+1) ++ "."-			             tryGet True (BS.tail input) (off+1)+			             tryGet prev True (BS.tail input) (off+1) 			)+	  where strs = maybe [] listOfStrings prev -readTimeLog :: Binary a => FilePath -> IO (TimeLog a)+readTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a) readTimeLog filename = do 	content <- BS.readFile filename         return $ runGet start content   where start = do   		startString <- getLazyByteString (BS.length magic) 		if startString == magic-		 then go+		 then go Nothing 		 else error $ 		 	"Timelog starts with unknown marker " ++ 			show (map (chr.fromIntegral) (BS.unpack startString))-        go = do v <- get-		m <- isEmpty-		if m then return [v]-		     else (v :) <$> go+        go prev = do v <- ls_get strs+	  	     m <- isEmpty+		     if m then return [v]+		          else (v :) <$> go (Just (tlData v))+	  where strs = maybe [] listOfStrings prev+
src/capture-main.hs view
@@ -1,15 +1,18 @@+{-# LANGUAGE CPP #-} module Main where  import Control.Monad import Control.Concurrent import System.Directory import System.FilePath-import Graphics.X11.XScreenSaver (compiledWithXScreenSaver) import System.IO-import System.Posix.IO import System.IO.Error+#ifdef WIN32+import System.Win32.Mutex+#else+import System.Posix.IO+#endif import System.Exit-import System.Locale.SetLocale import System.Console.GetOpt import System.Environment import Data.Maybe@@ -18,6 +21,7 @@ import Capture import TimeLog import UpgradeLog1+import CommonStartup  import Paths_arbtt (version) @@ -47,14 +51,20 @@      ]	       -- | This is very raw, someone ought to improve this-lockFile filename = flip catch (\e -> hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") >> exitFailure) $ do-    fd <- openFd (filename  ++ ".lck") WriteOnly (Just 0o644) defaultFileFlags-    setLock fd (WriteLock, AbsoluteSeek, 0, 0)+lockFile filename = do+#ifdef WIN32+    success <- claimMutex filename+    unless success $ do+    	hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!")+	exitFailure+#else+    flip catch (\e -> hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") >> exitFailure) $ do+        fd <- openFd (filename  ++ ".lck") WriteOnly (Just 0o644) defaultFileFlags+        setLock fd (WriteLock, AbsoluteSeek, 0, 0)+#endif         main = do-    setLocale LC_ALL (Just "") -    unless compiledWithXScreenSaver $-    	hPutStrLn stderr "arbtt [Warning]: X11 was compiled without support for XScreenSaver"+    commonStartup          args <- getArgs     flags <- case getOpt Permute options args of@@ -78,5 +88,5 @@     let captureFile = dir </> "capture.log"     lockFile captureFile     upgradeLogFile1 captureFile-    setupChecks+    setupCapture     runLogger captureFile (sampleRate * 1000) captureData
src/dump-main.hs view
@@ -12,6 +12,7 @@  import TimeLog import Data+import CommonStartup  import Paths_arbtt (version) @@ -36,6 +37,7 @@   main = do+  commonStartup   args <- getArgs   flags <- case getOpt Permute options args of           (o,[],[]) | Help `notElem` o  && Version `notElem` o -> return o
src/recover-main.hs view
@@ -12,6 +12,7 @@  import TimeLog import Data+import CommonStartup  import Paths_arbtt (version) @@ -39,6 +40,7 @@   main = do+  commonStartup   args <- getArgs   flags <- case getOpt Permute options args of           (o,[],[]) | Help `notElem` o  && Version `notElem` o -> return o
src/stats-main.hs view
@@ -18,6 +18,7 @@ import Data import Categorize import Stats+import CommonStartup  import Paths_arbtt (version) @@ -74,6 +75,7 @@   main = do+  commonStartup   args <- getArgs   flags <- case getOpt Permute options args of           (o,[],[]) | Help `notElem` o  && Version `notElem` o -> return o