propellor 3.2.3 → 3.3.0

raw patch · 38 files changed

+525/−113 lines, 38 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +29/−0
• debian/changelog +29/−0
• joeyconfig.hs +19/−0
• propellor.cabal +2/−1
• src/Propellor/Bootstrap.hs +23/−0
• src/Propellor/CmdLine.hs +34/−16
• src/Propellor/DotDir.hs +1/−1
• src/Propellor/Gpg.hs +2/−5
• src/Propellor/Info.hs +5/−0
• src/Propellor/PrivData.hs +1/−3
• src/Propellor/Property.hs +4/−4
• src/Propellor/Property/Apt.hs +112/−0
• src/Propellor/Property/Chroot.hs +1/−0
• src/Propellor/Property/Debootstrap.hs +2/−1
• src/Propellor/Property/DiskImage.hs +5/−5
• src/Propellor/Property/Docker.hs +3/−2
• src/Propellor/Property/File.hs +63/−0
• src/Propellor/Property/Gpg.hs +0/−2
• src/Propellor/Property/OS.hs +1/−1
• src/Propellor/Property/Pacman.hs +68/−0
• src/Propellor/Property/Parted.hs +4/−3
• src/Propellor/Property/Reboot.hs +1/−1
• src/Propellor/Property/Rsync.hs +5/−4
• src/Propellor/Property/SiteSpecific/JoeySites.hs +4/−3
• src/Propellor/Property/Tor.hs +14/−6
• src/Propellor/Property/User.hs +1/−1
• src/Propellor/Shim.hs +0/−2
• src/Propellor/Types.hs +1/−0
• src/Propellor/Types/CmdLine.hs +1/−0
• src/Propellor/Types/MetaTypes.hs +26/−2
• src/Propellor/Types/OS.hs +4/−1
• src/Utility/Exception.hs +23/−3
• src/Utility/FileSystemEncoding.hs +22/−19
• src/Utility/Misc.hs +0/−17
• src/Utility/SystemDirectory.hs +1/−1
• src/Utility/UserInfo.hs +9/−7
• src/wrapper.hs +4/−1
• stack.yaml +1/−1

@@ -1,3 +1,32 @@+propellor (3.3.0) unstable; urgency=medium++  * Arch Linux is now supported by Propellor!+    Thanks to Zihao Wang for this port.+  * Added Propellor.Property.Pacman for Arch's package manager.+    Maintained by Zihao Wang.+  * The types of some properties changed; eg from Property DebianLike+    to Property (DebianLike + ArchLinux). Also, DebianLike and Linux+    are no longer type synonyms; propellor now knows that Linux includes+    ArchLinux. This could require updates to code, so is a minor API change.+  * GHC's fileSystemEncoding is used for all String IO, to avoid+    encoding-related crashes in eg, Propellor.Property.File.+  * Add --build option to simply build config.hs.+  * More informative usage message. Thanks, Daniel Brooks+  * Tor.hiddenService' added to support multiple ports.+    Thanks, Félix Sipma.+  * Apt.noPDiffs added.+    Thanks, Sean Whitton.+  * stack.yaml: Compile with GHC 8.0.1 against lts-7.16.+    Thanks, Andrew Cowie.+  * Added Propellor.Property.File.configFileName and related functions+    to generate good filenames for config directories.+  * Added Apt.suiteAvailablePinned, Apt.pinnedTo.+    Thanks, Sean Whitton.+  * Added File.containsBlock+    Thanks, Sean Whitton.++ -- Joey Hess <id@joeyh.name>  Tue, 07 Feb 2017 12:09:24 -0400+ propellor (3.2.3) unstable; urgency=medium    * Improve extraction of gpg secret key id list, to work with gpg 2.1.

@@ -1,3 +1,32 @@+propellor (3.3.0) unstable; urgency=medium++  * Arch Linux is now supported by Propellor!+    Thanks to Zihao Wang for this port.+  * Added Propellor.Property.Pacman for Arch's package manager.+    Maintained by Zihao Wang.+  * The types of some properties changed; eg from Property DebianLike+    to Property (DebianLike + ArchLinux). Also, DebianLike and Linux+    are no longer type synonyms; propellor now knows that Linux includes+    ArchLinux. This could require updates to code, so is a minor API change.+  * GHC's fileSystemEncoding is used for all String IO, to avoid+    encoding-related crashes in eg, Propellor.Property.File.+  * Add --build option to simply build config.hs.+  * More informative usage message. Thanks, Daniel Brooks+  * Tor.hiddenService' added to support multiple ports.+    Thanks, Félix Sipma.+  * Apt.noPDiffs added.+    Thanks, Sean Whitton.+  * stack.yaml: Compile with GHC 8.0.1 against lts-7.16.+    Thanks, Andrew Cowie.+  * Added Propellor.Property.File.configFileName and related functions+    to generate good filenames for config directories.+  * Added Apt.suiteAvailablePinned, Apt.pinnedTo.+    Thanks, Sean Whitton.+  * Added File.containsBlock+    Thanks, Sean Whitton.++ -- Joey Hess <id@joeyh.name>  Tue, 07 Feb 2017 12:09:24 -0400+ propellor (3.2.3) unstable; urgency=medium    * Improve extraction of gpg secret key id list, to work with gpg 2.1.

