diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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. diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -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 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. diff --git a/joeyconfig.hs b/joeyconfig.hs --- a/joeyconfig.hs +++ b/joeyconfig.hs @@ -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" diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 3.2.3 +Version: 3.3.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess @@ -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 diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -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 diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -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 diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs --- a/src/Propellor/DotDir.hs +++ b/src/Propellor/DotDir.hs @@ -316,7 +316,7 @@ ] stackResolver :: String -stackResolver = "lts-5.10" +stackResolver = "lts-7.16" fullClone :: IO Result fullClone = do diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -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 diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -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) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -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 diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -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, diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -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" diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -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 diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -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 diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -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 diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -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. diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -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 +-- +-- +-- 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 diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs --- a/src/Propellor/Property/Gpg.hs +++ b/src/Propellor/Property/Gpg.hs @@ -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 ) diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -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 diff --git a/src/Propellor/Property/Pacman.hs b/src/Propellor/Property/Pacman.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Pacman.hs @@ -0,0 +1,68 @@ +-- | Maintainer: Zihao Wang +-- +-- Support for the Pacman package manager + +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) diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -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"] diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs --- a/src/Propellor/Property/Reboot.hs +++ b/src/Propellor/Property/Reboot.hs @@ -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 diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs --- a/src/Propellor/Property/Rsync.hs +++ b/src/Propellor/Property/Rsync.hs @@ -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"] diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -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 @@ -- -- -- 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]" diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs --- a/src/Propellor/Property/Tor.hs +++ b/src/Propellor/Property/Tor.hs @@ -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 diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -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 diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -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 diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -24,6 +24,7 @@ , DebianLike , Debian , Buntish + , ArchLinux , FreeBSD , HasInfo , type (+) diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs --- a/src/Propellor/Types/CmdLine.hs +++ b/src/Propellor/Types/CmdLine.hs @@ -28,4 +28,5 @@ | ChrootChain HostName FilePath Bool Bool | GitPush Fd Fd | Check + | Build deriving (Read, Show, Eq) diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -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 diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -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 + | 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 diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs --- a/src/Utility/Exception.hs +++ b/src/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2016 Joey Hess - - 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) ] diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2016 Joey Hess - - 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 diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs --- a/src/Utility/Misc.hs +++ b/src/Utility/Misc.hs @@ -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. diff --git a/src/Utility/SystemDirectory.hs b/src/Utility/SystemDirectory.hs --- a/src/Utility/SystemDirectory.hs +++ b/src/Utility/SystemDirectory.hs @@ -13,4 +13,4 @@ module System.Directory ) where -import System.Directory hiding (isSymbolicLink) +import System.Directory hiding (isSymbolicLink, getFileSize) diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -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 diff --git a/src/wrapper.hs b/src/wrapper.hs --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ # When updating the resolver here, also update stackResolver in Propellor.DotDir -resolver: lts-5.10 +resolver: lts-7.16 packages: - '.'