packages feed

propellor 2.3.0 → 2.4.0

raw patch · 38 files changed

+405/−206 lines, 38 filesdep +exceptionsdep +transformersdep −MonadCatchIO-transformers

Dependencies added: exceptions, transformers

Dependencies removed: MonadCatchIO-transformers

Files

CHANGELOG view
@@ -1,3 +1,19 @@+propellor (2.4.0) unstable; urgency=medium++  * Propellor no longer supports Debian wheezy (oldstable).+  * Git.bareRepo: Fix bug in calls to userScriptProperty.+    Thanks, Jelmer Vernooij.+  * Removed Obnam.latestVersion which was only needed for Debian wheezy+    backport.+  * Merged Utility changes from git-annex.+  * Switched from MonadCatchIO-transformers to the newer transformers and+    exceptions libraries.+  * Ensure build deps are installed before building propellor in --spin+    and cron job, even if propellor was already built before, to deal with+    upgrades that add new dependencies.++ -- Joey Hess <id@joeyh.name>  Wed, 06 May 2015 14:28:59 -0400+ propellor (2.3.0) unstable; urgency=medium    * Make propellor resistent to changes to shared libraries, such as libffi,
config-joey.hs view
@@ -334,6 +334,7 @@ 	& GitHome.installedFor (User "joey") 	& Ssh.authorizedKey (User "db48x") "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAAIAQDQ6urXcMDeyuFf4Ga7CuGezTShKnEMPHKJm7RQUtw3yXCPX5wnbvPS2+UFnHMzJvWOX5S5b/XpBpOusP0jLpxwOCEg4nA5b7uvWJ2VIChlMqopYMo+tDOYzK/Q74MZiNWi2hvf1tn3N9SnqOa7muBMKMENIX5KJdH8cJ/BaPqAP883gF8r2SwSZFvaB0xYCT/CIylC593n/+0+Lm07NUJIO8jil3n2SwXdVg6ib65FxZoO86M46wTghnB29GXqrzraOg+5DY1zzCWpIUtFwGr4DP0HqLVtmAkC7NI14l1M0oHE0UEbhoLx/a+mOIMD2DuzW3Rs3ZmHtGLj4PL/eBU8D33AqSeM0uR/0pEcoq6A3a8ixibj9MBYD2lMh+Doa2audxS1OLM//FeNccbm1zlvvde82PZtiO11P98uN+ja4A+CfgQU5s0z0wikc4gXNhWpgvz8DrOEJrjstwOoqkLg2PpIdHRw7dhpp3K1Pc+CGAptDwbKkxs4rzUgMbO9DKI7fPcXXgKHLLShMpmSA2vsQUMfuCp2cVrQJ+Vkbwo29N0Js5yU7L4NL4H854Nbk5uwWJCs/mjXtvTimN2va23HEecTpk44HDUjJ9NyevAfPcO9q1ZtgXFTQSMcdv1m10Fvmnaiy8biHnopL6MBo1VRITh5UFiJYfK4kpTTg2vSspii/FYkkYOAnnZtXZqMehP7OZjJ6HWJpsCVR2hxP3sKOoQu+kcADWa/4obdp+z7gY8iMMjd6kwuIWsNV8KsX+eVJ4UFpAi/L00ZjI2B9QLVCsOg6D1fT0698wEchwUROy5vZZJq0078BdAGnwC0WGLt+7OUgn3O2gUAkb9ffD0odbZSqq96NCelM6RaHA+AaIE4tjGL3lFkyOtb+IGPNACQ73/lmaRQd6Cgasq9cEo0g22Ew5NQi0CBuu1aLDk7ezu3SbU09eB9lcZ+8lFnl5K2eQFeVJStFJbJNfOvgKyOb7ePsrUFF5GJ2J/o1F60fRnG64HizZHxyFWkEOh+k3i8qO+whPa5MTQeYLYb6ysaTPrUwNRcSNNCcPEN8uYOh1dOFAtIYDcYA56BZ321yz0b5umj+pLsrFU+4wMjWxZi0inJzDS4dVegBVcRm0NP5u8VRosJQE9xdbt5K1I0khzhrEW1kowoTbhsZCaDHhL9LZo73Z1WIHvulvlF3RLZip5hhtQu3ZVkbdV5uts8AWaEWVnIu9z0GtQeeOuseZpT0u1/1xjVAOKIzuY3sB7FKOaipe8TDvmdiQf/ICySqqYaYhN6GOhiYccSleoX6yzhYuCvzTgAyWHIfW0t25ff1CM7Vn+Vo9cVplIer1pbwhZZy4QkROWTOE+3yuRlQ+o6op4hTGdAZhjKh9zkDW7rzqQECFrZrX/9mJhxYKjhpkk0X3dSipPt9SUHagc4igya+NgCygQkWBOQfr4uia0LcwDxy4Kchw7ZuypHuGVZkGhNHXS+9JdAHopnSqYwDMG/z1ys1vQihgER0b9g3TchvGF+nmHe2kbM1iuIYMNNlaZD1yGZ5qR7wr/8dw8r0NBEwzsUfak3BUPX7H6X0tGS96llwUxmvQD85WNNoef0uryuAtDEwWlfN1RmWysZDc57Rn4gZi0M5jXmQD23ZiYXYBcG849OeqNzlxONEFsForXO/29Ud4x/Hqa9tf+kJbqMRsaLFO+PXhHzgl6ZHLAljQDxrJ6keNnkqaYfqQ8wyRi1mKv4Ab57kde7mUsZhe7w93GaE9Lxfvu7d3pB+lXfI9NJCSITHreUP4JfmFW+p/eVg+r/1wbElNylGna4I4+qYObOUncGwFKYdFPdtU1XLDKXmywTEgbEh7iI9zX0xD3bPHQLMg+TTtXiU9dQm1x/0zRf9trwDsRDJCbG4/P4iQYkcVvYx2CCfi0JSHv8tWsLi3GJKJLXUxZyzfvY2lThPeYnnY/HFrPJCyJUN55QuRmfzbu8rHgWlcyOlVpKtz+7kn823kEQykiIYKIKrb0G6VBzuMtAk9XzJPv+Wu7suOGXHlVfCqPLk6RjHDm4kTYciW9VgxDts5Y+zwcAbrUeA4UuN/6KisWpivMrfDSIHUCeH/lHBtNkqKohdrUKJMEOx5X6r2dJbmoTFBDi5XtYu/5cBtiDMmupNB0S+pZ2JD5/RKtj6kgzTeE1q/OG4q/eq1O1rjf0vIS31luy27K/YHFIGE0D/CmuXE74Uyaxm27RnrKUxEBl84V70GaIF4F5On8pSThxxizigXTRTKiczc+A5Zi29mid+1EFeUAJOa/DuHJfpVNY4pYEmhPl/Bk66L8kzlbJz6Hg/LIiJIRcy3UKrbSxPFIDpXn33drBHgklMDlrIVDZDXF6cn0Ml71SabB4A3TM6TK+oWZoyvftPIhcWhVwAWQj7nFNAiMEl1z/29ovHrRooqQFozf7GDW8Mjiu7ChZP9zx2H8JB/AAEFuWMwGV4AHICYdS9lOl/v+cDhgsnXdeuKEuxHhYlRxuRxJk/f17Sm/5H85UIzlu85wi3q/DW2FTZnlw4iJLnL6FArUIMzuBOZyoEhh0SPR41Xc4kkucDhnENybTZSR/yDzb0P1B7qjZ4GqcSEFja/hm/LH1oKJzZg8MEqeUoKYCUdVv9ek4IUGUONtVs53V5SOwFWR/nVuDk2BENr7NadYYVtu6MjBwgjso7NuhoNxVwIEP3BW67OQ8bxfNBtJJQNJejAhgZiqJItI9ucAfjQ== db48x@anglachel" 	& Apt.installed ["sudo"]+	& Ssh.noPasswords 	& IABak.gitServer monsters 	& IABak.registrationServer monsters 	& IABak.graphiteServer@@ -405,10 +406,7 @@ -- This is my standard system setup. standardSystem :: HostName -> DebianSuite -> Architecture -> Motd -> Host standardSystem hn suite arch motd = standardSystemUnhardened hn suite arch motd-	-- Harden the system, but only once root's authorized_keys-	-- is safely in place.-	& check (Ssh.hasAuthorizedKeys (User "root"))-		(Ssh.passwordAuthentication False)+	& Ssh.noPasswords  standardSystemUnhardened :: HostName -> DebianSuite -> Architecture -> Motd -> Host standardSystemUnhardened hn suite arch motd = host hn
debian/changelog view
@@ -1,3 +1,19 @@+propellor (2.4.0) unstable; urgency=medium++  * Propellor no longer supports Debian wheezy (oldstable).+  * Git.bareRepo: Fix bug in calls to userScriptProperty.+    Thanks, Jelmer Vernooij.+  * Removed Obnam.latestVersion which was only needed for Debian wheezy+    backport.+  * Merged Utility changes from git-annex.+  * Switched from MonadCatchIO-transformers to the newer transformers and+    exceptions libraries.+  * Ensure build deps are installed before building propellor in --spin+    and cron job, even if propellor was already built before, to deal with+    upgrades that add new dependencies.++ -- Joey Hess <id@joeyh.name>  Wed, 06 May 2015 14:28:59 -0400+ propellor (2.3.0) unstable; urgency=medium    * Make propellor resistent to changes to shared libraries, such as libffi,
debian/control view
@@ -15,7 +15,8 @@ 	libghc-network-dev, 	libghc-quickcheck2-dev, 	libghc-mtl-dev,-	libghc-monadcatchio-transformers-dev,+	libghc-transformers-dev,+	libghc-exceptions-dev, Maintainer: Gergely Nagy <algernon@madhouse-project.org> Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor@@ -36,7 +37,8 @@ 	libghc-network-dev, 	libghc-quickcheck2-dev, 	libghc-mtl-dev,-	libghc-monadcatchio-transformers-dev,+	libghc-transformers-dev,+	libghc-exceptions-dev, 	git, Description: property-based host configuration management in haskell  Propellor enures that the system it's run in satisfies a list of
propellor.cabal view
@@ -1,5 +1,5 @@ Name: propellor-Version: 2.3.0+Version: 2.4.0 Cabal-Version: >= 1.6 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -37,8 +37,8 @@   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async, time, QuickCheck, mtl,-   MonadCatchIO-transformers+   containers, network, async, time, QuickCheck, mtl, transformers,+   exceptions    if (! os(windows))     Build-Depends: unix@@ -49,8 +49,8 @@   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async, time, QuickCheck, mtl,-   MonadCatchIO-transformers+   containers, network, async, time, QuickCheck, mtl, transformers,+   exceptions    if (! os(windows))     Build-Depends: unix@@ -60,8 +60,8 @@   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async, time, QuickCheck, mtl,-   MonadCatchIO-transformers+   containers, network, async, time, QuickCheck, mtl, transformers,+   exceptions    if (! os(windows))     Build-Depends: unix
src/Propellor/Bootstrap.hs view
@@ -17,12 +17,10 @@ -- Should be run inside the propellor config dir, and will install -- all necessary build dependencies and build propellor. bootstrapPropellorCommand :: ShellCommand-bootstrapPropellorCommand = "if ! test -x ./propellor; then " ++ go ++ "; fi;" ++ checkBinaryCommand-  where-	  go = intercalate " && "-		[ depsCommand-		, buildCommand-		]+bootstrapPropellorCommand = checkDepsCommand ++ +	"&& if ! test -x ./propellor; then " +		++ buildCommand ++ +	"; fi;" ++ checkBinaryCommand  -- Use propellor --check to detect if the local propellor binary has -- stopped working (eg due to library changes), and must be rebuilt.@@ -41,6 +39,11 @@ 	, "ln -sf dist/build/propellor-config/propellor-config propellor" 	] +-- Run cabal configure to check if all dependencies are installed;+-- if not, run the depsCommand.+checkDepsCommand :: ShellCommand+checkDepsCommand = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand ++ "; fi"+ -- Install build dependencies of propellor. -- -- First, try to install ghc, cabal, gnupg, and all haskell libraries that@@ -77,7 +80,8 @@ 		, "libghc-network-dev" 		, "libghc-quickcheck2-dev" 		, "libghc-mtl-dev"-		, "libghc-monadcatchio-transformers-dev"+		, "libghc-transformers-dev"+		, "libghc-exceptions-dev" 		]  installGitCommand :: ShellCommand
src/Propellor/Engine.hs view
@@ -17,7 +17,6 @@ import Control.Applicative import System.Console.ANSI import "mtl" Control.Monad.RWS.Strict-import Control.Exception (bracket) import System.PosixCompat import System.Posix.IO import System.FilePath
src/Propellor/Exception.hs view
@@ -2,12 +2,12 @@  module Propellor.Exception where -import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M-import Control.Exception- import Propellor.Types import Propellor.Message+import Utility.Exception +import Control.Exception (IOException)+ -- | Catches IO exceptions and returns FailedChange. catchPropellor :: Propellor Result -> Propellor Result catchPropellor a = either err return =<< tryPropellor a@@ -15,4 +15,4 @@ 	err e =  warningMessage (show e) >> return FailedChange  tryPropellor :: Propellor a -> Propellor (Either IOException a)-tryPropellor = M.try+tryPropellor = try
src/Propellor/Message.hs view
@@ -6,7 +6,7 @@ import System.IO import System.Log.Logger import System.Log.Formatter-import System.Log.Handler (setFormatter, LogHandler)+import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import "mtl" Control.Monad.Reader import Data.Maybe
src/Propellor/Property/Debootstrap.hs view
@@ -20,7 +20,6 @@  import Data.List import Data.Char-import Control.Exception import System.Posix.Directory import System.Posix.Files
src/Propellor/Property/File.hs view
@@ -35,7 +35,7 @@ hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo hasPrivContentExposedFrom = hasPrivContent' writeFile -hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property HasInfo+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property HasInfo hasPrivContent' writer source f context =  	withPrivData source context $ \getcontent ->  		property desc $ getcontent $ \privcontent ->
src/Propellor/Property/Git.hs view
@@ -103,15 +103,15 @@ 	dirExists repo : case gitshared of 		NotShared -> 			[ ownerGroup repo user (userGroup user)-			, userScriptProperty user ["git", "init", "--bare", "--shared=false", repo]+			, userScriptProperty user ["git init --bare --shared=false " ++ shellEscape repo] 			] 		SharedAll -> 			[ ownerGroup repo user (userGroup user)-			, userScriptProperty user ["git", "init", "--bare", "--shared=all", repo]+			, userScriptProperty user ["git init --bare --shared=all " ++ shellEscape repo] 			] 		Shared group' -> 			[ ownerGroup repo user group'-			, userScriptProperty user ["git", "init", "--bare", "--shared=group", repo]+			, userScriptProperty user ["git init --bare --shared=group " ++ shellEscape repo] 			]   where 	isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])
src/Propellor/Property/Obnam.hs view
@@ -110,62 +110,3 @@  installed :: Property NoInfo installed = Apt.installed ["obnam"]---- | Ensures that a recent version of obnam gets installed.------ Only does anything for Debian Stable.-latestVersion :: Property NoInfo-latestVersion = withOS "obnam latest version" $ \o -> case o of-	(Just (System (Debian suite) _)) | isStable suite -> ensureProperty $-		Apt.setSourcesListD (stablesources suite) "obnam"-			`requires` Apt.trustsKey' key-	_ -> noChange-  where-	stablesources suite = -		[ "deb http://code.liw.fi/debian " ++ Apt.showSuite suite ++ " main"-		]-	-- gpg key used by the code.liw.fi repository.-	key = Apt.AptKey "obnam" $ unlines-		[ "-----BEGIN PGP PUBLIC KEY BLOCK-----"-		, "Version: GnuPG v1.4.9 (GNU/Linux)"-		, ""-		, "mQGiBEfzuTgRBACcVNG/H6QJqLx5qiQs2zmPe6D6BWOWHfgNgG4IWzNstm21YDxb"-		, "KqwFG0gxcnZJGHkXAhkSfqTokYd0lc5eBemcA1pkceNjzMEX8wwiZ810HzJD4eEH"-		, "sjoWR8+qKrZeixzZqReAfqztcXoBGKQ0u1R1vpg1txUa75OM4BUqaUbsmwCgmS4x"-		, "DjMxSaUSPuu6vQ7ZGZBXSP0D/RQw8DBHMfsv3DiaqFqk8tkuUkpMFPIekHidSHlO"-		, "EACbncqbbyHksyCpFNVNcQIDHrOLjOZK9BAXkSd8I3ww7U+nLdDcCblrW8CZnJtm"-		, "ZYrxfaXaHZ/It9/RCAsQ+c8xtmyUPjsf//4Vf8olxNQHzgBSe5/LJRi4Vd53he+K"-		, "YP4LA/9IZbjvVmm8+8Y0pQrTHlI6nTImtzdBXHc4+T3lLBj9XODHLozC2kSBOQky"-		, "q/EisTITHTXL8vYg4NsKm5RTbPAuBwdtxcny8CXfOqKtGOdrebmKotGllTozzdPv"-		, "9p53cuce6oJ2oMUodc074JOGTWwDSgLiJX4nViGcU1wy/vtQnrQkY29kZS5saXcu"-		, "ZmkgYXJjaGl2ZSBrZXkgPGxpd0BsaXcuZmk+iGAEExECACAFAkfzuTgCGwMGCwkI"-		, "BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRBG53tJR95LscKrAJ0ZtKqa2x6Kplwa2mzx"-		, "ItImbIGMJACdETqofDYzUN91yLAFlOnxAyrE+UyIRgQQEQIABgUCSFd5GgAKCRAf"-		, "u5W/LZrMjqr8AJ4xPVHpW8ZNlgMwDSVb075RnA2DiACgg2SR69jAHFQOWV6xfLRr"-		, "vh0bLKGJAhwEEAEIAAYFAktEyIwACgkQ61zh116FEfm7Lg//Wiy3TjWAk8YHUddv"-		, "zOioYzCxQ985GsVhJGAVPqSGOc9vfTWBJZ8J3l0NnYTRpEGucmbF9G+mAt9iGXu6"-		, "7yZkxyFdvbo7EDsqMU1wLOM6PiU+Un63MKlbTNmFn7OKE8aXPRAFgcyUO/qjdqoD"-		, "sa9FgU5Z0f60m9qah6BPXH6IzMLHYoiP7t8rCBIwLgyl3w2w+Fjt1DFpbW9Kb7jz"-		, "i8jFvC8jPmxV8xh2OSgVZyNk4qg6hIV8GVQY7AJt8OurZSckgQd7ifHK9JTGohtF"-		, "tXCiqeDEvnMF4A9HI/TcXJBzonZ8ds1JCq42nSSKmL+8TyjtUSD/xHygazuc0CK0"-		, "hFnQWBub60IfyV6F0oTagJ8cmARv2sezHAeHDkzPHE8RdjgktazH1eJrA4LheEd6"-		, "KeSnVtYWpw8dgMv5PleFyQiAj/t3C/N50fd15tUyfnH15G7nFjMQV2Yx35uwSxOj"-		, "376OWnDN/YGTNk283XXULbyVJYR8Q2unso20XQ94yQ2A5EpHHPrHoLxrL/ydM08d"-		, "nvKstLZIZtal1seiMkymtlSiGz25A5oqsclwS6VZCKdWA8HO/wlElOMcaHyl6Y1y"-		, "gYP7y9O5yFYKFOrCH0nFjJbwmkRiBLsxuuWsYgJigVGq/atSrtawkHdshpCw0HCY"-		, "N/RFcWkJ864BdsO0C0sDzueNkQO5Ag0ER/O5RBAIAJiwPH9tyJTgXcC2Y4XWboOq"-		, "rx5CkOnr5b45oS9cK2eIJ8TKxE3XgKLxUr3mIH0QR2kZgDOwNl0WY+7/CXjn+Spn"-		, "BokPg54rafEUePodGpGdUXdgrHhAMHYjh8fXFJ1SlQcg46/zc1wDI7jBCkGrK3V8"-		, "5cXDqwTFTN5LcjoSRWeM4Voa6pEfDdL3rMlnOw9R9gDHRBBb6CDSjWXqM86pR889"-		, "5QrR0SDwiJNrMoyxSjMXFKGBQAsYHJ82myZrlbuZbroZjVp5Uh7eB1ZiPljNVtcr"-		, "sksACIWBCo1rvLzrPXsLYOeV3cDDtYAkSwGfuzC1Etbe+qgfIroFTOqdefMw4s8A"-		, "AwUH/0KLXm4MS54QQspg3evu4Q4U/E8Hem5/FqB0GhBCitQ4rUsucKyY8/ItpUn5"-		, "ismLE60bQqka+Mzd/Zw18TCTzImv0ozAaZ2sNtBado7f6jcC8EDfY5zzK1ukcsAr"-		, "Qc5hdLHYuTQW5KpA6fKaW969OUzIwPbdVaCOLOBpxKC6N6iBspQYd6uiQtLw6EUO"-		, "50oQqUiJABf0eOocvdw5e2KQQpuC3205+VMYtyl4w3pdJihK8NK0AikGXzDVsbQt"-		, "l8kmB5ZrN4WIKhMke1FxbqQC5Q3XATvYRzpzzisZb/HYGNti8W6du5EUwJ0D2NRh"-		, "cu+twocOzW0VKfmrDApfifJ9OsSISQQYEQIACQUCR/O5RAIbDAAKCRBG53tJR95L"-		, "seQOAJ95KUyzjRjdYgZkDC69Mgu25L86UACdGduINUaRly43ag4kwUXxpqswBBM="-		, "=i2c3"-		, "-----END PGP PUBLIC KEY BLOCK-----"-		]
src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs view
@@ -142,7 +142,7 @@ 	haskellpkgsinstalled = userScriptProperty (User builduser) 		[ "cd " ++ gitannexdir ++ " && ./standalone/android/install-haskell-packages" 		]-	osver = System (Debian Testing) "i386" -- once jessie is released, use: (Stable "jessie")+	osver = System (Debian Testing) "i386"  -- armel builder has a companion container using amd64 that -- runs the build first to get TH splices. They need
src/Propellor/Property/SiteSpecific/JoeySites.hs view
@@ -96,7 +96,6 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props 	& Apt.installed ["leafnode"] 	& oldUseNetInstalled "oldusenet-server"-	& Obnam.latestVersion 	& oldUseNetBackup 	& check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) 		(property "olduse.net spool in place" $ makeChange $ do@@ -184,7 +183,6 @@ mumbleServer :: [Host] -> Property HasInfo mumbleServer hosts = combineProperties hn $ props 	& Apt.serviceInstalledRunning "mumble-server"-	& Obnam.latestVersion 	& Obnam.backup "/var/lib/mumble-server" (Cron.Times "55 5 * * *") 		[ "--repository=sftp://2318@usw-s002.rsync.net/~/" ++ hn ++ ".obnam" 		, "--client-name=mumble"@@ -198,7 +196,6 @@ -- git.kitenet.net and git.joeyh.name gitServer :: [Host] -> Property HasInfo gitServer hosts = propertyList "git.kitenet.net setup" $ props-	& Obnam.latestVersion 	& Obnam.backupEncrypted "/srv/git" (Cron.Times "33 3 * * *") 		[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" 		, "--ssh-key=" ++ sshkey
src/Propellor/Property/Ssh.hs view
@@ -4,6 +4,7 @@ 	setSshdConfig, 	permitRootLogin, 	passwordAuthentication,+	noPasswords, 	hasAuthorizedKeys, 	authorizedKey, 	restarted,@@ -53,6 +54,14 @@  passwordAuthentication :: Bool -> Property NoInfo passwordAuthentication = setSshdConfig "PasswordAuthentication"++-- | Configure ssh to not allow password logins.+--+-- To prevent lock-out, this is done only once root's +-- authorized_keys is in place.+noPasswords :: Property NoInfo+noPasswords = check (hasAuthorizedKeys (User "root")) $+	passwordAuthentication False  dotDir :: User -> IO FilePath dotDir user = do
src/Propellor/Spin.hs view
@@ -12,7 +12,6 @@ import System.Posix.IO import System.Posix.Directory import Control.Concurrent.Async-import Control.Exception (bracket) import qualified Data.ByteString as B import qualified Data.Set as S import qualified Network.BSD as BSD@@ -168,7 +167,7 @@ 	-> CreateProcess 	-> IO () updateServer target relay hst connect haveprecompiled =-	withBothHandles createProcessSuccess connect go+	withIOHandles createProcessSuccess connect go   where 	hn = fromMaybe target relay 	relaying = relay == Just target
src/Propellor/Types.hs view
@@ -40,7 +40,7 @@ import Data.Monoid import Control.Applicative import "mtl" Control.Monad.RWS.Strict-import "MonadCatchIO-transformers" Control.Monad.CatchIO+import Control.Monad.Catch import qualified Data.Set as S import qualified Data.Map as M @@ -73,7 +73,9 @@ 		, MonadReader Host 		, MonadWriter [EndAction] 		, MonadIO-		, MonadCatchIO+		, MonadCatch+		, MonadThrow+		, MonadMask 		)  instance Monoid (Propellor Result) where
src/Utility/Applicative.hs view
@@ -1,6 +1,6 @@ {- applicative stuff  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
src/Utility/Data.hs view
@@ -1,6 +1,6 @@ {- utilities for simple data types  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
src/Utility/DataUnits.hs view
@@ -42,6 +42,7 @@ 	bandwidthUnits, 	oldSchoolUnits, 	Unit(..),+	ByteSize,  	roughSize, 	compareSizes,
src/Utility/Directory.hs view
@@ -1,4 +1,4 @@-{- directory manipulation+{- directory traversal and manipulation  -  - Copyright 2011-2014 Joey Hess <id@joeyh.name>  -@@ -11,13 +11,20 @@  import System.IO.Error import System.Directory-import Control.Exception (throw) import Control.Monad import Control.Monad.IfElse import System.FilePath import Control.Applicative+import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO)+import Data.Maybe +#ifdef mingw32_HOST_OS+import qualified System.Win32 as Win32+#else+import qualified System.Posix as Posix+#endif+ import Utility.PosixFiles import Utility.SafeCommand import Utility.Tmp@@ -49,7 +56,7 @@ dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]   where-  	go [] = return []+	go [] = return [] 	go (dir:dirs) 		| skipdir (takeFileName dir) = go dirs 		| otherwise = unsafeInterleaveIO $ do@@ -80,7 +87,7 @@ dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]   where-  	go c [] = return c+	go c [] = return c 	go c (dir:dirs) 		| skipdir (takeFileName dir) = go c dirs 		| otherwise = unsafeInterleaveIO $ do@@ -104,9 +111,9 @@ 			-- But, mv will move into a directory if 			-- dest is one, which is not desired. 			whenM (isdir dest) rethrow-			viaTmp mv dest undefined+			viaTmp mv dest "" 	  where-		rethrow = throw e+		rethrow = throwM e 		mv tmp _ = do 			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] 			unless ok $ do@@ -133,3 +140,90 @@ #else 	go = removeFile file #endif++#ifndef mingw32_HOST_OS+data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream+#else+data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())+#endif++type IsOpen = MVar () -- full when the handle is open++openDirectory :: FilePath -> IO DirectoryHandle+openDirectory path = do+#ifndef mingw32_HOST_OS+	dirp <- Posix.openDirStream path+	isopen <- newMVar ()+	return (DirectoryHandle isopen dirp)+#else+	(h, fdat) <- Win32.findFirstFile (path </> "*")+	-- Indicate that the fdat contains a filename that readDirectory+	-- has not yet returned, by making the MVar be full.+	-- (There's always at least a "." entry.)+	alreadyhave <- newMVar ()+	isopen <- newMVar ()+	return (DirectoryHandle isopen h fdat alreadyhave)+#endif++closeDirectory :: DirectoryHandle -> IO ()+#ifndef mingw32_HOST_OS+closeDirectory (DirectoryHandle isopen dirp) =+	whenOpen isopen $+		Posix.closeDirStream dirp+#else+closeDirectory (DirectoryHandle isopen h _ alreadyhave) =+	whenOpen isopen $ do+		_ <- tryTakeMVar alreadyhave+		Win32.findClose h+#endif+  where+	whenOpen :: IsOpen -> IO () -> IO ()+	whenOpen mv f = do+		v <- tryTakeMVar mv+		when (isJust v) f++{- |Reads the next entry from the handle. Once the end of the directory+is reached, returns Nothing and automatically closes the handle.+-}+readDirectory :: DirectoryHandle -> IO (Maybe FilePath)+#ifndef mingw32_HOST_OS+readDirectory hdl@(DirectoryHandle _ dirp) = do+	e <- Posix.readDirStream dirp+	if null e+		then do+			closeDirectory hdl+			return Nothing+		else return (Just e)+#else+readDirectory hdl@(DirectoryHandle _ h fdat mv) = do+	-- If the MVar is full, then the filename in fdat has+	-- not yet been returned. Otherwise, need to find the next+	-- file.+	r <- tryTakeMVar mv+	case r of+		Just () -> getfn+		Nothing -> do+			more <- Win32.findNextFile h fdat+			if more+				then getfn+				else do+					closeDirectory hdl+					return Nothing+  where+	getfn = do+		filename <- Win32.getFindDataFileName fdat+		return (Just filename)+#endif++-- True only when directory exists and contains nothing.+-- Throws exception if directory does not exist.+isDirectoryEmpty :: FilePath -> IO Bool+isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check+  where+	check h = do+		v <- readDirectory h+		case v of+			Nothing -> return True+			Just f+				| not (dirCruft f) -> return False+				| otherwise -> check h
src/Utility/Env.hs view
@@ -1,6 +1,6 @@ {- portable environment variables  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
src/Utility/Exception.hs view
@@ -1,59 +1,88 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2012 Joey Hess <id@joeyh.name>+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE ScopedTypeVariables #-} -module Utility.Exception where+module Utility.Exception (+	module X,+	catchBoolIO,+	catchMaybeIO,+	catchDefaultIO,+	catchMsgIO,+	catchIO,+	tryIO,+	bracketIO,+	catchNonAsync,+	tryNonAsync,+	tryWhenExists,+) where -import Control.Exception-import qualified Control.Exception as E-import Control.Applicative+import Control.Monad.Catch as X hiding (Handler)+import qualified Control.Monad.Catch as M+import Control.Exception (IOException, AsyncException) import Control.Monad+import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError) import Utility.Data  {- Catches IO errors and returns a Bool -}-catchBoolIO :: IO Bool -> IO Bool+catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False  {- Catches IO errors and returns a Maybe -}-catchMaybeIO :: IO a -> IO (Maybe a)-catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a+catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)+catchMaybeIO a = do+	catchDefaultIO Nothing $ do+		v <- a+		return (Just v)  {- Catches IO errors and returns a default value. -}-catchDefaultIO :: a -> IO a -> IO a+catchDefaultIO :: MonadCatch m => a -> m a -> m a catchDefaultIO def a = catchIO a (const $ return def)  {- Catches IO errors and returns the error message. -}-catchMsgIO :: IO a -> IO (Either String a)-catchMsgIO a = either (Left . show) Right <$> tryIO a+catchMsgIO :: MonadCatch m => m a -> m (Either String a)+catchMsgIO a = do+	v <- tryIO a+	return $ either (Left . show) Right v  {- catch specialized for IO errors only -}-catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = E.catch+catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a+catchIO = M.catch  {- try specialized for IO errors only -}-tryIO :: IO a -> IO (Either IOException a)-tryIO = try+tryIO :: MonadCatch m => m a -> m (Either IOException a)+tryIO = M.try +{- bracket with setup and cleanup actions lifted to IO.+ -+ - Note that unlike catchIO and tryIO, this catches all exceptions. -}+bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a+bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)+ {- Catches all exceptions except for async exceptions.  - This is often better to use than catching them all, so that  - ThreadKilled and UserInterrupt get through.  -}-catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a+catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches`-	[ Handler (\ (e :: AsyncException) -> throw e)-	, Handler (\ (e :: SomeException) -> onerr e)+	[ M.Handler (\ (e :: AsyncException) -> throwM e)+	, M.Handler (\ (e :: SomeException) -> onerr e) 	] -tryNonAsync :: IO a -> IO (Either SomeException a)-tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)+tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)+tryNonAsync a = go `catchNonAsync` (return . Left)+  where+	go = do+		v <- a+		return (Right v)  {- Catches only DoesNotExist exceptions, and lets all others through. -}-tryWhenExists :: IO a -> IO (Maybe a)-tryWhenExists a = eitherToMaybe <$>-	tryJust (guard . isDoesNotExistError) a+tryWhenExists :: MonadCatch m => m a -> m (Maybe a)+tryWhenExists a = do+	v <- tryJust (guard . isDoesNotExistError) a+	return (eitherToMaybe v)
src/Utility/FileMode.hs view
@@ -11,7 +11,6 @@  import System.IO import Control.Monad-import Control.Exception (bracket) import System.PosixCompat.Types import Utility.PosixFiles #ifndef mingw32_HOST_OS@@ -125,7 +124,7 @@ #endif  combineModes :: [FileMode] -> FileMode-combineModes [] = undefined+combineModes [] = 0 combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms @@ -152,7 +151,11 @@  - as writeFile.  -} writeFileProtected :: FilePath -> String -> IO ()-writeFileProtected file content = withUmask 0o0077 $+writeFileProtected file content = writeFileProtected' file +	(\h -> hPutStr h content)++writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()+writeFileProtected' file writer = withUmask 0o0077 $ 	withFile file WriteMode $ \h -> do 		void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes-		hPutStr h content+		writer h
src/Utility/FileSystemEncoding.hs view
@@ -1,6 +1,6 @@ {- GHC File system encoding handling.  -- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -14,6 +14,8 @@ 	decodeBS, 	decodeW8, 	encodeW8,+	encodeW8NUL,+	decodeW8NUL, 	truncateFilePath, ) where @@ -25,6 +27,7 @@ import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils+import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8@@ -89,6 +92,9 @@  - w82c produces a String, which may contain Chars that are invalid  - unicode. From there, this is really a simple matter of applying the  - file system encoding, only complicated by GHC's interface to doing so.+ -+ - Note that the encoding stops at any NUL in the input. FilePaths+ - do not normally contain embedded NUL, but Haskell Strings may.  -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath@@ -100,6 +106,17 @@  - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath++{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}+encodeW8NUL :: [Word8] -> FilePath+encodeW8NUL = join nul . map encodeW8 . split (s2w8 nul)+  where+	nul = ['\NUL']++decodeW8NUL :: FilePath -> [Word8]+decodeW8NUL = join (s2w8 nul) . map decodeW8 . split nul+  where+	nul = ['\NUL']  {- Truncates a FilePath to the given number of bytes (or less),  - as represented on disk.
src/Utility/LinuxMkLibs.hs view
@@ -1,6 +1,6 @@ {- Linux library copier and binary shimmer  -- - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -29,14 +29,14 @@ 	( do 		installfile top lib 		checksymlink lib-		return $ Just $ takeDirectory lib+		return $ Just $ parentDir lib 	, return Nothing 	)   where 	checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do 		l <- readSymbolicLink (inTop top f)-		let absl = absPathFrom (takeDirectory f) l-		let target = relPathDirToFile (takeDirectory f) absl+		let absl = absPathFrom (parentDir f) l+		target <- relPathDirToFile (takeDirectory f) absl 		installfile top absl 		nukeFile (top ++ f) 		createSymbolicLink target (inTop top f)
src/Utility/Misc.hs view
@@ -1,6 +1,6 @@ {- misc utility functions  -- - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2011 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
src/Utility/Monad.hs view
@@ -1,6 +1,6 @@ {- monadic stuff  -- - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
src/Utility/Path.hs view
@@ -1,6 +1,6 @@ {- path manipulation  -- - Copyright 2010-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -66,7 +66,7 @@ absPathFrom dir path = simplifyPath (combine dir path)  {- On Windows, this converts the paths to unix-style, in order to run- - MissingH's absNormPath on them. Resulting path will use / separators. -}+ - MissingH's absNormPath on them. -} absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS absNormPathUnix dir path = MissingH.absNormPath dir path@@ -77,11 +77,15 @@ 	todos = replace "/" "\\" #endif +{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}+parentDir :: FilePath -> FilePath+parentDir = takeDirectory . dropTrailingPathSeparator+ {- Just the parent directory of a path, or Nothing if the path has no- - parent (ie for "/") -}-parentDir :: FilePath -> Maybe FilePath-parentDir dir-	| null dirs = Nothing+- parent (ie for "/" or ".") -}+upFrom :: FilePath -> Maybe FilePath+upFrom dir+	| length dirs < 2 = Nothing 	| otherwise = Just $ joinDrive drive (join s $ init dirs)   where 	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""@@ -89,13 +93,13 @@ 	dirs = filter (not . null) $ split s path 	s = [pathSeparator] -prop_parentDir_basics :: FilePath -> Bool-prop_parentDir_basics dir+prop_upFrom_basics :: FilePath -> Bool+prop_upFrom_basics dir 	| null dir = True-	| dir == "/" = parentDir dir == Nothing+	| dir == "/" = p == Nothing 	| otherwise = p /= Just dir   where-	p = parentDir dir+	p = upFrom dir  {- Checks if the first FilePath is, or could be said to contain the second.  - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc@@ -124,14 +128,25 @@  -    relPathCwdToFile "/tmp/foo/bar" == ""   -} relPathCwdToFile :: FilePath -> IO FilePath-relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f+relPathCwdToFile f = do+	c <- getCurrentDirectory+	relPathDirToFile c f -{- Constructs a relative path from a directory to a file.+{- Constructs a relative path from a directory to a file. -}+relPathDirToFile :: FilePath -> FilePath -> IO FilePath+relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to++{- This requires the first path to be absolute, and the+ - second path cannot contain ../ or ./  -- - Both must be absolute, and cannot contain .. etc. (eg use absPath first).+ - On Windows, if the paths are on different drives,+ - a relative path is not possible and the path is simply+ - returned as-is.  -}-relPathDirToFile :: FilePath -> FilePath -> FilePath-relPathDirToFile from to = join s $ dotdots ++ uncommon+relPathDirToFileAbs :: FilePath -> FilePath -> FilePath+relPathDirToFileAbs from to+	| takeDrive from /= takeDrive to = to+	| otherwise = join s $ dotdots ++ uncommon   where 	s = [pathSeparator] 	pfrom = split s from@@ -144,10 +159,11 @@  prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to+	| null from || null to = True 	| from == to = null r 	| otherwise = not (null r)   where-	r = relPathDirToFile from to +	r = relPathDirToFileAbs from to   prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference@@ -156,22 +172,31 @@ 	 - location, but it's not really the same directory. 	 - Code used to get this wrong. -} 	same_dir_shortcurcuits_at_difference =-		relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])+		relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) 			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) 				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]  {- Given an original list of paths, and an expanded list derived from it,- - generates a list of lists, where each sublist corresponds to one of the- - original paths. When the original path is a directory, any items- - in the expanded list that are contained in that directory will appear in- - its segment.+ - which may be arbitrarily reordered, generates a list of lists, where+ - each sublist corresponds to one of the original paths.+ -+ - When the original path is a directory, any items in the expanded list+ - that are contained in that directory will appear in its segment.+ -+ - The order of the original list of paths is attempted to be preserved in+ - the order of the returned segments. However, doing so has a O^NM+ - growth factor. So, if the original list has more than 100 paths on it,+ - we stop preserving ordering at that point. Presumably a user passing+ - that many paths in doesn't care too much about order of the later ones.  -} segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation-segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest+segmentPaths (l:ls) new = found : segmentPaths ls rest   where-	(found, rest)=partition (l `dirContains`) new+	(found, rest) = if length ls < 100+		then partition (l `dirContains`) new+		else break (\p -> not (l `dirContains` p)) new  {- This assumes that it's cheaper to call segmentPaths on the result,  - than it would be to run the action separately with each path. In@@ -185,7 +210,7 @@ relHome path = do 	home <- myHomeDir 	return $ if dirContains home path-		then "~/" ++ relPathDirToFile home path+		then "~/" ++ relPathDirToFileAbs home path 		else path  {- Checks if a command is available in PATH.
src/Utility/PosixFiles.hs view
@@ -2,7 +2,7 @@  -  - This is like System.PosixCompat.Files, except with a fixed rename.  -- - Copyright 2014 Joey Hess <joey@kitenet.net>+ - Copyright 2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
src/Utility/Process.hs view
@@ -25,14 +25,16 @@ 	processTranscript, 	processTranscript', 	withHandle,-	withBothHandles,+	withIOHandles,+	withOEHandles, 	withQuietOutput,+	feedWithQuietOutput, 	createProcess, 	startInteractiveProcess, 	stdinHandle, 	stdoutHandle, 	stderrHandle,-	bothHandles,+	ioHandles, 	processHandle, 	devNull, ) where@@ -255,12 +257,12 @@ 			(stderrHandle, base { std_err = CreatePipe })  {- Like withHandle, but passes (stdin, stdout) handles to the action. -}-withBothHandles+withIOHandles 	:: CreateProcessRunner 	-> CreateProcess 	-> ((Handle, Handle) -> IO a) 	-> IO a-withBothHandles creator p a = creator p' $ a . bothHandles+withIOHandles creator p a = creator p' $ a . ioHandles   where 	p' = p 		{ std_in = CreatePipe@@ -268,6 +270,20 @@ 		, std_err = Inherit 		} +{- Like withHandle, but passes (stdout, stderr) handles to the action. -}+withOEHandles+	:: CreateProcessRunner+	-> CreateProcess+	-> ((Handle, Handle) -> IO a)+	-> IO a+withOEHandles creator p a = creator p' $ a . oeHandles+  where+	p' = p+		{ std_in = Inherit+		, std_out = CreatePipe+		, std_err = CreatePipe+		}+ {- Forces the CreateProcessRunner to run quietly;  - both stdout and stderr are discarded. -} withQuietOutput@@ -281,6 +297,21 @@ 		} 	creator p' $ const $ return () +{- Stdout and stderr are discarded, while the process is fed stdin+ - from the handle. -}+feedWithQuietOutput+	:: CreateProcessRunner+	-> CreateProcess+	-> (Handle -> IO a)+	-> IO a+feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do+	let p' = p+		{ std_in = CreatePipe+		, std_out = UseHandle nullh+		, std_err = UseHandle nullh+		}+	creator p' $ a . stdinHandle+ devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null"@@ -303,9 +334,12 @@ stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle"-bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)-bothHandles (Just hin, Just hout, _, _) = (hin, hout)-bothHandles _ = error "expected bothHandles"+ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)+ioHandles (Just hin, Just hout, _, _) = (hin, hout)+ioHandles _ = error "expected ioHandles"+oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)+oeHandles (_, Just hout, Just herr, _) = (hout, herr)+oeHandles _ = error "expected oeHandles"  processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid
src/Utility/QuickCheck.hs view
@@ -1,6 +1,6 @@ {- QuickCheck with additional instances  -- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
src/Utility/SafeCommand.hs view
@@ -1,6 +1,6 @@ {- safely running shell commands  -- - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -101,19 +101,26 @@ prop_idempotent_shellEscape_multiword :: [String] -> Bool prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s -{- Segements a list of filenames into groups that are all below the manximum- - command-line length limit. Does not preserve order. -}-segmentXargs :: [FilePath] -> [[FilePath]]-segmentXargs l = go l [] 0 []+{- Segments a list of filenames into groups that are all below the maximum+ - command-line length limit. -}+segmentXargsOrdered :: [FilePath] -> [[FilePath]]+segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered++{- Not preserving data is a little faster, and streams better when+ - there are a great many filesnames. -}+segmentXargsUnordered :: [FilePath] -> [[FilePath]]+segmentXargsUnordered l = go l [] 0 []   where-	go [] c _ r = c:r+	go [] c _ r = (c:r) 	go (f:fs) c accumlen r-		| len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)+		| newlen > maxlen && len < maxlen = go (f:fs) [] 0 (c:r) 		| otherwise = go fs (f:c) newlen r 	  where 		len = length f 		newlen = accumlen + len -	{- 10k of filenames per command, well under Linux's 20k limit;-	 - allows room for other parameters etc. -}+	{- 10k of filenames per command, well under 100k limit+	 - of Linux (and OSX has a similar limit);+	 - allows room for other parameters etc. Also allows for+	 - eg, multibyte characters. -} 	maxlen = 10240
src/Utility/Scheduled.hs view
@@ -1,6 +1,6 @@ {- scheduled activities  - - - Copyright 2013-2014 Joey Hess <joey@kitenet.net>+ - Copyright 2013-2014 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}
src/Utility/ThreadScheduler.hs view
@@ -1,6 +1,6 @@ {- thread scheduling  -- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2012, 2013 Joey Hess <id@joeyh.name>  - Copyright 2011 Bas van Dijk & Roel van Dijk  -  - License: BSD-2-clause
src/Utility/Tmp.hs view
@@ -9,11 +9,11 @@  module Utility.Tmp where -import Control.Exception (bracket) import System.IO import System.Directory import Control.Monad.IfElse import System.FilePath+import Control.Monad.IO.Class  import Utility.Exception import Utility.FileSystemEncoding@@ -24,45 +24,52 @@ {- Runs an action like writeFile, writing to a temp file first and  - then moving it into place. The temp file is stored in the same  - directory as the final file to avoid cross-device renames. -}-viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()-viaTmp a file content = do-	let (dir, base) = splitFileName file-	createDirectoryIfMissing True dir-	(tmpfile, handle) <- openTempFile dir (base ++ ".tmp")-	hClose handle-	a tmpfile content-	rename tmpfile file+viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()+viaTmp a file content = bracketIO setup cleanup use+  where+	(dir, base) = splitFileName file+	template = base ++ ".tmp"+	setup = do+		createDirectoryIfMissing True dir+		openTempFile dir template+	cleanup (tmpfile, h) = do+		_ <- tryIO $ hClose h+		tryIO $ removeFile tmpfile+	use (tmpfile, h) = do+		liftIO $ hClose h+		a tmpfile content+		liftIO $ rename tmpfile file  {- Runs an action with a tmp file located in the system's tmp directory  - (or in "." if there is none) then removes the file. -}-withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a withTmpFile template a = do-	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory 	withTmpFileIn tmpdir template a  {- Runs an action with a tmp file located in the specified directory,  - then removes the file. -}-withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use   where-	create = openTempFile tmpdir template-	remove (name, handle) = do-		hClose handle+	create = liftIO $ openTempFile tmpdir template+	remove (name, h) = liftIO $ do+		hClose h 		catchBoolIO (removeFile name >> return True)-	use (name, handle) = a name handle+	use (name, h) = a name h  {- Runs an action with a tmp directory located within the system's tmp  - directory (or within "." if there is none), then removes the tmp  - directory and all its contents. -}-withTmpDir :: Template -> (FilePath -> IO a) -> IO a+withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a withTmpDir template a = do-	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory 	withTmpDirIn tmpdir template a  {- Runs an action with a tmp directory located within a specified directory,  - then removes the tmp directory and all its contents. -}-withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a-withTmpDirIn tmpdir template = bracket create remove+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a+withTmpDirIn tmpdir template = bracketIO create remove   where 	remove d = whenM (doesDirectoryExist d) $ do #if mingw32_HOST_OS
src/Utility/UserInfo.hs view
@@ -1,6 +1,6 @@ {- user info  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}