@@ -13,6 +13,7 @@ import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User import qualified Propellor.Property.Hostname as Hostname+import qualified Propellor.Property.Fstab as Fstab import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Dns as Dns import qualified Propellor.Property.OpenId as OpenId@@ -50,6 +51,7 @@ 	, mayfly 	, oyster 	, orca+	, baleen 	, honeybee 	, kite 	, elephant@@ -182,6 +184,22 @@ 	-- block 22. 	& Ssh.listenPort (Port 80) +baleen :: Host+baleen = host "baleen.kitenet.net" $ props+	& standardSystem Unstable X86_64 [ "New git-annex build box." ]++	-- Not on public network; ssh access via bounce host.+	& ipv4 "138.38.77.40"+	+	-- The root filesystem content may be lost if the VM is resized.+	-- /dev/vdb contains persistent storage.+	& Fstab.mounted "auto" "/dev/vdb" "/var/lib/container" mempty+	+	& Apt.unattendedUpgrades+	& Postfix.satellite+	& Apt.serviceInstalledRunning "ntp"+	& Systemd.persistentJournal+ orca :: Host orca = host "orca.kitenet.net" $ props 	& standardSystem Unstable X86_64 [ "Main git-annex build box." ]@@ -638,6 +656,7 @@ 		& ipv6 "2001:4978:f:2d9::2" 	, host "mouse.kitenet.net" $ props 		& ipv6 "2001:4830:1600:492::2"+		& ipv4 "67.223.19.96" 	, host "animx" $ props 		& ipv4 "76.7.162.101" 		& ipv4 "76.7.162.186"

@@ -1,5 +1,5 @@ Name: propellor-Version: 3.2.3+Version: 3.3.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>@@ -128,6 +128,7 @@     Propellor.Property.Obnam     Propellor.Property.OpenId     Propellor.Property.OS+    Propellor.Property.Pacman     Propellor.Property.Parted     Propellor.Property.Partition     Propellor.Property.Postfix

@@ -60,6 +60,7 @@   where 	osinstall = case msys of 		Just (System (FreeBSD _) _) -> map pkginstall fbsddeps+		Just (System (ArchLinux) _) -> map pacmaninstall archlinuxdeps 		Just (System (Debian _ _) _) -> useapt 		Just (System (Buntish _) _) -> useapt 		-- assume a debian derived system when not specified@@ -74,6 +75,7 @@  	aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p 	pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p+	pacmaninstall p = "pacman -S --noconfirm --needed " ++ p  	-- This is the same deps listed in debian/control. 	debdeps =@@ -112,6 +114,25 @@ 		, "hs-text" 		, "gmake" 		]+	archlinuxdeps =+		[ "gnupg"+		, "ghc"+		, "cabal-install"+		, "haskell-async"+		, "haskell-missingh"+		, "haskell-hslogger"+		, "haskell-unix-compat"+		, "haskell-ansi-terminal"+		, "haskell-hackage-security"+		, "haskell-ifelse"+		, "haskell-network"+		, "haskell-mtl"+		, "haskell-transformers-base"+		, "haskell-exceptions"+		, "haskell-stm"+		, "haskell-text"+		, "make"+		]  installGitCommand :: Maybe System -> ShellCommand installGitCommand msys = case msys of@@ -121,6 +142,8 @@ 		[ "ASSUME_ALWAYS_YES=yes pkg update" 		, "ASSUME_ALWAYS_YES=yes pkg install git" 		]+	(Just (System (ArchLinux) _)) -> use+		[ "pacman -S --noconfirm --needed git"] 	-- assume a debian derived system when not specified 	Nothing -> use apt   where

@@ -19,26 +19,41 @@ import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim+import Utility.FileSystemEncoding  usage :: Handle -> IO () usage h = hPutStrLn h $ unlines 	[ "Usage:"-	, "  propellor --init"-	, "  propellor"-	, "  propellor hostname"-	, "  propellor --spin targethost [--via relayhost]"-	, "  propellor --add-key keyid"-	, "  propellor --rm-key keyid"-	, "  propellor --list-fields"-	, "  propellor --dump field context"-	, "  propellor --edit field context"-	, "  propellor --set field context"-	, "  propellor --unset field context"-	, "  propellor --unset-unused"-	, "  propellor --merge"-	, "  propellor --build"-	, "  propellor --check"-	]+	, "  with no arguments, provision the current host"+	, ""+	, "  --init"+	, "      initialize ~/.propellor"+	, "  hostname"+	, "      provision the current host as if it had the specified hostname"+	, "  --spin targethost [--via relayhost]"+	, "      provision the specified host"+	, "  --build"+	, "      recompile using your current config"+	, "  --add-key keyid"+	, "      add an additional signing key to the private data"+	, "  --rm-key keyid"+	, "      remove a signing key from the private data"+	, "  --list-fields"+	, "      list private data fields"+	, "  --set field context"+	, "      set a private data field"+	, "  --unset field context"+	, "      clear a private data field"+	, "  --unset-unused"+	, "      clear unused fields from the private data"+	, "  --dump field context"+	, "      show the content of a private data field"+	, "  --edit field context"+	, "      edit the content of a private data field"+	, "  --merge"+	, "      combine multiple spins into a single git commit"+	, "  --check"+	, "      double-check that propellor can actually run here"]  usageError :: [String] -> IO a usageError ps = do@@ -54,6 +69,7 @@ 			<$> mapM hostname (reverse hs) 			<*> pure (Just r) 		_ -> Spin <$> mapM hostname ps <*> pure Nothing+	go ("--build":[]) = return Build 	go ("--add-key":k:[]) = return $ AddKey k 	go ("--rm-key":k:[]) = return $ RmKey k 	go ("--set":f:c:[]) = withprivfield f c Set@@ -94,6 +110,7 @@ -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () defaultMain hostlist = withConcurrentOutput $ do+	useFileSystemEncoding 	Shim.cleanEnv 	checkDebugMode 	cmdline <- processCmdLine@@ -102,6 +119,7 @@   where 	go cr (Serialized cmdline) = go cr cmdline 	go _ Check = return ()+	go cr Build = buildFirst Nothing cr Build $ return () 	go _ (Set field context) = setPrivData field context 	go _ (Unset field context) = unsetPrivData field context 	go _ (UnsetUnused) = unsetPrivDataUnused hostlist

