diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,32 @@ +propellor (4.1.0) unstable; urgency=medium + + * User.hasInsecurePassword makes sure shadow passwords are enabled, + so if the insecure password is later changed, the new password won't be + exposed. + * Bugfix: Apache.httpsVirtualHost' must create ssl/hn/ dir earlier + Thanks, Sean Whitton. + * Bootstrap.clonedFrom: Fix bug that broke copying .git/config into + chroot. + * Diskimage.imageExists: Align disk image size to multiple of 4096 + sector size, since some programs (such as VBoxManage convertdd) + refuse to operate on disk images not aligned to a sector size. + * Bootstrap.bootstrappedFrom: Fix bug that caused propellor to only + be built from the bootstrapped config the first time. + * Bootstrap.bootstrappedFrom: Avoid doing anything when not run in a + chroot. + * When provisioning a container, output was buffered until the whole + process was done; now output will be displayed immediately. + * LightDM.autoLogin: Make it require LightDM.installed. + (minor API change as the type changed) + * Propellor.Property.XFCE added with some useful properties for the + desktop environment. + * Added File.applyPath property. + * Added File.checkOverwrite. + * File.isCopyOf: Fix bug that prevented this property from working + when the destination file did not yet exist. + + -- Joey Hess Wed, 05 Jul 2017 17:30:00 -0400 + propellor (4.0.6) unstable; urgency=medium * Fix bug that sometimes made --spin fail with diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,32 @@ +propellor (4.1.0) unstable; urgency=medium + + * User.hasInsecurePassword makes sure shadow passwords are enabled, + so if the insecure password is later changed, the new password won't be + exposed. + * Bugfix: Apache.httpsVirtualHost' must create ssl/hn/ dir earlier + Thanks, Sean Whitton. + * Bootstrap.clonedFrom: Fix bug that broke copying .git/config into + chroot. + * Diskimage.imageExists: Align disk image size to multiple of 4096 + sector size, since some programs (such as VBoxManage convertdd) + refuse to operate on disk images not aligned to a sector size. + * Bootstrap.bootstrappedFrom: Fix bug that caused propellor to only + be built from the bootstrapped config the first time. + * Bootstrap.bootstrappedFrom: Avoid doing anything when not run in a + chroot. + * When provisioning a container, output was buffered until the whole + process was done; now output will be displayed immediately. + * LightDM.autoLogin: Make it require LightDM.installed. + (minor API change as the type changed) + * Propellor.Property.XFCE added with some useful properties for the + desktop environment. + * Added File.applyPath property. + * Added File.checkOverwrite. + * File.isCopyOf: Fix bug that prevented this property from working + when the destination file did not yet exist. + + -- Joey Hess Wed, 05 Jul 2017 17:30:00 -0400 + propellor (4.0.6) unstable; urgency=medium * Fix bug that sometimes made --spin fail with diff --git a/joeyconfig.hs b/joeyconfig.hs --- a/joeyconfig.hs +++ b/joeyconfig.hs @@ -21,6 +21,8 @@ import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.LetsEncrypt as LetsEncrypt +import qualified Propellor.Property.LightDM as LightDM +import qualified Propellor.Property.XFCE as XFCE import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Gpg as Gpg @@ -47,6 +49,7 @@ hosts :: [Host] -- * \ | | '--------' hosts = -- (o) ` [ darkstar + , demo , gnu , dragon , clam @@ -88,26 +91,40 @@ & JoeySites.dkimMilter & JoeySites.postfixSaslPasswordClient - & JoeySites.alarmClock "*-*-* 7:30" (User "joey") - "/usr/bin/timeout 45m /home/joey/bin/goodmorning" + -- & JoeySites.alarmClock "*-*-* 7:30" (User "joey") + -- "/usr/bin/timeout 45m /home/joey/bin/goodmorning" & Ssh.userKeys (User "joey") hostContext [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar") ] - & imageBuilt "/srv/propellor-disk.img" c MSDOS (grubBooted PC) + & imageBuilt "/srv/propellor-disk.img" + (Chroot.hostChroot demo (Chroot.Debootstrapped mempty)) + MSDOS (grubBooted PC) [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag , partition EXT4 `mountedAt` "/" `mountOpt` errorReadonly + `addFreeSpace` MegaBytes 256 , swapPartition (MegaBytes 256) ] + `before` File.ownerGroup "/srv/propellor-disk.img" (User "joey") (Group "joey") + +demo :: Host +demo = host "demo" $ props + & osDebian Unstable X86_64 + & Apt.installed ["linux-image-amd64"] + & bootstrappedFrom GitRepoOutsideChroot + & User.accountFor user + & root `User.hasInsecurePassword` "debian" + & user `User.hasInsecurePassword` "debian" + & XFCE.installedMin + & XFCE.networkManager + & XFCE.defaultPanelFor user File.OverwriteExisting + & LightDM.autoLogin user + & Apt.installed ["firefox"] where - c d = Chroot.debootstrapped mempty d $ props - & osDebian Unstable X86_64 - & Hostname.setTo "demo" - & Apt.installed ["linux-image-amd64"] - & User "root" `User.hasInsecurePassword` "root" - & bootstrappedFrom GitRepoOutsideChroot + user = User "user" + root = User "root" gnu :: Host gnu = host "gnu.kitenet.net" $ props @@ -323,6 +340,7 @@ & alias "ns4.kitenet.net" & myDnsPrimary True "kitenet.net" [ (RelDomain "mouse-onion", CNAME $ AbsDomain "htieo6yu2qtcn2j3.onion") + , (RelDomain "beaver-onion", CNAME $ AbsDomain "tl4xsvaxryjylgxs.onion") ] & myDnsPrimary True "joeyh.name" [] & myDnsPrimary True "ikiwiki.info" [] @@ -412,9 +430,10 @@ beaver :: Host beaver = host "beaver.kitenet.net" $ props & ipv6 "2001:4830:1600:195::2" - & Apt.serviceInstalledRunning "aiccu" & Apt.installed ["ssh"] & Ssh.hostPubKey SshDsa "ssh-dss AAAAB3NzaC1kc3MAAACBAIrLX260fY0Jjj/p0syNhX8OyR8hcr6feDPGOj87bMad0k/w/taDSOzpXe0Wet7rvUTbxUjH+Q5wPd4R9zkaSDiR/tCb45OdG6JsaIkmqncwe8yrU+pqSRCxttwbcFe+UU+4AAcinjVedZjVRDj2rRaFPc9BXkPt7ffk8GwEJ31/AAAAFQCG/gOjObsr86vvldUZHCteaJttNQAAAIB5nomvcqOk/TD07DLaWKyG7gAcW5WnfY3WtnvLRAFk09aq1EuiJ6Yba99Zkb+bsxXv89FWjWDg/Z3Psa22JMyi0HEDVsOevy/1sEQ96AGH5ijLzFInfXAM7gaJKXASD7hPbVdjySbgRCdwu0dzmQWHtH+8i1CMVmA2/a5Y/wtlJAAAAIAUZj2US2D378jBwyX1Py7e4sJfea3WSGYZjn4DLlsLGsB88POuh32aOChd1yzF6r6C2sdoPBHQcWBgNGXcx4gF0B5UmyVHg3lIX2NVSG1ZmfuLNJs9iKNu4cHXUmqBbwFYQJBvB69EEtrOw4jSbiTKwHFmqdA/mw1VsMB+khUaVw==" + & Tor.installed + & Tor.hiddenServiceAvailable "ssh" (Port 22) & alias "usbackup.kitenet.net" & JoeySites.backupsBackedupFrom hosts "eubackup.kitenet.net" "/home/joey/lib/backup" & Apt.serviceInstalledRunning "anacron" @@ -521,7 +540,7 @@ -- and administrative sanity. openidProvider :: Systemd.Container openidProvider = Systemd.debContainer "openid-provider" $ props - & standardContainer (Stable "jessie") + & standardContainer (Stable "stretch") & alias hn & OpenId.providerFor [User "joey", User "liw"] hn (Just (Port 8081)) where @@ -530,7 +549,7 @@ -- Exhibit: kite's 90's website on port 1994. ancientKitenet :: Systemd.Container ancientKitenet = Systemd.debContainer "ancient-kitenet" $ props - & standardContainer (Stable "jessie") + & standardContainer (Stable "stretch") & alias hn & Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www/html" (Just "remotes/origin/old-kitenet.net") @@ -544,7 +563,7 @@ oldusenetShellBox :: Systemd.Container oldusenetShellBox = Systemd.debContainer "oldusenet-shellbox" $ props - & standardContainer (Stable "jessie") + & standardContainer (Stable "stretch") & alias "shell.olduse.net" & JoeySites.oldUseNetShellBox diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 4.0.6 +Version: 4.1.0 Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess @@ -153,6 +153,7 @@ Propellor.Property.Unbound Propellor.Property.User Propellor.Property.Uwsgi + Propellor.Property.XFCE Propellor.Property.ZFS Propellor.Property.ZFS.Process Propellor.Property.ZFS.Properties diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -3,6 +3,8 @@ checkBinaryCommand, installGitCommand, buildPropellor, + checkDepsCommand, + buildCommand, ) where import Propellor.Base diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -8,6 +8,8 @@ fromHost, fromHost', onlyProcess, + chainPropellor, + runChainPropellor, ) where import System.Exit @@ -17,7 +19,9 @@ import System.PosixCompat import System.Posix.IO import System.FilePath +import System.Console.Concurrent import Control.Applicative +import Control.Concurrent.Async import Prelude import Propellor.Types @@ -28,6 +32,8 @@ import Propellor.Info import Utility.Exception import Utility.Directory +import Utility.Process +import Utility.PartialPrelude -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. @@ -96,3 +102,53 @@ return l unlock = closeFd alreadyrunning = error "Propellor is already running on this host!" + +-- | Chains to a propellor sub-Process, forwarding its output on to the +-- display, except for the last line which is a Result. +chainPropellor :: CreateProcess -> IO Result +chainPropellor p = + -- We want to use outputConcurrent to display output + -- as it's received. If only stdout were captured, + -- concurrent-output would buffer all outputConcurrent. + -- Also capturing stderr avoids that problem. + withOEHandles createProcessSuccess p $ \(outh, errh) -> do + (r, ()) <- processChainOutput outh + `concurrently` forwardChainError errh + return r + +-- | Reads and displays each line from the Handle, except for the last line +-- which is a Result. +processChainOutput :: Handle -> IO Result +processChainOutput h = go Nothing + where + go lastline = do + v <- catchMaybeIO (hGetLine h) + case v of + Nothing -> case lastline of + Nothing -> do + return FailedChange + Just l -> case readish l of + Just r -> pure r + Nothing -> do + outputConcurrent (l ++ "\n") + return FailedChange + Just s -> do + outputConcurrent $ + maybe "" (\l -> if null l then "" else l ++ "\n") lastline + go (Just s) + +forwardChainError :: Handle -> IO () +forwardChainError h = do + v <- catchMaybeIO (hGetLine h) + case v of + Nothing -> return () + Just s -> do + errorConcurrent (s ++ "\n") + forwardChainError h + +-- | Used by propellor sub-Processes that are run by chainPropellor. +runChainPropellor :: Host -> Propellor Result -> IO () +runChainPropellor h a = do + r <- runPropellor h a + flushConcurrentOutput + putStrLn $ "\n" ++ show r diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -14,7 +14,6 @@ infoMessage, errorMessage, stopPropellorMessage, - processChainOutput, messagesDone, createProcessConcurrent, withConcurrentOutput, @@ -31,7 +30,6 @@ import Propellor.Types import Propellor.Types.Exception -import Utility.PartialPrelude import Utility.Monad import Utility.Exception @@ -141,27 +139,6 @@ -- the color set and reset happen in the same line. , pure "\n" ] - --- | Reads and displays each line from the Handle, except for the last line --- which is a Result. -processChainOutput :: Handle -> IO Result -processChainOutput h = go Nothing - where - go lastline = do - v <- catchMaybeIO (hGetLine h) - case v of - Nothing -> case lastline of - Nothing -> do - return FailedChange - Just l -> case readish l of - Just r -> pure r - Nothing -> do - outputConcurrent (l ++ "\n") - return FailedChange - Just s -> do - outputConcurrent $ - maybe "" (\l -> if null l then "" else l ++ "\n") lastline - go (Just s) -- | Called when all messages about properties have been printed. messagesDone :: IO () diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -50,6 +50,7 @@ import Control.Monad.IfElse import "mtl" Control.Monad.RWS.Strict import System.Posix.Files +import Data.Maybe import Data.List import Data.Hashable import Control.Applicative diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -189,7 +189,7 @@ `requires` modEnabled "ssl" `before` setuphttps teardown = siteDisabled domain - setuphttp = siteEnabled' domain $ + setuphttp = (siteEnabled' domain $ -- The sslconffile is only created after letsencrypt gets -- the cert. The "*" is needed to make apache not error -- when the file doesn't exist. @@ -201,23 +201,23 @@ , "RewriteRule ^/.well-known/(.*) - [L]" -- Everything else redirects to https , "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]" - ] + ]) + `requires` File.dirExists (takeDirectory cf) setuphttps = LetsEncrypt.letsEncrypt letos domain docroot `onChange` postsetuphttps postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props - & File.dirExists (takeDirectory cf) & File.hasContent cf sslvhost `onChange` reloaded -- always reload since the cert has changed & reloaded where - cf = sslconffile "letsencrypt" sslvhost = vhost (Port 443) [ "SSLEngine on" , "SSLCertificateFile " ++ LetsEncrypt.certFile domain , "SSLCertificateKeyFile " ++ LetsEncrypt.privKeyFile domain , "SSLCertificateChainFile " ++ LetsEncrypt.chainFile domain ] + cf = sslconffile "letsencrypt" sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf" vhost p ls = [ "" diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -17,17 +17,17 @@ -- | Bootstraps a propellor installation into -- /usr/local/propellor/ -- --- Normally, propellor is already bootstrapped when it runs, so this --- property is not useful. However, this can be useful inside a --- chroot used to build a disk image, to make the disk image --- have propellor installed. +-- This property only does anything when used inside a chroot. +-- This is particularly useful inside a chroot used to build a +-- disk image, to make the disk image have propellor installed. -- -- The git repository is cloned (or pulled to update if it already exists). -- -- All build dependencies are installed, using distribution packages -- or falling back to using cabal. bootstrappedFrom :: RepoSource -> Property Linux -bootstrappedFrom reposource = go `requires` clonedFrom reposource +bootstrappedFrom reposource = check inChroot $ + go `requires` clonedFrom reposource where go :: Property Linux go = property "Propellor bootstrapped" $ do @@ -35,7 +35,8 @@ assumeChange $ exposeTrueLocaldir $ const $ runShellCommand $ buildShellCommand [ "cd " ++ localdir - , bootstrapPropellorCommand system + , checkDepsCommand system + , buildCommand ] -- | Clones the propellor repeository into /usr/local/propellor/ @@ -83,7 +84,7 @@ -- configuration. copygitconfig :: Property Linux copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do - let gitconfig = localdir <> ".git" <> "config" + let gitconfig = localdir ".git" "config" cfg <- liftIO $ B.readFile gitconfig exposeTrueLocaldir $ const $ liftIO $ B.writeFile gitconfig cfg 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 @@ -37,7 +37,6 @@ import qualified Data.Map as M import System.Posix.Directory -import System.Console.Concurrent -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. @@ -201,9 +200,7 @@ , "--continue" , show cmd ] - let p' = p { env = Just pe } - r <- liftIO $ withHandle StdoutHandle createProcessSuccess p' - processChainOutput + r <- liftIO $ chainPropellor (p { env = Just pe }) liftIO cleanup return r @@ -223,13 +220,12 @@ go h = do changeWorkingDirectory localdir when onconsole forceConsole - onlyProcess (provisioningLock loc) $ do - r <- runPropellor (setInChroot h) $ ensureChildProperties $ - if systemdonly - then [toChildProperty Systemd.installed] - else hostProperties h - flushConcurrentOutput - putStrLn $ "\n" ++ show r + onlyProcess (provisioningLock loc) $ + runChainPropellor (setInChroot h) $ + ensureChildProperties $ + if systemdonly + then [toChildProperty Systemd.installed] + else hostProperties h chain _ _ = errorMessage "bad chain command" inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) 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 @@ -49,7 +49,11 @@ -- First the specified Chroot is set up, and its properties are satisfied. -- -- Then, the disk image is set up, and the chroot is copied into the --- appropriate partition(s) of it. +-- appropriate partition(s) of it. +-- +-- The partitions default to being sized just large enough to fit the files +-- from the chroot. You can use `addFreeSpace` to make them a bit larger +-- than that, or `setSize` to use a fixed size. -- -- Note that the disk image file is reused if it already exists, -- to avoid expensive IO to generate a new one. And, it's updated in-place, @@ -247,7 +251,7 @@ -- -- If the file is too large, truncates it down to the specified size. imageExists :: FilePath -> ByteSize -> Property Linux -imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do +imageExists img isz = property ("disk image exists" ++ img) $ liftIO $ do ms <- catchMaybeIO $ getFileStatus img case ms of Just s @@ -258,6 +262,12 @@ _ -> do L.writeFile img (L.replicate (fromIntegral sz) 0) return MadeChange + where + sz = ceiling (fromInteger isz / sectorsize) * ceiling sectorsize + -- Disks have a sector size, and making a disk image not + -- aligned to a sector size will confuse some programs. + -- Common sector sizes are 512 and 4096; use 4096 as it's larger. + sectorsize = 4096 :: Double -- | A pair of properties. The first property is satisfied within the -- chroot, and is typically used to download the boot loader. 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 @@ -576,8 +576,7 @@ let p = inContainerProcess cid (if isConsole msgh then ["-it"] else []) (shim : params) - r <- withHandle StdoutHandle createProcessSuccess p $ - processChainOutput + r <- chainPropellor p when (r /= FailedChange) $ setProvisionedFlag cid return r @@ -596,10 +595,9 @@ where go cid h = do changeWorkingDirectory localdir - onlyProcess (provisioningLock cid) $ do - r <- runPropellor h $ ensureChildProperties $ hostProperties h - flushConcurrentOutput - putStrLn $ "\n" ++ show r + onlyProcess (provisioningLock cid) $ + runChainPropellor h $ + ensureChildProperties $ hostProperties h stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} module Propellor.Property.File where @@ -105,11 +105,11 @@ -- | Replaces the content of a file with the transformed content of another file basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike -f `basedOn` (f', a) = property' desc $ \o -> do - tmpl <- liftIO $ readFile f' +f `basedOn` (src, a) = property' desc $ \o -> do + tmpl <- liftIO $ readFile src ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f where - desc = f ++ " is based on " ++ f' + desc = f ++ " is based on " ++ src -- | Removes a file. Does not remove symlinks or non-plain-files. notPresent :: FilePath -> Property UnixLike @@ -150,23 +150,26 @@ -- | Ensures that a file is a copy of another (regular) file. isCopyOf :: FilePath -> FilePath -> Property UnixLike -f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f') +f `isCopyOf` src = property desc $ go =<< (liftIO $ tryIO $ getFileStatus src) where - desc = f ++ " is copy of " ++ f' + desc = f ++ " is copy of " ++ src go (Right stat) = if isRegularFile stat - then gocmp =<< (liftIO $ cmp) - else warningMessage (f' ++ " is not a regular file") >> + then ifM (liftIO $ doesFileExist f) + ( gocmp =<< (liftIO $ cmp) + , doit + ) + else warningMessage (src ++ " is not a regular file") >> return FailedChange go (Left e) = warningMessage (show e) >> return FailedChange - cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File f'] + cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File src] gocmp ExitSuccess = noChange gocmp (ExitFailure 1) = doit gocmp _ = warningMessage "cmp failed" >> return FailedChange - doit = makeChange $ copy f' `viaStableTmp` f - copy src dest = unlessM (runcp src dest) $ errorMessage "cp failed" - runcp src dest = boolSystem "cp" + doit = makeChange $ copy `viaStableTmp` f + copy dest = unlessM (runcp dest) $ errorMessage "cp failed" + runcp dest = boolSystem "cp" [Param "--preserve=all", Param "--", File src, File dest] -- | Ensures that a file/dir has the specified owner and group. @@ -177,6 +180,20 @@ `changesFile` f og = owner ++ ":" ++ group +-- | Given a base directory, and a relative path under that +-- directory, applies a property to each component of the path in turn, +-- starting with the base directory. +-- +-- For example, to make a file owned by a user, making sure their home +-- directory and the subdirectories to it are also owned by them: +-- +-- > "/home/user/program/file" `hasContent` ["foo"] +-- > `before` applyPath "/home/user" ".config/program/file" +-- > (\f -> ownerGroup f (User "user") (Group "user")) +applyPath :: Monoid (Property metatypes) => FilePath -> FilePath -> (FilePath -> Property metatypes) -> Property metatypes +applyPath basedir relpath mkp = mconcat $ + map mkp (scanl () basedir (splitPath relpath)) + -- | Ensures that a file/dir has the specfied mode. mode :: FilePath -> FileMode -> Property UnixLike mode f v = p `changesFile` f @@ -290,3 +307,12 @@ Nothing -> '_' : ns ++ unescape cs' Just n -> chr n : unescape cs' unescape (c:cs) = c : unescape cs + +data Overwrite = OverwriteExisting | PreserveExisting + +-- | When passed PreserveExisting, only ensures the property when the file +-- does not exist. +checkOverwrite :: Overwrite -> FilePath -> (FilePath -> Property i) -> Property i +checkOverwrite OverwriteExisting f mkp = mkp f +checkOverwrite PreserveExisting f mkp = + check (not <$> doesFileExist f) (mkp f) diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs --- a/src/Propellor/Property/HostingProvider/Linode.hs +++ b/src/Propellor/Property/HostingProvider/Linode.hs @@ -17,6 +17,7 @@ ] `onChange` Grub.mkConfig `requires` Grub.installed Grub.PC + `describe` "GRUB configured for Linode serial console" -- | Linode's pv-grub-x86_64 (only used for its older XEN instances) -- does not support booting recent Debian kernels compressed diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs --- a/src/Propellor/Property/LightDM.hs +++ b/src/Propellor/Property/LightDM.hs @@ -10,7 +10,8 @@ installed = Apt.installed ["lightdm"] -- | Configures LightDM to skip the login screen and autologin as a user. -autoLogin :: User -> Property UnixLike +autoLogin :: User -> Property DebianLike autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting` ("SeatDefaults", "autologin-user", u) `describe` "lightdm autologin" + `requires` installed 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 @@ -248,7 +248,7 @@ ] `describe` "cgit configured" -- I keep the website used for git.kitenet.net/git.joeyh.name checked into git.. - & Git.cloned (User "root") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing + & Git.cloned (User "joey") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing -- Don't need global apache configuration for cgit. ! Apache.confEnabled "cgit" & website "git.kitenet.net" 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 @@ -97,8 +97,12 @@ -- | Makes a user's password be the passed String. Highly insecure: -- The password is right there in your config file for anyone to see! hasInsecurePassword :: User -> String -> Property DebianLike -hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $ - chpasswd u p [] +hasInsecurePassword u@(User n) p = go + `requires` shadowConfig True + where + go :: Property DebianLike + go = property (n ++ " has insecure password") $ + chpasswd u p [] chpasswd :: User -> String -> [String] -> Propellor Result chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuccess diff --git a/src/Propellor/Property/XFCE.hs b/src/Propellor/Property/XFCE.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/XFCE.hs @@ -0,0 +1,41 @@ +module Propellor.Property.XFCE where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import qualified Propellor.Property.User as User + +installed :: Property DebianLike +installed = Apt.installed ["task-xfce-desktop"] + `describe` "XFCE desktop installed" + +-- | Minimal install of XFCE, with a terminal emulator and panel, +-- and X and network-manager, but not any of the extra apps. +installedMin :: Property DebianLike +installedMin = Apt.installedMin ["xfce4", "xfce4-terminal", "task-desktop"] + `describe` "minimal XFCE desktop installed" + +-- | Installs network-manager-gnome, which is the way to get +-- network-manager to manage networking in XFCE too. +networkManager :: Property DebianLike +networkManager = Apt.installedMin ["network-manager-gnome"] + +-- | Normally at first login, XFCE asks what kind of panel the user wants. +-- This enables the default configuration noninteractively. +defaultPanelFor :: User -> File.Overwrite -> Property DebianLike +defaultPanelFor u@(User username) overwrite = property' desc $ \w -> do + home <- liftIO $ User.homedir u + ensureProperty w (go home) + where + desc = "default XFCE panel for " ++ username + basecf = ".config" "xfce4" "xfconf" + "xfce-perchannel-xml" "xfce4-panel.xml" + -- This location is probably Debian-specific. + defcf = "/etc/xdg/xfce4/panel/default.xml" + go :: FilePath -> Property DebianLike + go home = tightenTargets $ + File.checkOverwrite overwrite (home basecf) $ \cf -> + cf `File.isCopyOf` defcf + `before` File.applyPath home basecf + (\f -> File.ownerGroup f u (userGroup u)) + `requires` Apt.installed ["xfce4-panel"]