From 8096511f807f633b6a50631ef03c1db98a910be1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 3 Apr 2017 15:41:31 -0400 Subject: avoid opendkim checks on incoming email This caused a problem when eg a gmail email was sent to branchable and forwarded on to kite. Kite thought branchable was forging the dkim signature of gmail, and gmail does strict enforcement of dkim, so it rejected it. DKIM seems like a mightly hefty hammer, and I remember similar issues being dicussed where mailing list software got broken by DKIM. I guess this will mean a few more joe-jobs get through, but I'd rather not silently lose important legitimate email! --- src/Propellor/Property/SiteSpecific/JoeySites.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 28246dfe..063a2eda 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -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} _" -- cgit v1.3-2-g0d8e From d1cbc66cb06482a5cb4168fc44b7e84fd4e8849e Mon Sep 17 00:00:00 2001 From: Daniel Brooks Date: Tue, 4 Apr 2017 13:56:03 -0700 Subject: property 'mount' a swap partition in Fstab.mounted --- src/Propellor/Property/Fstab.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs index 60f11d8e..602276ea 100644 --- a/src/Propellor/Property/Fstab.hs +++ b/src/Propellor/Property/Fstab.hs @@ -35,7 +35,9 @@ mounted fs src mnt opts = tightenTargets $ -- This use of mountPoints, which is linux-only, is why this -- property currently only supports linux. mountnow = check (notElem mnt <$> mountPoints) $ - cmdProperty "mount" [mnt] + if fs == "swap" + then cmdProperty "swapon" [mnt] + else cmdProperty "mount" [mnt] newtype SwapPartition = SwapPartition FilePath -- cgit v1.3-2-g0d8e From baf65fa9fff4b8451ba7f1ee129484723a8deb9b Mon Sep 17 00:00:00 2001 From: Daniel Brooks Date: Tue, 4 Apr 2017 23:32:57 -0700 Subject: break Fstab.mounted into smaller pieces which can be composed --- src/Propellor/Property/Fstab.hs | 52 ++++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 16 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs index 602276ea..7bf18726 100644 --- a/src/Propellor/Property/Fstab.hs +++ b/src/Propellor/Property/Fstab.hs @@ -14,6 +14,17 @@ import Data.Char import Data.List import Utility.Table +-- | Ensures that contains a line mounting the specified +-- `Source` on the specified `MountPoint`. +listed :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux +listed fs src mnt opts = tightenTargets $ + "/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 contains a line mounting the specified -- `Source` on the specified `MountPoint`, and that it's currently mounted. -- @@ -24,20 +35,29 @@ 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") - `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) $ - if fs == "swap" - then cmdProperty "swapon" [mnt] - else cmdProperty "mount" [mnt] +mounted fs src mnt opts = (listed fs src mnt opts) `onChange` (mountNow src) + +-- | Ensures that 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) + +-- This use of mountPoints, which is linux-only, is why this +-- property currently only supports linux. +mountNow :: Source -> RevertableProperty Linux Linux +mountNow mnt = tightenTargets domount tightenTargets doumount + where domount = check (notElem mnt <$> mountPoints) $ + cmdProperty "mount" [mnt] + doumount = check (elem mnt <$> mountPoints) $ + cmdProperty "umount" [mnt] + +swapOn :: Source -> RevertableProperty Linux Linux +swapOn mnt = tightenTargets doswapon tightenTargets doswapoff + where swaps = lines <$> readProcess "swapon" ["--no-headings", "--show=NAME"] + doswapon = check (notElem mnt <$> swaps) $ + cmdProperty "swapon" [mnt] + doswapoff = check (elem mnt <$> swaps) $ + cmdProperty "swapoff" [mnt] newtype SwapPartition = SwapPartition FilePath @@ -79,8 +99,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 ] -- cgit v1.3-2-g0d8e From 544ad71f3fce7d394945b447fcaf938d8067c5b3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 6 Apr 2017 19:43:48 -0400 Subject: listed property should work on !Linux --- src/Propellor/Property/Fstab.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs index 7bf18726..8196377f 100644 --- a/src/Propellor/Property/Fstab.hs +++ b/src/Propellor/Property/Fstab.hs @@ -16,10 +16,9 @@ import Utility.Table -- | Ensures that contains a line mounting the specified -- `Source` on the specified `MountPoint`. -listed :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux -listed fs src mnt opts = tightenTargets $ - "/etc/fstab" `File.containsLine` l - `describe` (mnt ++ " mounted by fstab") +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" -- cgit v1.3-2-g0d8e From 57525e0d0d1d300aa807f1c876945ee5e38a29df Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 6 Apr 2017 20:08:14 -0400 Subject: tweaks to db45x's patch Removed mountNow as a top-level property, as I don't think it makes sense for anything except for mounted to use it. db45x's patch turns out to have introduced a bug in mounted's use of "mountNow src". That made mountNow check if the device was a mount point, which it isn't. The fix would have been to use "mountNow mnt", but my inlining of mountnow just basically reverted the part of the patch that introduced the bug. swapOn does not involve the fstab so moved to the Mount module. (Also noticed that Mount.mounted is a kind of weird property, given that it fails the next time ran. It's only used internally by some chroot properties, so I left it as-is, but added a comment. It might make sense to make Mount.mounted check like mountNow does if the thing is already mounted.) --- debian/changelog | 7 +++ ...ent_5_6dc24952c8efa31a401191a8cf2d0b39._comment | 14 ++++++ src/Propellor/Property/Fstab.hs | 52 +++++++++------------- src/Propellor/Property/Mount.hs | 14 ++++++ 4 files changed, 57 insertions(+), 30 deletions(-) create mode 100644 doc/forum/Fstab.mounted_could_call_swapon_when_activating_swap/comment_5_6dc24952c8efa31a401191a8cf2d0b39._comment (limited to 'src') diff --git a/debian/changelog b/debian/changelog index c3ae1903..dcbe0a3e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +propellor (4.0.3) UNRELEASED; urgency=medium + + * Added Fstab.listed, Fstab.swap, and Mount.swapOn properties. + Thanks, Daniel Brooks. + + -- Joey Hess Thu, 06 Apr 2017 19:40:12 -0400 + propellor (4.0.2) unstable; urgency=medium * Apt.mirror can be used to set the preferred apt mirror of a host, diff --git a/doc/forum/Fstab.mounted_could_call_swapon_when_activating_swap/comment_5_6dc24952c8efa31a401191a8cf2d0b39._comment b/doc/forum/Fstab.mounted_could_call_swapon_when_activating_swap/comment_5_6dc24952c8efa31a401191a8cf2d0b39._comment new file mode 100644 index 00000000..f87500b2 --- /dev/null +++ b/doc/forum/Fstab.mounted_could_call_swapon_when_activating_swap/comment_5_6dc24952c8efa31a401191a8cf2d0b39._comment @@ -0,0 +1,14 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 5""" + date="2017-04-06T23:51:08Z" + content=""" +Merged. Have not tested it either. + +On my Debian system, the swapon command does not support the +`--no-headings` that you used. It's `--noheadings` here. Is that a typo in +your patch? + +I've simply removed that option for now, since it probably won't +hurt if it treats the heading like another device that's swapped on. +"""]] diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs index 8196377f..29b85426 100644 --- a/src/Propellor/Property/Fstab.hs +++ b/src/Propellor/Property/Fstab.hs @@ -14,16 +14,6 @@ import Data.Char import Data.List import Utility.Table --- | Ensures that contains a line mounting the specified --- `Source` on the specified `MountPoint`. -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 contains a line mounting the specified -- `Source` on the specified `MountPoint`, and that it's currently mounted. -- @@ -34,29 +24,31 @@ listed fs src mnt opts = "/etc/fstab" `File.containsLine` l -- 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 = (listed fs src mnt opts) `onChange` (mountNow src) +mounted fs src mnt opts = tightenTargets $ + listed fs src mnt opts + `onChange` mountnow + where + -- 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 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 contains a line enabling the specified --- `Source` to be used as swap space, and that it's enabled +-- `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) - --- This use of mountPoints, which is linux-only, is why this --- property currently only supports linux. -mountNow :: Source -> RevertableProperty Linux Linux -mountNow mnt = tightenTargets domount tightenTargets doumount - where domount = check (notElem mnt <$> mountPoints) $ - cmdProperty "mount" [mnt] - doumount = check (elem mnt <$> mountPoints) $ - cmdProperty "umount" [mnt] - -swapOn :: Source -> RevertableProperty Linux Linux -swapOn mnt = tightenTargets doswapon tightenTargets doswapoff - where swaps = lines <$> readProcess "swapon" ["--no-headings", "--show=NAME"] - doswapon = check (notElem mnt <$> swaps) $ - cmdProperty "swapon" [mnt] - doswapoff = check (elem mnt <$> swaps) $ - cmdProperty "swapoff" [mnt] +swap src = listed "swap" src "none" mempty + `onChange` swapOn src newtype SwapPartition = SwapPartition FilePath 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 . +-- +-- 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 -- 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 'src') 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 9dbd25a91c88a99832db5a2b31f0e87f0bff47e8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 16:49:38 -0400 Subject: well, that didnt work :( --- .../comment_2_9fea601af57777e1cb49952483f4da63._comment | 7 +++++++ src/Propellor/Property/Bootstrap.hs | 3 +++ 2 files changed, 10 insertions(+) create mode 100644 doc/todo/property_to_install_propellor/comment_2_9fea601af57777e1cb49952483f4da63._comment (limited to 'src') diff --git a/doc/todo/property_to_install_propellor/comment_2_9fea601af57777e1cb49952483f4da63._comment b/doc/todo/property_to_install_propellor/comment_2_9fea601af57777e1cb49952483f4da63._comment new file mode 100644 index 00000000..f862f79b --- /dev/null +++ b/doc/todo/property_to_install_propellor/comment_2_9fea601af57777e1cb49952483f4da63._comment @@ -0,0 +1,7 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 2""" + date="2017-04-09T20:49:04Z" + content=""" +Well, seems that `unshare` does not work in a chroot. Hmm. +"""]] diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index 6158d967..4a60276e 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -77,6 +77,9 @@ clonedFrom reposource = property ("Propellor repo cloned from " ++ originloc) $ -- | Runs the shell command with the true localdir exposed, -- not the one bind-mounted into a chroot. +-- +-- FIXME: unshare -m does not work in a chroot! +-- "unshare: cannot change root filesystem propagation: Invalid argument" exposeTrueLocaldir :: String -> Propellor Bool exposeTrueLocaldir s = do s' <- ifM inChroot -- cgit v1.3-2-g0d8e From 9b8ca1509060a355966a6377615e3f9e91a655da Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 17:11:34 -0400 Subject: new approach for exposing the underlying localdir inside a chroot --- src/Propellor/Property/Bootstrap.hs | 42 ++++++++++++++++++++++++------------- 1 file changed, 27 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index 4a60276e..8d0c4db9 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -29,7 +29,7 @@ bootstrappedFrom reposource = go `requires` clonedFrom reposource go :: Property Linux go = property "Propellor bootstrapped" $ do system <- getOS - assumeChange $ exposeTrueLocaldir $ buildShellCommand + assumeChange $ exposeTrueLocaldir $ runShellCommand $ buildShellCommand [ "cd " ++ localdir , bootstrapPropellorCommand system ] @@ -48,7 +48,7 @@ clonedFrom reposource = property ("Propellor repo cloned from " ++ originloc) $ ( do let tmpclone = localdir ++ ".tmpclone" system <- getOS - assumeChange $ exposeTrueLocaldir $ buildShellCommand + assumeChange $ exposeTrueLocaldir $ runShellCommand $ buildShellCommand [ installGitCommand system , "rm -rf " ++ tmpclone , "git clone " ++ shellEscape originloc ++ " " ++ tmpclone @@ -61,7 +61,7 @@ clonedFrom reposource = property ("Propellor repo cloned from " ++ originloc) $ , "(cd " ++ tmpclone ++ " && tar c) | (cd " ++ localdir ++ " && tar x)" , "rm -rf " ++ tmpclone ] - , assumeChange $ exposeTrueLocaldir $ buildShellCommand + , assumeChange $ exposeTrueLocaldir $ runShellCommand $ buildShellCommand [ "cd " ++ localdir , "git pull" ] @@ -69,25 +69,34 @@ clonedFrom reposource = property ("Propellor repo cloned from " ++ originloc) $ where needclone = (inChroot <&&> truelocaldirisempty) <||> (liftIO (not <$> doesDirectoryExist localdir)) - truelocaldirisempty = exposeTrueLocaldir $ + truelocaldirisempty = exposeTrueLocaldir $ runShellCommand $ "test ! -d " ++ localdir ++ "/.git" originloc = case reposource of GitRepoUrl s -> s GitRepoOutsideChroot -> localdir --- | Runs the shell command with the true localdir exposed, +-- | Runs an action with the true localdir exposed, -- not the one bind-mounted into a chroot. -- --- FIXME: unshare -m does not work in a chroot! --- "unshare: cannot change root filesystem propagation: Invalid argument" -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'] +-- 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 :: IO a -> Propellor a +exposeTrueLocaldir a = ifM inChroot + ( liftIO $ withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> + bracket_ + (movebindmount localdir tmpdir) + (movebindmount tmpdir localdir) + a + , liftIO a + ) + where + movebindmount from to = do + run "mount" [Param "--bind", File from, File to] + run "umount" [File from] + run cmd ps = unlessM (boolSystem cmd ps) $ + error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps) assumeChange :: Propellor Bool -> Propellor Result assumeChange a = do @@ -96,3 +105,6 @@ assumeChange a = do buildShellCommand :: [String] -> String buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")") + +runShellCommand :: String -> IO Bool +runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s] -- cgit v1.3-2-g0d8e From e976032e98788907052cae09be639a99d25de0d1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 17:17:54 -0400 Subject: propellor spin --- src/Propellor/Property/Bootstrap.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index 8d0c4db9..fa240782 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -94,7 +94,9 @@ exposeTrueLocaldir a = ifM inChroot where movebindmount from to = do run "mount" [Param "--bind", File from, File to] - run "umount" [File from] + -- Have to lazy unmount, because the propellor process + -- is running in the localdir that it's unmounting.. + run "umount" [Param "-l", File from] run cmd ps = unlessM (boolSystem cmd ps) $ error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps) -- cgit v1.3-2-g0d8e From c25bf31c9438aedfe34ee3d870d8a6ef58767a68 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 17:20:08 -0400 Subject: avoid "sh: 1: git: not found" before auto-install of git --- src/Propellor/Bootstrap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 9d2d603d..29c55213 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -144,7 +144,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" -- cgit v1.3-2-g0d8e From 4a0f3076a6f3269409e7bf33120b0cc9cfa65630 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 17:23:53 -0400 Subject: propellor spin --- src/Propellor/Property/Bootstrap.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index fa240782..7fd9595b 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -5,6 +5,7 @@ import Propellor.Bootstrap import Propellor.Property.Chroot import Data.List +import System.Posix.Directory -- | Where a propellor repository should be bootstrapped from. data RepoSource @@ -97,6 +98,12 @@ exposeTrueLocaldir a = ifM inChroot -- 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) -- cgit v1.3-2-g0d8e From 547a04ea0a9d085432fe33c916e337b49a2d3715 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 17:32:15 -0400 Subject: propellor spin --- src/Propellor/Property/Bootstrap.hs | 63 ++++++++++++++++++++----------------- 1 file changed, 35 insertions(+), 28 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index 7fd9595b..68506918 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -30,10 +30,11 @@ bootstrappedFrom reposource = go `requires` clonedFrom reposource go :: Property Linux go = property "Propellor bootstrapped" $ do system <- getOS - assumeChange $ exposeTrueLocaldir $ runShellCommand $ buildShellCommand - [ "cd " ++ localdir - , bootstrapPropellorCommand system - ] + assumeChange $ exposeTrueLocaldir $ const $ + runShellCommand $ buildShellCommand + [ "cd " ++ localdir + , bootstrapPropellorCommand system + ] -- | Clones the propellor repeository into /usr/local/propellor/ -- @@ -44,53 +45,59 @@ bootstrappedFrom reposource = go `requires` clonedFrom reposource -- 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 +clonedFrom reposource = property ("Propellor repo cloned from " ++ sourcedesc) $ do ifM needclone ( do let tmpclone = localdir ++ ".tmpclone" system <- getOS - assumeChange $ exposeTrueLocaldir $ 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 + 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 + ] + , assumeChange $ exposeTrueLocaldir $ const $ + runShellCommand $ buildShellCommand + [ "cd " ++ localdir + , "git pull" ] - , assumeChange $ exposeTrueLocaldir $ runShellCommand $ buildShellCommand - [ "cd " ++ localdir - , "git pull" - ] ) where needclone = (inChroot <&&> truelocaldirisempty) <||> (liftIO (not <$> doesDirectoryExist localdir)) - truelocaldirisempty = exposeTrueLocaldir $ runShellCommand $ - "test ! -d " ++ localdir ++ "/.git" - originloc = case reposource of + truelocaldirisempty = exposeTrueLocaldir $ const $ + runShellCommand ("test ! -d " ++ localdir ++ "/.git") + sourcedesc = case reposource of GitRepoUrl s -> s GitRepoOutsideChroot -> localdir -- | Runs an action with the true localdir exposed, --- not the one bind-mounted into a chroot. +-- 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 :: IO a -> Propellor a +exposeTrueLocaldir :: (FilePath -> IO a) -> Propellor a exposeTrueLocaldir a = ifM inChroot ( liftIO $ withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> bracket_ (movebindmount localdir tmpdir) (movebindmount tmpdir localdir) - a - , liftIO a + (a tmpdir) + , liftIO $ a localdir ) where movebindmount from to = do -- cgit v1.3-2-g0d8e From ffc328a5842e154eb3fce66d628cbc4a26d7b254 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 17:33:26 -0400 Subject: propellor spin --- src/Propellor/Property/Bootstrap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index 68506918..5f64fd69 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -64,7 +64,7 @@ clonedFrom reposource = property ("Propellor repo cloned from " ++ sourcedesc) $ -- 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)" + , "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)" , "rm -rf " ++ tmpclone ] , assumeChange $ exposeTrueLocaldir $ const $ -- cgit v1.3-2-g0d8e From 6a632221a2d2d1e31859c8deb79543056224a76f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 17:50:40 -0400 Subject: avoid call stack --- src/Propellor/Spin.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') 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 -- cgit v1.3-2-g0d8e From 983ee62929037c7297e2281ea3910e94a85bead5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Apr 2017 10:52:33 -0400 Subject: reorg --- src/Propellor/Property/Bootstrap.hs | 39 ++----------------------------------- src/Propellor/Property/Chroot.hs | 33 +++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 37 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index 5f64fd69..dc1c2e0f 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -5,12 +5,13 @@ import Propellor.Bootstrap import Propellor.Property.Chroot import Data.List -import System.Posix.Directory -- | Where a propellor repository should be bootstrapped from. data RepoSource = GitRepoUrl String | GitRepoOutsideChroot + -- ^ When used in a chroot, this clones the git repository from + -- outside the chroot. -- | Bootstraps a propellor installation into -- /usr/local/propellor/ @@ -38,10 +39,6 @@ bootstrappedFrom reposource = go `requires` clonedFrom reposource -- | 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 @@ -82,38 +79,6 @@ clonedFrom reposource = property ("Propellor repo cloned from " ++ sourcedesc) $ GitRepoUrl s -> s GitRepoOutsideChroot -> localdir --- | 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 -> IO a) -> Propellor a -exposeTrueLocaldir a = ifM inChroot - ( liftIO $ withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> - bracket_ - (movebindmount localdir tmpdir) - (movebindmount tmpdir localdir) - (a tmpdir) - , liftIO $ a localdir - ) - where - movebindmount from to = 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) - assumeChange :: Propellor Bool -> Propellor Result assumeChange a = do ok <- a diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 7738d97e..96c75846 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, @@ -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 -> IO a) -> Propellor a +exposeTrueLocaldir a = ifM inChroot + ( liftIO $ withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> + bracket_ + (movebindmount localdir tmpdir) + (movebindmount tmpdir localdir) + (a tmpdir) + , liftIO $ a localdir + ) + where + movebindmount from to = 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 -- cgit v1.3-2-g0d8e From 03950541b77405b8822dd2cadb47bc249a2bb5d3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Apr 2017 11:12:17 -0400 Subject: copy git configuration into chroot --- src/Propellor/Property/Bootstrap.hs | 82 +++++++++++++++++++++++-------------- src/Propellor/Property/Chroot.hs | 8 ++-- 2 files changed, 55 insertions(+), 35 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index dc1c2e0f..5678a865 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -5,13 +5,14 @@ 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 clones the git repository from - -- outside the chroot. + -- ^ 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/ @@ -42,42 +43,61 @@ bootstrappedFrom reposource = go `requires` clonedFrom reposource -- 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 " ++ sourcedesc) $ do - ifM needclone - ( 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 - ] - , assumeChange $ exposeTrueLocaldir $ const $ +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 - [ "cd " ++ localdir - , "git pull" + [ 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 ] - ) - where + + 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 + GitRepoOutsideChroot -> localdir ++ " outside the chroot" assumeChange :: Propellor Bool -> Propellor Result assumeChange a = do @@ -87,5 +107,5 @@ assumeChange a = do buildShellCommand :: [String] -> String buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")") -runShellCommand :: String -> IO Bool +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 96c75846..5f764d47 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -304,17 +304,17 @@ newtype InChroot = InChroot Bool -- 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 -> IO a) -> Propellor a +exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a exposeTrueLocaldir a = ifM inChroot - ( liftIO $ withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> + ( withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> bracket_ (movebindmount localdir tmpdir) (movebindmount tmpdir localdir) (a tmpdir) - , liftIO $ a localdir + , a localdir ) where - movebindmount from to = do + 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.. -- 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 'src') 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 f6b2ab29f24c7399ed7ab718c541eb46bc0f24f7 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Thu, 27 Apr 2017 19:17:34 +0200 Subject: Restic: make sure the repo exists before running restic commands --- src/Propellor/Property/Restic.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs index 55a68324..668843bb 100644 --- a/src/Propellor/Property/Restic.hs +++ b/src/Propellor/Property/Restic.hs @@ -86,8 +86,7 @@ init repo = check (not <$> repoExists repo) (cmdProperty "restic" initargs) -- and then moving it to the directory. restored :: FilePath -> ResticRepo -> Property (HasInfo + DebianLike) restored dir repo = go - `requires` installed - `requires` passwordFileConfigured repo + `requires` init repo where go :: Property DebianLike go = property (dir ++ " restored by restic") $ ifM (liftIO needsRestore) @@ -146,8 +145,7 @@ backup dir repo crontimes extraargs kp = backup' dir repo crontimes extraargs kp backup' :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike) backup' dir repo crontimes extraargs kp = cronjob `describe` desc - `requires` installed - `requires` passwordFileConfigured repo + `requires` init repo where desc = val repo ++ " restic backup" cronjob = Cron.niceJob ("restic_backup" ++ dir) crontimes (User "root") "/" $ -- cgit v1.3-2-g0d8e From 1b7abb5d209e4bdb66737f7fbdbc312e7802f081 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 27 Apr 2017 16:31:18 -0400 Subject: few little things --- src/Propellor/Property/Restic.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs index 668843bb..ef867de3 100644 --- a/src/Propellor/Property/Restic.hs +++ b/src/Propellor/Property/Restic.hs @@ -40,7 +40,7 @@ installed = withOS desc $ \w o -> case o of _ -> ensureProperty w $ Apt.installed ["restic"] where - desc = "installed restic" + desc = "installed restic" repoExists :: ResticRepo -> IO Bool repoExists repo = boolSystem "restic" @@ -119,7 +119,7 @@ restored dir repo = go ) -- | Installs a cron job that causes a given directory to be backed --- up, by running borg with some parameters. +-- 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. @@ -192,7 +192,7 @@ 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. +-- backups meeting any policy are kept. See restic's man page for details. data KeepPolicy = KeepLast Int | KeepHours Int -- cgit v1.3-2-g0d8e From b06edbda0478ed57954d716f64f6870d7ae68f63 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Fri, 28 Apr 2017 00:19:46 +0200 Subject: Restic: fix bug in shell escaping --- src/Propellor/Property/Restic.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs index 668843bb..02b2ead0 100644 --- a/src/Propellor/Property/Restic.hs +++ b/src/Propellor/Property/Restic.hs @@ -149,17 +149,17 @@ backup' dir repo crontimes extraargs kp = cronjob where desc = val repo ++ " restic backup" cronjob = Cron.niceJob ("restic_backup" ++ dir) crontimes (User "root") "/" $ - "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd lockfile = "/var/lock/propellor-restic.lock" - backupcmd = intercalate ";" $ + backupcmd = intercalate " && " $ createCommand : if null kp then [] else [pruneCommand] createCommand = unwords $ [ "restic" , "-r" - , val repo + , shellEscape (val repo) , "--password-file" - , getPasswordFile repo + , shellEscape (getPasswordFile repo) ] ++ map shellEscape extraargs ++ [ "backup" @@ -168,9 +168,9 @@ backup' dir repo crontimes extraargs kp = cronjob pruneCommand = unwords $ [ "restic" , "-r" - , val repo + , shellEscape (val repo) , "--password-file" - , getPasswordFile repo + , shellEscape (getPasswordFile repo) , "forget" , "--prune" ] -- 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 'src') 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 fa5cbd91f46e35ece6d9cd64230a831dade042c0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 16 May 2017 01:06:26 -0400 Subject: merge fixes from git-annex --- src/Utility/DataUnits.hs | 8 ++++++-- src/Utility/FileSystemEncoding.hs | 2 ++ src/Utility/Path.hs | 14 +++++++++----- src/Utility/Split.hs | 2 ++ 4 files changed, 19 insertions(+), 7 deletions(-) (limited to 'src') 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/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs index 862f0721..444dc4a9 100644 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -21,6 +21,8 @@ module Utility.FileSystemEncoding ( truncateFilePath, s2w8, w82s, + c2w8, + w82c, ) where import qualified GHC.Foreign as GHC diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs index 2383ad06..0779d167 100644 --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -27,6 +27,7 @@ import Utility.Exception 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. @@ -75,11 +76,13 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: FilePath -> Maybe FilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive $ joinPath $ 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) $ splitPath path + s = [pathSeparator] + dirs = filter (not . null) $ split s path prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir @@ -136,8 +139,9 @@ relPathDirToFileAbs from to | takeDrive from /= takeDrive to = to | otherwise = joinPath $ dotdots ++ uncommon where - pfrom = splitPath from - pto = splitPath 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 diff --git a/src/Utility/Split.hs b/src/Utility/Split.hs index b3e5e276..decfe7d3 100644 --- a/src/Utility/Split.hs +++ b/src/Utility/Split.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.Split where import Data.List (intercalate) -- cgit v1.3-2-g0d8e