@@ -316,7 +316,7 @@ 		]  stackResolver :: String-stackResolver = "lts-5.10"+stackResolver = "lts-7.16"  fullClone :: IO Result fullClone = do

@@ -16,7 +16,6 @@ import Utility.Monad import Utility.Misc import Utility.Tmp-import Utility.FileSystemEncoding import Utility.Env import Utility.Directory @@ -183,7 +182,7 @@ gpgDecrypt f = do 	gpgbin <- getGpgBin 	ifM (doesFileExist f)-		( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing (Just fileEncoding)+		( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing Nothing 		, return "" 		) @@ -201,6 +200,4 @@ 	encrypted <- writeReadProcessEnv gpgbin opts Nothing (Just writer) Nothing 	viaTmp writeFile f encrypted   where-	writer h = do-		fileEncoding h-		hPutStr h s+	writer h = hPutStr h s

@@ -3,6 +3,7 @@ module Propellor.Info ( 	osDebian, 	osBuntish,+	osArchLinux, 	osFreeBSD, 	setInfoProperty, 	addInfoProperty,@@ -105,6 +106,10 @@ -- and further indicates the release and architecture. osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD) osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch)++-- | Specifies that a host's operating system is Arch Linux+osArchLinux :: Architecture -> Property (HasInfo + ArchLinux)+osArchLinux arch = tightenTargets $ os (System (ArchLinux) arch)  os :: System -> Property (HasInfo + UnixLike) os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)

@@ -57,7 +57,6 @@ import Utility.FileMode import Utility.Env import Utility.Table-import Utility.FileSystemEncoding import Utility.Directory  -- | Allows a Property to access the value of a specific PrivDataField,@@ -171,7 +170,6 @@ setPrivData :: PrivDataField -> Context -> IO () setPrivData field context = do 	putStrLn "Enter private data on stdin; ctrl-D when done:"-	fileEncoding stdin 	setPrivDataTo field context . PrivData =<< hGetContentsStrict stdin  unsetPrivData :: PrivDataField -> Context -> IO ()@@ -274,7 +272,7 @@ readPrivData = fromMaybe M.empty . readish  readPrivDataFile :: FilePath -> IO PrivMap-readPrivDataFile f = readPrivData <$> readFileStrictAnyEncoding f+readPrivDataFile f = readPrivData <$> readFileStrict f  makePrivDataDir :: IO () makePrivDataDir = createDirectoryIfMissing False privDataDir

@@ -222,7 +222,7 @@ changesFileContent :: Checkable p i => p i -> FilePath -> Property i changesFileContent p f = checkResult getmd5 comparemd5 p   where-	getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f+	getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrict f 	comparemd5 oldmd5 = do 		newmd5 <- getmd5 		return $ if oldmd5 == newmd5 then NoChange else MadeChange@@ -263,7 +263,7 @@ -- -- For example: ----- > upgraded :: UnixLike+-- > upgraded :: Property (DebianLike + FreeBSD) -- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded) -- > 	`describe` "OS upgraded" --@@ -308,8 +308,8 @@ -- -- > myproperty :: Property Debian -- > myproperty = withOS "foo installed" $ \w o -> case o of--- > 	(Just (System (Debian (Stable release)) arch)) -> ensureProperty w ...--- > 	(Just (System (Debian suite) arch)) -> ensureProperty w ...+-- > 	(Just (System (Debian kernel (Stable release)) arch)) -> ensureProperty w ...+-- > 	(Just (System (Debian kernel suite) arch)) -> ensureProperty w ... -- >	_ -> unsupportedOS' -- -- Note that the operating system specifics may not be declared for all hosts,

