propellor 5.5.0 → 5.6.0

raw patch · 49 files changed

+902/−534 lines, 49 filesdep ~base

Dependency ranges changed: base

Files

• CHANGELOG +25/−0
• Makefile +2/−2
• README.md +3/−3
• debian/changelog +25/−0
• debian/control +2/−4
• doc/README.mdwn +3/−3
• joeyconfig.hs +18/−11
• propellor.cabal +8/−2
• src/Propellor/Bootstrap.hs +25/−21
• src/Propellor/EnsureProperty.hs +1/−1
• src/Propellor/Gpg.hs +2/−0
• src/Propellor/Property.hs +4/−9
• src/Propellor/Property/Borg.hs +8/−5
• src/Propellor/Property/Cron.hs +1/−1
• src/Propellor/Property/DiskImage.hs +21/−3
• src/Propellor/Property/Firewall.hs +0/−1
• src/Propellor/Property/Libvirt.hs +210/−0
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +3/−2
• src/Propellor/Property/SiteSpecific/JoeySites.hs +47/−23
• src/Propellor/Property/Systemd.hs +12/−7
• src/Propellor/Property/User.hs +1/−1
• src/Propellor/Ssh.hs +1/−1
• src/Propellor/Types.hs +1/−0
• src/Propellor/Types/OS.hs +1/−1
• src/Propellor/Types/Singletons.hs +1/−1
• src/Propellor/Utilities.hs +8/−0
• src/Utility/Directory.hs +4/−110
• src/Utility/Directory/Stream.hs +130/−0
• src/Utility/Directory/TestDirectory.hs +40/−0
• src/Utility/Env.hs +0/−24
• src/Utility/Env/Basic.hs +22/−0
• src/Utility/Env/Set.hs +41/−0
• src/Utility/Exception.hs +1/−17
• src/Utility/FileMode.hs +3/−2
• src/Utility/FileSystemEncoding.hs +20/−0
• src/Utility/Misc.hs +0/−21
• src/Utility/PartialPrelude.hs +3/−5
• src/Utility/Path.hs +8/−54
• src/Utility/PosixFiles.hs +0/−42
• src/Utility/Process.hs +11/−80
• src/Utility/Process/Shim.hs +2/−3
• src/Utility/Process/Transcript.hs +83/−0
• src/Utility/SafeCommand.hs +11/−9
• src/Utility/Scheduled.hs +2/−1
• src/Utility/Split.hs +4/−0
• src/Utility/ThreadScheduler.hs +0/−4
• src/Utility/Tmp.hs +3/−52
• src/Utility/Tmp/Dir.hs +67/−0
• src/Utility/UserInfo.hs +14/−8

@@ -1,3 +1,28 @@+propellor (5.6.0) unstable; urgency=medium++  * withOS had a type level bug that allowed ensureProperty to be used inside+    it with a Property that does not match the type of the withOS itself.+    (API change)+    The fix may cause some of your valid uses of withOS to no longer type+    check; the best way to work around that is to use pickOS to pick between+    several properties that are further specialized using withOS.+    For an example of how to do that, see the source code to+    Propellor.Property.Borg.installed+  * Propellor.Property.Cron.runPropellor is a Property DebianLike; it was+    incorrectly a Property UnixLike before and that wrong type was hidden by+    the withOS bug.+  * Some openbsd portability fixes. Thanks, rsiddharth.+  * Added Libvirt module. Thanks, Sean Whitton.+  * When bootstrapping on Debian, libghc-stm-dev may not be available,+    as it's become part of ghc, so check before trying to install it.+  * Fix build with ghc 8.6.3.+  * Avoid exposing the constructor of OuterMetaTypesWitness, to avoid+    the kind of mistake that led to the withOS bug.+  * Merged Utility changes from git-annex.+  * Fix --spin crash when ~/.ssh/ directory did not already exist.++ -- Joey Hess <id@joeyh.name>  Fri, 18 Jan 2019 12:11:53 -0400+ propellor (5.5.0) unstable; urgency=medium    * letsencrypt': Pass --expand to support expanding the list of domains

@@ -30,8 +30,8 @@  clean: 	rm -rf dist Setup tags propellor propellor.1 privdata/local-	find -name \*.o -exec rm {} \;-	find -name \*.hi -exec rm {} \;+	find . -name \*.o -exec rm {} \;+	find . -name \*.hi -exec rm {} \;  # hothasktags chokes on some template haskell etc, so ignore errors # duplicate tags with Propellor.Property. removed from the start, as we

@@ -37,11 +37,11 @@ ## quick start  1. Get propellor installed on your development machine (ie, laptop).-     `cabal install propellor`+     `apt-get install propellor`           or-     `stack install propellor`+     `cabal install propellor`           or-     `apt-get install propellor`+     `cabal unpack propellor; cd propellor-version; stack install` 2. Run `propellor --init` ; this will set up a `~/.propellor/` git    repository for you. 3. Edit `~/.propellor/config.hs`, and add a host you want to manage.

@@ -1,3 +1,28 @@+propellor (5.6.0) unstable; urgency=medium++  * withOS had a type level bug that allowed ensureProperty to be used inside+    it with a Property that does not match the type of the withOS itself.+    (API change)+    The fix may cause some of your valid uses of withOS to no longer type+    check; the best way to work around that is to use pickOS to pick between+    several properties that are further specialized using withOS.+    For an example of how to do that, see the source code to+    Propellor.Property.Borg.installed+  * Propellor.Property.Cron.runPropellor is a Property DebianLike; it was+    incorrectly a Property UnixLike before and that wrong type was hidden by+    the withOS bug.+  * Some openbsd portability fixes. Thanks, rsiddharth.+  * Added Libvirt module. Thanks, Sean Whitton.+  * When bootstrapping on Debian, libghc-stm-dev may not be available,+    as it's become part of ghc, so check before trying to install it.+  * Fix build with ghc 8.6.3.+  * Avoid exposing the constructor of OuterMetaTypesWitness, to avoid+    the kind of mistake that led to the withOS bug.+  * Merged Utility changes from git-annex.+  * Fix --spin crash when ~/.ssh/ directory did not already exist.++ -- Joey Hess <id@joeyh.name>  Fri, 18 Jan 2019 12:11:53 -0400+ propellor (5.5.0) unstable; urgency=medium    * letsencrypt': Pass --expand to support expanding the list of domains

@@ -4,7 +4,7 @@ Build-Depends:  	debhelper (>= 9), 	git (>= 2.0),-	ghc (>= 7.6),+	ghc (>= 8.4.3), 	cabal-install, 	libghc-async-dev, 	libghc-split-dev,@@ -16,7 +16,6 @@ 	libghc-mtl-dev, 	libghc-transformers-dev, 	libghc-exceptions-dev (>= 0.6),-	libghc-stm-dev, 	libghc-text-dev, 	libghc-hashable-dev, Maintainer: Joey Hess <id@joeyh.name>@@ -28,7 +27,7 @@ Architecture: any Section: admin Depends: ${misc:Depends}, ${shlibs:Depends},-	ghc (>= 7.4),+	ghc (>= 8.4.3), 	cabal-install, 	libghc-async-dev, 	libghc-split-dev,@@ -40,7 +39,6 @@ 	libghc-mtl-dev, 	libghc-transformers-dev, 	libghc-exceptions-dev (>= 0.6),-	libghc-stm-dev, 	libghc-text-dev, 	libghc-hashable-dev, 	git (>= 2.0),

@@ -37,11 +37,11 @@ ## quick start  1. Get propellor installed on your development machine (ie, laptop).-     `cabal install propellor`+     `apt-get install propellor`           or-     `stack install propellor`+     `cabal install propellor`           or-     `apt-get install propellor`+     `cabal unpack propellor; cd propellor-version; stack install` 2. Run `propellor --init` ; this will set up a `~/.propellor/` git    repository for you. 3. Edit `~/.propellor/config.hs`, and add a host you want to manage.

