diff options
Diffstat (limited to 'src')
31 files changed, 556 insertions, 105 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 9d2d603d..a3b7f315 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -83,7 +83,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "ghc" , "cabal-install" , "libghc-async-dev" - , "libghc-missingh-dev" + , "libghc-split-dev" , "libghc-hslogger-dev" , "libghc-unix-compat-dev" , "libghc-ansi-terminal-dev" @@ -94,13 +94,14 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "libghc-exceptions-dev" , "libghc-stm-dev" , "libghc-text-dev" + , "libghc-hashable-dev" ] fbsddeps = [ "gnupg" , "ghc" , "hs-cabal-install" , "hs-async" - , "hs-MissingH" + , "hs-split" , "hs-hslogger" , "hs-unix-compat" , "hs-ansi-terminal" @@ -111,13 +112,14 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "hs-exceptions" , "hs-stm" , "hs-text" + , "hs-hashable" ] archlinuxdeps = [ "gnupg" , "ghc" , "cabal-install" , "haskell-async" - , "haskell-missingh" + , "haskell-split" , "haskell-hslogger" , "haskell-unix-compat" , "haskell-ansi-terminal" @@ -129,6 +131,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "haskell-exceptions" , "haskell-stm" , "haskell-text" + , "hashell-hashable" ] installGitCommand :: Maybe System -> ShellCommand @@ -144,7 +147,7 @@ installGitCommand msys = case msys of -- assume a debian derived system when not specified Nothing -> use apt where - use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi" + use cmds = "if ! git --version >/dev/null 2>&1; then " ++ intercalate " && " cmds ++ "; fi" apt = [ "apt-get update" , "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git" diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs index 6ac153cc..43c4eddf 100644 --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -2,7 +2,6 @@ module Propellor.Gpg where import System.IO import Data.Maybe -import Data.List.Utils import Control.Monad import Control.Applicative import Prelude @@ -18,6 +17,7 @@ import Utility.Misc import Utility.Tmp import Utility.Env import Utility.Directory +import Utility.Split type KeyId = String diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 94c82c9f..8b2a4e3d 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -50,8 +50,8 @@ import Data.Monoid import Control.Monad.IfElse import "mtl" Control.Monad.RWS.Strict import System.Posix.Files -import qualified Data.Hash.MD5 as MD5 import Data.List +import Data.Hashable import Control.Applicative import Prelude @@ -64,8 +64,8 @@ import Propellor.Info import Propellor.EnsureProperty import Utility.Exception import Utility.Monad -import Utility.Misc import Utility.Directory +import Utility.Misc -- | Makes a perhaps non-idempotent Property be idempotent by using a flag -- file to indicate whether it has run before. @@ -228,12 +228,12 @@ changesFile p f = checkResult getstat comparestat p -- Changes to mtime etc that do not change file content are treated as -- NoChange. changesFileContent :: Checkable p i => p i -> FilePath -> Property i -changesFileContent p f = checkResult getmd5 comparemd5 p +changesFileContent p f = checkResult gethash comparehash p where - getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrict f - comparemd5 oldmd5 = do - newmd5 <- getmd5 - return $ if oldmd5 == newmd5 then NoChange else MadeChange + gethash = catchMaybeIO $ hash <$> readFileStrict f + comparehash oldhash = do + newhash <- gethash + return $ if oldhash == newhash then NoChange else MadeChange -- | Determines if the first file is newer than the second file. -- diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs index 346125ff..a8f7db15 100644 --- a/src/Propellor/Property/Apt/PPA.hs +++ b/src/Propellor/Property/Apt/PPA.hs @@ -6,10 +6,11 @@ module Propellor.Property.Apt.PPA where import Data.List import Control.Applicative import Prelude -import Data.String.Utils import Data.String (IsString(..)) + import Propellor.Base import qualified Propellor.Property.Apt as Apt +import Utility.Split -- | Ensure software-properties-common is installed. installed :: Property DebianLike diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs new file mode 100644 index 00000000..5678a865 --- /dev/null +++ b/src/Propellor/Property/Bootstrap.hs @@ -0,0 +1,111 @@ +module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where + +import Propellor.Base +import Propellor.Bootstrap +import Propellor.Property.Chroot + +import Data.List +import qualified Data.ByteString as B + +-- | Where a propellor repository should be bootstrapped from. +data RepoSource + = GitRepoUrl String + | GitRepoOutsideChroot + -- ^ When used in a chroot, this copies the git repository from + -- outside the chroot, including its configuration. + +-- | 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. +-- +-- 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 + where + go :: Property Linux + go = property "Propellor bootstrapped" $ do + system <- getOS + assumeChange $ exposeTrueLocaldir $ const $ + runShellCommand $ buildShellCommand + [ "cd " ++ localdir + , bootstrapPropellorCommand system + ] + +-- | Clones the propellor repeository into /usr/local/propellor/ +-- +-- If the propellor repo has already been cloned, pulls to get it +-- up-to-date. +clonedFrom :: RepoSource -> Property Linux +clonedFrom reposource = case reposource of + GitRepoOutsideChroot -> go `onChange` copygitconfig + _ -> go + where + go :: Property Linux + go = property ("Propellor repo cloned from " ++ sourcedesc) $ + ifM needclone (makeclone, updateclone) + + makeclone = do + let tmpclone = localdir ++ ".tmpclone" + system <- getOS + assumeChange $ exposeTrueLocaldir $ \sysdir -> do + let originloc = case reposource of + GitRepoUrl s -> s + GitRepoOutsideChroot -> sysdir + runShellCommand $ buildShellCommand + [ installGitCommand system + , "rm -rf " ++ tmpclone + , "git clone " ++ shellEscape originloc ++ " " ++ tmpclone + , "mkdir -p " ++ localdir + -- This is done rather than deleting + -- the old localdir, because if it is bound + -- mounted from outside the chroot, deleting + -- it after unmounting in unshare will remove + -- the bind mount outside the unshare. + , "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)" + , "rm -rf " ++ tmpclone + ] + + updateclone = assumeChange $ exposeTrueLocaldir $ const $ + runShellCommand $ buildShellCommand + [ "cd " ++ localdir + , "git pull" + ] + + -- Copy the git config of the repo outside the chroot into the + -- chroot. This way it has the same remote urls, and other git + -- configuration. + copygitconfig :: Property Linux + copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do + let gitconfig = localdir <> ".git" <> "config" + cfg <- liftIO $ B.readFile gitconfig + exposeTrueLocaldir $ const $ + liftIO $ B.writeFile gitconfig cfg + return MadeChange + + needclone = (inChroot <&&> truelocaldirisempty) + <||> (liftIO (not <$> doesDirectoryExist localdir)) + + truelocaldirisempty = exposeTrueLocaldir $ const $ + runShellCommand ("test ! -d " ++ localdir ++ "/.git") + + sourcedesc = case reposource of + GitRepoUrl s -> s + GitRepoOutsideChroot -> localdir ++ " outside the chroot" + +assumeChange :: Propellor Bool -> Propellor Result +assumeChange a = do + ok <- a + return (cmdResult ok <> MadeChange) + +buildShellCommand :: [String] -> String +buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")") + +runShellCommand :: String -> Propellor Bool +runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s] diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 7738d97e..ad2ae705 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -11,6 +11,7 @@ module Propellor.Property.Chroot ( ChrootTarball(..), noServices, inChroot, + exposeTrueLocaldir, -- * Internal use provisioned', propagateChrootInfo, @@ -32,9 +33,9 @@ import qualified Propellor.Property.File as File import qualified Propellor.Shim as Shim import Propellor.Property.Mount import Utility.FileMode +import Utility.Split import qualified Data.Map as M -import Data.List.Utils import System.Posix.Directory import System.Console.Concurrent @@ -295,6 +296,38 @@ setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) } newtype InChroot = InChroot Bool deriving (Typeable, Show) +-- | Runs an action with the true localdir exposed, +-- not the one bind-mounted into a chroot. The action is passed the +-- path containing the contents of the localdir outside the chroot. +-- +-- In a chroot, this is accomplished by temporily bind mounting the localdir +-- to a temp directory, to preserve access to the original bind mount. Then +-- we unmount the localdir to expose the true localdir. Finally, to cleanup, +-- the temp directory is bind mounted back to the localdir. +exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a +exposeTrueLocaldir a = ifM inChroot + ( withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> + bracket_ + (movebindmount localdir tmpdir) + (movebindmount tmpdir localdir) + (a tmpdir) + , a localdir + ) + where + movebindmount from to = liftIO $ do + run "mount" [Param "--bind", File from, File to] + -- Have to lazy unmount, because the propellor process + -- is running in the localdir that it's unmounting.. + run "umount" [Param "-l", File from] + -- We were in the old localdir; move to the new one after + -- flipping the bind mounts. Otherwise, commands that try + -- to access the cwd will fail because it got umounted out + -- from under. + changeWorkingDirectory "/" + changeWorkingDirectory localdir + run cmd ps = unlessM (boolSystem cmd ps) $ + error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps) + -- | Generates a Chroot that has all the properties of a Host. -- -- Note that it's possible to create loops using this, where a host diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index 6b84acb5..f2de1a27 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -33,6 +33,7 @@ module Propellor.Property.Cmd ( Script, scriptProperty, userScriptProperty, + cmdResult, -- * Lower-level interface for running commands CommandParam(..), boolSystem, diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 1080418b..d53bab71 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -59,13 +59,13 @@ import qualified Propellor.Property.Pacman as Pacman import qualified Propellor.Shim as Shim import Utility.Path import Utility.ThreadScheduler +import Utility.Split import Control.Concurrent.Async hiding (link) import System.Posix.Directory import System.Posix.Process import Prelude hiding (init) import Data.List hiding (init) -import Data.List.Utils import qualified Data.Map as M import System.Console.Concurrent diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs index 60f11d8e..29b85426 100644 --- a/src/Propellor/Property/Fstab.hs +++ b/src/Propellor/Property/Fstab.hs @@ -24,19 +24,32 @@ import Utility.Table -- Note that if anything else is already mounted at the `MountPoint`, it -- will be left as-is by this property. mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux -mounted fs src mnt opts = tightenTargets $ - "/etc/fstab" `File.containsLine` l - `describe` (mnt ++ " mounted by fstab") +mounted fs src mnt opts = tightenTargets $ + listed fs src mnt opts `onChange` mountnow where - l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] - dump = "0" - passno = "2" -- This use of mountPoints, which is linux-only, is why this -- property currently only supports linux. mountnow = check (notElem mnt <$> mountPoints) $ cmdProperty "mount" [mnt] +-- | Ensures that </etc/fstab> contains a line mounting the specified +-- `Source` on the specified `MountPoint`. Does not ensure that it's +-- currently `mounted`. +listed :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike +listed fs src mnt opts = "/etc/fstab" `File.containsLine` l + `describe` (mnt ++ " mounted by fstab") + where + l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] + dump = "0" + passno = "2" + +-- | Ensures that </etc/fstab> contains a line enabling the specified +-- `Source` to be used as swap space, and that it's enabled. +swap :: Source -> Property Linux +swap src = listed "swap" src "none" mempty + `onChange` swapOn src + newtype SwapPartition = SwapPartition FilePath -- | Replaces </etc/fstab> with a file that should cause the currently @@ -77,8 +90,8 @@ genFstab mnts swaps mnttransform = do , pure "0" , pure (if mnt == "/" then "1" else "2") ] - getswapcfg (SwapPartition swap) = sequence - [ fromMaybe swap <$> getM (\a -> a swap) + getswapcfg (SwapPartition s) = sequence + [ fromMaybe s <$> getM (\a -> a s) [ uuidprefix getSourceUUID , sourceprefix getSourceLabel ] diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs index e1342d91..1eb9d690 100644 --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -3,9 +3,9 @@ module Propellor.Property.Hostname where import Propellor.Base import qualified Propellor.Property.File as File import Propellor.Property.Chroot (inChroot) +import Utility.Split import Data.List -import Data.List.Utils -- | Ensures that the hostname is set using best practices, to whatever -- name the `Host` has. diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index 026509a9..5dcc5fe1 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -40,6 +40,9 @@ formatMountOpts (MountOpts []) = "defaults" formatMountOpts (MountOpts l) = intercalate "," l -- | Mounts a device, without listing it in </etc/fstab>. +-- +-- Note that this property will fail if the device is already mounted +-- at the MountPoint. mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike mounted fs src mnt opts = property (mnt ++ " mounted") $ toResult <$> liftIO (mount fs src mnt opts) @@ -52,6 +55,17 @@ bindMount src dest = tightenTargets $ `assume` MadeChange `describe` ("bind mounted " ++ src ++ " to " ++ dest) +-- | Enables swapping to a device, which must be formatted already as a swap +-- partition. +swapOn :: Source -> RevertableProperty Linux Linux +swapOn mnt = tightenTargets doswapon <!> tightenTargets doswapoff + where + swaps = lines <$> readProcess "swapon" ["--show=NAME"] + doswapon = check (notElem mnt <$> swaps) $ + cmdProperty "swapon" [mnt] + doswapoff = check (elem mnt <$> swaps) $ + cmdProperty "swapoff" [mnt] + mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool mount fs src mnt opts = boolSystem "mount" $ [ Param "-t", Param fs diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs new file mode 100644 index 00000000..64cd4091 --- /dev/null +++ b/src/Propellor/Property/Restic.hs @@ -0,0 +1,202 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Support for the restic backup tool <https://github.com/restic/restic> + +module Propellor.Property.Restic + ( ResticRepo (..) + , installed + , repoExists + , init + , restored + , backup + , KeepPolicy (..) + ) where + +import Propellor.Base hiding (init) +import Prelude hiding (init) +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.File as File +import Data.List (intercalate) + +type Url = String + +type ResticParam = String + +data ResticRepo + = Direct FilePath + | SFTP User HostName FilePath + | REST Url + +instance ConfigurableValue ResticRepo where + val (Direct fp) = fp + val (SFTP u h fp) = "sftp:" ++ val u ++ "@" ++ val h ++ ":" ++ fp + val (REST url) = "rest:" ++ url + +installed :: Property DebianLike +installed = withOS desc $ \w o -> case o of + (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $ + Apt.installedBackport ["restic"] + _ -> ensureProperty w $ + Apt.installed ["restic"] + where + desc = "installed restic" + +repoExists :: ResticRepo -> IO Bool +repoExists repo = boolSystem "restic" + [ Param "-r" + , File (val repo) + , Param "--password-file" + , File (getPasswordFile repo) + , Param "snapshots" + ] + +passwordFileDir :: FilePath +passwordFileDir = "/etc/restic-keys" + +getPasswordFile :: ResticRepo -> FilePath +getPasswordFile repo = passwordFileDir </> File.configFileName (val repo) + +passwordFileConfigured :: ResticRepo -> Property (HasInfo + UnixLike) +passwordFileConfigured repo = propertyList "restic password file" $ props + & File.dirExists passwordFileDir + & File.mode passwordFileDir 0O2700 + & getPasswordFile repo `File.hasPrivContent` hostContext + +-- | Inits a new restic repository +init :: ResticRepo -> Property (HasInfo + DebianLike) +init repo = check (not <$> repoExists repo) (cmdProperty "restic" initargs) + `requires` installed + `requires` passwordFileConfigured repo + where + initargs = + [ "-r" + , val repo + , "--password-file" + , getPasswordFile repo + , "init" + ] + +-- | Restores a directory from a restic backup. +-- +-- Only does anything if the directory does not exist, or exists, +-- but is completely empty. +-- +-- The restore is performed atomically; restoring to a temp directory +-- and then moving it to the directory. +restored :: FilePath -> ResticRepo -> Property (HasInfo + DebianLike) +restored dir repo = go + `requires` init repo + where + go :: Property DebianLike + go = property (dir ++ " restored by restic") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "restic-restore" $ \tmpdir -> do + ok <- boolSystem "restic" + [ Param "-r" + , File (val repo) + , Param "--password-file" + , File (getPasswordFile repo) + , Param "restore" + , Param "latest" + , Param "--target" + , File tmpdir + ] + let restoreddir = tmpdir ++ "/" ++ dir + ifM (pure ok <&&> doesDirectoryExist restoreddir) + ( do + void $ tryIO $ removeDirectory dir + renameDirectory restoreddir dir + return MadeChange + , return FailedChange + ) + +-- | Installs a cron job that causes a given directory to be backed +-- up, by running restic with some parameters. +-- +-- If the directory does not exist, or exists but is completely empty, +-- this Property will immediately restore it from an existing backup. +-- +-- So, this property can be used to deploy a directory of content +-- to a host, while also ensuring any changes made to it get backed up. +-- For example: +-- +-- > & Restic.backup "/srv/git" +-- > (Restic.SFTP (User root) (HostName myserver) /mnt/backup/git.restic") +-- > Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Restic.KeepDays 7, Restic.KeepWeeks 4, Restic.KeepMonths 6, Restic.KeepYears 1] +-- +-- Since restic uses a fair amount of system resources, only one restic +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike) +backup dir repo crontimes extraargs kp = backup' dir repo crontimes extraargs kp + `requires` restored dir repo + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike) +backup' dir repo crontimes extraargs kp = cronjob + `describe` desc + `requires` init repo + where + desc = val repo ++ " restic backup" + cronjob = Cron.niceJob ("restic_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd + lockfile = "/var/lock/propellor-restic.lock" + backupcmd = intercalate " && " $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "restic" + , "-r" + , shellEscape (val repo) + , "--password-file" + , shellEscape (getPasswordFile repo) + ] + ++ map shellEscape extraargs ++ + [ "backup" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "restic" + , "-r" + , shellEscape (val repo) + , "--password-file" + , shellEscape (getPasswordFile repo) + , "forget" + , "--prune" + ] + ++ + map keepParam kp + +-- | Constructs a ResticParam that specifies which old backup generations to +-- keep. By default, all generations are kept. However, when this parameter is +-- passed to the `backup` property, they will run restic prune to clean out +-- generations not specified here. +keepParam :: KeepPolicy -> ResticParam +keepParam (KeepLast n) = "--keep-last=" ++ val n +keepParam (KeepHours n) = "--keep-hourly=" ++ val n +keepParam (KeepDays n) = "--keep-daily=" ++ val n +keepParam (KeepWeeks n) = "--keep-weekly=" ++ val n +keepParam (KeepMonths n) = "--keep-monthly=" ++ val n +keepParam (KeepYears n) = "--keep-yearly=" ++ val n + +-- | Policy for backup generations to keep. For example, KeepDays 30 will +-- keep the latest backup for each day when a backup was made, and keep the +-- last 30 such backups. When multiple KeepPolicies are combined together, +-- backups meeting any policy are kept. See restic's man page for details. +data KeepPolicy + = KeepLast Int + | KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs index 00109381..460d0b16 100644 --- a/src/Propellor/Property/Sbuild.hs +++ b/src/Propellor/Property/Sbuild.hs @@ -98,10 +98,10 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.Schroot as Schroot import qualified Propellor.Property.Reboot as Reboot import qualified Propellor.Property.User as User - import Utility.FileMode +import Utility.Split + import Data.List -import Data.List.Utils type Suite = String diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 28246dfe..9b4a3378 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -22,10 +22,10 @@ import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Fail2Ban as Fail2Ban import qualified Propellor.Property.LetsEncrypt as LetsEncrypt import Utility.FileMode +import Utility.Split import Data.List import System.Posix.Files -import Data.String.Utils scrollBox :: Property (HasInfo + DebianLike) scrollBox = propertyList "scroll server" $ props @@ -573,8 +573,8 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "# Enable postgrey." , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_sasl_authenticated,,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" - , "# Enable spamass-milter, amavis-milter, opendkim" - , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock inet:localhost:8891" + , "# Enable spamass-milter, amavis-milter (opendkim is not enabled because it causes mails forwarded from eg gmail to be rejected)" + , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock" , "# opendkim is used for outgoing mail" , "non_smtpd_milters = inet:localhost:8891" , "milter_connect_macros = j {daemon_name} v {if_name} _" diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 7c40bd16..d1a94aa8 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -55,9 +55,9 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import Propellor.Property.Systemd.Core import Utility.FileMode +import Utility.Split import Data.List -import Data.List.Utils import qualified Data.Map as M type ServiceName = String diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs index 372bac6d..42b23df2 100644 --- a/src/Propellor/Property/ZFS/Process.hs +++ b/src/Propellor/Property/ZFS/Process.hs @@ -5,7 +5,8 @@ module Propellor.Property.ZFS.Process where import Propellor.Base -import Data.String.Utils (split) +import Utility.Split + import Data.List -- | Gets the properties of a ZFS volume. diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 447f8e9f..3b3729f9 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -87,7 +87,7 @@ spin' mprivdata relay target hst = do -- And now we can run it. unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ - error "remote propellor failed" + giveup "remote propellor failed" where hn = fromMaybe target relay sys = case fromInfo (hostInfo hst) of diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs index a7a9452e..a8f50ed0 100644 --- a/src/Propellor/Ssh.hs +++ b/src/Propellor/Ssh.hs @@ -6,7 +6,7 @@ import Utility.FileSystemEncoding import System.PosixCompat import Data.Time.Clock.POSIX -import qualified Data.Hash.MD5 as MD5 +import Data.Hashable -- Parameters can be passed to both ssh and scp, to enable a ssh connection -- caching socket. @@ -50,24 +50,22 @@ sshCachingParams hn = do -- 100 bytes. Try to never construct a filename longer than that. -- -- When space allows, include the full hostname in the socket filename. --- Otherwise, include at least a partial md5sum of it, --- to avoid using the same socket file for multiple hosts. +-- Otherwise, a checksum of the hostname is included in the name, to +-- avoid using the same socket file for multiple hosts. socketFile :: FilePath -> HostName -> FilePath socketFile home hn = selectSocketFile - [ sshdir </> hn ++ ".sock" + [ sshdir </> hn ++ ".sock" , sshdir </> hn - , sshdir </> take 10 hn ++ "-" ++ md5 - , sshdir </> md5 - , home </> ".propellor-" ++ md5 + , sshdir </> take 10 hn ++ "-" ++ checksum + , sshdir </> checksum ] - (".propellor-" ++ md5) + (home </> ".propellor-" ++ checksum) where sshdir = home </> ".ssh" </> "propellor" - md5 = take 9 $ MD5.md5s $ MD5.Str hn + checksum = take 9 $ show $ abs $ hash hn selectSocketFile :: [FilePath] -> FilePath -> FilePath selectSocketFile [] d = d -selectSocketFile [f] _ = f selectSocketFile (f:fs) d | valid_unix_socket_path f = f | otherwise = selectSocketFile fs d diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs index 8d62e63b..87756d81 100644 --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -6,12 +6,12 @@ import Propellor.Types.OS (HostName) import Propellor.Types.Empty import Propellor.Types.Info import Propellor.Types.ConfigurableValue +import Utility.Split import Data.Word import qualified Data.Map as M import qualified Data.Set as S import Data.List -import Data.String.Utils (split, replace) import Data.Monoid import Prelude @@ -102,14 +102,14 @@ data Record type ReverseIP = String reverseIP :: IPAddr -> ReverseIP -reverseIP (IPv4 addr) = intercalate "." (reverse $ split "." addr) ++ ".in-addr.arpa" +reverseIP (IPv4 addr) = intercalate "." (reverse $ splitc '.' addr) ++ ".in-addr.arpa" reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ val $ canonicalIP addr) ++ ".ip6.arpa" -- | Converts an IP address (particularly IPv6) to canonical, fully -- expanded form. canonicalIP :: IPAddr -> IPAddr canonicalIP (IPv4 addr) = IPv4 addr -canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":" $ replaceImplicitGroups addr +canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ splitc ':' $ replaceImplicitGroups addr where canonicalGroup g | l <= 4 = replicate (4 - l) '0' ++ g @@ -117,7 +117,7 @@ canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ": where l = length g emptyGroups n = iterate (++ ":") "" !! n - numberOfImplicitGroups a = 8 - length (split ":" $ replace "::" "" a) + numberOfImplicitGroups a = 8 - length (splitc ':' $ replace "::" "" a) replaceImplicitGroups a = concat $ aux $ split "::" a where aux [] = [] diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs index 22b848fa..c68f6ba5 100644 --- a/src/Propellor/Types/ZFS.hs +++ b/src/Propellor/Types/ZFS.hs @@ -7,10 +7,10 @@ module Propellor.Types.ZFS where import Propellor.Types.ConfigurableValue +import Utility.Split import Data.String import qualified Data.Set as Set -import qualified Data.String.Utils as SU import Data.List -- | A single ZFS filesystem. @@ -46,7 +46,7 @@ instance Show ZDataset where show = val instance IsString ZDataset where - fromString s = ZDataset $ SU.split "/" s + fromString s = ZDataset $ splitc '/' s instance IsString ZPool where fromString p = ZPool p diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs index 6e40932e..a6c9ffcf 100644 --- a/src/Utility/DataUnits.hs +++ b/src/Utility/DataUnits.hs @@ -45,6 +45,7 @@ module Utility.DataUnits ( ByteSize, roughSize, + roughSize', compareSizes, readSize ) where @@ -109,7 +110,10 @@ oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits {- approximate display of a particular number of bytes -} roughSize :: [Unit] -> Bool -> ByteSize -> String -roughSize units short i +roughSize units short i = roughSize' units short 2 i + +roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String +roughSize' units short precision i | i < 0 = '-' : findUnit units' (negate i) | otherwise = findUnit units' i where @@ -123,7 +127,7 @@ roughSize units short i showUnit x (Unit size abbrev name) = s ++ " " ++ unit where v = (fromInteger x :: Double) / fromInteger size - s = showImprecise 2 v + s = showImprecise precision v unit | short = abbrev | s == "1" = name diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs index bb3780c6..d9a26944 100644 --- a/src/Utility/FileMode.hs +++ b/src/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2017 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -130,6 +130,21 @@ withUmask umask a = bracket setup cleanup go withUmask _ a = a #endif +getUmask :: IO FileMode +#ifndef mingw32_HOST_OS +getUmask = bracket setup cleanup return + where + setup = setFileCreationMask nullFileMode + cleanup = setFileCreationMask +#else +getUmask = return nullFileMode +#endif + +defaultFileMode :: IO FileMode +defaultFileMode = do + umask <- getUmask + return $ intersectFileModes (complement umask) stdFileMode + combineModes :: [FileMode] -> FileMode combineModes [] = 0 combineModes [m] = m @@ -162,7 +177,10 @@ writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () -writeFileProtected' file writer = withUmask 0o0077 $ +writeFileProtected' file writer = protectedOutput $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h + +protectedOutput :: IO a -> IO a +protectedOutput = withUmask 0o0077 diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs index be43ace9..444dc4a9 100644 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -10,8 +10,8 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, + fileEncoding, withFilePath, - md5FilePath, decodeBS, encodeBS, decodeW8, @@ -19,6 +19,10 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, + s2w8, + w82s, + c2w8, + w82c, ) where import qualified GHC.Foreign as GHC @@ -26,17 +30,15 @@ import qualified GHC.IO.Encoding as Encoding import Foreign.C import System.IO import System.IO.Unsafe -import qualified Data.Hash.MD5 as MD5 import Data.Word -import Data.Bits.Utils import Data.List -import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 #endif import Utility.Exception +import Utility.Split {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current @@ -63,6 +65,13 @@ useFileSystemEncoding = do hSetEncoding stderr e Encoding.setLocaleEncoding e +fileEncoding :: Handle -> IO () +#ifndef mingw32_HOST_OS +fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding +#else +fileEncoding h = hSetEncoding h Encoding.utf8 +#endif + {- Marshal a Haskell FilePath into a NUL terminated C string using temporary - storage. The FilePath is encoded using the filesystem encoding, - reversing the decoding that should have been done when the FilePath @@ -93,10 +102,6 @@ _encodeFilePath fp = unsafePerformIO $ do GHC.withCString enc fp (GHC.peekCString Encoding.char8) `catchNonAsync` (\_ -> return fp) -{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} -md5FilePath :: FilePath -> MD5.Str -md5FilePath = MD5.Str . _encodeFilePath - {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBS :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS @@ -137,14 +142,26 @@ decodeW8 = s2w8 . _encodeFilePath {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) +encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) where - nul = ['\NUL'] + nul = '\NUL' decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul +decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where - nul = ['\NUL'] + nul = '\NUL' + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs index 122f3964..15f82fd1 100644 --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -12,10 +12,10 @@ import Utility.Directory import Utility.Process import Utility.Monad import Utility.Path +import Utility.Split import Data.Maybe import System.FilePath -import Data.List.Utils import System.Posix.Files import Data.Char import Control.Monad.IfElse diff --git a/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs index 55795563..47e98318 100644 --- a/src/Utility/PartialPrelude.hs +++ b/src/Utility/PartialPrelude.hs @@ -2,7 +2,7 @@ - bugs. - - This exports functions that conflict with the prelude, which avoids - - them being accidentially used. + - them being accidentally used. -} {-# OPTIONS_GHC -fno-warn-tabs #-} diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs index 3ee5ff39..0779d167 100644 --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -10,7 +10,6 @@ module Utility.Path where -import Data.String.Utils import System.FilePath import Data.List import Data.Maybe @@ -25,10 +24,10 @@ import System.Posix.Files import Utility.Exception #endif -import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo import Utility.Directory +import Utility.Split {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -68,18 +67,6 @@ simplifyPath path = dropTrailingPathSeparator $ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) -{- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. -} -absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath -#ifndef mingw32_HOST_OS -absNormPathUnix dir path = MissingH.absNormPath dir path -#else -absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) - where - fromdos = replace "\\" "/" - todos = replace "/" "\\" -#endif - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath parentDir = takeDirectory . dropTrailingPathSeparator @@ -89,12 +76,13 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: FilePath -> Maybe FilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) + | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs where - -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" + -- on Unix, the drive will be "/" when the dir is absolute, + -- otherwise "" (drive, path) = splitDrive dir - dirs = filter (not . null) $ split s path s = [pathSeparator] + dirs = filter (not . null) $ split s path prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir @@ -149,11 +137,11 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to | takeDrive from /= takeDrive to = to - | otherwise = intercalate s $ dotdots ++ uncommon + | otherwise = joinPath $ dotdots ++ uncommon where - s = [pathSeparator] - pfrom = split s from - pto = split s to + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto @@ -227,6 +215,8 @@ inPath command = isJust <$> searchPath command - - The command may be fully qualified already, in which case it will - be returned if it exists. + - + - Note that this will find commands in PATH that are not executable. -} searchPath :: String -> IO (Maybe FilePath) searchPath command diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index ed02f49e..6d981cb5 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -174,22 +174,21 @@ createBackgroundProcess p a = a =<< createProcess p -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript = processTranscript' id +processTranscript cmd opts = processTranscript' (proc cmd opts) -processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) -processTranscript' modproc cmd opts input = do +processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) +processTranscript' cp input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} (readf, writef) <- System.Posix.IO.createPipe readh <- System.Posix.IO.fdToHandle readf writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = UseHandle writeh + , std_err = UseHandle writeh + } hClose writeh get <- mkreader readh @@ -200,12 +199,11 @@ processTranscript' modproc cmd opts input = do return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } + p@(_, _, _, pid) <- createProcess $ cp + { std_in = if isJust input then CreatePipe else Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } getout <- mkreader (stdoutHandle p) geterr <- mkreader (stderrHandle p) diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs index 5ce17a84..eb34d3de 100644 --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -11,7 +11,7 @@ module Utility.SafeCommand where import System.Exit import Utility.Process -import Data.String.Utils +import Utility.Split import System.FilePath import Data.Char import Data.List @@ -86,7 +86,7 @@ shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' - escaped = intercalate "'\"'\"'" $ split "'" f + escaped = intercalate "'\"'\"'" $ splitc '\'' f -- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs index d23aaf03..b68ff901 100644 --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -29,6 +29,7 @@ module Utility.Scheduled ( import Utility.Data import Utility.PartialPrelude import Utility.Misc +import Utility.Tuple import Data.List import Data.Time.Clock @@ -37,7 +38,6 @@ import Data.Time.Calendar import Data.Time.Calendar.WeekDate import Data.Time.Calendar.OrdinalDate import Data.Time.Format () -import Data.Tuple.Utils import Data.Char import Control.Applicative import Prelude diff --git a/src/Utility/Split.hs b/src/Utility/Split.hs new file mode 100644 index 00000000..decfe7d3 --- /dev/null +++ b/src/Utility/Split.hs @@ -0,0 +1,30 @@ +{- split utility functions + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Split where + +import Data.List (intercalate) +import Data.List.Split (splitOn) + +-- | same as Data.List.Utils.split +-- +-- intercalate x . splitOn x === id +split :: Eq a => [a] -> [a] -> [[a]] +split = splitOn + +-- | Split on a single character. This is over twice as fast as using +-- split on a list of length 1, while producing identical results. -} +splitc :: Eq c => c -> [c] -> [[c]] +splitc c s = case break (== c) s of + (i, _c:rest) -> i : splitc c rest + (i, []) -> i : [] + +-- | same as Data.List.Utils.replace +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new = intercalate new . split old diff --git a/src/Utility/Tuple.hs b/src/Utility/Tuple.hs new file mode 100644 index 00000000..25c6e8f3 --- /dev/null +++ b/src/Utility/Tuple.hs @@ -0,0 +1,17 @@ +{- tuple utility functions + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.Tuple where + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c |