@@ -100,6 +100,55 @@   where 	generators = [debCdn, kernelOrg, securityUpdates] ++ more +type PinPriority = Int++-- | Adds an apt source for a suite, and pins that suite to a given pin value+-- (see apt_preferences(5)).  Revert to drop the source and unpin the suite.+--+-- If the requested suite is the host's OS suite, the suite is pinned, but no+-- source is added.  That apt source should already be available, or you can use+-- a property like 'Apt.stdSourcesList'.+suiteAvailablePinned+	:: DebianSuite+	-> PinPriority+	-> RevertableProperty Debian Debian+suiteAvailablePinned s pin = available <!> unavailable+  where+	available :: Property Debian+	available = tightenTargets $ combineProperties (desc True) $ props+		& File.hasContent prefFile (suitePinBlock "*" s pin)+		& setSourcesFile++	unavailable :: Property Debian+	unavailable = tightenTargets $ combineProperties (desc False) $ props+		& File.notPresent sourcesFile+			`onChange` update+		& File.notPresent prefFile++	setSourcesFile :: Property Debian+	setSourcesFile = withOS (desc True) $ \w o -> case o of+			(Just (System (Debian _ hostSuite) _))+				| s /= hostSuite -> ensureProperty w $+					File.hasContent sourcesFile sources+					`onChange` update+			_ -> noChange++	-- Unless we are pinning a backports suite, filter out any backports+	-- sources that were added by our generators.  The user probably doesn't+	-- want those to be pinned to the same value+	sources = dropBackports $ concatMap (\gen -> gen s) generators+	  where+		dropBackports+			| "-backports" `isSuffixOf` (showSuite s) = id+			| otherwise = filter (not . isInfixOf "-backports")++	generators = [debCdn, kernelOrg, securityUpdates]+	prefFile = "/etc/apt/preferences.d/20" ++ showSuite s ++ ".pref"+	sourcesFile = "/etc/apt/sources.list.d/" ++ showSuite s ++ ".list"++	desc True = "Debian " ++ showSuite s ++ " pinned, priority " ++ show pin+	desc False = "Debian " ++ showSuite s ++ " not pinned"+ setSourcesList :: [Line] -> Property DebianLike setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update @@ -196,6 +245,50 @@   where 	cmd = "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove" +-- | The name of a package, a glob to match the names of packages, or a regexp+-- surrounded by slashes to match the names of packages.  See+-- apt_preferences(5), "Regular expressions and glob(7) syntax"+type AptPackagePref = String++-- | Pins a list of packages, package wildcards and/or regular expressions to a+-- list of suites and corresponding pin priorities (see apt_preferences(5)).+-- Revert to unpin.+--+-- Each package, package wildcard or regular expression will be pinned to all of+-- the specified suites.+--+-- Note that this will have no effect unless there is an apt source for each of+-- the suites.  One way to add an apt source is 'Apt.suiteAvailablePinned'.+--+-- For example, to obtain Emacs Lisp addon packages not present in your release+-- of Debian from testing, falling back to sid if they're not available in+-- testing, you could use+--+--  > & Apt.suiteAvailablePinned Testing (-10)+--  > & Apt.suiteAvailablePinned Unstable (-10)+--  > & ["elpa-*"] `Apt.pinnedTo` [(Testing, 100), (Unstable, 50)]+pinnedTo+	:: [AptPackagePref]+	-> [(DebianSuite, PinPriority)]+	-> RevertableProperty Debian Debian+pinnedTo ps pins = (\p -> pinnedTo' p pins) `applyToList` ps+	`describe` unwords (("pinned to " ++ showSuites):ps)+  where+	showSuites = intercalate "," $ showSuite . fst <$> pins++pinnedTo'+	:: AptPackagePref+	-> [(DebianSuite, PinPriority)]+	-> RevertableProperty Debian Debian+pinnedTo' p pins =+	(tightenTargets $ prefFile `File.hasContent` prefs)+	<!> (tightenTargets $ File.notPresent prefFile)+  where+	prefs = foldr step [] pins+	step (suite, pin) ls = ls ++ suitePinBlock p suite pin ++ [""]+	prefFile = "/etc/apt/preferences.d/10propellor_"+		++ File.configFileName p <.> "pref"+ -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. robustly :: Property DebianLike -> Property DebianLike@@ -348,6 +441,25 @@ 	notAdded = (notElem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"] 	add = cmdProperty "dpkg" ["--add-architecture", arch] 		`assume` MadeChange++-- | Disable the use of PDiffs for machines with high-bandwidth connections.+noPDiffs :: Property DebianLike+noPDiffs = tightenTargets $ "/etc/apt/apt.conf.d/20pdiffs" `File.hasContent`+	[ "Acquire::PDiffs \"false\";" ]++suitePin :: DebianSuite -> String+suitePin s = prefix s ++ showSuite s+  where+	prefix (Stable _) = "n="+	prefix _ = "a="++suitePinBlock :: AptPackagePref -> DebianSuite -> PinPriority -> [Line]+suitePinBlock p suite pin =+	[ "Explanation: This file added by propellor"+	, "Package: " ++ p+	, "Pin: release " ++ suitePin suite+	, "Pin-Priority: " ++ show pin+	]  dpkgStatus :: FilePath dpkgStatus = "/var/lib/dpkg/status"

@@ -93,6 +93,7 @@ 	buildchroot (Debootstrapped cf) system loc = case system of 		(Just s@(System (Debian _ _) _)) -> Right $ debootstrap s 		(Just s@(System (Buntish _) _)) -> Right $ debootstrap s+		(Just (System ArchLinux _)) -> Left "Arch Linux not supported by debootstrap." 		(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap." 		Nothing -> Left "Cannot debootstrap; OS not specified" 	  where

@@ -96,6 +96,7 @@ extractSuite :: System -> Maybe String extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s extractSuite (System (Buntish r) _) = Just r+extractSuite (System (ArchLinux) _) = Nothing extractSuite (System (FreeBSD _) _) = Nothing  -- | Ensures debootstrap is installed.@@ -148,7 +149,7 @@ 		. filter ("debootstrap_" `isInfixOf`) 		. filter (".tar." `isInfixOf`) 		. extractUrls baseurl <$>-		readFileStrictAnyEncoding indexfile+		readFileStrict indexfile 	nukeFile indexfile  	tarfile <- case urls of

@@ -81,16 +81,16 @@ -- chroot while the disk image is being built, which should prevent any -- daemons that are included from being started on the system that is -- building the disk image.-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt = imageBuilt' False  -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed.-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt' rebuild img mkchroot tabletype final partspec = 	imageBuiltFrom img chrootdir tabletype final partspec 		`requires` Chroot.provisioned chroot@@ -124,7 +124,7 @@ 	skipit = doNothing :: Property UnixLike  -- | Builds a disk image from the contents of a chroot.-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) UnixLike imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg   where 	desc = img ++ " built from " ++ chrootdir@@ -150,7 +150,7 @@ 		imageFinalized final mnts mntopts devs parttable 	rmimg = File.notPresent img -partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> 	mconcat $ zipWith3 (go w) mnts mntopts devs   where

@@ -55,6 +55,7 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cmd as Cmd+import qualified Propellor.Property.Pacman as Pacman import qualified Propellor.Shim as Shim import Utility.Path import Utility.ThreadScheduler@@ -68,8 +69,8 @@ import qualified Data.Map as M import System.Console.Concurrent -installed :: Property DebianLike-installed = Apt.installed ["docker.io"]+installed :: Property (DebianLike + ArchLinux)+installed = Apt.installed ["docker.io"] `pickOS` Pacman.installed ["docker"]  -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional.