@@ -27,6 +27,7 @@ import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Borg as Borg import qualified Propellor.Property.Gpg as Gpg+import qualified Propellor.Property.OpenId as OpenId import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Journald as Journald import qualified Propellor.Property.Fail2Ban as Fail2Ban@@ -97,7 +98,7 @@ clam = host "clam.kitenet.net" $ props 	& standardSystem (Stable "stretch") X86_64 		["Unreliable server. Anything here may be lost at any time!" ]-	& ipv4 "167.114.76.178"+	& ipv4 "178.33.208.168"  	& User.hasPassword (User "root") 	& Ssh.hostKeys hostContext@@ -155,6 +156,9 @@ 	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer 		GitAnnexBuilder.stackAutoBuilder 		(Stable "jessie") X86_32 (Just "ancient") (Cron.Times "45 * * * *") "2h")+	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer+		GitAnnexBuilder.standardAutoBuilder+		Testing ARM64 Nothing (Cron.Times "1 * * * *") "4h")  banana :: Host banana = host "banana.kitenet.net" $ props@@ -181,11 +185,7 @@ 		) 	& JoeySites.cubieTruckOneWire 	-	& Apt.installed ["firmware-misc-nonfree"]-	& Apt.installed ["firmware-brcm80211"]-		-- Workaround for https://bugs.debian.org/844056-		`requires` File.hasPrivContent "/lib/firmware/brcm/brcmfmac43362-sdio.txt" anyContext-		`requires` File.dirExists "/lib/firmware/brcm"+	& Apt.installed ["firmware-atheros"] 	& Apt.serviceInstalledRunning "ntp" -- no hardware clock 	& bootstrappedFrom GitRepoOutsideChroot 	& Ssh.hostKeys hostContext@@ -203,16 +203,12 @@ 	& Postfix.satellite  	& check (not <$> inChroot) (setupRevertableProperty autobuilder)-	& check (not <$> inChroot) (undoRevertableProperty ancientautobuilder) 	-- In case compiler needs more than available ram 	& Apt.serviceInstalledRunning "swapspace"   where 	autobuilder = Systemd.nspawned $ GitAnnexBuilder.autoBuilderContainer 		(GitAnnexBuilder.armAutoBuilder GitAnnexBuilder.standardAutoBuilder)-		Unstable ARMEL Nothing (Cron.Times "15 15 * * *") "10h"-	ancientautobuilder = Systemd.nspawned $ GitAnnexBuilder.autoBuilderContainer-		(GitAnnexBuilder.armAutoBuilder GitAnnexBuilder.stackAutoBuilder)-		(Stable "jessie") ARMEL (Just "ancient") (Cron.Times "5 15 * * *") "10h"+		Testing ARMEL Nothing (Cron.Times "15 15 * * *") "10h"  -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed@@ -309,6 +305,7 @@ 	& JoeySites.kgbServer 	 	& Systemd.nspawned ancientKitenet+	& Systemd.nspawned openidProvider 	 	& alias "podcatcher.kitenet.net" 	& JoeySites.podcatcher@@ -486,6 +483,16 @@ 	& standardContainer (Stable "stretch") 	& alias "shell.olduse.net" 	& JoeySites.oldUseNetShellBox++-- My own openid provider. Uses php, so containerized for security+-- and administrative sanity.+openidProvider :: Systemd.Container+openidProvider = Systemd.debContainer "openid-provider" $ props+	& standardContainer (Stable "stretch")+	& alias hn+	& OpenId.providerFor [User "joey", User "liw"] hn (Just (Port 8086))+  where+	hn = "openid.kitenet.net"  type Motd = [String] 

@@ -1,5 +1,5 @@ Name: propellor-Version: 5.5.0+Version: 5.6.0 Cabal-Version: 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>@@ -101,6 +101,7 @@     Propellor.Property.Kerberos     Propellor.Property.Laptop     Propellor.Property.LetsEncrypt+    Propellor.Property.Libvirt     Propellor.Property.List     Propellor.Property.LightDM     Propellor.Property.Locale@@ -199,7 +200,11 @@     Utility.Data     Utility.DataUnits     Utility.Directory+    Utility.Directory.Stream+    Utility.Directory.TestDirectory     Utility.Env+    Utility.Env.Basic+    Utility.Env.Set     Utility.Exception     Utility.FileMode     Utility.FileSystemEncoding@@ -209,10 +214,10 @@     Utility.Monad     Utility.Path     Utility.PartialPrelude-    Utility.PosixFiles     Utility.Process     Utility.Process.Shim     Utility.Process.NonConcurrent+    Utility.Process.Transcript     Utility.SafeCommand     Utility.Scheduled     Utility.Scheduled@@ -221,6 +226,7 @@     Utility.Table     Utility.ThreadScheduler     Utility.Tmp+    Utility.Tmp.Dir     Utility.Tuple     Utility.UserInfo     System.Console.Concurrent

@@ -95,6 +95,8 @@ 	go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi" 	go Stack = "if ! stack build --dry-run >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi" +data Dep = Dep String | OldDep String+ -- Install build dependencies of propellor, using the specified -- Bootstrapper. --@@ -128,32 +130,34 @@  	useapt builder = "apt-get update" : map aptinstall (debdeps builder) -	aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p+	aptinstall (Dep p) = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p+	aptinstall (OldDep p) = "if LANG=C apt-cache policy " ++ p ++ "| grep -q Candidate:; then " ++ aptinstall (Dep p) ++ "; fi" 	pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p 	pacmaninstall p = "pacman -S --noconfirm --needed " ++ p  	debdeps Cabal =-		[ "gnupg"+		[ Dep "gnupg" 		-- Below are the same deps listed in debian/control.-		, "ghc"-		, "cabal-install"-		, "libghc-async-dev"-		, "libghc-split-dev"-		, "libghc-hslogger-dev"-		, "libghc-unix-compat-dev"-		, "libghc-ansi-terminal-dev"-		, "libghc-ifelse-dev"-		, "libghc-network-dev"-		, "libghc-mtl-dev"-		, "libghc-transformers-dev"-		, "libghc-exceptions-dev"-		, "libghc-stm-dev"-		, "libghc-text-dev"-		, "libghc-hashable-dev"+		, Dep "ghc"+		, Dep "cabal-install"+		, Dep "libghc-async-dev"+		, Dep "libghc-split-dev"+		, Dep "libghc-hslogger-dev"+		, Dep "libghc-unix-compat-dev"+		, Dep "libghc-ansi-terminal-dev"+		, Dep "libghc-ifelse-dev"+		, Dep "libghc-network-dev"+		, Dep "libghc-mtl-dev"+		, Dep "libghc-transformers-dev"+		, Dep "libghc-exceptions-dev"+		, Dep "libghc-text-dev"+		, Dep "libghc-hashable-dev"+		-- Deps that are only needed on old systems.+		, OldDep "libghc-stm-dev" 		] 	debdeps Stack =-		[ "gnupg"-		, "haskell-stack"+		[ Dep "gnupg"+		, Dep "haskell-stack" 		]  	fbsddeps Cabal =@@ -262,8 +266,8 @@ 	-- a binary that is fully built. Also, avoid ever removing 	-- or breaking the symlink. 	---	-- Need cp -a to make build timestamp checking work.-	unlessM (boolSystem "cp" [Param "-af", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $+	-- Need cp -pfRL to make build timestamp checking work.+	unlessM (boolSystem "cp" [Param "-pfRL", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $ 		error "cp of binary failed" 	rename (tmpfor safetycopy) safetycopy 	symlinkPropellorBin safetycopy

@@ -7,7 +7,7 @@ module Propellor.EnsureProperty 	( ensureProperty 	, property'-	, OuterMetaTypesWitness(..)+	, OuterMetaTypesWitness 	, Cannot_ensureProperty_WithInfo 	) where 

@@ -13,11 +13,13 @@ import Propellor.Git.Config import Utility.SafeCommand import Utility.Process+import Utility.Process.Transcript import Utility.Process.NonConcurrent import Utility.Monad import Utility.Misc import Utility.Tmp import Utility.Env+import Utility.Env.Set import Utility.Directory import Utility.Split import Utility.Exception

@@ -303,7 +303,8 @@   where 	-- This use of getSatisfy is safe, because both a and b 	-- are added as children, so their info will propigate.-	c = withOS (getDesc a) $ \_ o ->+	c = property (getDesc a) $ do+		o <- getOS 		if matching o a 			then maybe (pure NoChange) id (getSatisfy a) 			else if matching o b@@ -330,15 +331,9 @@ withOS 	:: (SingI metatypes) 	=> Desc-	-> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result)+	-> (OuterMetaTypesWitness metatypes -> Maybe System -> Propellor Result) 	-> Property (MetaTypes metatypes)-withOS desc a = property desc $ a dummyoutermetatypes =<< getOS-  where-	-- Using this dummy value allows ensureProperty to be used-	-- even though the inner property probably doesn't target everything-	-- that the outer withOS property targets.-	dummyoutermetatypes :: OuterMetaTypesWitness ('[])-	dummyoutermetatypes = OuterMetaTypesWitness sing+withOS desc a = property' desc $ \w -> a w =<< getOS  -- | A property that always fails with an unsupported OS error. unsupportedOS :: Property UnixLike

