summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore4
-rw-r--r--Makefile35
-rw-r--r--debian/changelog10
-rw-r--r--doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_4_294fcbae675879cb81aeb8d37cf3b635._comment13
-rw-r--r--doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_5_c627ddd43a68235e749b3025b2b6a51a._comment18
-rw-r--r--doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_6_00f48f55d8a48a7799d81d40bfe11921._comment13
-rw-r--r--doc/forum/Branch_not_signed_with_trusted_gpg_key_warning/comment_1_2b0f428151a6d338250c44549791395f._comment13
-rw-r--r--doc/forum/CUPS_configuration.mdwn3
-rw-r--r--doc/forum/DNS_for_LAN/comment_1_cc8b39a2344a74a32d821c59b499634a._comment8
-rw-r--r--doc/forum/DNS_for_LAN/comment_2_bd310b1f5865a2d35502721e138ca091._comment15
-rw-r--r--doc/forum/Error_trying_to_remove_a_key.mdwn8
-rw-r--r--doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__.mdwn1
-rw-r--r--doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__/comment_1_6271f4830c2a5bcc2bf296c32630bcba._comment28
-rw-r--r--doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__/comment_2_eb46e45efa0f40dbbc0a7471002eb97d._comment8
-rw-r--r--doc/forum/recommendations_for_setting_up__a_Fedora_chroot_on_a_Debian_host.mdwn9
-rw-r--r--doc/forum/ssh__95__known__95__hosts.mdwn1
-rw-r--r--doc/forum/ssh__95__known__95__hosts/comment_1_9447b1382bf54e6f4620bae200a62238._comment27
-rw-r--r--doc/news/version_5.10.2.mdwn10
-rw-r--r--doc/news/version_5.7.0.mdwn20
-rw-r--r--doc/todo/Default_of_new_style_builds_breaks_Bootstrap.OSOnly.mdwn29
-rw-r--r--doc/todo/Default_of_new_style_builds_breaks_Bootstrap.OSOnly/comment_1_b09c0c736838132b7dd69a1c510ff877._comment13
-rw-r--r--doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored.mdwn11
-rw-r--r--doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_1_4a662d7ab4f49a914718ca6e6f69ee86._comment29
-rw-r--r--doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_2_0a595f3481c37280bf3d9d9545b2e954._comment10
-rw-r--r--doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_3_c605e8c4b6e13fb1a5168ad34c3c7f46._comment16
-rw-r--r--doc/todo/Support_for_mirroring_bare_git_repos.mdwn2
-rw-r--r--doc/todo/Support_for_mirroring_bare_git_repos/comment_1_f8d0ade5f31f85c1db50b3ec6a9a3818._comment19
-rw-r--r--doc/todo/cabal_new-build_cruft.mdwn17
-rw-r--r--doc/todo/depend_on_concurrent-output.mdwn23
-rw-r--r--src/Propellor/Bootstrap.hs34
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs44
-rw-r--r--src/Propellor/Types/Dns.hs2
-rw-r--r--src/Propellor/Wrapper.hs1
-rw-r--r--src/System/Console/Concurrent.hs10
-rw-r--r--src/System/Console/Concurrent/Internal.hs187
-rw-r--r--src/System/Process/Concurrent.hs16
-rw-r--r--src/Utility/Process/Shim.hs3
37 files changed, 513 insertions, 197 deletions
diff --git a/.gitignore b/.gitignore
index d9285db3..50258d53 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,6 +1,9 @@
/propellor
+/propellor.built
dist/*
+dist-newstyle/*
tags
+configured
privdata/local
privdata/keyring.gpg~
Setup
@@ -15,4 +18,5 @@ propellor.1
.cabal-sandbox/
.dir-locals.el
cabal.sandbox.config
+cabal.project.local
*~
diff --git a/Makefile b/Makefile
index 0e4b2ca3..2d55cc44 100644
--- a/Makefile
+++ b/Makefile
@@ -1,35 +1,43 @@
CABAL?=cabal
DATE := $(shell dpkg-parsechangelog 2>/dev/null | grep Date | cut -d " " -f2-)
-build: tags propellor.1 dist/setup-config
+build: tags propellor.1 configured
$(CABAL) build
- ln -sf dist/build/propellor-config/propellor-config propellor
+ @if [ -d dist-newstyle ]; then \
+ ln -sf $$(cabal exec -- sh -c 'command -v propellor-config') propellor; \
+ else \
+ ln -sf dist/build/propellor-config/propellor-config propellor; \
+ fi
install:
install -d $(DESTDIR)/usr/bin $(DESTDIR)/usr/src/propellor
- install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor
- mkdir -p dist/gittmp
- $(CABAL) sdist
- cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1)
+ if [ -d dist-newstyle ]; then \
+ install -s $$(cabal exec -- sh -c 'command -v propellor') $(DESTDIR)/usr/bin/propellor; \
+ else \
+ install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor; \
+ fi
+ mkdir -p gittmp
+ $(CABAL) sdist -o - | (cd gittmp && tar zx --strip-components=1)
# cabal sdist does not preserve symlinks, so copy over file
- cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done
+ cd gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../$$f $$f; done
# reset mtime on files in git bundle so bundle is reproducible
- find dist/gittmp -print0 | xargs -0r touch --no-dereference --date="$(DATE)"
+ find gittmp -print0 | xargs -0r touch --no-dereference --date="$(DATE)"
export GIT_AUTHOR_NAME=build \
&& export GIT_AUTHOR_EMAIL=build@buildhost \
&& export GIT_AUTHOR_DATE="$(DATE)" \
&& export GIT_COMMITTER_NAME=build \
&& export GIT_COMMITTER_EMAIL=build@buildhost \
&& export GIT_COMMITTER_DATE="$(DATE)" \
- && cd dist/gittmp && git init \
+ && cd gittmp && git init \
&& git add . \
&& git commit -q -m "distributed version of propellor" \
&& git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \
&& git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head
- rm -rf dist/gittmp
+ rm -rf gittmp
clean:
- rm -rf dist Setup tags propellor propellor.1 privdata/local
+ rm -rf dist dist-newstyle configured Setup \
+ tags propellor propellor.1 privdata/local
find . -name \*.o -exec rm {} \;
find . -name \*.hi -exec rm {} \;
@@ -37,11 +45,12 @@ clean:
# duplicate tags with Propellor.Property. removed from the start, as we
# often import qualified by just the module base name.
tags:
- find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags 2>/dev/null | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags || true
+ @find . | grep -v /.git/ | grep -v /tmp/ | grep -v dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags 2>/dev/null | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags || true
-dist/setup-config: propellor.cabal
+configured: propellor.cabal
@if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi
@$(CABAL) configure
+ touch configured
propellor.1: doc/usage.mdwn doc/mdwn2man
doc/mdwn2man propellor 1 < doc/usage.mdwn > propellor.1
diff --git a/debian/changelog b/debian/changelog
index 12e78937..24bbf641 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,13 @@
+propellor (5.10.3) UNRELEASED; urgency=medium
+
+ * Fix display of concurrent output from processes when using
+ Propellor.Property.Conductor.
+ (Reversion introduced in version 5.5.0.)
+ * Support bootstrapping to hosts using cabal 3.x, with new-dist directory.
+ * Makefile: Fix build with cabal 3.x.
+
+ -- Joey Hess <id@joeyh.name> Fri, 05 Jun 2020 11:26:21 -0400
+
propellor (5.10.2) unstable; urgency=medium
* Fix build with ghc 8.6.3.
diff --git a/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_4_294fcbae675879cb81aeb8d37cf3b635._comment b/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_4_294fcbae675879cb81aeb8d37cf3b635._comment
new file mode 100644
index 00000000..726067da
--- /dev/null
+++ b/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_4_294fcbae675879cb81aeb8d37cf3b635._comment
@@ -0,0 +1,13 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2020-06-17T21:33:14Z"
+ content="""
+ cabal install --install-method=symlink --installdir=. exe:propellor --overwrite-policy=always
+
+But, this seems to do a lot of extra work, including generating a tarball
+of all the source code, and possibly building the package again
+unncessarily. And only works with a new enough cabal version.
+
+Ok, I've implemented it using `find`.
+"""]]
diff --git a/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_5_c627ddd43a68235e749b3025b2b6a51a._comment b/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_5_c627ddd43a68235e749b3025b2b6a51a._comment
new file mode 100644
index 00000000..cccac0fe
--- /dev/null
+++ b/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_5_c627ddd43a68235e749b3025b2b6a51a._comment
@@ -0,0 +1,18 @@
+[[!comment format=mdwn
+ username="david"
+ avatar="http://cdn.libravatar.org/avatar/22c2d800db6a7699139df604a67cb221"
+ subject="Same issues now on Debian testing"
+ date="2020-08-12T17:22:31Z"
+ content="""
+I had to
+
+- merge from joeyh's master branch
+- cd /usr/local/propellor
+- sudo make clean
+- sudo make
+
+in order to get things going.
+
+I would not be surprised at all to learn there is an easier way (perhaps just blowing away /usr/local/propellor)
+
+"""]]
diff --git a/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_6_00f48f55d8a48a7799d81d40bfe11921._comment b/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_6_00f48f55d8a48a7799d81d40bfe11921._comment
new file mode 100644
index 00000000..2fa6ef19
--- /dev/null
+++ b/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_6_00f48f55d8a48a7799d81d40bfe11921._comment
@@ -0,0 +1,13 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 6"""
+ date="2020-08-14T16:31:36Z"
+ content="""
+I'm curious why you needed to make clean. AFAIK the new cabal will ignore
+any cruft left by the old version and should just do a from scratch build
+on its own.
+
+Indeed, one of my hosts managed by propellor has both
+/usr/local/propellor/dist and dist-newstyle, and is building successfully
+in the latter directory.
+"""]]
diff --git a/doc/forum/Branch_not_signed_with_trusted_gpg_key_warning/comment_1_2b0f428151a6d338250c44549791395f._comment b/doc/forum/Branch_not_signed_with_trusted_gpg_key_warning/comment_1_2b0f428151a6d338250c44549791395f._comment
new file mode 100644
index 00000000..7e1c0a5d
--- /dev/null
+++ b/doc/forum/Branch_not_signed_with_trusted_gpg_key_warning/comment_1_2b0f428151a6d338250c44549791395f._comment
@@ -0,0 +1,13 @@
+[[!comment format=mdwn
+ username="sravikumar@b98554d12f31e17b71dd07098f122792ca8837ce"
+ nickname="sravikumar"
+ avatar="http://cdn.libravatar.org/avatar/227f208e95d449decbc71eccc658cdbe"
+ subject="comment 1"
+ date="2020-07-10T20:04:47Z"
+ content="""
+Resolved the issue by adding the gpg signing key again to propellor with
+
+```
+propellor --add-key SIGNING_KEY_ID
+```
+"""]]
diff --git a/doc/forum/CUPS_configuration.mdwn b/doc/forum/CUPS_configuration.mdwn
new file mode 100644
index 00000000..48e2ff4f
--- /dev/null
+++ b/doc/forum/CUPS_configuration.mdwn
@@ -0,0 +1,3 @@
+Any ideas for good ways to manage CUPS config? /etc/cups/printers.conf starts with `# DO NOT EDIT THIS FILE WHEN CUPSD IS RUNNING`. I can do the obvious stop / replace / restart, but am curious if anyone has any success stories or pitfalls to relate.
+
+A very quick search suggests using "lpadmin" is the approved way of updating CUPS config. So I guess I can run some Cmd.cmpProperty calls
diff --git a/doc/forum/DNS_for_LAN/comment_1_cc8b39a2344a74a32d821c59b499634a._comment b/doc/forum/DNS_for_LAN/comment_1_cc8b39a2344a74a32d821c59b499634a._comment
new file mode 100644
index 00000000..53519ebb
--- /dev/null
+++ b/doc/forum/DNS_for_LAN/comment_1_cc8b39a2344a74a32d821c59b499634a._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="david"
+ avatar="http://cdn.libravatar.org/avatar/22c2d800db6a7699139df604a67cb221"
+ subject="mDNS is ok"
+ date="2020-06-10T23:53:36Z"
+ content="""
+I ended up (finally) enabling mDNS in network-manager and systemd-resolved and it seems work pretty well for my goal of ssh-ing to machines on my LAN. avahi is the other main mDNS server as far as I know.
+"""]]
diff --git a/doc/forum/DNS_for_LAN/comment_2_bd310b1f5865a2d35502721e138ca091._comment b/doc/forum/DNS_for_LAN/comment_2_bd310b1f5865a2d35502721e138ca091._comment
new file mode 100644
index 00000000..4af921f4
--- /dev/null
+++ b/doc/forum/DNS_for_LAN/comment_2_bd310b1f5865a2d35502721e138ca091._comment
@@ -0,0 +1,15 @@
+[[!comment format=mdwn
+ username="david"
+ avatar="http://cdn.libravatar.org/avatar/22c2d800db6a7699139df604a67cb221"
+ subject="network-manager snippet"
+ date="2020-06-11T10:25:10Z"
+ content="""
+[[!format haskell \"\"\"
+File.hasContent \"/etc/NetworkManager/conf.d/mDNS.conf\" [ \"[connection]\"
+ , \"connection.mdns=2\"
+ ]
+ `requires` File.dirExists \"/etc/NetworkManager/conf.d\"
+\"\"\"]]
+
+The `=2` is important if you want the host to actually tell other hosts what it's IP is, and not just query,
+"""]]
diff --git a/doc/forum/Error_trying_to_remove_a_key.mdwn b/doc/forum/Error_trying_to_remove_a_key.mdwn
new file mode 100644
index 00000000..252e507f
--- /dev/null
+++ b/doc/forum/Error_trying_to_remove_a_key.mdwn
@@ -0,0 +1,8 @@
+I try to remove a key from my propellor repository, but it fails:
+
+ % propellor --rm-key 41EED9A677C20D87
+ gpg: there is a secret key for public key "41EED9A677C20D87"!
+ gpg: use option "--delete-secret-keys" to delete it first.
+ removing key from propellor's keyring ... failed
+
+I believe gpg gets access to my secret keys using the agent now, it no longer use direct access.
diff --git a/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__.mdwn b/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__.mdwn
new file mode 100644
index 00000000..c2bc154a
--- /dev/null
+++ b/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__.mdwn
@@ -0,0 +1 @@
+An s390x running Ubuntu Bionic has starting failing with the message in the subject when I run propellor. Any ideas what might be going on there? It seems to be right after it fetches from the central git repo.
diff --git a/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__/comment_1_6271f4830c2a5bcc2bf296c32630bcba._comment b/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__/comment_1_6271f4830c2a5bcc2bf296c32630bcba._comment
new file mode 100644
index 00000000..d400839b
--- /dev/null
+++ b/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__/comment_1_6271f4830c2a5bcc2bf296c32630bcba._comment
@@ -0,0 +1,28 @@
+[[!comment format=mdwn
+ username="david"
+ avatar="http://cdn.libravatar.org/avatar/22c2d800db6a7699139df604a67cb221"
+ subject="variation on the theme."
+ date="2020-08-14T14:30:52Z"
+ content="""
+Today for some reason I had one run produce more output, with many repeats of the same warning. It seems to be more than a warning, since the corresponding properties fail. I have rebooted the VM, in case there was some transient resource exhaustion problem. Successive runs of /usr/local/bin/propellor_cronjob stop very early as in my original report.
+
+ [[!format text \"\"\"
+lotus.casa.cs.unb.ca apt installed etckeeper apt-transport-https ... ok
+lotus.casa.cs.unb.ca unattended upgrades true ... failed
+lotus.casa.cs.unb.ca replace /etc/apt/apt.conf.d/20-propellor-auto-upgrades ... ok
+lotus.casa.cs.unb.ca git repo at /etc/ config setting user.email set to root@tethera.net ... ok
+** warning: waitForProcess: does not exist (No child processes)
+lotus.casa.cs.unb.ca git repo at /etc/ config setting user.name set to Root ... ok
+lotus.casa.cs.unb.ca ssh installed ... ok
+lotus.casa.cs.unb.ca ssh config: PermitRootLogin without-password ... ok
+lotus.casa.cs.unb.ca ssh config: PasswordAuthentication no ... done
+lotus.casa.cs.unb.ca root has authorized_keys ... failed
+** warning: waitForProcess: does not exist (No child processes)
+lotus.casa.cs.unb.ca root has authorized_keys ... failed
+** warning: waitForProcess: does not exist (No child processes)
+** warning: waitForProcess: does not exist (No child processes)
+lotus.casa.cs.unb.ca root has authorized_keys ... failed
+\"\"\"]]
+
+
+"""]]
diff --git a/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__/comment_2_eb46e45efa0f40dbbc0a7471002eb97d._comment b/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__/comment_2_eb46e45efa0f40dbbc0a7471002eb97d._comment
new file mode 100644
index 00000000..3ed165d4
--- /dev/null
+++ b/doc/forum/propellor:_waitForProcess:_does_not_exist___40__No_child_processes__41__/comment_2_eb46e45efa0f40dbbc0a7471002eb97d._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="david"
+ avatar="http://cdn.libravatar.org/avatar/22c2d800db6a7699139df604a67cb221"
+ subject="addendum"
+ date="2020-08-14T14:32:59Z"
+ content="""
+Actually it seems a bit random as to whether I get the longwinded or the concise failure. Out of about 10 tries, I get the longer run maybe 3 times.
+"""]]
diff --git a/doc/forum/recommendations_for_setting_up__a_Fedora_chroot_on_a_Debian_host.mdwn b/doc/forum/recommendations_for_setting_up__a_Fedora_chroot_on_a_Debian_host.mdwn
new file mode 100644
index 00000000..c12a7556
--- /dev/null
+++ b/doc/forum/recommendations_for_setting_up__a_Fedora_chroot_on_a_Debian_host.mdwn
@@ -0,0 +1,9 @@
+I'd like a way to set up Fedora chroots for testing purposes on my Debian workstations. Currently I use the example from the systemd-nspawn manpage
+[[!format text """
+# machinectl pull-raw --verify=no \
+ https://download.fedoraproject.org/pub/fedora/linux/releases/31/Cloud/x86_64/images/Fedora-Cloud-Base-31-1.9.x86_64.raw.xz \
+ Fedora-Cloud-Base-31-1.9.x86-64
+# systemd-nspawn -M Fedora-Cloud-Base-31-1.9.x86-64
+"""]]
+
+If I understand correctly the existing Systemd.container function needs a way to make a chroot.
diff --git a/doc/forum/ssh__95__known__95__hosts.mdwn b/doc/forum/ssh__95__known__95__hosts.mdwn
new file mode 100644
index 00000000..94db5996
--- /dev/null
+++ b/doc/forum/ssh__95__known__95__hosts.mdwn
@@ -0,0 +1 @@
+I would find it useful if there was a function similar to Ssh.knownHost that updated /etc/ssh/ssh_known_hosts. I suppose it just requires parameterizing knownHost in terms of what file to operate on, but I'm still pretty clueless about IO in Haskell.
diff --git a/doc/forum/ssh__95__known__95__hosts/comment_1_9447b1382bf54e6f4620bae200a62238._comment b/doc/forum/ssh__95__known__95__hosts/comment_1_9447b1382bf54e6f4620bae200a62238._comment
new file mode 100644
index 00000000..eb52f671
--- /dev/null
+++ b/doc/forum/ssh__95__known__95__hosts/comment_1_9447b1382bf54e6f4620bae200a62238._comment
@@ -0,0 +1,27 @@
+[[!comment format=mdwn
+ username="david"
+ avatar="http://cdn.libravatar.org/avatar/22c2d800db6a7699139df604a67cb221"
+ subject="prototype"
+ date="2020-06-11T01:23:28Z"
+ content="""
+This seems to work for me. Obviously less hardcoding and code duplication would be nicer.
+
+[[!format haskell \"\"\"
+-- | Puts some host's ssh public key(s), as set using `hostPubKey`
+-- or `hostKey` into /etc/ssh/ssh_known_hosts
+sshKnownHost :: [Host] -> HostName -> Property UnixLike
+sshKnownHost hosts hn = property' desc $ \w ->
+ go w =<< knownHostLines hosts hn
+ where
+ desc = \" globally known ssh key for \" ++ hn
+
+ go _ [] = do
+ warningMessage $ \"no configured ssh host keys for \" ++ hn
+ return FailedChange
+ go w ls = do
+ f <- return \"/etc/ssh/ssh_known_hosts\"
+ ensureProperty w $
+ f `File.containsLines` ls
+ `requires` File.dirExists (takeDirectory f)
+\"\"\"]]
+"""]]
diff --git a/doc/news/version_5.10.2.mdwn b/doc/news/version_5.10.2.mdwn
new file mode 100644
index 00000000..264b7f60
--- /dev/null
+++ b/doc/news/version_5.10.2.mdwn
@@ -0,0 +1,10 @@
+propellor 5.10.2 released with [[!toggle text="these changes"]]
+[[!toggleable text="""
+ * Fix build with ghc 8.6.3.
+ Thanks, Robin Munn
+ * Bootstrap: Fix typo in Arch Linux dependencies.
+ Thanks, Robin Munn
+ * Bootstrap: Add haskell-type-errors package on Arch Linux.
+ Thanks, Robin Munn
+ * Apt.buildDepIn: Run build-dep command in a temporary directory,
+ since it may sometimes not clean up all the files it creates."""]] \ No newline at end of file
diff --git a/doc/news/version_5.7.0.mdwn b/doc/news/version_5.7.0.mdwn
deleted file mode 100644
index 194a2a6f..00000000
--- a/doc/news/version_5.7.0.mdwn
+++ /dev/null
@@ -1,20 +0,0 @@
-propellor 5.7.0 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Sbuild.built no longer includes Apt.stdSourcesList by default,
- in order to support non-Debian OS's. (API change)
- To upgrade: Simply add Sbuild.osDebianStandard to all Sbuild.built
- calls which have osDebian.
- Thanks, Sean Whitton
- * Propellor.Property.PropellorRepo renamed to Propellor.Property.Localdir
- to widen its scope. (API change)
- * Added Localdir.removed property.
- Thanks, Sean Whitton
- * Sbuild.built uses Localdir.removed to clean up the propellor localdir
- after it's done running in a schroot.
- Thanks, Sean Whitton
- * Cron.runPropellor made revertable. (minor API change)
- Thanks, Sean Whitton
- * Added Cron.jobDropped.
- Thanks, Sean Whitton
- * Added Utility.FileMode to the modules exported by Propellor.Utilities
- to propellor library users."""]] \ No newline at end of file
diff --git a/doc/todo/Default_of_new_style_builds_breaks_Bootstrap.OSOnly.mdwn b/doc/todo/Default_of_new_style_builds_breaks_Bootstrap.OSOnly.mdwn
new file mode 100644
index 00000000..b3a3cd90
--- /dev/null
+++ b/doc/todo/Default_of_new_style_builds_breaks_Bootstrap.OSOnly.mdwn
@@ -0,0 +1,29 @@
+It looks like ghc in Debian unstable is defaulting to new style cabal builds which bypasses `Bootstrap.bootstrapWith Bootstrap.OSOnly`:
+
+ ...
+ git branch origin/spw3conf gpg signature verified; merging
+ Already up to date.
+ Build profile: -w ghc-8.8.3 -O1
+ In order, the following will be built (use -v for more details):
+ - IfElse-0.85 (lib:IfElse) (requires build)
+ - first-class-families-0.8.0.0 (lib) (requires build)
+ - hsc2hs-0.68.7 (exe:hsc2hs) (requires download & build)
+ - old-locale-1.0.0.7 (lib) (requires build)
+ - syb-0.7.1 (lib) (requires build)
+ - th-abstraction-0.3.2.0 (lib) (requires build)
+ - network-bsd-2.8.1.0 (lib) (requires build)
+ - type-errors-0.2.0.0 (lib) (requires build)
+ - hslogger-1.3.1.0 (lib) (requires build)
+ - propellor-5.10.1 (lib) (first run)
+ - propellor-5.10.1 (exe:propellor-config) (first run)
+ Downloading hsc2hs-0.68.7
+ Configuring IfElse-0.85...
+ Preprocessing library for IfElse-0.85..
+ Building library for IfElse-0.85..
+ [1 of 1] Compiling Control.Monad.IfElse ( Control/Monad/IfElse.hs, dist/build/Control/Monad/IfElse.o )
+ Downloaded hsc2hs-0.68.7
+ ...
+
+I think the simplest fix is to replace `cabal build` with `cabal v1-build` in `Propellor.Bootstrap.buildCommand`?
+
+--spwhitton
diff --git a/doc/todo/Default_of_new_style_builds_breaks_Bootstrap.OSOnly/comment_1_b09c0c736838132b7dd69a1c510ff877._comment b/doc/todo/Default_of_new_style_builds_breaks_Bootstrap.OSOnly/comment_1_b09c0c736838132b7dd69a1c510ff877._comment
new file mode 100644
index 00000000..0ca694ff
--- /dev/null
+++ b/doc/todo/Default_of_new_style_builds_breaks_Bootstrap.OSOnly/comment_1_b09c0c736838132b7dd69a1c510ff877._comment
@@ -0,0 +1,13 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2020-06-17T22:01:21Z"
+ content="""
+Simplest yes, but also kicking the can down the road as they'll
+presumably remove 1- at some point.
+
+I've implemented new-build support in
+[[!commit 745784f61bdd678e20b1b18743f18d458836a802]].
+Have not actually tested it on bootstrapping a new host yet, but I assume
+it will work barring some dumb typo.
+"""]]
diff --git a/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored.mdwn b/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored.mdwn
new file mode 100644
index 00000000..08d5cf86
--- /dev/null
+++ b/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored.mdwn
@@ -0,0 +1,11 @@
+Recent versions of Borg require the `--encryption` option to initialize a repository.
+
+Also, `borg extract` needs an archive name and it extracts the backup in the current directory.
+
+I have made a fix for this, please pull the `borg-fixes` branch at `http://git.ni.fr.eu.org/nicolas/propellor.git`.
+
+Tested with borg version 1.1.9.
+
+My haskell level is still not that great, I would love to get comments on my code.
+
+Thanks.
diff --git a/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_1_4a662d7ab4f49a914718ca6e6f69ee86._comment b/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_1_4a662d7ab4f49a914718ca6e6f69ee86._comment
new file mode 100644
index 00000000..7c5d7eb5
--- /dev/null
+++ b/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_1_4a662d7ab4f49a914718ca6e6f69ee86._comment
@@ -0,0 +1,29 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 1"""
+ date="2020-07-31T15:11:20Z"
+ content="""
+pull failed
+
+ joey@darkstar:~/src/propellor>git fetch http://git.ni.fr.eu.org/nicolas/propellor.git
+ fatal: Couldn't find remote ref HEAD
+
+I wonder if perhaps you forgot to run `git update-server-info`?
+Or possibly this is just not an url that actually points to the raw git
+repo, it looks like a gitweb installation and gitweb does not serve git
+repos IIRC.
+
+Hardcoding `BORG_PASSPHRASE` into a propellor configuration does not seem
+good. It could use `withPrivData` to get the passphrase.
+
+If `latestArchive` didn't work, it should probably display a
+`warningMessage` rather than just failing with no indication why.
+
+There is the small problem that borg 1.0.9 is in debian oldstable and if
+someone were using propellor with it, which is supported, the changes
+to extraction would break that. Not as bad as extraction currently being
+broken for everyone with a current version of borg though! But,
+it would be easy to at least detect the old version and refuse to use it to
+restore. Either by borg --version or by using withOS and to match against
+the debian version, like Propellor.Property.Systemd.machined does.
+"""]]
diff --git a/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_2_0a595f3481c37280bf3d9d9545b2e954._comment b/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_2_0a595f3481c37280bf3d9d9545b2e954._comment
new file mode 100644
index 00000000..0cd6f1a7
--- /dev/null
+++ b/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_2_0a595f3481c37280bf3d9d9545b2e954._comment
@@ -0,0 +1,10 @@
+[[!comment format=mdwn
+ username="Nicolas.Schodet"
+ avatar="http://cdn.libravatar.org/avatar/0d7ec808ec329d04ee9a93c0da3c0089"
+ subject="comment 2"
+ date="2020-08-01T14:58:33Z"
+ content="""
+HEAD was pointing to a non-existant master branch, sorry about that.
+
+I will try to fix the other issues, thanks for the review.
+"""]]
diff --git a/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_3_c605e8c4b6e13fb1a5168ad34c3c7f46._comment b/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_3_c605e8c4b6e13fb1a5168ad34c3c7f46._comment
new file mode 100644
index 00000000..81fb2234
--- /dev/null
+++ b/doc/todo/Fix_Borg.init_on_recent_borg_versions__44___fix_Borg.restored/comment_3_c605e8c4b6e13fb1a5168ad34c3c7f46._comment
@@ -0,0 +1,16 @@
+[[!comment format=mdwn
+ username="Nicolas.Schodet"
+ avatar="http://cdn.libravatar.org/avatar/0d7ec808ec329d04ee9a93c0da3c0089"
+ subject="Branch updated"
+ date="2020-08-10T21:41:11Z"
+ content="""
+Hello, I updated my branch with:
+
+- a different commit message with a withPrivData example,
+- a fix for --glob-archive and --last not supported on borg 1.0.9,
+- a warning message if no archive is found.
+
+Not sure if it was clear: the restored function did not work either on borg 1.0.9 before my changes.
+
+Tested on buster and stretch.
+"""]]
diff --git a/doc/todo/Support_for_mirroring_bare_git_repos.mdwn b/doc/todo/Support_for_mirroring_bare_git_repos.mdwn
new file mode 100644
index 00000000..3c5da097
--- /dev/null
+++ b/doc/todo/Support_for_mirroring_bare_git_repos.mdwn
@@ -0,0 +1,2 @@
+Since "git pull" has the potential to fail because of merge problems (this is not theoretical, it happened to me today), I'd prefer to just fetch into a bare repo.
+I don't know the best way to go about this. Maybe a "Git.fetched" function that does not assume a non-bare repo (as Git.cloned currently does).
diff --git a/doc/todo/Support_for_mirroring_bare_git_repos/comment_1_f8d0ade5f31f85c1db50b3ec6a9a3818._comment b/doc/todo/Support_for_mirroring_bare_git_repos/comment_1_f8d0ade5f31f85c1db50b3ec6a9a3818._comment
new file mode 100644
index 00000000..fb6ff177
--- /dev/null
+++ b/doc/todo/Support_for_mirroring_bare_git_repos/comment_1_f8d0ade5f31f85c1db50b3ec6a9a3818._comment
@@ -0,0 +1,19 @@
+[[!comment format=mdwn
+ username="david"
+ avatar="http://cdn.libravatar.org/avatar/22c2d800db6a7699139df604a67cb221"
+ subject="first attempt"
+ date="2020-05-16T23:44:41Z"
+ content="""
+This isn't very general, but it seems to work
+
+[[!format haskell \"\"\"
+bareMirror :: String -> String -> Property DebianLike
+bareMirror dir url = propertyList (\"bare mirror of \" ++ url ++ \" in \" ++ dir ) $ props
+ & Git.installed
+ & Git.bareRepo dir (User \"root\") Git.SharedAll
+ & Git.repoConfigured dir (\"remote.origin.url\", url)
+ & Git.repoConfigured dir (\"remote.origin.mirror\", \"true\")
+ & Git.repoConfigured dir (\"remote.origin.fetch\", \"+refs/*:refs/*\")
+ & Cmd.cmdProperty \"git\" [\"-C\", dir, \"fetch\", \"origin\" ] `changesFileContent` (dir </> \"HEAD\")
+\"\"\"]]
+"""]]
diff --git a/doc/todo/cabal_new-build_cruft.mdwn b/doc/todo/cabal_new-build_cruft.mdwn
new file mode 100644
index 00000000..586e9fde
--- /dev/null
+++ b/doc/todo/cabal_new-build_cruft.mdwn
@@ -0,0 +1,17 @@
+cabal new-build (now the default with recent cabal versions) stores stuff
+in dist-newstyle, versioned by the ghc version and the package version.
+
+So, as propellor builds itself on a host over and over again,
+and the host is upgraded and propellor is upgraded, dist-newstyle will
+accumulate cruft used by old builds.
+
+cabal clean can remove it of course, but then it won't update the build
+incrementally.
+
+What would be good is, a way to detect that the versioning has changed,
+and only then run cabal clean. One way to do that, would be when updating
+the propellor symlink to the cabal built binary, compare the old and new
+binary location. If they're not the same, the versioning has changed,
+and so cabal clean and re-build. --[[Joey]]
+
+(Note that stack probably has the same problem too.)
diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn
index c3641385..48dd829e 100644
--- a/doc/todo/depend_on_concurrent-output.mdwn
+++ b/doc/todo/depend_on_concurrent-output.mdwn
@@ -27,3 +27,26 @@ Waiting on concurrent-output reaching Debian stable.
> from debian. That is a somewhat old version and perhaps it was buggy?
> However, I have not had any luck reproducing the problem there running
> readProcess in ghci. --[[Joey]]
+>
+> > Tried again in 2020, same bugs still happened. On a system running
+> > debian unstable with concurrent-output 1.10.9, and a system running stable that
+> > had cabal installed concurrent-output 1.10.11.
+> >
+> > The former system (kite) had the strange output problem.
+> >
+> > The latter system (keysafe) seemed ok but crashed at the end with
+> > a STM transaction deadlock. Seemed to only happen when spinning the
+> > host remotely, or not always; I tried to reproduce it running propellor
+> > manually to bisect concurrent-output but without success.
+> >
+> > This is really looking like a reversion, or several, in newer
+> > versions of concurrent-output. The code bundled with propellor is
+> > the same as concurrent-output 1.7.4.
+
+> > > I think I've fixed it, concurrent-output (>= 1.10.12 || <= 1.7.4)
+> > > will be needed to avoid the bug. Will be several years until that's
+> > > in debian stable..
+> > >
+> > > I've updated the embedded concurrent-output copy, and it should
+> > > be kept up-to-date as concurrent-output changes, to avoid more
+> > > such reversions. --[[Joey]]
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index d772d7c7..6aa5720c 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -81,13 +81,21 @@ buildCommand bs = intercalate " && " (go (getBuilder bs))
go Cabal =
[ "cabal configure"
, "cabal build -j1 propellor-config"
- , "ln -sf dist/build/propellor-config/propellor-config propellor"
+ , "ln -sf" `commandCabalBuildTo` "propellor"
]
go Stack =
[ "stack build :propellor-config"
, "ln -sf $(stack path --dist-dir)/build/propellor-config/propellor-config propellor"
]
+commandCabalBuildTo :: ShellCommand -> FilePath -> ShellCommand
+commandCabalBuildTo cmd dest = intercalate "; "
+ [ "if [ -d dist-newstyle ]"
+ , "then " ++ cmd ++ " $(cabal exec -- sh -c 'command -v propellor-config') " ++ shellEscape dest
+ , "else " ++ cmd ++ " dist/build/propellor-config/propellor-config " ++ shellEscape dest
+ , "fi"
+ ]
+
-- Check if all dependencies are installed; if not, run the depsCommand.
checkDepsCommand :: Bootstrapper -> Maybe System -> ShellCommand
checkDepsCommand bs sys = go (getBuilder bs)
@@ -257,32 +265,28 @@ buildPropellor mh = unlessM (actionMessage "Propellor build" build) $
-- dependencies and retries.
cabalBuild :: Maybe System -> IO Bool
cabalBuild msys = do
- make "dist/setup-config" ["propellor.cabal"] cabal_configure
+ make "configured" ["propellor.cabal"] cabal_configure
unlessM cabal_build $
unlessM (cabal_configure <&&> cabal_build) $
error "cabal build failed"
- -- For safety against eg power loss in the middle of the build,
- -- make a copy of the binary, and move it into place atomically.
- -- This ensures that the propellor symlink only ever points at
- -- a binary that is fully built. Also, avoid ever removing
- -- or breaking the symlink.
- --
- -- Need cp -pfRL to make build timestamp checking work.
- unlessM (boolSystem "cp" [Param "-pfRL", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $
+ -- Make a copy of the binary, and move it into place atomically.
+ let safetycopy = "propellor.built"
+ let cpcmd = "cp -pfL" `commandCabalBuildTo` safetycopy
+ unlessM (boolSystem "sh" [Param "-c", Param cpcmd]) $
error "cp of binary failed"
- rename (tmpfor safetycopy) safetycopy
- symlinkPropellorBin safetycopy
+ rename safetycopy "propellor"
return True
where
- cabalbuiltbin = "dist/build/propellor-config/propellor-config"
- safetycopy = cabalbuiltbin ++ ".built"
cabal_configure = ifM (cabal ["configure"])
- ( return True
+ ( do
+ writeFile "configured" ""
+ return True
, case msys of
Nothing -> return False
Just sys ->
boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))]
<&&> cabal ["configure"]
+ <&&> (writeFile "configured" "" >> return True)
)
-- The -j1 is to only run one job at a time -- in some situations,
-- eg in qemu, ghc does not run reliably in parallel.
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 9b8a7e70..64bee99d 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -1238,33 +1238,46 @@ homeNAS = propertyList "home NAS" $ props
[ "# let users power control startech hub with uhubctl"
, "ATTR{idVendor}==\"" ++ hubvendor ++ "\", ATTR{idProduct}==\"005a\", MODE=\"0666\""
]
- & autoMountDrivePort "archive-10" (USBHubPort hubvendor hubloc 1)
+ & autoMountDrivePort "archive-10"
+ (USBHubPort hubvendor 1)
+ (USBDriveId wd "1230")
(Just "archive-oldest")
- & autoMountDrivePort "archive-11" (USBHubPort hubvendor hubloc 2)
+ & autoMountDrivePort "archive-11"
+ (USBHubPort hubvendor 2)
+ (USBDriveId wd "25ee")
(Just "archive-older")
- & autoMountDrivePort "archive-12" (USBHubPort hubvendor hubloc 3)
+ & autoMountDrivePort "archive-12"
+ (USBHubPort hubvendor 3)
+ (USBDriveId seagate "3322")
(Just "archive-old")
- & autoMountDrivePort "archive-13" (USBHubPort hubvendor hubloc 4)
+ & autoMountDrivePort "archive-13"
+ (USBHubPort hubvendor 4)
+ (USBDriveId wd "25a3")
(Just "archive")
& autoMountDrive "passport" Nothing
& Apt.installed ["git-annex", "borgbackup"]
where
hubvendor = "0409"
- hubloc = "4-1.6"
+ wd = "1058"
+ seagate = "0bc2"
data USBHubPort = USBHubPort
{ hubVendor :: String
- , hubLocation :: String
, hubPort :: Int
}
+data USBDriveId = USBDriveId
+ { driveVendorId :: String
+ , driveProductId :: String
+ }
+
-- Makes a USB drive with the given label automount, and unmount after idle
-- for a while.
--
-- The hub port is turned on and off automatically as needed, using
-- uhubctl.
-autoMountDrivePort :: Mount.Label -> USBHubPort -> Maybe FilePath -> Property DebianLike
-autoMountDrivePort label hp malias = propertyList desc $ props
+autoMountDrivePort :: Mount.Label -> USBHubPort -> USBDriveId -> Maybe FilePath -> Property DebianLike
+autoMountDrivePort label hp drive malias = propertyList desc $ props
& File.hasContent ("/etc/systemd/system/" ++ hub)
[ "[Unit]"
, "Description=Startech usb hub port " ++ show (hubPort hp)
@@ -1272,7 +1285,7 @@ autoMountDrivePort label hp malias = propertyList desc $ props
, "[Service]"
, "Type=oneshot"
, "RemainAfterExit=true"
- , "ExecStart=/usr/sbin/uhubctl -a on " ++ selecthubport
+ , "ExecStart=/bin/sh -c 'uhubctl -a on " ++ selecthubport ++ "'"
, "ExecStop=/bin/sh -c 'uhubctl -a off " ++ selecthubport
-- Powering off the port does not remove device
-- files, so ask udev to remove the devfile; it will
@@ -1300,7 +1313,18 @@ autoMountDrivePort label hp malias = propertyList desc $ props
selecthubport = unwords
[ "-p", show (hubPort hp)
, "-n", hubVendor hp
- , "-l", hubLocation hp
+ , "-l", concat
+ -- The hub's location id, eg "1-1.4", does not seem
+ -- as stable as uhubctl claims it will be,
+ -- and the vendor is not sufficient since I have 2
+ -- hubs from the same vendor. So search for the
+ -- drive lsusb to find that. This works even if the
+ -- port is powered off, as long as it's been on at
+ -- some point before.
+ [ "$(lsusb -tvv | perl -lne \"if (\\\\$h && m!/sys/bus/usb/devices/(.*?) !) {\\\\$v=\\\\$1}; if (m/Hub/) { \\\\$h=1 } else { \\\\$h=0 }; if (/"
+ , driveVendorId drive ++ ":" ++ driveProductId drive
+ ++ "/) { print \\\\$v; last}\")"
+ ]
]
-- Makes a USB drive with the given label automount, and unmount after idle
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 30302a7d..e9902513 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -181,7 +181,7 @@ newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)
instance IsInfo NamedConfMap where
propagateInfo _ = PropagateInfo False
--- | Adding a Master NamedConf stanza for a particulr domain always
+-- | Adding a Master NamedConf stanza for a particular domain always
-- overrides an existing Secondary stanza for that domain, while a
-- Secondary stanza is only added when there is no existing Master stanza.
instance Sem.Semigroup NamedConfMap where
diff --git a/src/Propellor/Wrapper.hs b/src/Propellor/Wrapper.hs
index f399b2cf..1bef651c 100644
--- a/src/Propellor/Wrapper.hs
+++ b/src/Propellor/Wrapper.hs
@@ -2,7 +2,6 @@
-- distribution.
--
-- Distributions should install this program into PATH.
--- (Cabal builds it as dist/build/propellor/propellor).
--
-- This is not the propellor main program (that's config.hs).
-- This bootstraps ~/.propellor/config.hs, builds it if
diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs
index 12447637..8ab73c3d 100644
--- a/src/System/Console/Concurrent.hs
+++ b/src/System/Console/Concurrent.hs
@@ -7,29 +7,25 @@
-- > import Control.Concurrent.Async
-- > import System.Console.Concurrent
-- >
--- > main = withConcurrentOutput $
+-- > main = withConcurrentOutput $ do
-- > outputConcurrent "washed the car\n"
-- > `concurrently`
-- > outputConcurrent "walked the dog\n"
-- > `concurrently`
-- > createProcessConcurrent (proc "ls" [])
-{-# LANGUAGE CPP #-}
-
module System.Console.Concurrent (
-- * Concurrent output
withConcurrentOutput,
Outputable(..),
outputConcurrent,
errorConcurrent,
- ConcurrentProcessHandle,
-#ifndef mingw32_HOST_OS
createProcessConcurrent,
-#endif
- waitForProcessConcurrent,
createProcessForeground,
flushConcurrentOutput,
lockOutput,
+ ConcurrentProcessHandle,
+ waitForProcessConcurrent,
-- * Low level access to the output buffer
OutputBuffer,
StdHandle(..),
diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs
index ffe6a9e8..de4cffaf 100644
--- a/src/System/Console/Concurrent/Internal.hs
+++ b/src/System/Console/Concurrent/Internal.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}
-{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -O2 #-}
{- Building this module with -O0 causes streams not to fuse and too much
- memory to be used. -}
@@ -15,9 +14,6 @@
module System.Console.Concurrent.Internal where
import System.IO
-#ifndef mingw32_HOST_OS
-import System.Posix.IO
-#endif
import System.Directory
import System.Exit
import Control.Monad
@@ -32,6 +28,7 @@ import Data.Monoid
import qualified System.Process as P
import qualified Data.Text as T
import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as L
import Control.Applicative
import Prelude
@@ -43,8 +40,6 @@ data OutputHandle = OutputHandle
, outputBuffer :: TMVar OutputBuffer
, errorBuffer :: TMVar OutputBuffer
, outputThreads :: TMVar Integer
- , processWaiters :: TMVar [Async ()]
- , waitForProcessLock :: TMVar ()
}
data Lock = Locked
@@ -57,8 +52,6 @@ globalOutputHandle = unsafePerformIO $ OutputHandle
<*> newTMVarIO (OutputBuffer [])
<*> newTMVarIO (OutputBuffer [])
<*> newTMVarIO 0
- <*> newTMVarIO []
- <*> newEmptyTMVarIO
-- | Holds a lock while performing an action. This allows the action to
-- perform its own output to the console, without using functions from this
@@ -109,7 +102,8 @@ dropOutputLock :: IO ()
dropOutputLock = withLock $ void . takeTMVar
-- | Use this around any actions that use `outputConcurrent`
--- or `createProcessConcurrent`
+-- or `createProcessConcurrent`, unless
+-- `System.Console.Regions.displayConsoleRegions` is being used.
--
-- This is necessary to ensure that buffered concurrent output actually
-- gets displayed before the program exits.
@@ -140,20 +134,30 @@ class Outputable v where
instance Outputable T.Text where
toOutput = id
+-- | Note that using a lazy Text as an Outputable value
+-- will buffer it all in memory.
+instance Outputable L.Text where
+ toOutput = toOutput . L.toStrict
+
instance Outputable String where
toOutput = toOutput . T.pack
-- | Displays a value to stdout.
--
--- No newline is appended to the value, so if you want a newline, be sure
--- to include it yourself.
---
-- Uses locking to ensure that the whole output occurs atomically
-- even when other threads are concurrently generating output.
--
+-- No newline is appended to the value, so if you want a newline, be sure
+-- to include it yourself.
+--
-- When something else is writing to the console at the same time, this does
-- not block. It buffers the value, so it will be displayed once the other
-- writer is done.
+--
+-- When outputConcurrent is used within a call to
+-- `System.Console.Regions.displayConsoleRegions`, the output is displayed
+-- above the currently open console regions. Only lines ending in a newline
+-- are displayed in this case (it uses `waitCompleteLines`).
outputConcurrent :: Outputable v => v -> IO ()
outputConcurrent = outputConcurrent' StdOut
@@ -179,69 +183,13 @@ outputConcurrent' stdh v = bracket setup cleanup go
h = toHandle stdh
bv = bufferFor stdh
-newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle
-
-toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h)
+-- | This alias is provided to avoid breaking backwards compatibility.
+type ConcurrentProcessHandle = P.ProcessHandle
--- | Use this to wait for processes started with
--- `createProcessConcurrent` and `createProcessForeground`, and get their
--- exit status.
---
--- Note that such processes are actually automatically waited for
--- internally, so not calling this explicitly will not result
--- in zombie processes. This behavior differs from `P.waitForProcess`
+-- | Same as `P.waitForProcess`; provided to avoid breaking backwards
+-- compatibility.
waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode
-waitForProcessConcurrent (ConcurrentProcessHandle h) =
- bracket lock unlock checkexit
- where
- lck = waitForProcessLock globalOutputHandle
- lock = atomically $ tryPutTMVar lck ()
- unlock True = atomically $ takeTMVar lck
- unlock False = return ()
- checkexit locked = maybe (waitsome locked) return
- =<< P.getProcessExitCode h
- waitsome True = do
- let v = processWaiters globalOutputHandle
- l <- atomically $ readTMVar v
- if null l
- -- Avoid waitAny [] which blocks forever
- then P.waitForProcess h
- else do
- -- Wait for any of the running
- -- processes to exit. It may or may not
- -- be the one corresponding to the
- -- ProcessHandle. If it is,
- -- getProcessExitCode will succeed.
- void $ tryIO $ waitAny l
- checkexit True
- waitsome False = do
- -- Another thread took the lck first. Wait for that thread to
- -- wait for one of the running processes to exit.
- atomically $ do
- putTMVar lck ()
- takeTMVar lck
- checkexit False
-
--- Registers an action that waits for a process to exit,
--- adding it to the processWaiters list, and removing it once the action
--- completes.
-asyncProcessWaiter :: IO () -> IO ()
-asyncProcessWaiter waitaction = do
- regdone <- newEmptyTMVarIO
- waiter <- async $ do
- self <- atomically (takeTMVar regdone)
- waitaction `finally` unregister self
- register waiter regdone
- where
- v = processWaiters globalOutputHandle
- register waiter regdone = atomically $ do
- l <- takeTMVar v
- putTMVar v (waiter:l)
- putTMVar regdone waiter
- unregister waiter = atomically $ do
- l <- takeTMVar v
- putTMVar v (filter (/= waiter) l)
+waitForProcessConcurrent = P.waitForProcess
-- | Wrapper around `System.Process.createProcess` that prevents
-- multiple processes that are running concurrently from writing
@@ -260,9 +208,10 @@ asyncProcessWaiter waitaction = do
-- redirected to a buffer. The buffered output will be displayed as soon
-- as the output lock becomes free.
--
--- Currently only available on Unix systems, not Windows.
-#ifndef mingw32_HOST_OS
-createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
+-- Note that the the process is waited for by a background thread,
+-- so unlike createProcess, neglecting to call waitForProcess will not
+-- result in zombie processess.
+createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
createProcessConcurrent p
| willOutput (P.std_out p) || willOutput (P.std_err p) =
ifM tryTakeOutputLock
@@ -271,56 +220,65 @@ createProcessConcurrent p
)
| otherwise = do
r@(_, _, _, h) <- P.createProcess p
- asyncProcessWaiter $
- void $ tryIO $ P.waitForProcess h
- return (toConcurrentProcessHandle r)
-#endif
+ _ <- async $ void $ tryIO $ P.waitForProcess h
+ return r
-- | Wrapper around `System.Process.createProcess` that makes sure a process
-- is run in the foreground, with direct access to stdout and stderr.
-- Useful when eg, running an interactive process.
-createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
+--
+-- Note that the the process is waited for by a background thread,
+-- so unlike createProcess, neglecting to call waitForProcess will not
+-- result in zombie processess.
+createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
createProcessForeground p = do
takeOutputLock
fgProcess p
-fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
+fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
fgProcess p = do
r@(_, _, _, h) <- P.createProcess p
`onException` dropOutputLock
registerOutputThread
-- Wait for the process to exit and drop the lock.
- asyncProcessWaiter $ do
+ _ <- async $ do
void $ tryIO $ P.waitForProcess h
unregisterOutputThread
dropOutputLock
- return (toConcurrentProcessHandle r)
+ return r
-#ifndef mingw32_HOST_OS
-bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
+bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
bgProcess p = do
- (toouth, fromouth) <- pipe
- (toerrh, fromerrh) <- pipe
let p' = p
- { P.std_out = rediroutput (P.std_out p) toouth
- , P.std_err = rediroutput (P.std_err p) toerrh
+ { P.std_out = rediroutput (P.std_out p)
+ , P.std_err = rediroutput (P.std_err p)
}
registerOutputThread
- r@(_, _, _, h) <- P.createProcess p'
+ (stdin_h, stdout_h, stderr_h, h) <- P.createProcess p'
`onException` unregisterOutputThread
- asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h
- outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth
- errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh
+ let r =
+ ( stdin_h
+ , mungeret (P.std_out p) stdout_h
+ , mungeret (P.std_err p) stderr_h
+ , h
+ )
+ -- Wait for the process for symmetry with fgProcess,
+ -- which does the same.
+ _ <- async $ void $ tryIO $ P.waitForProcess h
+ outbuf <- setupOutputBuffer StdOut (mungebuf (P.std_out p) stdout_h)
+ errbuf <- setupOutputBuffer StdErr (mungebuf (P.std_err p) stderr_h)
void $ async $ bufferWriter [outbuf, errbuf]
- return (toConcurrentProcessHandle r)
+ return r
where
- pipe = do
- (from, to) <- createPipe
- (,) <$> fdToHandle to <*> fdToHandle from
- rediroutput ss h
- | willOutput ss = P.UseHandle h
+ rediroutput ss
+ | willOutput ss = P.CreatePipe
| otherwise = ss
-#endif
+ mungebuf ss mh
+ | willOutput ss = mh
+ | otherwise = Nothing
+ mungeret ss mh
+ | willOutput ss = Nothing
+ | otherwise = mh
willOutput :: P.StdStream -> Bool
willOutput P.Inherit = True
@@ -353,32 +311,31 @@ data AtEnd = AtEnd
data BufSig = BufSig
-setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-setupOutputBuffer h toh ss fromh = do
- hClose toh
+setupOutputBuffer :: StdHandle -> Maybe Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
+setupOutputBuffer h fromh = do
buf <- newMVar (OutputBuffer [])
bufsig <- atomically newEmptyTMVar
bufend <- atomically newEmptyTMVar
- void $ async $ outputDrainer ss fromh buf bufsig bufend
+ void $ async $ outputDrainer fromh buf bufsig bufend
return (h, buf, bufsig, bufend)
-- Drain output from the handle, and buffer it.
-outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()
-outputDrainer ss fromh buf bufsig bufend
- | willOutput ss = go
- | otherwise = atend
+outputDrainer :: Maybe Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()
+outputDrainer mfromh buf bufsig bufend = case mfromh of
+ Nothing -> atend
+ Just fromh -> go fromh
where
- go = do
+ go fromh = do
t <- T.hGetChunk fromh
if T.null t
- then atend
+ then do
+ atend
+ hClose fromh
else do
modifyMVar_ buf $ addOutputBuffer (Output t)
changed
- go
- atend = do
- atomically $ putTMVar bufend AtEnd
- hClose fromh
+ go fromh
+ atend = atomically $ putTMVar bufend AtEnd
changed = atomically $ do
void $ tryTakeTMVar bufsig
putTMVar bufsig BufSig
diff --git a/src/System/Process/Concurrent.hs b/src/System/Process/Concurrent.hs
index 0e00e4fd..346ce2e0 100644
--- a/src/System/Process/Concurrent.hs
+++ b/src/System/Process/Concurrent.hs
@@ -9,26 +9,14 @@
module System.Process.Concurrent where
import System.Console.Concurrent
-import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))
import System.Process hiding (createProcess, waitForProcess)
import System.IO
import System.Exit
-- | Calls `createProcessConcurrent`
---
--- You should use the waitForProcess in this module on the resulting
--- ProcessHandle. Using System.Process.waitForProcess instead can have
--- mildly unexpected results.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-createProcess p = do
- (i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p
- return (i, o, e, h)
+createProcess = createProcessConcurrent
-- | Calls `waitForProcessConcurrent`
---
--- You should only use this on a ProcessHandle obtained by calling
--- createProcess from this module. Using this with a ProcessHandle
--- obtained from System.Process.createProcess etc will have extremely
--- unexpected results; it can wait a very long time before returning.
waitForProcess :: ProcessHandle -> IO ExitCode
-waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle
+waitForProcess = waitForProcessConcurrent
diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs
index 09312c7f..3efc6450 100644
--- a/src/Utility/Process/Shim.hs
+++ b/src/Utility/Process/Shim.hs
@@ -1,3 +1,4 @@
module Utility.Process.Shim (module X) where
-import System.Process as X
+import System.Process as X hiding (createProcess, waitForProcess)
+import System.Process.Concurrent as X