@@ -6,8 +6,10 @@ import Utility.FileMode  import qualified Data.ByteString.Lazy as L+import Data.List (isInfixOf, isPrefixOf) import System.Posix.Files import System.Exit+import Data.Char  type Line = String @@ -21,11 +23,33 @@ containsLine :: FilePath -> Line -> Property UnixLike f `containsLine` l = f `containsLines` [l] +-- | Ensures that a list of lines are present in a file, adding any that are not+-- to the end of the file.+--+-- Note that this property does not guarantee that the lines will appear+-- consecutively, nor in the order specified.  If you need either of these, use+-- 'File.containsBlock'. containsLines :: FilePath -> [Line] -> Property UnixLike f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f   where 	go content = content ++ filter (`notElem` content) ls +-- | Ensures that a block of consecutive lines is present in a file, adding it+-- to the end if not.  Revert to ensure that the block is not present (though+-- the lines it contains could be present, non-consecutively).+containsBlock :: FilePath -> [Line] -> RevertableProperty UnixLike UnixLike+f `containsBlock` ls =+	fileProperty (f ++ " contains block:" ++ show ls) add f+	<!> fileProperty (f ++ " lacks block:" ++ show ls) remove f+  where+	add content+		| ls `isInfixOf` content = content+		| otherwise              = content ++ ls+	remove [] = []+	remove content@(x:xs)+		| ls `isPrefixOf` content = remove (drop (length ls) content)+		| otherwise = x : remove xs+ -- | Ensures that a line is not present in a file. -- Note that the file is ensured to exist, so if it doesn't, an empty -- file will be written.@@ -221,3 +245,42 @@ 	go tmpfile = do 		a tmpfile 		liftIO $ rename tmpfile f++-- | Generates a base configuration file name from a String, which+-- can be put in a configuration directory, such as+-- </etc/apt/sources.list.d/>+--+-- The generated file name is limited to using ASCII alphanumerics,+-- \'_\' and \'.\' , so that programs that only accept a limited set of+-- characters will accept it. Any other characters will be encoded+-- in escaped form.+--+-- Some file extensions, such as ".old" may be filtered out by+-- programs that use configuration directories. To avoid such problems,+-- it's a good idea to add an static prefix and extension to the +-- result of this function. For example:+--+-- > aptConf foo = "/etc/apt/apt.conf.d" </> "propellor_" ++ configFileName foo <.> ".conf"+configFileName :: String -> FilePath+configFileName = concatMap escape+  where+	escape c+		| isAscii c && isAlphaNum c = [c]+		| c == '.' = [c]+		| otherwise = '_' : show (ord c)++-- | Applies configFileName to any value that can be shown.+showConfigFileName :: Show v => v -> FilePath+showConfigFileName = configFileName . show++-- | Inverse of showConfigFileName.+readConfigFileName :: Read v => FilePath -> Maybe v+readConfigFileName = readish . unescape+  where+	unescape [] = []+	unescape ('_':cs) = case break (not . isDigit) cs of+		([], _) -> '_' : unescape cs+		(ns, cs') -> case readish ns of+			Nothing -> '_' : ns ++ unescape cs'+			Just n -> chr n : unescape cs'+	unescape (c:cs) = c : unescape cs

@@ -2,7 +2,6 @@  import Propellor.Base import qualified Propellor.Property.Apt as Apt-import Utility.FileSystemEncoding  import System.PosixCompat @@ -35,7 +34,6 @@ 				( return NoChange 				, makeChange $ withHandle StdinHandle createProcessSuccess 					(proc "su" ["-c", "gpg --import", u]) $ \h -> do-						fileEncoding h 						hPutStr h (unlines keylines) 						hClose h 				)

@@ -64,7 +64,7 @@ -- > & User.accountFor "joey" -- > & User.hasSomePassword "joey" -- > -- rest of system properties here-cleanInstallOnce :: Confirmation -> Property Linux+cleanInstallOnce :: Confirmation -> Property DebianLike cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ 	go `requires` confirmed "clean install confirmed" confirmation   where

@@ -0,0 +1,68 @@+-- | Maintainer: Zihao Wang <dev@wzhd.org>+--+-- Support for the Pacman package manager <https://www.archlinux.org/pacman/>++module Propellor.Property.Pacman where++import Propellor.Base++runPacman :: [String] -> UncheckedProperty ArchLinux+runPacman ps = tightenTargets $ cmdProperty "pacman" ps++-- | Have pacman update its lists of packages, but without upgrading anything.+update :: Property ArchLinux+update =  combineProperties ("pacman update") $ props+	& runPacman ["-Sy", "--noconfirm"]+		`assume` MadeChange++upgrade :: Property ArchLinux+upgrade = combineProperties ("pacman upgrade") $ props+	& runPacman ["-Syu", "--noconfirm"]+		`assume` MadeChange++type Package = String++installed :: [Package] -> Property ArchLinux+installed = installed' ["--noconfirm"]++installed' :: [String] -> [Package] -> Property ArchLinux+installed' params ps = check (not <$> isInstalled' ps) go+	`describe` unwords ("pacman installed":ps)+  where+	go = runPacman (params ++ ["-S"] ++ ps)++removed :: [Package] -> Property ArchLinux+removed ps = check (any (== IsInstalled) <$> getInstallStatus ps)+	(runPacman (["-R", "--noconfirm"] ++ ps))+	`describe` unwords ("pacman removed":ps)++isInstalled :: Package -> IO Bool+isInstalled p = isInstalled' [p]++isInstalled' :: [Package] -> IO Bool+isInstalled' ps = all (== IsInstalled) <$> getInstallStatus ps++data InstallStatus = IsInstalled | NotInstalled+	deriving (Show, Eq)++{- Returns the InstallStatus of packages that are installed+ - or known and not installed. If a package is not known at all to apt+ - or dpkg, it is not included in the list. -}+getInstallStatus :: [Package] -> IO [InstallStatus]+getInstallStatus ps = mapMaybe id <$> mapM status ps+  where+	status :: Package -> IO (Maybe InstallStatus)+	status p = do+	  ifM (succeeds "pacman" ["-Q", p])+	    (return (Just IsInstalled),+	      ifM (succeeds "pacman" ["-Sp", p])+	        (return (Just NotInstalled),+	         return Nothing))++succeeds :: String -> [String] -> IO Bool+succeeds cmd args = (quietProcess >> return True)+	`catchIO` (\_ -> return False)+  where+	quietProcess :: IO ()+	quietProcess = withQuietOutput createProcessSuccess p+	p = (proc cmd args)

@@ -23,6 +23,7 @@  import Propellor.Base import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Pacman as Pacman import qualified Propellor.Property.Partition as Partition import Utility.DataUnits import Data.Char@@ -192,12 +193,12 @@ -- -- Parted is run in script mode, so it will never prompt for input. -- It is asked to use cylinder alignment for the disk.-parted :: Eep -> FilePath -> [String] -> Property DebianLike+parted :: Eep -> FilePath -> [String] -> Property (DebianLike + ArchLinux) parted YesReallyDeleteDiskContents disk ps = p `requires` installed   where 	p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) 		`assume` MadeChange  -- | Gets parted installed.-installed :: Property DebianLike-installed = Apt.installed ["parted"]+installed :: Property (DebianLike + ArchLinux)+installed = Apt.installed ["parted"] `pickOS` Pacman.installed ["parted"]