@@ -59,12 +59,15 @@ 	go (UsesEnvVar (k, v)) = (k, v)  installed :: Property DebianLike-installed = withOS desc $ \w o -> case o of-	(Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $-		Apt.backportInstalled ["borgbackup", "python3-msgpack"]-	_ -> ensureProperty w $-		Apt.installed ["borgbackup"]+installed = pickOS installdebian aptinstall   where+	installdebian :: Property Debian+	installdebian = withOS desc $ \w o -> case o of+		(Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $+			Apt.backportInstalled ["borgbackup", "python3-msgpack"]+		_ -> ensureProperty w $+			Apt.installed ["borgbackup"]+	aptinstall = Apt.installed ["borgbackup"] `describe` desc         desc = "installed borgbackup"  repoExists :: BorgRepo -> IO Bool

@@ -79,7 +79,7 @@ 	("nice ionice -c 3 sh -c " ++ shellEscape command)  -- | Installs a cron job to run propellor.-runPropellor :: Times -> Property UnixLike+runPropellor :: Times -> Property DebianLike runPropellor times = withOS "propellor cron job" $ \w o -> do 	bootstrapper <- getBootstrapper 	ensureProperty w $

@@ -17,6 +17,7 @@ 	imageRebuiltFor, 	imageBuiltFrom, 	imageExists,+	imageChrootNotPresent, 	GrubTarget(..), 	noBootloader, ) where@@ -200,14 +201,13 @@ 		`describe` desc   where 	desc = "built disk image " ++ describeDiskImage img-	RawDiskImage imgfile = rawDiskImage img 	cleanrebuild :: Property Linux 	cleanrebuild 		| rebuild = property desc $ do 			liftIO $ removeChroot chrootdir 			return MadeChange 		| otherwise = doNothing-	chrootdir = imgfile ++ ".chroot"+	chrootdir = imageChroot img 	chroot = 		let c = propprivdataonly $ mkchroot chrootdir 		in setContainerProps c $ containerProps c@@ -378,7 +378,7 @@ imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` desc   where 	desc = "disk image exists " ++ img-	parttablefile = img ++ ".parttable"+	parttablefile = imageParttableFile dest 	setup = property' desc $ \w -> do 		oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile 		res <- ensureProperty w $ imageExists dest (partTableSize parttable)@@ -487,6 +487,24 @@  noBootloaderFinalized :: Finalization noBootloaderFinalized _img _mnt _loopDevs = doNothing++imageChrootNotPresent :: DiskImage d => d -> Property UnixLike+imageChrootNotPresent img = check (doesDirectoryExist dir) $+	property "destroy the chroot used to build the image" $ makeChange $ do+		removeChroot dir+		nukeFile $ imageParttableFile img+  where+	dir = imageChroot img++imageChroot :: DiskImage d => d -> FilePath+imageChroot img = imgfile <.> "chroot"+  where+	RawDiskImage imgfile = rawDiskImage img++imageParttableFile :: DiskImage d => d -> FilePath+imageParttableFile img = imgfile <.> "parttable"+  where+	RawDiskImage imgfile = rawDiskImage img  isChild :: FilePath -> Maybe MountPoint -> Bool isChild mntpt (Just d)

@@ -17,7 +17,6 @@ 	IPWithMask(..), ) where -import Data.Monoid import qualified Data.Semigroup as Sem import Data.Char import Data.List

@@ -0,0 +1,210 @@+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>++module Propellor.Property.Libvirt (+	NumVCPUs(..),+	MiBMemory(..),+	AutoStart(..),+	DiskImageType(..),+	installed,+	defaultNetworkAutostarted,+	defaultNetworkStarted,+	defined,+) where++import Propellor.Base+import Propellor.Types.Info+import Propellor.Property.Chroot+import Propellor.Property.DiskImage+import qualified Propellor.Property.Apt as Apt++import Utility.Split++-- | The number of virtual CPUs to assign to the virtual machine+newtype NumVCPUs = NumVCPUs Int++-- | The number of MiB of memory to assign to the virtual machine+newtype MiBMemory = MiBMemory Int++-- | Whether the virtual machine should be started after it is defined, and at+-- host system boot+data AutoStart = AutoStart | NoAutoStart++-- | Which type of disk image to build for the virtual machine+data DiskImageType = Raw -- | QCow2++-- | Install basic libvirt components+installed :: Property DebianLike+installed = Apt.installed ["libvirt-clients", "virtinst"]++-- | Ensure that the default libvirt network is set to autostart, and start it.+--+-- On Debian, it is not started by default after installation of libvirt.+defaultNetworkAutostarted :: Property DebianLike+defaultNetworkAutostarted = autostarted+	`requires` installed+	`before` defaultNetworkStarted+  where+	autostarted = check (not <$> doesFileExist autostartFile) $+		cmdProperty "virsh" ["net-autostart", "default"]+	autostartFile = "/etc/libvirt/qemu/networks/autostart/default.xml"++-- | Ensure that the default libvirt network is started.+defaultNetworkStarted :: Property DebianLike+defaultNetworkStarted =	go `requires` installed+  where+	go :: Property UnixLike+	go = property "start libvirt's default network" $ do+		runningNetworks <- liftIO $ virshGetColumns ["net-list"]+		if ["default"] `elem` (take 1 <$> runningNetworks)+			then noChange+			else makeChange $ unlessM startIt $+				errorMessage "failed to start default network"+	startIt = boolSystem "virsh" [Param "net-start", Param "default"]+++-- | Builds a disk image with the properties of the given Host, installs a+-- libvirt configuration file to boot the image, and if it is set to autostart,+-- start the VM.+--+-- Note that building the disk image happens only once.  So if you change the+-- properties of the given Host, this property will not modify the disk image.+-- In order to later apply properties to the VM, you should spin it directly, or+-- arrange to have it spun with a property like 'Cron.runPropellor', or use+-- 'Propellor.Property.Conductor' from the VM host.+--+-- Suggested usage in @config.hs@:+--+-- > mybox = host "mybox.example.com" $ props+-- > 	& osDebian (Stable "stretch") X86_64+-- > 	& Libvirt.defaultNetworkAutostarted+-- > 	& Libvirt.defined Libvirt.Raw+-- > 		(Libvirt.MiBMemory 2048) (Libvirt.NumVCPUs 2)+-- > 		Libvirt.NoAutoStart subbox+-- >+-- > subbox = host "subbox.mybox.example.com" $ props+-- > 	& osDebian Unstable X86_64+-- > 	& hasPartition+-- > 		( partition EXT4+-- > 			`mountedAt` "/"+-- > 			`addFreeSpace` MegaBytes 10240+-- > 		)+-- > 	& Apt.installed ["linux-image-amd64"]+-- > 	& Grub.installed PC+-- >+-- > 	& ipv4 "192.168.122.31"+-- > 	& Network.static "ens3" (IPv4 "192.168.122.31")+-- > 		(Just (Network.Gateway (IPv4 "192.168.122.1")))+-- > 		`requires` Network.cleanInterfacesFile+-- > 	& Hostname.sane+defined+	:: DiskImageType+	-> MiBMemory+	-> NumVCPUs+	-> AutoStart+	-> Host+	-> Property (HasInfo + DebianLike)+defined imageType (MiBMemory mem) (NumVCPUs cpus) auto h =+	(built `before` nuked `before` xmlDefined `before` started)+	`requires` installed+  where+	built :: Property (HasInfo + DebianLike)+	built = check (not <$> doesFileExist imageLoc) $+		setupRevertableProperty $ imageBuiltFor h+			(image) (Debootstrapped mempty)++	nuked :: Property UnixLike+	nuked = imageChrootNotPresent image++	xmlDefined :: Property UnixLike+	xmlDefined = check (not <$> doesFileExist conf) $+		property "define the libvirt VM" $+		withTmpFile (hostName h) $ \t fh -> do+			xml <- liftIO $ readProcess "virt-install" $+				[ "-n", hostName h+				, "--memory=" ++ show mem+				, "--vcpus=" ++ show cpus+				, "--disk"+				, "path=" ++ imageLoc+					++ ",device=disk,bus=virtio"+				, "--print-xml"+				] ++ autoStartArg ++ osVariantArg+			liftIO $ hPutStrLn fh xml+			liftIO $ hClose fh+			makeChange $ unlessM (defineIt t) $+				errorMessage "failed to define VM"+	  where+		defineIt t = boolSystem "virsh" [Param "define", Param t]++	started :: Property UnixLike+	started = case auto of+		AutoStart -> property "start the VM" $ do+			runningVMs <- liftIO $ virshGetColumns ["list"]+			-- From the point of view of `virsh start`, the "State"+			-- column in the output of `virsh list` is not relevant.+			-- So long as the VM is listed, it's considered started.+			if [hostName h] `elem` (take 1 . drop 1 <$> runningVMs)+				then noChange+				else makeChange $ unlessM startIt $+					errorMessage "failed to start VM"+		NoAutoStart -> doNothing+	  where+		startIt = boolSystem "virsh" [Param "start", Param $ hostName h]++	image = case imageType of+		Raw -> RawDiskImage imageLoc+	imageLoc =+		"/var/lib/libvirt/images" </> hostName h <.> case imageType of+			Raw -> "img"+	conf = "/etc/libvirt/qemu" </> hostName h <.> "xml"++	osVariantArg = maybe [] (\v -> ["--os-variant=" ++ v]) $ osVariant h+	autoStartArg = case auto of+		AutoStart -> ["--autostart"]+		NoAutoStart -> []++-- ==== utility functions ====++-- The --os-variant property is optional, per virt-install(1), so return Nothing+-- if there isn't a known correct value.  The VM will still be defined.  Pass+-- the value if we can, though, to optimise the generated XML for the host's OS+osVariant :: Host -> Maybe String+osVariant h = hostSystem h >>= \s -> case s of+	System (Debian _ (Stable "jessie")) _ -> Just "debian8"+	System (Debian _ (Stable "stretch")) _ -> Just "debian9"+	System (Debian _ Testing) _ -> Just "debiantesting"+	System (Debian _ Unstable) _ -> Just "debiantesting"++	System (Buntish "trusty") _ -> Just "ubuntu14.04"+	System (Buntish "utopic") _ -> Just "ubuntu14.10"+	System (Buntish "vivid") _ -> Just "ubuntu15.04"+	System (Buntish "wily") _ -> Just "ubuntu15.10"+	System (Buntish "xenial") _ -> Just "ubuntu16.04"+	System (Buntish "yakkety") _ -> Just "ubuntu16.10"+	System (Buntish "zesty") _ -> Just "ubuntu17.04"+	System (Buntish "artful") _ -> Just "ubuntu17.10"+	System (Buntish "bionic") _ -> Just "ubuntu18.04"++	System (FreeBSD (FBSDProduction FBSD101)) _ -> Just "freebsd10.1"+	System (FreeBSD (FBSDProduction FBSD102)) _ -> Just "freebsd10.2"+	System (FreeBSD (FBSDProduction FBSD093)) _ -> Just "freebsd9.3"+	System (FreeBSD (FBSDLegacy FBSD101)) _ -> Just "freebsd10.1"+	System (FreeBSD (FBSDLegacy FBSD102)) _ -> Just "freebsd10.2"+	System (FreeBSD (FBSDLegacy FBSD093)) _ -> Just "freebsd9.3"++	-- libvirt doesn't have an archlinux variant yet, it seems+	System ArchLinux _ -> Nothing++	-- other stable releases that we don't know about (since there are+	-- infinitely many possible stable release names, as it is a freeform+	-- string, we need this to avoid a compiler warning)+	System (Debian _ _) _ -> Nothing+	System (Buntish _) _ -> Nothing++-- Run a virsh command with the given list of arguments, that is expected to+-- yield tabular output, and return the rows+virshGetColumns :: [String] -> IO [[String]]+virshGetColumns args = map (filter (not . null) . split " ") . drop 2 . lines+ 	<$> readProcess "virsh" args++hostSystem :: Host -> Maybe System+hostSystem = fromInfoVal . fromInfo . hostInfo

@@ -122,9 +122,9 @@ 		& Apt.stdSourcesList 		& Apt.unattendedUpgrades 		& Apt.cacheCleaned-		& buildDepsApt 		& User.accountFor (User builduser) 		& tree (architectureToDebianArchString arch) flavor+		& buildDepsApt  stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian) stackAutoBuilder suite arch flavor =@@ -140,7 +140,7 @@ 		-- Workaround https://github.com/commercialhaskell/stack/issues/2093 		& Apt.installed ["libtinfo-dev"] -stackInstalled :: Property Linux+stackInstalled :: Property DebianLike stackInstalled = withOS "stack installed" $ \w o -> 	case o of 		(Just (System (Debian Linux (Stable "jessie")) arch)) ->@@ -182,6 +182,7 @@ 	propertyList "arm git-annex autobuilder" $ props 		& baseautobuilder suite arch flavor 		-- Works around ghc crash with parallel builds on arm.+		& File.dirExists (homedir </> ".cabal") 		& (homedir </> ".cabal" </> "config") 			`File.containsLine` "jobs: 1" 		-- Work around https://github.com/systemd/systemd/issues/7135

@@ -400,23 +400,31 @@ 	"xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update" 	`requires` Apt.installed ["git-annex", "myrepos"] -kiteMailServer :: Property (HasInfo + DebianLike)-kiteMailServer = propertyList "kitenet.net mail server" $ props-	& Postfix.installed-	& Apt.installed ["postfix-pcre"]-	& Apt.serviceInstalledRunning "postgrey"+spamdEnabled :: Property DebianLike+spamdEnabled = tightenTargets $ +	cmdProperty "update-rc.d" ["spamassassin", "enable"]+		`assume` MadeChange +spamassassinConfigured :: Property DebianLike+spamassassinConfigured = propertyList "spamassassin configured" $ props 	& Apt.serviceInstalledRunning "spamassassin" 	& "/etc/default/spamassassin" `File.containsLines` 		[ "# Propellor deployed"-		, "ENABLED=1" 		, "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\"" 		, "CRON=1" 		, "NICE=\"--nicelevel 15\""-		] `onChange` Service.restarted "spamassassin"-		`describe` "spamd enabled"+		]+		`describe` "spamd configured"+		`onChange` spamdEnabled+		`onChange` Service.restarted "spamassassin" 		`requires` Apt.serviceInstalledRunning "cron" +kiteMailServer :: Property (HasInfo + DebianLike)+kiteMailServer = propertyList "kitenet.net mail server" $ props+	& Postfix.installed+	& Apt.installed ["postfix-pcre"]+	& Apt.serviceInstalledRunning "postgrey"+	& spamassassinConfigured 	& Apt.serviceInstalledRunning "spamass-milter" 	-- Add -m to prevent modifying messages Subject or body. 	& "/etc/default/spamass-milter" `File.containsLine`@@ -585,10 +593,18 @@ 	& "/etc/pine.conf" `File.hasContent` 		[ "# deployed with propellor" 		, "inbox-path={localhost}inbox"-		, "rsh-command=/usr/lib/dovecot/imap"+		, "rsh-command=" ++ imapalpinescript 		] 		`describe` "pine configured to use local imap server"-+	& imapalpinescript `File.hasContent`+		[ "#!/bin/sh"+		, "# deployed with propellor"+		, "set -e"+		, "exec /usr/lib/dovecot/imap 2>/dev/null"+		]+		`onChange` (imapalpinescript `File.mode`+			combineModes (readModes ++ executeModes))+		`describe` "imap script for pine" 	& Apt.serviceInstalledRunning "mailman" 	-- Override the default http url. (Only affects new lists.) 	& "/etc/mailman/mm_cfg.py" `File.containsLine`@@ -600,6 +616,7 @@   where 	ctx = Context "kitenet.net" 	pinescript = "/usr/local/bin/pine"+	imapalpinescript = "/usr/local/bin/imap-for-alpine" 	dovecotusers = "/etc/dovecot/users"  	ssmtp = Postfix.Service@@ -806,7 +823,7 @@ 		, "RewriteRule /~anna/.* http://waldeneffect\\.org/ [R]" 		, "RewriteRule /~anna/.* http://waldeneffect\\.org/ [R]" 		, "RewriteRule /~anna http://waldeneffect\\.org/ [R]"-		, "RewriteRule /simpleid/ http://openid.kitenet.net:8081/simpleid/"+		, "RewriteRule /simpleid/ http://openid.kitenet.net:8086/simpleid/" 		, "# Even the kite home page is not here any more!" 		, "RewriteRule ^/$ http://www.kitenet.net/ [R]" 		, "RewriteRule ^/index.html http://www.kitenet.net/ [R]"@@ -937,7 +954,6 @@ 		`requires` Apt.installed 			[ "ghc", "cabal-install", "make" 			, "libghc-http-types-dev"-			, "libghc-stm-dev" 			, "libghc-aeson-dev" 			, "libghc-wai-dev" 			, "libghc-warp-dev"@@ -1016,13 +1032,17 @@ 	-- rsync server command to be updated too. 	rsynccommand = "rsync -e 'ssh -i" ++ sshkeyfile ++ "' -avz rrds/ joey@kitenet.net:/srv/web/homepower.joeyh.name/rrds/" +homerouterWifiInterfaceOld :: String+homerouterWifiInterfaceOld = "wlx00c0ca82eb78" -- thinkpenguin wifi adapter+ homerouterWifiInterface :: String-homerouterWifiInterface = "wlan0" -- "wlx7cdd90400448" is a wifi dongle+homerouterWifiInterface = "wlx7cdd90400448" -- small wifi dongle  -- My home router, running hostapd and dnsmasq, -- with eth0 connected to a satellite modem, and a fallback ppp connection. homeRouter :: Property (HasInfo + DebianLike) homeRouter = propertyList "home router" $ props+	& File.notPresent (Network.interfaceDFile homerouterWifiInterfaceOld) 	& Network.static homerouterWifiInterface (IPv4 "10.1.1.1") Nothing 		`requires` Network.cleanInterfacesFile 	& Apt.installed ["hostapd"]@@ -1134,6 +1154,8 @@ 	, "yeahconsole", "xkbset", "xinput" 	, "assword", "pumpa" 	, "vorbis-tools", "audacity"+	, "ekiga"+	, "bluez-firmware", "blueman", "pulseaudio-module-bluetooth" 	, "xul-ext-ublock-origin", "xul-ext-pdf.js", "xul-ext-status4evar" 	, "vim-syntastic", "vim-fugitive" 	, "adb", "gthumb"@@ -1203,15 +1225,17 @@ 	& Apt.installed ["uhubctl"] 	& "/etc/udev/rules.d/52-startech-hub.rules" `File.hasContent` 		[ "# let users power control startech hub with uhubctl"-		, "ATTR{idVendor}==\"0409\", ATTR{idProduct}==\"005a\", MODE=\"0666\""+		, "ATTR{idVendor}==\"" ++ hubvendor ++ "\", ATTR{idProduct}==\"005a\", MODE=\"0666\"" 		]-	& autoMountDrive "archive-10" (USBHubPort 1) (Just "archive-older")-	& autoMountDrive "archive-11" (USBHubPort 2) (Just "archive-old")-	& autoMountDrive "archive-12" (USBHubPort 3) (Just "archive")-	& autoMountDrive "passport" (USBHubPort 4) Nothing+	& autoMountDrive "archive-10" (USBHubPort hubvendor 1) (Just "archive-older")+	& autoMountDrive "archive-11" (USBHubPort hubvendor 2) (Just "archive-old")+	& autoMountDrive "archive-12" (USBHubPort hubvendor 3) (Just "archive")+	& autoMountDrive "passport" (USBHubPort hubvendor 4) Nothing 	& Apt.installed ["git-annex", "borgbackup"]+  where+	hubvendor = "0409" -newtype USBHubPort = USBHubPort Int+data USBHubPort = USBHubPort String Int  -- Makes a USB drive with the given label automount, and unmount after idle -- for a while.@@ -1219,7 +1243,7 @@ -- The hub port is turned on and off automatically as needed, using -- uhubctl. autoMountDrive :: Mount.Label -> USBHubPort -> Maybe FilePath -> Property DebianLike-autoMountDrive label (USBHubPort port) malias = propertyList desc $ props+autoMountDrive label (USBHubPort hubvendor port) malias = propertyList desc $ props 	& File.ownerGroup mountpoint (User "joey") (Group "joey") 		`requires` File.dirExists mountpoint 	& case malias of@@ -1248,8 +1272,8 @@ 		, "[Service]" 		, "Type=oneshot" 		, "RemainAfterExit=true"-		, "ExecStart=/usr/sbin/uhubctl -a on -p " ++ show port-		, "ExecStop=/bin/sh -c 'uhubctl -a off -p " ++ show port +++		, "ExecStart=/usr/sbin/uhubctl -a on -p " ++ show port ++ " --vendor " ++ hubvendor +		, "ExecStop=/bin/sh -c 'uhubctl -a off -p " ++ show port ++ " --vendor " ++ hubvendor 			-- Powering off the port does not remove device 			-- files, so ask udev to remove the devfile; it will 			-- be added back after the drive next spins up@@ -1257,7 +1281,7 @@ 			-- spun up. 			-- (This only works when the devfile is in 			-- by-label.)-			"; udevadm trigger --action=remove " ++ devfile ++ " || true'"+			++ "; udevadm trigger --action=remove " ++ devfile ++ " || true'" 		, "[Install]" 		, "WantedBy=" 		]

@@ -204,13 +204,18 @@  -- | Ensures machined and machinectl are installed machined :: Property Linux-machined = withOS "machined installed" $ \w o ->-	case o of-		-- Split into separate debian package since systemd 225.-		(Just (System (Debian _ suite) _))-			| not (isStable suite) || suite == (Stable "stretch") ->-				ensureProperty w $ Apt.installed ["systemd-container"]-		_ -> noChange+machined = installeddebian `pickOS` assumeinstalled+  where+	installeddebian :: Property DebianLike+	installeddebian = withOS "machined installed" $ \w o ->+		case o of+			-- Split into separate debian package since systemd 225.+			(Just (System (Debian _ suite) _))+				| not (isStable suite) || suite == (Stable "stretch") ->+					ensureProperty w $ Apt.installed ["systemd-container"]+			_ -> noChange+	assumeinstalled :: Property Linux+	assumeinstalled = doNothing  -- | Defines a container with a given machine name, -- and how to create its chroot if not already present.

@@ -168,7 +168,7 @@ 	existinggroups <- map (fst . break (== ':')) . lines 		<$> liftIO (readFile "/etc/group") 	let toadd = filter (`elem` existinggroups) desktopgroups-	ensureProperty o $ propertyList desc $ toProps $+	ensureProperty o $ combineProperties desc $ toProps $ 		map (hasGroup user . Group) toadd   where 	desc = "user " ++ u ++ " is in standard desktop groups"

@@ -19,7 +19,7 @@ sshCachingParams hn = do 	home <- myHomeDir 	let socketfile = socketFile home hn-	createDirectoryIfMissing False (takeDirectory socketfile)+	createDirectoryIfMissing True (takeDirectory socketfile) 	let ps = 		[ Param "-o" 		, Param ("ControlPath=" ++ socketfile)

@@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}

@@ -23,7 +23,7 @@  import Propellor.Types.ConfigurableValue -import Network.BSD (HostName)+import Network.Socket (HostName) import Data.Typeable import Data.String 

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, UndecidableInstances #-}+{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, FlexibleContexts #-}  -- | Simple implementation of singletons, portable back to ghc 7.6.3 

@@ -9,19 +9,27 @@ module Propellor.Utilities ( 	  module Utility.PartialPrelude 	, module Utility.Process+	, module Utility.Process.Transcript 	, module Utility.Exception 	, module Utility.Env+	, module Utility.Env.Set 	, module Utility.Directory+	, module Utility.Directory.TestDirectory 	, module Utility.Tmp+	, module Utility.Tmp.Dir 	, module Utility.Monad 	, module Utility.Misc ) where  import Utility.PartialPrelude import Utility.Process+import Utility.Process.Transcript import Utility.Exception import Utility.Env+import Utility.Env.Set import Utility.Directory+import Utility.Directory.TestDirectory import Utility.Tmp+import Utility.Tmp.Dir import Utility.Monad import Utility.Misc

@@ -16,22 +16,18 @@ import System.IO.Error import Control.Monad import System.FilePath+import System.PosixCompat.Files import Control.Applicative-import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe import Prelude -#ifdef mingw32_HOST_OS-import qualified System.Win32 as Win32-#else-import qualified System.Posix as Posix+#ifndef mingw32_HOST_OS import Utility.SafeCommand import Control.Monad.IfElse #endif  import Utility.SystemDirectory-import Utility.PosixFiles import Utility.Tmp import Utility.Exception import Utility.Monad@@ -42,10 +38,6 @@ dirCruft ".." = True dirCruft _ = False -fsCruft :: FilePath -> Bool-fsCruft "lost+found" = True-fsCruft d = dirCruft d- {- Lists the contents of a directory.  - Unlike getDirectoryContents, paths are not relative to the directory. -} dirContents :: FilePath -> IO [FilePath]@@ -100,10 +92,10 @@ 	go c (dir:dirs) 		| skipdir (takeFileName dir) = go c dirs 		| otherwise = unsafeInterleaveIO $ do-			subdirs <- go c+			subdirs <- go [] 				=<< filterM (isDirectory <$$> getSymbolicLinkStatus) 				=<< catchDefaultIO [] (dirContents dir)-			go (subdirs++[dir]) dirs+			go (subdirs++dir:c) dirs  {- Moves one filename to another.  - First tries a rename, but falls back to moving across devices if needed. -}@@ -162,101 +154,3 @@ #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 = testDirectory d dirCruft---- | True if the directory does not exist or contains nothing.--- Ignores "lost+found" which can exist in an empty filesystem.-isUnpopulated :: FilePath -> IO Bool-isUnpopulated d = catchDefaultIO True $ testDirectory d fsCruft---- | Run test on entries found in directory, return False as soon as the--- test returns False, else return True.  Throws exception if directory does--- not exist.-testDirectory :: FilePath -> (FilePath -> Bool) -> IO Bool-testDirectory d test = bracket (openDirectory d) closeDirectory check-  where-	check h = do-		v <- readDirectory h-		case v of-			Nothing -> return True-			Just f-				| not (test f) -> return False-				| otherwise -> check h

@@ -0,0 +1,130 @@+{- streaming directory traversal+ -+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Directory.Stream where++import Control.Monad+import System.FilePath+import System.IO.Unsafe (unsafeInterleaveIO)+import Control.Concurrent+import Data.Maybe+import Prelude++#ifdef mingw32_HOST_OS+import qualified System.Win32 as Win32+#else+import qualified System.Posix as Posix+#endif++import Utility.Directory+import Utility.Exception++#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++-- | Like getDirectoryContents, but rather than buffering the whole+-- directory content in memory, lazily streams.+--+-- This is like lazy readFile in that the handle to the directory remains+-- open until the whole list is consumed, or until the list is garbage+-- collected. So use with caution particularly when traversing directory+-- trees.+streamDirectoryContents :: FilePath -> IO [FilePath]+streamDirectoryContents d = openDirectory d >>= collect+  where+	collect hdl = readDirectory hdl >>= \case+		Nothing -> return []+		Just f -> do+			rest <- unsafeInterleaveIO (collect hdl)+			return (f:rest)++-- | 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

@@ -0,0 +1,40 @@+{- testing properties of directories+ -+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++module Utility.Directory.TestDirectory where++import Utility.Directory+import Utility.Directory.Stream+import Utility.Exception++-- | True only when directory exists and contains nothing.+-- Throws exception if directory does not exist.+isDirectoryEmpty :: FilePath -> IO Bool+isDirectoryEmpty d = testDirectory d dirCruft++-- | True if the directory does not exist or contains nothing.+-- Ignores "lost+found" which can exist in an empty filesystem.+isUnpopulated :: FilePath -> IO Bool+isUnpopulated d = catchDefaultIO True $ testDirectory d fsCruft++fsCruft :: FilePath -> Bool+fsCruft "lost+found" = True+fsCruft d = dirCruft d++-- | Run test on entries found in directory, return False as soon as the+-- test returns False, else return True.  Throws exception if directory does+-- not exist.+testDirectory :: FilePath -> (FilePath -> Bool) -> IO Bool+testDirectory d test = bracket (openDirectory d) closeDirectory check+  where+	check h = do+		v <- readDirectory h+		case v of+			Nothing -> return True+			Just f+				| not (test f) -> return False+				| otherwise -> check h

@@ -16,7 +16,6 @@ import Data.Maybe import Prelude import qualified System.Environment as E-import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif@@ -40,29 +39,6 @@ getEnvironment = PE.getEnvironment #else getEnvironment = E.getEnvironment-#endif--{- Sets an environment variable. To overwrite an existing variable,- - overwrite must be True.- -- - On Windows, setting a variable to "" unsets it. -}-setEnv :: String -> String -> Bool -> IO ()-#ifndef mingw32_HOST_OS-setEnv var val overwrite = PE.setEnv var val overwrite-#else-setEnv var val True = System.SetEnv.setEnv var val-setEnv var val False = do-	r <- getEnv var-	case r of-		Nothing -> setEnv var val True-		Just _ -> return ()-#endif--unsetEnv :: String -> IO ()-#ifndef mingw32_HOST_OS-unsetEnv = PE.unsetEnv-#else-unsetEnv = System.SetEnv.unsetEnv #endif  {- Adds the environment variable to the input environment. If already

@@ -0,0 +1,22 @@+{- portable environment variables, without any dependencies+ -+ - Copyright 2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Env.Basic where++import Utility.Exception+import Control.Applicative+import Data.Maybe+import Prelude+import qualified System.Environment as E++getEnv :: String -> IO (Maybe String)+getEnv = catchMaybeIO . E.getEnv++getEnvDefault :: String -> String -> IO String+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var

@@ -0,0 +1,41 @@+{- portable environment variables+ -+ - Copyright 2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.Env.Set where++#ifdef mingw32_HOST_OS+import qualified System.Environment as E+import qualified System.SetEnv+import Utility.Env+#else+import qualified System.Posix.Env as PE+#endif++{- Sets an environment variable. To overwrite an existing variable,+ - overwrite must be True.+ -+ - On Windows, setting a variable to "" unsets it. -}+setEnv :: String -> String -> Bool -> IO ()+#ifndef mingw32_HOST_OS+setEnv var val overwrite = PE.setEnv var val overwrite+#else+setEnv var val True = System.SetEnv.setEnv var val+setEnv var val False = do+	r <- getEnv var+	case r of+		Nothing -> setEnv var val True+		Just _ -> return ()+#endif++unsetEnv :: String -> IO ()+#ifndef mingw32_HOST_OS+unsetEnv = PE.unsetEnv+#else+unsetEnv = System.SetEnv.unsetEnv+#endif

@@ -5,7 +5,7 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Exception (@@ -29,11 +29,7 @@ import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException)-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) import Control.Exception (SomeAsyncException)-#endif-#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType)@@ -46,15 +42,7 @@  - where there's a problem that the user is excpected to see in some  - circumstances. -} giveup :: [Char] -> a-#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,9,0) giveup = errorWithoutStackTrace-#else-giveup = error-#endif-#else-giveup = error-#endif  {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool@@ -95,11 +83,7 @@ catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` 	[ M.Handler (\ (e :: AsyncException) -> throwM e)-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) 	, M.Handler (\ (e :: SomeAsyncException) -> throwM e)-#endif-#endif 	, M.Handler (\ (e :: SomeException) -> onerr e) 	] 

@@ -15,9 +15,9 @@ import System.IO import Control.Monad import System.PosixCompat.Types-import Utility.PosixFiles+import System.PosixCompat.Files #ifndef mingw32_HOST_OS-import System.Posix.Files+import System.Posix.Files (symbolicLinkMode) import Control.Monad.IO.Class (liftIO) #endif import Control.Monad.IO.Class (MonadIO)@@ -69,6 +69,7 @@ otherGroupModes =  	[ groupReadMode, otherReadMode 	, groupWriteMode, otherWriteMode+	, groupExecuteMode, otherExecuteMode 	]  {- Removes the write bits from a file. -}

@@ -12,6 +12,9 @@ 	useFileSystemEncoding, 	fileEncoding, 	withFilePath,+	RawFilePath,+	fromRawFilePath,+	toRawFilePath, 	decodeBS, 	encodeBS, 	decodeW8,@@ -32,6 +35,7 @@ import System.IO.Unsafe import Data.Word import Data.List+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8@@ -119,6 +123,22 @@ #else encodeBS = L8.fromString #endif++{- Recent versions of the unix package have this alias; defined here+ - for backwards compatibility. -}+type RawFilePath = S.ByteString++{- Note that the RawFilePath is assumed to never contain NUL,+ - since filename's don't. This should only be used with actual+ - RawFilePaths not arbitrary ByteString that may contain NUL. -}+fromRawFilePath :: RawFilePath -> FilePath+fromRawFilePath = encodeW8 . S.unpack++{- Note that the FilePath is assumed to never contain NUL,+ - since filename's don't. This should only be used with actual FilePaths+ - not arbitrary String that may contain NUL. -}+toRawFilePath :: FilePath -> RawFilePath+toRawFilePath = S.pack . decodeW8  {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.  -

@@ -5,7 +5,6 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Misc where@@ -16,10 +15,6 @@ import Data.Char import Data.List import System.Exit-#ifndef mingw32_HOST_OS-import System.Posix.Process (getAnyProcessStatus)-import Utility.Exception-#endif import Control.Applicative import Prelude @@ -111,22 +106,6 @@   where 	peekbytes :: Int -> Ptr Word8 -> IO [Word8] 	peekbytes len buf = mapM (peekElemOff buf) [0..pred len]--{- Reaps any zombie git processes. - -- - Warning: Not thread safe. Anything that was expecting to wait- - on a process and get back an exit status is going to be confused- - if this reap gets there first. -}-reapZombies :: IO ()-#ifndef mingw32_HOST_OS-reapZombies =-	-- throws an exception when there are no child processes-	catchDefaultIO Nothing (getAnyProcessStatus False True)-		>>= maybe (return ()) (const reapZombies)--#else-reapZombies = return ()-#endif  exitBool :: Bool -> IO a exitBool False = exitFailure

@@ -38,11 +38,9 @@  {- Attempts to read a value from a String.  -- - Ignores leading/trailing whitespace, and throws away any trailing- - text after the part that can be read.- -- - readMaybe is available in Text.Read in new versions of GHC,- - but that one requires the entire string to be consumed.+ - Unlike Text.Read.readMaybe, this ignores some trailing text+ - after the part that can be read. However, if the trailing text looks+ - like another readable value, it fails.  -} readish :: Read a => String -> Maybe a readish s = case reads s of

@@ -5,7 +5,7 @@  - License: BSD-2-clause  -} -{-# LANGUAGE PackageImports, CPP #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Path where@@ -17,13 +17,6 @@ import Control.Applicative import Prelude -#ifdef mingw32_HOST_OS-import qualified System.FilePath.Posix as Posix-#else-import System.Posix.Files-import Utility.Exception-#endif- import Utility.Monad import Utility.UserInfo import Utility.Directory@@ -136,17 +129,22 @@  -} relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to-	| takeDrive from /= takeDrive to = to+#ifdef mingw32_HOST_OS+	| normdrive from /= normdrive to = to+#endif 	| otherwise = joinPath $ dotdots ++ uncommon   where 	pfrom = sp from 	pto = sp to-	sp = map dropTrailingPathSeparator . splitPath+	sp = map dropTrailingPathSeparator . splitPath . dropDrive 	common = map fst $ takeWhile same $ zip pfrom pto 	same (c,d) = c == d 	uncommon = drop numcommon pto 	dotdots = replicate (length pfrom - numcommon) ".." 	numcommon = length common+#ifdef mingw32_HOST_OS+	normdrive = map toLower . takeWhile (/= ':') . takeDrive+#endif  prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to@@ -241,50 +239,6 @@ 	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)   where 	f = takeFileName file--{- Converts a DOS style path to a msys2 style path. Only on Windows.- - Any trailing '\' is preserved as a trailing '/' - - - - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i- -- - The virtual filesystem contains:- -  /c, /d, ...	mount points for Windows drives- -}-toMSYS2Path :: FilePath -> FilePath-#ifndef mingw32_HOST_OS-toMSYS2Path = id-#else-toMSYS2Path p-	| null drive = recombine parts-	| otherwise = recombine $ "/" : driveletter drive : parts-  where-	(drive, p') = splitDrive p-	parts = splitDirectories p'-	driveletter = map toLower . takeWhile (/= ':')-	recombine = fixtrailing . Posix.joinPath-	fixtrailing s-		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s-		| otherwise = s-#endif--{- Maximum size to use for a file in a specified directory.- -- - Many systems have a 255 byte limit to the name of a file, - - so that's taken as the max if the system has a larger limit, or has no- - limit.- -}-fileNameLengthLimit :: FilePath -> IO Int-#ifdef mingw32_HOST_OS-fileNameLengthLimit _ = return 255-#else-fileNameLengthLimit dir = do-	-- getPathVar can fail due to statfs(2) overflow-	l <- catchDefaultIO 0 $-		fromIntegral <$> getPathVar dir FileNameLimit-	if l <= 0-		then return 255-		else return $ minimum [l, 255]-#endif  {- Given a string that we'd like to use as the basis for FilePath, but that  - was provided by a third party and is not to be trusted, returns the closest

@@ -1,42 +0,0 @@-{- POSIX files (and compatablity wrappers).- -- - This is like System.PosixCompat.Files, but with a few fixes.- -- - Copyright 2014 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-tabs #-}--module Utility.PosixFiles (-	module X,-	rename-) where--import System.PosixCompat.Files as X hiding (rename)--#ifndef mingw32_HOST_OS-import System.Posix.Files (rename)-#else-import qualified System.Win32.File as Win32-import qualified System.Win32.HardLink as Win32-#endif--{- System.PosixCompat.Files.rename on Windows calls renameFile,- - so cannot rename directories. - -- - Instead, use Win32 moveFile, which can. It needs to be told to overwrite- - any existing file. -}-#ifdef mingw32_HOST_OS-rename :: FilePath -> FilePath -> IO ()-rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING-#endif--{- System.PosixCompat.Files.createLink throws an error, but windows- - does support hard links. -}-#ifdef mingw32_HOST_OS-createLink :: FilePath -> FilePath -> IO ()-createLink = Win32.createHardLink-#endif

@@ -24,11 +24,10 @@ 	createProcessSuccess, 	createProcessChecked, 	createBackgroundProcess,-	processTranscript,-	processTranscript', 	withHandle, 	withIOHandles, 	withOEHandles,+	withNullHandle, 	withQuietOutput, 	feedWithQuietOutput, 	createProcess,@@ -54,13 +53,6 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad-#ifndef mingw32_HOST_OS-import qualified System.Posix.IO-#else-import Control.Applicative-#endif-import Data.Maybe-import Prelude  type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -170,68 +162,6 @@ createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p --- | Runs a process, optionally feeding it some input, and--- returns a transcript combining its stdout and stderr, and--- whether it succeeded or failed.-processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)-processTranscript cmd opts = processTranscript' (proc cmd opts)--processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)-processTranscript' cp input = do-#ifndef mingw32_HOST_OS-{- This implementation interleves stdout and stderr in exactly the order- - the process writes them. -}-	(readf, writef) <- System.Posix.IO.createPipe-	readh <- System.Posix.IO.fdToHandle readf-	writeh <- System.Posix.IO.fdToHandle writef-	p@(_, _, _, pid) <- createProcess $ cp-		{ std_in = if isJust input then CreatePipe else Inherit-		, std_out = UseHandle writeh-		, std_err = UseHandle writeh-		}-	hClose writeh--	get <- mkreader readh-	writeinput input p-	transcript <- get--	ok <- checkSuccessProcess pid-	return (transcript, ok)-#else-{- This implementation for Windows puts stderr after stdout. -}-	p@(_, _, _, pid) <- createProcess $ cp-		{ std_in = if isJust input then CreatePipe else Inherit-		, std_out = CreatePipe-		, std_err = CreatePipe-		}--	getout <- mkreader (stdoutHandle p)-	geterr <- mkreader (stderrHandle p)-	writeinput input p-	transcript <- (++) <$> getout <*> geterr--	ok <- checkSuccessProcess pid-	return (transcript, ok)-#endif-  where-	mkreader h = do-		s <- hGetContents h-		v <- newEmptyMVar-		void $ forkIO $ do-			void $ E.evaluate (length s)-			putMVar v ()-		return $ do-			takeMVar v-			return s--	writeinput (Just s) p = do-		let inh = stdinHandle p-		unless (null s) $ do-			hPutStr inh s-			hFlush inh-		hClose inh-	writeinput Nothing _ = return ()- -- | Runs a CreateProcessRunner, on a CreateProcess structure, that -- is adjusted to pipe only from/to a single StdHandle, and passes -- the resulting Handle to an action.@@ -248,13 +178,10 @@ 		, std_out = Inherit 		, std_err = Inherit 		}-	(select, p')-		| h == StdinHandle  =-			(stdinHandle, base { std_in = CreatePipe })-		| h == StdoutHandle =-			(stdoutHandle, base { std_out = CreatePipe })-		| h == StderrHandle =-			(stderrHandle, base { std_err = CreatePipe })+	(select, p') = case h of+		StdinHandle -> (stdinHandle, base { std_in = CreatePipe })+		StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })+		StderrHandle -> (stderrHandle, base { std_err = CreatePipe })  -- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles@@ -284,13 +211,16 @@ 		, std_err = CreatePipe 		} +withNullHandle :: (Handle -> IO a) -> IO a+withNullHandle = withFile devNull WriteMode+ -- | Forces the CreateProcessRunner to run quietly; -- both stdout and stderr are discarded. withQuietOutput 	:: CreateProcessRunner 	-> CreateProcess 	-> IO ()-withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do+withQuietOutput creator p = withNullHandle $ \nullh -> do 	let p' = p 		{ std_out = UseHandle nullh 		, std_err = UseHandle nullh@@ -316,7 +246,8 @@ #ifndef mingw32_HOST_OS devNull = "/dev/null" #else-devNull = "NUL"+-- Use device namespace to prevent GHC from rewriting path+devNull = "\\\\.\\NUL" #endif  -- | Extract a desired handle from createProcess's tuple.

@@ -1,4 +1,3 @@-module Utility.Process.Shim (module X, createProcess, waitForProcess) where+module Utility.Process.Shim (module X) where -import System.Process as X hiding (createProcess, waitForProcess)-import System.Process.Concurrent+import System.Process as X

@@ -0,0 +1,83 @@+{- Process transcript+ -+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Process.Transcript where++import Utility.Process+import Utility.Misc++import System.IO+import System.Exit+import Control.Concurrent.Async+import Control.Monad+#ifndef mingw32_HOST_OS+import qualified System.Posix.IO+#else+import Control.Applicative+#endif+import Data.Maybe+import Prelude++-- | Runs a process and returns a transcript combining its stdout and+-- stderr, and whether it succeeded or failed.+processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)+processTranscript cmd opts = processTranscript' (proc cmd opts)++-- | Also feeds the process some input.+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)+processTranscript' cp input = do+	(t, c) <- processTranscript'' cp input+	return (t, c == ExitSuccess)++processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode)+processTranscript'' cp input = do+#ifndef mingw32_HOST_OS+{- This implementation interleves stdout and stderr in exactly the order+ - the process writes them. -}+	(readf, writef) <- System.Posix.IO.createPipe+	System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True+	System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True+	readh <- System.Posix.IO.fdToHandle readf+	writeh <- System.Posix.IO.fdToHandle writef+	p@(_, _, _, pid) <- createProcess $ cp+		{ std_in = if isJust input then CreatePipe else Inherit+		, std_out = UseHandle writeh+		, std_err = UseHandle writeh+		}+	hClose writeh++	get <- asyncreader readh+	writeinput input p+	transcript <- wait get+#else+{- This implementation for Windows puts stderr after stdout. -}+	p@(_, _, _, pid) <- createProcess $ cp+		{ std_in = if isJust input then CreatePipe else Inherit+		, std_out = CreatePipe+		, std_err = CreatePipe+		}++	getout <- asyncreader (stdoutHandle p)+	geterr <- asyncreader (stderrHandle p)+	writeinput input p+	transcript <- (++) <$> wait getout <*> wait geterr+#endif+	code <- waitForProcess pid+	return (transcript, code)+  where+	asyncreader = async . hGetContentsStrict++	writeinput (Just s) p = do+		let inh = stdinHandle p+		unless (null s) $ do+			hPutStr inh s+			hFlush inh+		hClose inh+	writeinput Nothing _ = return ()

@@ -27,19 +27,21 @@ -- | Used to pass a list of CommandParams to a function that runs -- a command and expects Strings. -} toCommand :: [CommandParam] -> [String]-toCommand = map unwrap+toCommand = map toCommand'++toCommand' :: CommandParam -> String+toCommand' (Param s) = s+-- Files that start with a non-alphanumeric that is not a path+-- separator are modified to avoid the command interpreting them as+-- options or other special constructs.+toCommand' (File s@(h:_))+	| isAlphaNum h || h `elem` pathseps = s+	| otherwise = "./" ++ s   where-	unwrap (Param s) = s-	-- Files that start with a non-alphanumeric that is not a path-	-- separator are modified to avoid the command interpreting them as-	-- options or other special constructs.-	unwrap (File s@(h:_))-		| isAlphaNum h || h `elem` pathseps = s-		| otherwise = "./" ++ s-	unwrap (File s) = s 	-- '/' is explicitly included because it's an alternative 	-- path separator on Windows. 	pathseps = pathSeparator:"./"+toCommand' (File s) = s  -- | Run a system command, and returns True or False if it succeeded or failed. --

@@ -30,6 +30,7 @@ import Utility.PartialPrelude import Utility.Misc import Utility.Tuple+import Utility.Split  import Data.List import Data.Time.Clock@@ -265,7 +266,7 @@ 	constructor "month" = Just Monthly 	constructor "year" = Just Yearly 	constructor u-		| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u+		| "s" `isSuffixOf` u = constructor $ dropFromEnd 1 u 		| otherwise = Nothing 	withday sd u = do 		c <- constructor u

@@ -28,3 +28,7 @@ -- | same as Data.List.Utils.replace replace :: Eq a => [a] -> [a] -> [a] -> [a]  replace old new = intercalate new . split old++-- | Only traverses the list once while dropping the last n characters.+dropFromEnd :: Int -> [a] -> [a]+dropFromEnd n l = zipWith const l (drop n l)

@@ -18,10 +18,8 @@ #endif #ifndef mingw32_HOST_OS import System.Posix.Signals-#ifndef __ANDROID__ import System.Posix.Terminal #endif-#endif  newtype Seconds = Seconds { fromSeconds :: Int } 	deriving (Eq, Ord, Show)@@ -63,10 +61,8 @@ 	let check sig = void $ 		installHandler sig (CatchOnce $ putMVar lock ()) Nothing 	check softwareTermination-#ifndef __ANDROID__ 	whenM (queryTerminal stdInput) $ 		check keyboardSignal-#endif 	takeMVar lock #endif 

@@ -1,4 +1,4 @@-{- Temporary files and directories.+{- Temporary files.  -  - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -@@ -11,24 +11,20 @@ module Utility.Tmp where  import System.IO-import Control.Monad.IfElse import System.FilePath import System.Directory import Control.Monad.IO.Class-#ifndef mingw32_HOST_OS-import System.Posix.Temp (mkdtemp)-#endif+import System.PosixCompat.Files  import Utility.Exception import Utility.FileSystemEncoding-import Utility.PosixFiles  type Template = String  {- 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 :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()+viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () viaTmp a file content = bracketIO setup cleanup use   where 	(dir, base) = splitFileName file@@ -61,51 +57,6 @@ 		hClose h 		catchBoolIO (removeFile name >> return True) 	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 :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a-withTmpDir template a = do-	topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory-#ifndef mingw32_HOST_OS-	-- Use mkdtemp to create a temp directory securely in /tmp.-	bracket-		(liftIO $ mkdtemp $ topleveltmpdir </> template)-		removeTmpDir-		a-#else-	withTmpDirIn topleveltmpdir template a-#endif--{- Runs an action with a tmp directory located within a specified directory,- - then removes the tmp directory and all its contents. -}-withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a-withTmpDirIn tmpdir template = bracketIO create removeTmpDir-  where-	create = do-		createDirectoryIfMissing True tmpdir-		makenewdir (tmpdir </> template) (0 :: Int)-	makenewdir t n = do-		let dir = t ++ "." ++ show n-		catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do-			createDirectory dir-			return dir--{- Deletes the entire contents of the the temporary directory, if it- - exists. -}-removeTmpDir :: MonadIO m => FilePath -> m ()-removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do-#if mingw32_HOST_OS-	-- Windows will often refuse to delete a file-	-- after a process has just written to it and exited.-	-- Because it's crap, presumably. So, ignore failure-	-- to delete the temp directory.-	_ <- tryIO $ removeDirectoryRecursive tmpdir-	return ()-#else-	removeDirectoryRecursive tmpdir-#endif  {- It's not safe to use a FilePath of an existing file as the template  - for openTempFile, because if the FilePath is really long, the tmpfile

@@ -0,0 +1,67 @@+{- Temporary directories+ -+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Tmp.Dir where++import Control.Monad.IfElse+import System.FilePath+import System.Directory+import Control.Monad.IO.Class+#ifndef mingw32_HOST_OS+import System.Posix.Temp (mkdtemp)+#endif++import Utility.Exception+import Utility.Tmp (Template)++{- 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 :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a+withTmpDir template a = do+	topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory+#ifndef mingw32_HOST_OS+	-- Use mkdtemp to create a temp directory securely in /tmp.+	bracket+		(liftIO $ mkdtemp $ topleveltmpdir </> template)+		removeTmpDir+		a+#else+	withTmpDirIn topleveltmpdir template a+#endif++{- Runs an action with a tmp directory located within a specified directory,+ - then removes the tmp directory and all its contents. -}+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a+withTmpDirIn tmpdir template = bracketIO create removeTmpDir+  where+	create = do+		createDirectoryIfMissing True tmpdir+		makenewdir (tmpdir </> template) (0 :: Int)+	makenewdir t n = do+		let dir = t ++ "." ++ show n+		catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do+			createDirectory dir+			return dir++{- Deletes the entire contents of the the temporary directory, if it+ - exists. -}+removeTmpDir :: MonadIO m => FilePath -> m ()+removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do+#if mingw32_HOST_OS+	-- Windows will often refuse to delete a file+	-- after a process has just written to it and exited.+	-- Because it's crap, presumably. So, ignore failure+	-- to delete the temp directory.+	_ <- tryIO $ removeDirectoryRecursive tmpdir+	return ()+#else+	removeDirectoryRecursive tmpdir+#endif

@@ -14,12 +14,14 @@ 	myUserGecos, ) where -import Utility.Env-import Utility.Data+import Utility.Env.Basic import Utility.Exception+#ifndef mingw32_HOST_OS+import Utility.Data+import Control.Applicative+#endif  import System.PosixCompat-import Control.Applicative import Prelude  {- Current user's home directory.@@ -45,8 +47,8 @@ #endif  myUserGecos :: IO (Maybe String)--- userGecos crashes on Android and is not available on Windows.-#if defined(__ANDROID__) || defined(mingw32_HOST_OS)+-- userGecos is not available on Windows.+#if defined(mingw32_HOST_OS) myUserGecos = return Nothing #else myUserGecos = eitherToMaybe <$> myVal [] userGecos@@ -55,9 +57,13 @@ myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars   where+	go [] = either (const $ envnotset) (Right . extract) <$> get+	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v #ifndef mingw32_HOST_OS-	go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)+	-- This may throw an exception if the system doesn't have a+	-- passwd file etc; don't let it crash.+	get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID #else-	go [] = return $ Left ("environment not set: " ++ show envvars)+	get = return envnotset #endif-	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v+	envnotset = Left ("environment not set: " ++ show envvars)