From c4fcd24f8758d6398254bd44a693c9706d16779b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 24 Mar 2017 14:09:40 -0400 Subject: releasing package propellor version 4.0.2 --- propellor.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 7319af23..e682cbd1 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 4.0.1 +Version: 4.0.2 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess -- cgit v1.3-2-g0d8e From 4ba09ab6844cc3fc3e94856da22190555b697193 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 15:00:33 -0400 Subject: added Propellor.Property.Bootstrap (untested) This commit was sponsored by Jake Vosloo on Patreon. --- ...ent_1_b05e9a44e5c7130d9cc928223cd82d78._comment | 16 ++++ joeyconfig.hs | 4 +- propellor.cabal | 1 + src/Propellor/Property/Bootstrap.hs | 95 ++++++++++++++++++++++ src/Propellor/Property/Cmd.hs | 1 + 5 files changed, 116 insertions(+), 1 deletion(-) create mode 100644 doc/todo/property_to_install_propellor/comment_1_b05e9a44e5c7130d9cc928223cd82d78._comment create mode 100644 src/Propellor/Property/Bootstrap.hs (limited to 'propellor.cabal') diff --git a/doc/todo/property_to_install_propellor/comment_1_b05e9a44e5c7130d9cc928223cd82d78._comment b/doc/todo/property_to_install_propellor/comment_1_b05e9a44e5c7130d9cc928223cd82d78._comment new file mode 100644 index 00000000..5a826fea --- /dev/null +++ b/doc/todo/property_to_install_propellor/comment_1_b05e9a44e5c7130d9cc928223cd82d78._comment @@ -0,0 +1,16 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 1""" + date="2017-04-09T17:42:10Z" + content=""" +Making this work when propellor is setting up a chroot is difficult, +because the localdir is bind mounted into the chroot. + +Hmm, `unshare` could be helpful. Run shell commands to clone the localdir +inside `unshare -m`, prefixed with a `umount localdir`. This way, the bind +mount is avoided, and it writes "under" it. Limits the commands that can be +run to set up the localdir to shell commands, but bootstrap already +operates on terms of shell commands so that seems ok. + +`unshare` is linux-specific; comes in util-linux on modern linuxes. +"""]] diff --git a/joeyconfig.hs b/joeyconfig.hs index e73897b4..036c2c92 100644 --- a/joeyconfig.hs +++ b/joeyconfig.hs @@ -38,6 +38,7 @@ import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuil import qualified Propellor.Property.SiteSpecific.Branchable as Branchable import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites import Propellor.Property.DiskImage +import Propellor.Property.Bootstrap main :: IO () -- _ ______`| ,-.__ main = defaultMain hosts -- / \___-=O`/|O`/__| (____.' @@ -93,7 +94,7 @@ darkstar = host "darkstar.kitenet.net" $ props [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar") ] - ! imageBuilt "/tmp/img" c MSDOS (grubBooted PC) + & imageBuilt "/tmp/img" c MSDOS (grubBooted PC) [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag , partition EXT4 `mountedAt` "/" @@ -106,6 +107,7 @@ darkstar = host "darkstar.kitenet.net" $ props & Hostname.setTo "demo" & Apt.installed ["linux-image-amd64"] & User "root" `User.hasInsecurePassword` "root" + & bootstrappedFrom GitRepoOutsideChroot gnu :: Host gnu = host "gnu.kitenet.net" $ props diff --git a/propellor.cabal b/propellor.cabal index a04089b5..f4a1f23a 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -87,6 +87,7 @@ Library Propellor.Property.Apt Propellor.Property.Apt.PPA Propellor.Property.Attic + Propellor.Property.Bootstrap Propellor.Property.Borg Propellor.Property.Ccache Propellor.Property.Cmd diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs new file mode 100644 index 00000000..6158d967 --- /dev/null +++ b/src/Propellor/Property/Bootstrap.hs @@ -0,0 +1,95 @@ +module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where + +import Propellor.Base +import Propellor.Bootstrap +import Propellor.Property.Chroot + +import Data.List + +-- | Where a propellor repository should be bootstrapped from. +data RepoSource + = GitRepoUrl String + | GitRepoOutsideChroot + +-- | 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 $ buildShellCommand + [ "cd " ++ localdir + , bootstrapPropellorCommand system + ] + +-- | Clones the propellor repeository into /usr/local/propellor/ +-- +-- GitRepoOutsideChroot can be used when this is used in a chroot. +-- In that case, it clones the /usr/local/propellor/ from outside the +-- chroot into the same path inside the chroot. +-- +-- If the propellor repo has already been cloned, pulls to get it +-- up-to-date. +clonedFrom :: RepoSource -> Property Linux +clonedFrom reposource = property ("Propellor repo cloned from " ++ originloc) $ do + ifM needclone + ( do + let tmpclone = localdir ++ ".tmpclone" + system <- getOS + assumeChange $ exposeTrueLocaldir $ 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 + ] + , assumeChange $ exposeTrueLocaldir $ buildShellCommand + [ "cd " ++ localdir + , "git pull" + ] + ) + where + needclone = (inChroot <&&> truelocaldirisempty) + <||> (liftIO (not <$> doesDirectoryExist localdir)) + truelocaldirisempty = exposeTrueLocaldir $ + "test ! -d " ++ localdir ++ "/.git" + originloc = case reposource of + GitRepoUrl s -> s + GitRepoOutsideChroot -> localdir + +-- | Runs the shell command with the true localdir exposed, +-- not the one bind-mounted into a chroot. +exposeTrueLocaldir :: String -> Propellor Bool +exposeTrueLocaldir s = do + s' <- ifM inChroot + ( return $ "unshare -m sh -c " ++ shellEscape + ("umount " ++ localdir ++ " && ( " ++ s ++ ")") + , return s + ) + liftIO $ boolSystem "sh" [ Param "-c", Param s'] + +assumeChange :: Propellor Bool -> Propellor Result +assumeChange a = do + ok <- a + return (cmdResult ok <> MadeChange) + +buildShellCommand :: [String] -> String +buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")") 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, -- cgit v1.3-2-g0d8e From c72d3f8fc88691572cb4531ea1760784bca0661d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 20 Apr 2017 00:57:56 -0400 Subject: releasing package propellor version 4.0.3 --- debian/changelog | 4 ++-- propellor.cabal | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index 70aa139d..498cb5bc 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,11 +1,11 @@ -propellor (4.0.3) UNRELEASED; urgency=medium +propellor (4.0.3) unstable; urgency=medium * Added Fstab.listed, Fstab.swap, and Mount.swapOn properties. Thanks, Daniel Brooks. * Added Propellor.Property.Bootstrap, which can be used to make disk images contain their own installation of propellor. - -- Joey Hess Thu, 06 Apr 2017 19:40:12 -0400 + -- Joey Hess Thu, 20 Apr 2017 00:54:32 -0400 propellor (4.0.2) unstable; urgency=medium diff --git a/propellor.cabal b/propellor.cabal index 714c3235..58651a01 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 4.0.2 +Version: 4.0.3 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess -- cgit v1.3-2-g0d8e From 33890da9cb62c6d621b8fb4db69af2eb6810e1f4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 20 Apr 2017 19:35:54 -0400 Subject: increase cabal-version f045116b618e255c583376447be635c245d63909 does not work with cabal 1.16 --- propellor.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 58651a01..e217bfd7 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,6 +1,6 @@ Name: propellor Version: 4.0.3 -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess Author: Joey Hess -- cgit v1.3-2-g0d8e From fe4b58f7db06cd59b95e73ef2a664372d0a4addd Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Thu, 27 Apr 2017 14:57:12 +0200 Subject: add Restic module --- propellor.cabal | 1 + src/Propellor/Property/Restic.hs | 204 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 205 insertions(+) create mode 100644 src/Propellor/Property/Restic.hs (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 58651a01..292bc79d 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -136,6 +136,7 @@ Library Propellor.Property.PropellorRepo Propellor.Property.Prosody Propellor.Property.Reboot + Propellor.Property.Restic Propellor.Property.Rsync Propellor.Property.Sbuild Propellor.Property.Scheduled diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs new file mode 100644 index 00000000..55a68324 --- /dev/null +++ b/src/Propellor/Property/Restic.hs @@ -0,0 +1,204 @@ +-- | Maintainer: Félix Sipma +-- +-- Support for the restic backup tool + +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` installed + `requires` passwordFileConfigured 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 borg 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` installed + `requires` passwordFileConfigured repo + where + desc = val repo ++ " restic backup" + cronjob = Cron.niceJob ("restic_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + lockfile = "/var/lock/propellor-restic.lock" + backupcmd = intercalate ";" $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "restic" + , "-r" + , val repo + , "--password-file" + , getPasswordFile repo + ] + ++ map shellEscape extraargs ++ + [ "backup" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "restic" + , "-r" + , val repo + , "--password-file" + , 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 borg's man page for details. +data KeepPolicy + = KeepLast Int + | KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int -- cgit v1.3-2-g0d8e From ba3bd76f4ade7ffeea3c1837f868f5264d284a8c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 15 May 2017 20:09:31 -0400 Subject: Removed dependency on MissingH, instead depends on split and hashable. MissingH is a heavy dependency, which pulls in parsec and a bunch of stuff. So eliminating it makes propellor easier to install and less likely to fail to build. changesFileContent now uses hashable's hash. This may not be stable across upgrades, I'm not sure -- but it's surely ok here, as the hash is not stored. socketFile also uses hash. I *think* this is ok, even if it's not stable. If it's not stable, an upgrade might make propellor hash a hostname to a different number, but with 9 digets of number in use, the chances of a collision are small. In any case, I've opned a bug report asking for the stability to be documented, and I think it's intended to be stable, only the documentation is bad. NB: I have not checked that the arch linux and freebsd packages for the new deps, that Propellor.Bootstrap lists, are the right names or even exist. Since propellor depends on hashable, it could be changed to use unordered-containers, rather than containers, which would be faster and perhaps less deps too. This commit was sponsored by Alexander Thompson on Patreon. --- debian/changelog | 1 + debian/control | 6 ++-- propellor.cabal | 15 +++++---- src/Propellor/Bootstrap.hs | 9 ++++-- src/Propellor/Gpg.hs | 2 +- src/Propellor/Property.hs | 14 ++++----- src/Propellor/Property/Apt/PPA.hs | 3 +- src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/Docker.hs | 2 +- src/Propellor/Property/Hostname.hs | 2 +- src/Propellor/Property/Sbuild.hs | 4 +-- src/Propellor/Property/SiteSpecific/JoeySites.hs | 2 +- src/Propellor/Property/Systemd.hs | 2 +- src/Propellor/Property/ZFS/Process.hs | 3 +- src/Propellor/Ssh.hs | 18 +++++------ src/Propellor/Types/Dns.hs | 8 ++--- src/Propellor/Types/ZFS.hs | 4 +-- src/Utility/FileMode.hs | 22 +++++++++++-- src/Utility/FileSystemEncoding.hs | 39 ++++++++++++++++-------- src/Utility/LinuxMkLibs.hs | 2 +- src/Utility/PartialPrelude.hs | 2 +- src/Utility/Path.hs | 28 +++++------------ src/Utility/Process.hs | 28 ++++++++--------- src/Utility/SafeCommand.hs | 4 +-- src/Utility/Scheduled.hs | 2 +- src/Utility/Split.hs | 28 +++++++++++++++++ src/Utility/Tuple.hs | 17 +++++++++++ 27 files changed, 170 insertions(+), 99 deletions(-) create mode 100644 src/Utility/Split.hs create mode 100644 src/Utility/Tuple.hs (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index 70aa139d..4fb9b669 100644 --- a/debian/changelog +++ b/debian/changelog @@ -4,6 +4,7 @@ propellor (4.0.3) UNRELEASED; urgency=medium Thanks, Daniel Brooks. * Added Propellor.Property.Bootstrap, which can be used to make disk images contain their own installation of propellor. + * Removed dependency on MissingH, instead depends on split and hashable. -- Joey Hess Thu, 06 Apr 2017 19:40:12 -0400 diff --git a/debian/control b/debian/control index 289e663b..e6819060 100644 --- a/debian/control +++ b/debian/control @@ -7,7 +7,7 @@ Build-Depends: ghc (>= 7.6), cabal-install, libghc-async-dev, - libghc-missingh-dev, + libghc-split-dev, libghc-hslogger-dev, libghc-unix-compat-dev, libghc-ansi-terminal-dev, @@ -18,6 +18,7 @@ Build-Depends: libghc-exceptions-dev (>= 0.6), libghc-stm-dev, libghc-text-dev, + libghc-hashable-dev, libghc-concurrent-output-dev, Maintainer: Joey Hess Standards-Version: 3.9.8 @@ -31,7 +32,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, ghc (>= 7.4), cabal-install, libghc-async-dev, - libghc-missingh-dev, + libghc-split-dev, libghc-hslogger-dev, libghc-unix-compat-dev, libghc-ansi-terminal-dev, @@ -42,6 +43,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-exceptions-dev (>= 0.6), libghc-stm-dev, libghc-text-dev, + libghc-hashable-dev, libghc-concurrent-output-dev, git, Description: property-based host configuration management in haskell diff --git a/propellor.cabal b/propellor.cabal index 714c3235..dc304fbc 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -46,9 +46,9 @@ Executable propellor -- propellor needs to support the ghc shipped in Debian stable, -- and also only depends on packages in Debian stable. base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Other-Modules: Propellor.DotDir @@ -61,9 +61,9 @@ Executable propellor-config Hs-Source-Dirs: src Build-Depends: base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Library GHC-Options: -Wall -fno-warn-tabs -O0 @@ -73,9 +73,9 @@ Library Hs-Source-Dirs: src Build-Depends: base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Exposed-Modules: Propellor @@ -221,10 +221,13 @@ Library Utility.Process.NonConcurrent Utility.SafeCommand Utility.Scheduled + Utility.Scheduled + Utility.Split Utility.SystemDirectory Utility.Table Utility.ThreadScheduler Utility.Tmp + Utility.Tuple Utility.UserInfo System.Console.Concurrent System.Console.Concurrent.Internal diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 29c55213..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 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/Chroot.hs b/src/Propellor/Property/Chroot.hs index 7738d97e..01cd4d3e 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -32,9 +32,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 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/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/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 063a2eda..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 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/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/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 + - Copyright 2010-2017 Joey Hess - - 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..862f0721 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,8 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, + s2w8, + w82s, ) where import qualified GHC.Foreign as GHC @@ -26,17 +28,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 +63,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 +100,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 +140,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..2383ad06 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,7 +24,6 @@ import System.Posix.Files import Utility.Exception #endif -import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo import Utility.Directory @@ -68,18 +66,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 +75,11 @@ 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 $ joinPath $ init dirs where -- 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) $ splitPath path prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir @@ -149,11 +134,10 @@ 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 = splitPath from + pto = splitPath to common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto @@ -227,6 +211,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..b3e5e276 --- /dev/null +++ b/src/Utility/Split.hs @@ -0,0 +1,28 @@ +{- split utility functions + - + - Copyright 2017 Joey Hess + - + - License: BSD-2-clause + -} + +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 + - + - 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 -- cgit v1.3-2-g0d8e From cd3dfc433ab48ab150386e52ed7e61abe55ae550 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 15 May 2017 20:15:42 -0400 Subject: squelch cabal warning about Default-Language Could use Hashell2010, but IIRC there are some slightly tricky differences. --- propellor.cabal | 3 +++ 1 file changed, 3 insertions(+) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 9dda1ad8..3b12344f 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -36,6 +36,7 @@ Description: It is configured using haskell. Executable propellor + Default-Language: Haskell98 Main-Is: wrapper.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) @@ -53,6 +54,7 @@ Executable propellor Propellor.DotDir Executable propellor-config + Default-Language: Haskell98 Main-Is: config.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) @@ -66,6 +68,7 @@ Executable propellor-config time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Library + Default-Language: Haskell98 GHC-Options: -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) GHC-Options: -fno-warn-redundant-constraints -- cgit v1.3-2-g0d8e