@@ -59,7 +59,7 @@ -- See 'Propellor.Property.HostingProvider.DigitalOcean' -- for an example of how to do this. toDistroKernel :: Property DebianLike-toDistroKernel = check (not <$> runningInstalledKernel) now+toDistroKernel = tightenTargets $ check (not <$> runningInstalledKernel) now 	`describe` "running installed kernel"  -- | Given a kernel version string @v@, reboots immediately if the running

@@ -2,6 +2,7 @@  import Propellor.Base import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Pacman as Pacman  type Src = FilePath type Dest = FilePath@@ -16,7 +17,7 @@  -- | Ensures that the Dest directory exists and has identical contents as -- the Src directory.-syncDir :: Src -> Dest -> Property DebianLike+syncDir :: Src -> Dest -> Property (DebianLike + ArchLinux) syncDir = syncDirFiltered []  data Filter @@ -43,7 +44,7 @@ -- Rsync checks each name to be transferred against its list of Filter -- rules, and the first matching one is acted on. If no matching rule -- is found, the file is processed.-syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike+syncDirFiltered :: [Filter] -> Src -> Dest -> Property (DebianLike + ArchLinux) syncDirFiltered filters src dest = rsync $ 	[ "-av" 	-- Add trailing '/' to get rsync to sync the Dest directory,@@ -56,7 +57,7 @@ 	, "--quiet" 	] ++ map toRsync filters -rsync :: [String] -> Property DebianLike+rsync :: [String] -> Property (DebianLike + ArchLinux) rsync ps = cmdProperty "rsync" ps 	`assume` MadeChange-	`requires` Apt.installed ["rsync"]+	`requires` Apt.installed ["rsync"] `pickOS` Pacman.installed ["rsync"]

@@ -78,7 +78,8 @@ 		`onChange` Ssh.restarted 	& User.shellSetTo (User "scroll") s 	& User.hasPassword (User "scroll")-	& Apt.serviceInstalledRunning "telnetd"+	-- telnetd attracted password crackers, so disabled+	& Apt.removed ["telnetd"] 	& Apt.installed ["shellinabox"] 	& File.hasContent "/etc/default/shellinabox" 		[ "# Deployed by propellor"@@ -369,7 +370,7 @@ -- (Obsolete; need to revert this.) pumpRss :: Property DebianLike pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.joeyh.name/"-	"wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"+	"wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"  ircBouncer :: Property (HasInfo + DebianLike) ircBouncer = propertyList "IRC bouncer" $ props@@ -891,7 +892,7 @@ -- <http://joeyh.name/blog/entry/a_programmable_alarm_clock_using_systemd/> -- -- oncalendar example value: "*-*-* 7:30"-alarmClock :: String -> User -> String -> Property DebianLike+alarmClock :: String -> User -> String -> Property Linux alarmClock oncalendar (User user) command = combineProperties "goodmorning timer installed" $ props 	& "/etc/systemd/system/goodmorning.timer" `File.hasContent` 		[ "[Unit]"

@@ -124,22 +124,30 @@ -- If used without `hiddenServiceData`, tor will generate a new -- private key. hiddenService :: HiddenServiceName -> Port -> Property DebianLike-hiddenService hn (Port port) = ConfFile.adjustSection-	(unwords ["hidden service", hn, "available on port", show port])+hiddenService hn port = hiddenService' hn [port]++hiddenService' :: HiddenServiceName -> [Port] -> Property DebianLike+hiddenService' hn ports = ConfFile.adjustSection+	(unwords ["hidden service", hn, "available on ports", intercalate "," (map show ports')]) 	(== oniondir) 	(not . isPrefixOf "HiddenServicePort")-	(const [oniondir, onionport])-	(++ [oniondir, onionport])+	(const (oniondir : onionports))+	(++ oniondir : onionports) 	mainConfig 	`onChange` restarted   where 	oniondir = unwords ["HiddenServiceDir", varLib </> hn]-	onionport = unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]+	onionports = map onionport ports'+	ports' = sort ports+	onionport port = unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]  -- | Same as `hiddenService` but also causes propellor to display -- the onion address of the hidden service. hiddenServiceAvailable :: HiddenServiceName -> Port -> Property DebianLike-hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port+hiddenServiceAvailable hn port = hiddenServiceAvailable' hn [port]++hiddenServiceAvailable' :: HiddenServiceName -> [Port] -> Property DebianLike+hiddenServiceAvailable' hn ports = hiddenServiceHostName $ hiddenService' hn ports   where 	hiddenServiceHostName p =  adjustPropertySatisfy p $ \satisfy -> do 		r <- satisfy

