diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2016-05-24 15:10:49 +0900 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2016-05-24 15:10:49 +0900 |
commit | cf2b9664c12a14b71046b7c762ec77aa48047652 (patch) | |
tree | 57c1d2763560d99874156863ea87ff34c6736bfd | |
parent | 6f6e8457296c28939d729c0d00310c1045551faa (diff) | |
parent | 23c0efee2ebf3575840e75af115a782cb447dd87 (diff) |
Merge tag '3.0.4' into debian
tagging package propellor version 3.0.4
34 files changed, 495 insertions, 31 deletions
diff --git a/debian/changelog b/debian/changelog index c88159cd..bab6d596 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,14 @@ +propellor (3.0.4) unstable; urgency=medium + + * Run letsencrypt with --noninteractive. + * Fix build with ghc 8.0.1. + Thanks, davean. + * Module added for the Borg backup system. + Thanks, Félix Sipma. + * Fix build with directory-1.2.6.2. + + -- Joey Hess <id@joeyh.name> Sun, 22 May 2016 15:54:49 -0400 + propellor (3.0.3-2) unstable; urgency=medium * Use CDBS & haskell-devscripts to build new binary packages diff --git a/doc/coding_style.mdwn b/doc/coding_style.mdwn index 92553d76..bf127fe0 100644 --- a/doc/coding_style.mdwn +++ b/doc/coding_style.mdwn @@ -2,6 +2,20 @@ If you do nothing else, avoid use of partial functions from the Prelude! `import Utility.PartialPrelude` helps avoid this by defining conflicting functions for all the common ones. Also avoid `!!`, it's partial too. +The rest of this coding style is followed to keep the code in Propellor +consistent. You don't have to follow these rules in your own config.hs, or +in Propellor modules that you don't intend to get merged into mainstrain +Propellor. + +Start a module with a comment indicating what software it provides +properties for, and who maintains the module. + + -- | Maintainer: Your Name Here <optional-email-address@example.org> + -- + -- Support for the Foo daemon <https://foo.example.com/> + + module Propellor.Property.Foo + Use tabs for indentation. Code should make sense with any tab stop setting, but 8 space tabs are diff --git a/doc/forum/recent_propellor_snapshots_cause_ghc_OOMs.mdwn b/doc/forum/recent_propellor_snapshots_cause_ghc_OOMs.mdwn new file mode 100644 index 00000000..3dc6c7c8 --- /dev/null +++ b/doc/forum/recent_propellor_snapshots_cause_ghc_OOMs.mdwn @@ -0,0 +1,6 @@ +With recent snapshots of propellor (after at least March 11) I am seeing significant increases of memory consumed by ghc when compiling propellor. Previous versions would compile and run on e.g. a raspberry pi. With a recent snapshot, I am seeing ghc OOM with a 5GB ulimit on my desktop. Has anybody else seen this? + +This is with the same version of GHC. + + % ghc --version + The Glorious Glasgow Haskell Compilation System, version 7.10.3 diff --git a/doc/forum/recent_propellor_snapshots_cause_ghc_OOMs/comment_1_0e46ad1844c37a65c532cafe81fd883a._comment b/doc/forum/recent_propellor_snapshots_cause_ghc_OOMs/comment_1_0e46ad1844c37a65c532cafe81fd883a._comment new file mode 100644 index 00000000..be42b0df --- /dev/null +++ b/doc/forum/recent_propellor_snapshots_cause_ghc_OOMs/comment_1_0e46ad1844c37a65c532cafe81fd883a._comment @@ -0,0 +1,13 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 1""" + date="2016-05-10T16:07:39Z" + content=""" +The enhanced property types in propellor 3.0 are known to have made ghc use +more memory when building it. Building with -O0 helped a lot for me, and +it's doing ok on a 500 mb memory machine. So I recommend -O0 in your cabal +file if you don't have that already. + +I wrote down my memory benchmarks here: +<http://source.propellor.branchable.com/?p=source.git;a=commit;h=af7b2d61c0c7f9b4fe53d8f5d18b5426a93cbd7b> +"""]] diff --git a/doc/news/version_3.0.2.mdwn b/doc/news/version_3.0.2.mdwn deleted file mode 100644 index 4a36d250..00000000 --- a/doc/news/version_3.0.2.mdwn +++ /dev/null @@ -1,10 +0,0 @@ -propellor 3.0.2 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Added Apt.periodicUpdates. - Thanks, Félix Sipma. - * Apt.unattendedUpgrades: Enable mailing problem reports to root. - Thanks, Félix Sipma. - * Added Propellor.Property.Fstab, and moved the fstabbed property to there. - * Attic module added for the backup system. - Thanks, Félix Sipma. - * Fix build with directory-1.2.6.2."""]]
\ No newline at end of file diff --git a/doc/news/version_3.0.3.mdwn b/doc/news/version_3.0.3.mdwn new file mode 100644 index 00000000..75ea3c33 --- /dev/null +++ b/doc/news/version_3.0.3.mdwn @@ -0,0 +1,6 @@ +propellor 3.0.3 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Remove Propellor.DotDir from the propellor library, as its use of + Paths\_propellor prevents use of the module out of propellor's tree. + This module is only needed for the wrapper program anyway, which + handles --init."""]]
\ No newline at end of file diff --git a/doc/todo/License_in_propellor.cabal.mdwn b/doc/todo/License_in_propellor.cabal.mdwn new file mode 100644 index 00000000..90a0e8f8 --- /dev/null +++ b/doc/todo/License_in_propellor.cabal.mdwn @@ -0,0 +1,3 @@ +`propellor.cabal` claims that propellor is licensed under the 3-clause BSD license. `debian/copyright` says it's licensed under the 2-clause BSD license. Which is correct? An ftp-master noticed. Thanks. --spwhitton + +> [[fixed|done]] --[[Joey]] diff --git a/doc/todo/License_in_propellor.cabal/comment_1_3009093e2ab7bcf9e60555da71796a63._comment b/doc/todo/License_in_propellor.cabal/comment_1_3009093e2ab7bcf9e60555da71796a63._comment new file mode 100644 index 00000000..3ea7af89 --- /dev/null +++ b/doc/todo/License_in_propellor.cabal/comment_1_3009093e2ab7bcf9e60555da71796a63._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 1""" + date="2016-05-10T16:06:12Z" + content=""" +It's 2-clause, see LICENSE. + +Cabal file license fields are too restricted syntax to be more than +a general indication of license in general I think. +"""]] diff --git a/doc/todo/merge_request:_Propellor.Property.Sbuild.mdwn b/doc/todo/merge_request:_Propellor.Property.Sbuild.mdwn new file mode 100644 index 00000000..3156fdb4 --- /dev/null +++ b/doc/todo/merge_request:_Propellor.Property.Sbuild.mdwn @@ -0,0 +1,18 @@ +Please consider merging branch `sbuild` of repository `https://git.spwhitton.name/propellor`. + +This branch adds the following features: + +- A new module `Propellor.Property.Sbuild` with properties for configuring sbuild schroots +- A new module `Propellor.Property.Schroot` with a property supporting those in `Propellor.Property.Sbuild` +- A new module `Propellor.Property.Ccache` with a property supporting those in `Propellor.Property.Sbuild` +- An export of `extractSuite` from `Propellor.Property.Debootstrap`, used in `Propellor.Property.Sbuild` +- Two new types of iptables matching rules in `Propellor.Property.Firewall`. + +The additions to `Propellor.Property.Firewall` were made to support `Sbuild.blockNetwork`, which is a hack from the Debian Wiki which doesn't seem to work with the latest version of sbuild. I left the additions to `Propellor.Property.Firewall` in my branch since they are probably independently useful. I left the `blockNetwork` property commented-out in `Sbuild.hs` in case I or someone else can make it work at a later date. + +I get the following strange warning from GHC thanks to my new export from `Propellor.Property.Debootstrap`. I can't figure out the problem and would be grateful for help. + + src/Propellor/Property/Debootstrap.hs:8:9: Warning: + `extractSuite' is exported by `extractSuite' and `extractSuite' + +--spwhitton diff --git a/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_1_b3343283b2d7d49ab70a95d762d0e081._comment b/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_1_b3343283b2d7d49ab70a95d762d0e081._comment new file mode 100644 index 00000000..89583ffc --- /dev/null +++ b/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_1_b3343283b2d7d49ab70a95d762d0e081._comment @@ -0,0 +1,25 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 1""" + date="2016-05-21T17:41:11Z" + content=""" +Re not running propellor in the sbuild chroot, I have in the past used +schroot for things where it would have made sense to run propellor +in the chroot. OTOH, systemd-container is a better fit for such uses cases +now, probably. + +Is the ~/.sbuildrc necessary to use the sbuild properties? If so, +would it make sense to have a property that configures it? + +You could use Utility.DataUnits for Ccache's MaxSize. This would be +more flexible and consistent with other things in propellor. + +Limit could be a monoid. This would perhaps simplify hasGroupCache +as it could only be used once to set multiple limits. + +Maybe instead of Ccache.hasGroupCache, call it Ccache.hasCache? + +That is a weird build warning! But, I don't see it with ghc 7.10.3. +Normally you'd see that warning when the module's export list exported the same +symbol twice. +"""]] diff --git a/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_2_d8afe7b1fd49df5794c9abf2be732f8b._comment b/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_2_d8afe7b1fd49df5794c9abf2be732f8b._comment new file mode 100644 index 00000000..44a2a542 --- /dev/null +++ b/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_2_d8afe7b1fd49df5794c9abf2be732f8b._comment @@ -0,0 +1,58 @@ +[[!comment format=mdwn + username="spwhitton" + subject="comment 2" + date="2016-05-22T01:48:27Z" + content=""" +Thanks for your feedback. + +> Re not running propellor in the sbuild chroot, I have in the past used +> schroot for things where it would have made sense to run propellor in +> the chroot. OTOH, systemd-container is a better fit for such uses +> cases now, probably. + +I was thinking that if someone wanted to use a schroot and run +propellor in it, useful properties could be appended to +`Propellor.Property.Schroot`. As far as types go, I think that the +types in `Propellor.Property.Chroot` would be sufficient. + +> Is the ~/.sbuildrc necessary to use the sbuild properties? If so, +> would it make sense to have a property that configures it? + +The only probably which *needs* the suggested ~/.sbuildrc is +`Sbuild.piupartsConfFor`. With the other properties and no +~/.sbuildrc, you should be able to go ahead and use sbuild(1) to +perform a clean build. + +I don't think there is a way to write a non-intrusive property to add +anything to a user's ~/.sbuildrc. That's because they will probably +have different preferences for the options to pass to piuparts than I +give in the example, and we would have to merge the adt-run code with +any existing post-build-commands. I'm not sure propellor should have +a perl config file parser. + +> You could use Utility.DataUnits for Ccache's MaxSize. This would be +> more flexible and consistent with other things in propellor. + +Done. + +> Limit could be a monoid. This would perhaps simplify hasGroupCache as +> it could only be used once to set multiple limits. + +Done. + +> Maybe instead of Ccache.hasGroupCache, call it Ccache.hasCache? + +Done, I think that's better. I was originally thinking that the name +`Ccache.hasCache` might be for a property `User -> Property +DebianLike`. However, if someone wanted to write a property configuring +a user cache, it would probably have the standard location +`~/.ccache`. This cache would be implicitly created when required, so +the name `Ccache.hasCache` would be needed. + +> That is a weird build warning! But, I don't see it with ghc +> 7.10.3. Normally you'd see that warning when the module's export list +> exported the same symbol twice. + +I'm on GHC 7.10.3, too... + +"""]] diff --git a/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_3_679468488a88f0a3f28ea0be548691a0._comment b/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_3_679468488a88f0a3f28ea0be548691a0._comment new file mode 100644 index 00000000..7d5da612 --- /dev/null +++ b/doc/todo/merge_request:_Propellor.Property.Sbuild/comment_3_679468488a88f0a3f28ea0be548691a0._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 1""" + date="2016-05-22T17:53:42Z" + content=""" +Would it make sense to move the ~/.sbuildrc example into the documentation +for the property that uses it? +"""]] diff --git a/doc/todo/propellor_--init_option_B_failure.mdwn b/doc/todo/propellor_--init_option_B_failure.mdwn new file mode 100644 index 00000000..f706cba6 --- /dev/null +++ b/doc/todo/propellor_--init_option_B_failure.mdwn @@ -0,0 +1,41 @@ +[[!tag user/spwhitton]] + +With 3.0.1, 3.0.2 or 3.0.3: + + artemis ~ % propellor --init + + + _ ______`| ,-.__ + .--------------------------- / \___-=O`/|O`/__| (____.' + - Welcome to -- \ / | / ) _.-'-._ + - Propellor! -- `/-==__ _/__|/__=-| ( \_ + `--------------------------- * \ | | '--------' + (o) ` + + + Propellor's configuration file is ~/.propellor/config.hs + + Let's get you started with a simple config that you can adapt + to your needs. You can start with: + A: A clone of propellor's git repository (most flexible) + B: The bare minimum files to use propellor (most simple) + Which would you prefer? [A|B] B + Initialized empty Git repository in /home/swhitton/.propellor/.git/ + Creating minimal config ... done + + ------------------------------------------------------------------------------ + + Let's try building the propellor configuration, to make sure it will work... + + Writing a default package environment file to + /home/swhitton/.propellor/cabal.sandbox.config + Creating a new sandbox at /home/swhitton/.propellor/.cabal-sandbox + Resolving dependencies... + Configuring config-0... + cabal: At least the following dependencies are missing: + propellor >=3.0 + propellor: failed to make dist/setup-config + +(propellor installed from Debian) + +: This is in the NEW queue. [[done]] --spwhitton diff --git a/doc/todo/propellor_--init_option_B_failure/comment_1_f2229a499f4be0e64d030e2ecc0927f6._comment b/doc/todo/propellor_--init_option_B_failure/comment_1_f2229a499f4be0e64d030e2ecc0927f6._comment new file mode 100644 index 00000000..e9edb435 --- /dev/null +++ b/doc/todo/propellor_--init_option_B_failure/comment_1_f2229a499f4be0e64d030e2ecc0927f6._comment @@ -0,0 +1,16 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 1""" + date="2016-05-02T12:03:24Z" + content=""" +You need to update the Debian package to include the propellor +haskell library in binary form. I had not included the haskell library in +the package before in binary form, because I was targeting only option A, +where it's cloned from the git archive in the package. + +Any other installation method than the debian package that I know of +installs both the propellor command and the propellor haskell library. + +(Note that propellor 3.0.1^W3.0.3 fixes an unrelated bug that prevented option B +from working.) +"""]] diff --git a/doc/todo/spin_without_remote_compilation/comment_3_3b1053891d1bd9c424f1b517a4686e5d._comment b/doc/todo/spin_without_remote_compilation/comment_3_3b1053891d1bd9c424f1b517a4686e5d._comment new file mode 100644 index 00000000..096d20aa --- /dev/null +++ b/doc/todo/spin_without_remote_compilation/comment_3_3b1053891d1bd9c424f1b517a4686e5d._comment @@ -0,0 +1,7 @@ +[[!comment format=mdwn + username="spwhitton" + subject="comment 3" + date="2016-05-14T01:37:11Z" + content=""" +This feature has become more poignant with propellor v3's increased memory requirements. +"""]] diff --git a/doc/todo/spin_without_remote_compilation/comment_4_0e98f5ea8af2e14ead239e5b777afb26._comment b/doc/todo/spin_without_remote_compilation/comment_4_0e98f5ea8af2e14ead239e5b777afb26._comment new file mode 100644 index 00000000..28307a2d --- /dev/null +++ b/doc/todo/spin_without_remote_compilation/comment_4_0e98f5ea8af2e14ead239e5b777afb26._comment @@ -0,0 +1,14 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 4""" + date="2016-05-21T17:06:37Z" + content=""" +There's a patch implementing this now, in: + + https://git.gueux.org/propellor.git precompiled + +I have not found the increased memory too onerous, it's still working +down to 500 mb cheap VMs. So I'm looking for details about cases where +it causes ghc to use too much memory. +<http://propellor.branchable.com/forum/recent_propellor_snapshots_cause_ghc_OOMs/> +"""]] diff --git a/doc/todo/use_ghc_8.0_custom_compile_errors.mdwn b/doc/todo/use_ghc_8.0_custom_compile_errors.mdwn new file mode 100644 index 00000000..7eed443a --- /dev/null +++ b/doc/todo/use_ghc_8.0_custom_compile_errors.mdwn @@ -0,0 +1,27 @@ +<https://downloads.haskell.org/~ghc/8.0.1/docs/html/users_guide/glasgow_exts.html#custom-errors> + +This could be used in propellor to improve compile time errors. + +For example, a RevertableProperty is sometimes used where only a regular +Property is accepted. In this case, the error could suggest that the user +apply `setupRevertableProperty` to extract the setup side of the RevertableProperty. + +And, when a Property HasInfo is provided to ensureProperty, propellor could +explain, in the compile error, why it can't let the user do that. + +Custom errors need a type class to be used. So, could do something like this: + + class NeedsProperty a where + withProperty :: (Property metatype -> b) -> b + + instance NeedsProperty (Property metatype) where withProperty = id + + instance TypeError (Text "Use setupRevertableProperty ...") + => NeedsProperty RevertableProperty where + withProperty = error "unreachable" + +(While propellor needs to be buildable with older versions of ghc, +the `instance TypeError` can just be wrapped in an ifdef to make it only be +used by the new ghc.) + +[[!tag user/joey]] diff --git a/propellor.cabal b/propellor.cabal index e931e3df..e6279aef 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,7 +1,7 @@ Name: propellor -Version: 3.0.3 +Version: 3.0.4 Cabal-Version: >= 1.8 -License: BSD3 +License: BSD2 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable @@ -81,6 +81,7 @@ Library Propellor.Property.Apt Propellor.Property.Apt.PPA Propellor.Property.Attic + Propellor.Property.Borg Propellor.Property.Cmd Propellor.Property.Concurrent Propellor.Property.Conductor @@ -206,6 +207,7 @@ Library Utility.Process.NonConcurrent Utility.SafeCommand Utility.Scheduled + Utility.SystemDirectory Utility.Table Utility.ThreadScheduler Utility.Tmp diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs index 2a0f5cbc..ae75589f 100644 --- a/src/Propellor/Base.hs +++ b/src/Propellor/Base.hs @@ -20,7 +20,7 @@ module Propellor.Base ( , module Propellor.Utilities -- * System modules - , module System.Directory + , module Utility.SystemDirectory , module System.IO , module System.FilePath , module Data.Maybe @@ -47,7 +47,7 @@ import Propellor.PropAccum import Propellor.Location import Propellor.Utilities -import System.Directory +import Utility.SystemDirectory import System.IO import System.FilePath import Data.Maybe diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index d9fa8ec7..fcac60bf 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -78,9 +78,3 @@ Props c &^ p = Props (toChildProperty p : c) -> RevertableProperty (MetaTypes y) (MetaTypes z) -> Props (MetaTypes (Combine x z)) Props c ! p = Props (c ++ [toChildProperty (revert p)]) - --- addPropsHost :: Host -> [Prop] -> Host --- addPropsHost (Host hn ps i) p = Host hn ps' i' --- where --- ps' = ps ++ [toChildProperty p] --- i' = i <> getInfoRecursive p diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs index 26f23500..4415f8c0 100644 --- a/src/Propellor/Property/Attic.hs +++ b/src/Propellor/Property/Attic.hs @@ -1,4 +1,6 @@ -- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Support for the Attic backup tool <https://attic-backup.org/> module Propellor.Property.Attic ( installed diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs new file mode 100644 index 00000000..f5842115 --- /dev/null +++ b/src/Propellor/Property/Borg.hs @@ -0,0 +1,155 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Support for the Borg backup tool <https://github.com/borgbackup> + +module Propellor.Property.Borg + ( 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 Data.List (intercalate) + +type BorgParam = String + +type BorgRepo = FilePath + +installed :: Property DebianLike +installed = withOS desc $ \w o -> case o of + (Just (System (Debian (Stable "jessie")) _)) -> ensureProperty w $ + Apt.installedBackport ["borgbackup"] + _ -> ensureProperty w $ + Apt.installed ["borgbackup"] + where + desc = "installed borgbackup" + +repoExists :: BorgRepo -> IO Bool +repoExists repo = boolSystem "borg" [Param "list", File repo] + +-- | Inits a new borg repository +init :: BorgRepo -> Property DebianLike +init backupdir = check (not <$> repoExists backupdir) (cmdProperty "borg" initargs) + `requires` installed + where + initargs = + [ "init" + , backupdir + ] + +-- | Restores a directory from an borg 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 -> BorgRepo -> Property DebianLike +restored dir backupdir = go `requires` installed + where + go :: Property DebianLike + go = property (dir ++ " restored by borg") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do + ok <- boolSystem "borg" $ + [ Param "extract" + , Param backupdir + , Param 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: +-- +-- > & Borg.backup "/srv/git" "root@myserver:/mnt/backup/git.borg" Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Borg.KeepDays 7, Borg.KeepWeeks 4, Borg.KeepMonths 6, Borg.KeepYears 1] +-- +-- Note that this property does not make borg encrypt the backup +-- repository. +-- +-- Since borg uses a fair amount of system resources, only one borg +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike +backup dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp + `requires` restored dir backupdir + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike +backup' dir backupdir crontimes extraargs kp = cronjob + `describe` desc + `requires` installed + where + desc = backupdir ++ " borg backup" + cronjob = Cron.niceJob ("borg_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + lockfile = "/var/lock/propellor-borg.lock" + backupcmd = intercalate ";" $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "borg" + , "create" + , "--stats" + ] + ++ map shellEscape extraargs ++ + [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "borg" + , "prune" + , shellEscape backupdir + ] + ++ + map keepParam kp + +-- | Constructs an BorgParam 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 borg prune to clean out +-- generations not specified here. +keepParam :: KeepPolicy -> BorgParam +keepParam (KeepHours n) = "--keep-hourly=" ++ show n +keepParam (KeepDays n) = "--keep-daily=" ++ show n +keepParam (KeepWeeks n) = "--keep-daily=" ++ show n +keepParam (KeepMonths n) = "--keep-monthly=" ++ show n +keepParam (KeepYears n) = "--keep-yearly=" ++ show 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 + = KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs index bf38046b..592a1e1d 100644 --- a/src/Propellor/Property/LetsEncrypt.hs +++ b/src/Propellor/Property/LetsEncrypt.hs @@ -1,4 +1,5 @@ --- | This module uses the letsencrypt reference client. +-- | This module gets LetsEncrypt <https://letsencrypt.org/> certificates +-- using CertBot <https://certbot.eff.org/> module Propellor.Property.LetsEncrypt where @@ -7,6 +8,8 @@ import qualified Propellor.Property.Apt as Apt import System.Posix.Files +-- Not using the certbot name yet, until it reaches jessie-backports and +-- testing. installed :: Property DebianLike installed = Apt.installed ["letsencrypt"] @@ -74,6 +77,7 @@ letsEncrypt' (AgreeTOS memail) domain domains webroot = , "--webroot" , "--webroot-path", webroot , "--text" + , "--noninteractive" , "--keep-until-expiring" ] ++ map (\d -> "--domain="++d) alldomains diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs index 6d6f4a7f..5bf3ff06 100644 --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -1,3 +1,5 @@ +-- | Support for the Obnam backup tool <http://obnam.org/> + module Propellor.Property.Obnam where import Propellor.Base diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index ce89b94a..b4812c7e 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -135,6 +135,8 @@ stackAutoBuilder suite arch flavor = & User.accountFor (User builduser) & tree arch flavor & stackInstalled + -- Workaround https://github.com/commercialhaskell/stack/issues/2093 + & Apt.installed ["libtinfo-dev"] stackInstalled :: Property Linux stackInstalled = withOS "stack installed" $ \w o -> diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs index 8784c641..3ce4b22c 100644 --- a/src/Propellor/Types/ZFS.hs +++ b/src/Propellor/Types/ZFS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstrainedClassMethods #-} -- | Types for ZFS Properties. -- -- Copyright 2016 Evan Cofsky <evan@theunixman.com> diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs index 3b12b9fc..693e7713 100644 --- a/src/Utility/Directory.hs +++ b/src/Utility/Directory.hs @@ -6,15 +6,14 @@ -} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs -w #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory ( module Utility.Directory, - module System.Directory + module Utility.SystemDirectory ) where import System.IO.Error -import System.Directory hiding (isSymbolicLink) import Control.Monad import System.FilePath import Control.Applicative @@ -31,6 +30,7 @@ import Utility.SafeCommand import Control.Monad.IfElse #endif +import Utility.SystemDirectory import Utility.PosixFiles import Utility.Tmp import Utility.Exception diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs index 8b110ae6..e691f13b 100644 --- a/src/Utility/Exception.hs +++ b/src/Utility/Exception.hs @@ -21,7 +21,8 @@ module Utility.Exception ( tryNonAsync, tryWhenExists, catchIOErrorType, - IOErrorType(..) + IOErrorType(..), + catchPermissionDenied, ) where import Control.Monad.Catch as X hiding (Handler) @@ -97,3 +98,6 @@ catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching onlymatching e | ioeGetErrorType e == errtype = onmatchingerr e | otherwise = throwM e + +catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a +catchPermissionDenied = catchIOErrorType PermissionDenied diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs index efef5fa2..bb3780c6 100644 --- a/src/Utility/FileMode.hs +++ b/src/Utility/FileMode.hs @@ -18,9 +18,10 @@ import System.PosixCompat.Types import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files +import Control.Monad.IO.Class (liftIO) #endif +import Control.Monad.IO.Class (MonadIO) import Foreign (complement) -import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Catch import Utility.Exception diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs index 67341d37..eab98337 100644 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -19,6 +19,7 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, + setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -164,3 +165,10 @@ truncateFilePath n = reverse . go [] n . L8.fromString else go (c:coll) (cnt - x') (L8.drop 1 bs) _ -> coll #endif + +{- This avoids ghc's output layer crashing on invalid encoded characters in + - filenames when printing them out. -} +setConsoleEncoding :: IO () +setConsoleEncoding = do + fileEncoding stdout + fileEncoding stderr diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs index 4550bebd..37253da2 100644 --- a/src/Utility/PosixFiles.hs +++ b/src/Utility/PosixFiles.hs @@ -1,6 +1,6 @@ {- POSIX files (and compatablity wrappers). - - - This is like System.PosixCompat.Files, except with a fixed rename. + - This is like System.PosixCompat.Files, but with a few fixes. - - Copyright 2014 Joey Hess <id@joeyh.name> - @@ -21,6 +21,7 @@ import System.PosixCompat.Files as X hiding (rename) import System.Posix.Files (rename) #else import qualified System.Win32.File as Win32 +import qualified System.Win32.HardLink as Win32 #endif {- System.PosixCompat.Files.rename on Windows calls renameFile, @@ -32,3 +33,10 @@ import qualified System.Win32.File as Win32 rename :: FilePath -> FilePath -> IO () rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING #endif + +{- System.PosixCompat.Files.createLink throws an error, but windows + - does support hard links. -} +#ifdef mingw32_HOST_OS +createLink :: FilePath -> FilePath -> IO () +createLink = Win32.createHardLink +#endif diff --git a/src/Utility/SystemDirectory.hs b/src/Utility/SystemDirectory.hs new file mode 100644 index 00000000..3dd44d19 --- /dev/null +++ b/src/Utility/SystemDirectory.hs @@ -0,0 +1,16 @@ +{- System.Directory without its conflicting isSymbolicLink + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +-- Disable warnings because only some versions of System.Directory export +-- isSymbolicLink. +{-# OPTIONS_GHC -fno-warn-tabs -w #-} + +module Utility.SystemDirectory ( + module System.Directory +) where + +import System.Directory hiding (isSymbolicLink) diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs index 7610f6cc..6a541cfe 100644 --- a/src/Utility/Tmp.hs +++ b/src/Utility/Tmp.hs @@ -11,9 +11,9 @@ module Utility.Tmp where import System.IO -import System.Directory import Control.Monad.IfElse import System.FilePath +import System.Directory import Control.Monad.IO.Class #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp) diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs index 7e94cafa..c6010116 100644 --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -17,9 +17,7 @@ module Utility.UserInfo ( import Utility.Env import System.PosixCompat -#ifndef mingw32_HOST_OS import Control.Applicative -#endif import Prelude {- Current user's home directory. @@ -58,6 +56,6 @@ myVal envvars extract = go envvars #ifndef mingw32_HOST_OS go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) #else - go [] = error $ "environment not set: " ++ show envvars + go [] = extract <$> error ("environment not set: " ++ show envvars) #endif go (v:vs) = maybe (go vs) return =<< getEnv v |