@@ -43,7 +43,7 @@ 		]  -- | Removes user home directory!! Use with caution.-nuked :: User -> Eep -> Property DebianLike+nuked :: User -> Eep -> Property Linux nuked user@(User u) _ = tightenTargets $ check hashomedir go 	`describe` ("nuked user " ++ u)   where

@@ -9,7 +9,6 @@ import Propellor.Base import Utility.LinuxMkLibs import Utility.FileMode-import Utility.FileSystemEncoding  import Data.List import System.Posix.Files@@ -57,7 +56,6 @@ checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath checkAlreadyShimmed f nope = ifM (doesFileExist f) 	( withFile f ReadMode $ \h -> do-		fileEncoding h 		s <- hGetLine h 		if s == shebang 			then return f

@@ -24,6 +24,7 @@ 	, DebianLike 	, Debian 	, Buntish+	, ArchLinux 	, FreeBSD 	, HasInfo 	, type (+)

@@ -28,4 +28,5 @@ 	| ChrootChain HostName FilePath Bool Bool 	| GitPush Fd Fd 	| Check+	| Build 	deriving (Read, Show, Eq)

@@ -7,6 +7,7 @@ 	DebianLike, 	Debian, 	Buntish,+	ArchLinux, 	FreeBSD, 	HasInfo, 	MetaTypes,@@ -35,14 +36,26 @@ 	deriving (Show, Eq, Ord)  -- | Any unix-like system-type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ]+type UnixLike = MetaTypes+	'[ 'Targeting 'OSDebian+	, 'Targeting 'OSBuntish+	, 'Targeting 'OSArchLinux+	, 'Targeting 'OSFreeBSD+	]+ -- | Any linux system-type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]+type Linux = MetaTypes+	'[ 'Targeting 'OSDebian+	, 'Targeting 'OSBuntish+	, 'Targeting 'OSArchLinux+	]+ -- | Debian and derivatives. type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] type Debian = MetaTypes '[ 'Targeting 'OSDebian ] type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ] type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ]+type ArchLinux = MetaTypes '[ 'Targeting 'OSArchLinux ]  -- | Used to indicate that a Property adds Info to the Host where it's used. type HasInfo = MetaTypes '[ 'WithInfo ]@@ -58,16 +71,19 @@ 	OSDebianS :: Sing ('Targeting 'OSDebian) 	OSBuntishS :: Sing ('Targeting 'OSBuntish) 	OSFreeBSDS :: Sing ('Targeting 'OSFreeBSD)+	OSArchLinuxS :: Sing ('Targeting 'OSArchLinux) 	WithInfoS :: Sing 'WithInfo instance SingI ('Targeting 'OSDebian) where sing = OSDebianS instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS+instance SingI ('Targeting 'OSArchLinux) where sing = OSArchLinuxS instance SingI 'WithInfo where sing = WithInfoS instance SingKind ('KProxy :: KProxy MetaType) where 	type DemoteRep ('KProxy :: KProxy MetaType) = MetaType 	fromSing OSDebianS = Targeting OSDebian 	fromSing OSBuntishS = Targeting OSBuntish 	fromSing OSFreeBSDS = Targeting OSFreeBSD+	fromSing OSArchLinuxS = Targeting OSArchLinux 	fromSing WithInfoS = WithInfo  -- | Convenience type operator to combine two `MetaTypes` lists.@@ -186,6 +202,14 @@ type instance EqT 'OSBuntish 'OSFreeBSD = 'False type instance EqT 'OSFreeBSD 'OSDebian  = 'False type instance EqT 'OSFreeBSD 'OSBuntish = 'False+type instance EqT 'OSArchLinux 'OSArchLinux = 'True+type instance EqT 'OSArchLinux 'OSDebian    = 'False+type instance EqT 'OSArchLinux 'OSBuntish   = 'False+type instance EqT 'OSArchLinux 'OSFreeBSD   = 'False+type instance EqT 'OSDebian    'OSArchLinux = 'False+type instance EqT 'OSBuntish   'OSArchLinux = 'False+type instance EqT 'OSFreeBSD   'OSArchLinux = 'False+ -- More modern version if the combinatiorial explosion gets too bad later: -- -- type family Eq (a :: MetaType) (b :: MetaType) where

@@ -33,6 +33,7 @@ data Distribution 	= Debian DebianKernel DebianSuite 	| Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per <http://joeyh.name/blog/entry/trademark_nonsense/>+	| ArchLinux 	| FreeBSD FreeBSDRelease 	deriving (Show, Eq) @@ -41,12 +42,14 @@ data TargetOS 	= OSDebian 	| OSBuntish+	| OSArchLinux 	| OSFreeBSD 	deriving (Show, Eq, Ord)  systemToTargetOS :: System -> TargetOS systemToTargetOS (System (Debian _ _) _) = OSDebian systemToTargetOS (System (Buntish _) _) = OSBuntish+systemToTargetOS (System (ArchLinux) _) = OSArchLinux systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD  -- | Most of Debian ports are based on Linux. There also exist hurd-i386,@@ -143,7 +146,7 @@ userGroup (User u) = Group u  newtype Port = Port Int-	deriving (Eq, Show)+	deriving (Eq, Ord, Show)  fromPort :: Port -> String fromPort (Port p) = show p

@@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2015 Joey Hess <id@joeyh.name>+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -10,6 +10,7 @@  module Utility.Exception ( 	module X,+	giveup, 	catchBoolIO, 	catchMaybeIO, 	catchDefaultIO,@@ -28,9 +29,11 @@ import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException)-#if MIN_VERSION_base(4,7,0)+#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)@@ -38,6 +41,21 @@  import Utility.Data +{- Like error, this throws an exception. Unlike error, if this exception+ - is not caught, it won't generate a backtrace. So use this for situations+ - 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 catchBoolIO = catchDefaultIO False@@ -77,8 +95,10 @@ catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` 	[ M.Handler (\ (e :: AsyncException) -> throwM e)-#if MIN_VERSION_base(4,7,0)+#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) 	]

@@ -1,6 +1,6 @@ {- GHC File system encoding handling.  -- - Copyright 2012-2014 Joey Hess <id@joeyh.name>+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -9,7 +9,7 @@ {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.FileSystemEncoding (-	fileEncoding,+	useFileSystemEncoding, 	withFilePath, 	md5FilePath, 	decodeBS,@@ -19,7 +19,6 @@ 	encodeW8NUL, 	decodeW8NUL, 	truncateFilePath,-	setConsoleEncoding, ) where  import qualified GHC.Foreign as GHC@@ -39,19 +38,30 @@  import Utility.Exception -{- Sets a Handle to use the filesystem encoding. This causes data- - written or read from it to be encoded/decoded the same- - as ghc 7.4 does to filenames etc. This special encoding- - allows "arbitrary undecodable bytes to be round-tripped through it".+{- Makes all subsequent Handles that are opened, as well as stdio Handles,+ - use the filesystem encoding, instead of the encoding of the current+ - locale.+ -+ - The filesystem encoding allows "arbitrary undecodable bytes to be+ - round-tripped through it". This avoids encoded failures when data is not+ - encoded matching the current locale.+ -+ - Note that code can still use hSetEncoding to change the encoding of a+ - Handle. This only affects the default encoding.  -}-fileEncoding :: Handle -> IO ()+useFileSystemEncoding :: IO ()+useFileSystemEncoding = do #ifndef mingw32_HOST_OS-fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding+	e <- Encoding.getFileSystemEncoding #else-{- The file system encoding does not work well on Windows,- - and Windows only has utf FilePaths anyway. -}-fileEncoding h = hSetEncoding h Encoding.utf8+	{- The file system encoding does not work well on Windows,+	 - and Windows only has utf FilePaths anyway. -}+	let e = Encoding.utf8 #endif+	hSetEncoding stdin e+	hSetEncoding stdout e+	hSetEncoding stderr e+	Encoding.setLocaleEncoding e	  {- Marshal a Haskell FilePath into a NUL terminated C string using temporary  - storage. The FilePath is encoded using the filesystem encoding,@@ -165,10 +175,3 @@ 					else go (c:coll) (cnt - x') (L8.drop 1 bs) 			_ -> coll #endif--{- This avoids ghc's output layer crashing on invalid encoded characters in- - filenames when printing them out. -}-setConsoleEncoding :: IO ()-setConsoleEncoding = do-	fileEncoding stdout-	fileEncoding stderr

@@ -10,9 +10,6 @@  module Utility.Misc where -import Utility.FileSystemEncoding-import Utility.Monad- import System.IO import Control.Monad import Foreign@@ -34,20 +31,6 @@ {- A version of readFile that is not lazy. -} readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s--{-  Reads a file strictly, and using the FileSystemEncoding, so it will- -  never crash on a badly encoded file. -}-readFileStrictAnyEncoding :: FilePath -> IO String-readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do-	fileEncoding h-	hClose h `after` hGetContentsStrict h--{- Writes a file, using the FileSystemEncoding so it will never crash- - on a badly encoded content string. -}-writeFileAnyEncoding :: FilePath -> String -> IO ()-writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do-	fileEncoding h-	hPutStr h content  {- Like break, but the item matching the condition is not included  - in the second result list.

@@ -13,4 +13,4 @@ 	module System.Directory ) where -import System.Directory hiding (isSymbolicLink)+import System.Directory hiding (isSymbolicLink, getFileSize)

@@ -15,6 +15,8 @@ ) where  import Utility.Env+import Utility.Data+import Utility.Exception  import System.PosixCompat import Control.Applicative@@ -24,7 +26,7 @@  -  - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath-myHomeDir = myVal env homeDirectory+myHomeDir = either giveup return =<< myVal env homeDirectory   where #ifndef mingw32_HOST_OS 	env = ["HOME"]@@ -33,7 +35,7 @@ #endif  {- Current user's user name. -}-myUserName :: IO String+myUserName :: IO (Either String String) myUserName = myVal env userName   where #ifndef mingw32_HOST_OS@@ -47,15 +49,15 @@ #if defined(__ANDROID__) || defined(mingw32_HOST_OS) myUserGecos = return Nothing #else-myUserGecos = Just <$> myVal [] userGecos+myUserGecos = eitherToMaybe <$> myVal [] userGecos #endif -myVal :: [String] -> (UserEntry -> String) -> IO String+myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars   where #ifndef mingw32_HOST_OS-	go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)+	go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID) #else-	go [] = extract <$> error ("environment not set: " ++ show envvars)+	go [] = return $ Left ("environment not set: " ++ show envvars) #endif-	go (v:vs) = maybe (go vs) return =<< getEnv v+	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v

@@ -20,6 +20,7 @@ import Utility.FileMode import Utility.Process import Utility.Process.NonConcurrent+import Utility.FileSystemEncoding  import System.Environment (getArgs) import System.Exit@@ -30,7 +31,9 @@ import Prelude  main :: IO ()-main = withConcurrentOutput $ go =<< getArgs+main = withConcurrentOutput $ do+	useFileSystemEncoding+	go =<< getArgs   where 	go ["--init"] = interactiveInit 	go args = ifM configInCurrentWorkingDirectory

@@ -1,4 +1,4 @@ # When updating the resolver here, also update stackResolver in Propellor.DotDir-resolver: lts-5.10+resolver: lts-7.16 packages: - '.'