From 82da31b3e0e9acdfbca4c48eb12ab1f28515ba10 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 9 Jul 2014 22:11:31 -0400 Subject: propellor (0.8.1) unstable; urgency=medium * Run apt-get update in initial bootstrap. * --list-fields now includes a table of fields that are not currently set, but would be used if they got set. * Remove .gitignore from cabal file list, to avoid build failure on Debian. Closes: #754334 # imported from the archive --- CHANGELOG | 1 + LICENSE | 22 + Makefile | 45 ++ README.md | 1 + Setup.hs | 5 + config-joey.hs | 416 ++++++++++++++++ config-simple.hs | 49 ++ config.hs | 1 + debian/README.Debian | 7 + debian/changelog | 194 ++++++++ debian/compat | 1 + debian/control | 44 ++ debian/copyright | 28 ++ debian/lintian-overrides | 2 + debian/propellor.1 | 15 + debian/rules | 18 + doc/README.mdwn | 71 +++ doc/comments.mdwn | 9 + doc/forum.mdwn | 4 + doc/forum/cabal_install_problem.mdwn | 5 + ...ent_1_2201805f80683575c4675e3268dfabc0._comment | 8 + ...te.origin_not_copied_to_managed_host__63__.mdwn | 95 ++++ ...ent_1_e9e7e5e728ec23fd6025203a1aa0596b._comment | 25 + doc/haskell_newbie.mdwn | 120 +++++ doc/index.mdwn | 31 ++ doc/install.mdwn | 4 + doc/news/version_0.5.2.mdwn | 9 + doc/news/version_0.5.3.mdwn | 6 + doc/news/version_0.6.0.mdwn | 11 + doc/news/version_0.7.0.mdwn | 9 + doc/news/version_0.8.0.mdwn | 20 + doc/security.mdwn | 37 ++ doc/todo.mdwn | 6 + doc/todo/better_privdata.mdwn | 12 + doc/todo/docker_todo_list.mdwn | 3 + ...ent_1_3801d48190c029a8591ab188427b31b6._comment | 10 + ...ent_2_441591f9aa106e8d6d1fa7fd6be0fc6f._comment | 10 + doc/todo/done.mdwn | 4 + doc/todo/hooks.mdwn | 7 + .../info_propigation_out_of_nested_properties.mdwn | 28 ++ doc/todo/metapackage.mdwn | 5 + doc/todo/ssh__95__user_+_sudo.mdwn | 1 + ...ent_1_3bc008e42587a3313f81ee740d7d80f0._comment | 10 + ...ent_2_35722c7d6f6c3e2315fbf72878066c01._comment | 8 + ...ent_3_d1e4040677b39342be00359210c02156._comment | 10 + doc/todo/ssh_hostkey_Info.mdwn | 7 + privdata/keyring.gpg | Bin 0 -> 113014 bytes privdata/privdata.gpg | 439 +++++++++++++++++ propellor.cabal | 139 ++++++ src/Propellor.hs | 77 +++ src/Propellor/CmdLine.hs | 405 ++++++++++++++++ src/Propellor/Engine.hs | 49 ++ src/Propellor/Exception.hs | 18 + src/Propellor/Info.hs | 83 ++++ src/Propellor/Message.hs | 66 +++ src/Propellor/PrivData.hs | 175 +++++++ src/Propellor/Property.hs | 163 +++++++ src/Propellor/Property/Apache.hs | 62 +++ src/Propellor/Property/Apt.hs | 269 +++++++++++ src/Propellor/Property/Cmd.hs | 49 ++ src/Propellor/Property/Cron.hs | 49 ++ src/Propellor/Property/Dns.hs | 426 +++++++++++++++++ src/Propellor/Property/Docker.hs | 529 +++++++++++++++++++++ src/Propellor/Property/Docker/Shim.hs | 61 +++ src/Propellor/Property/File.hs | 95 ++++ src/Propellor/Property/Git.hs | 93 ++++ src/Propellor/Property/Gpg.hs | 44 ++ src/Propellor/Property/Grub.hs | 39 ++ .../Property/HostingProvider/CloudAtCost.hs | 24 + .../Property/HostingProvider/DigitalOcean.hs | 21 + src/Propellor/Property/HostingProvider/Linode.hs | 10 + src/Propellor/Property/Hostname.hs | 39 ++ src/Propellor/Property/Network.hs | 30 ++ src/Propellor/Property/Obnam.hs | 159 +++++++ src/Propellor/Property/OpenId.hs | 30 ++ src/Propellor/Property/Postfix.hs | 25 + src/Propellor/Property/Reboot.hs | 7 + src/Propellor/Property/Scheduled.hs | 67 +++ src/Propellor/Property/Service.hs | 31 ++ .../Property/SiteSpecific/GitAnnexBuilder.hs | 178 +++++++ src/Propellor/Property/SiteSpecific/GitHome.hs | 34 ++ src/Propellor/Property/SiteSpecific/JoeySites.hs | 362 ++++++++++++++ src/Propellor/Property/Ssh.hs | 166 +++++++ src/Propellor/Property/Sudo.hs | 32 ++ src/Propellor/Property/Tor.hs | 19 + src/Propellor/Property/User.hs | 62 +++ src/Propellor/SimpleSh.hs | 101 ++++ src/Propellor/Types.hs | 149 ++++++ src/Propellor/Types/Dns.hs | 112 +++++ src/Propellor/Types/Info.hs | 68 +++ src/Propellor/Types/OS.hs | 27 ++ src/Propellor/Types/PrivData.hs | 34 ++ src/Utility/Applicative.hs | 16 + src/Utility/Data.hs | 17 + src/Utility/Directory.hs | 135 ++++++ src/Utility/Env.hs | 81 ++++ src/Utility/Exception.hs | 59 +++ src/Utility/FileMode.hs | 158 ++++++ src/Utility/FileSystemEncoding.hs | 132 +++++ src/Utility/LinuxMkLibs.hs | 61 +++ src/Utility/Misc.hs | 148 ++++++ src/Utility/Monad.hs | 69 +++ src/Utility/PartialPrelude.hs | 68 +++ src/Utility/Path.hs | 293 ++++++++++++ src/Utility/PosixFiles.hs | 33 ++ src/Utility/Process.hs | 353 ++++++++++++++ src/Utility/QuickCheck.hs | 52 ++ src/Utility/SafeCommand.hs | 120 +++++ src/Utility/Scheduled.hs | 396 +++++++++++++++ src/Utility/Table.hs | 28 ++ src/Utility/ThreadScheduler.hs | 75 +++ src/Utility/Tmp.hs | 100 ++++ src/Utility/UserInfo.hs | 55 +++ src/config.hs | 1 + src/wrapper.hs | 93 ++++ 115 files changed, 9094 insertions(+) create mode 120000 CHANGELOG create mode 100644 LICENSE create mode 100644 Makefile create mode 120000 README.md create mode 100644 Setup.hs create mode 100644 config-joey.hs create mode 100644 config-simple.hs create mode 120000 config.hs create mode 100644 debian/README.Debian create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/lintian-overrides create mode 100644 debian/propellor.1 create mode 100755 debian/rules create mode 100644 doc/README.mdwn create mode 100644 doc/comments.mdwn create mode 100644 doc/forum.mdwn create mode 100644 doc/forum/cabal_install_problem.mdwn create mode 100644 doc/forum/cabal_install_problem/comment_1_2201805f80683575c4675e3268dfabc0._comment create mode 100644 doc/forum/remote.origin_not_copied_to_managed_host__63__.mdwn create mode 100644 doc/forum/remote.origin_not_copied_to_managed_host__63__/comment_1_e9e7e5e728ec23fd6025203a1aa0596b._comment create mode 100644 doc/haskell_newbie.mdwn create mode 100644 doc/index.mdwn create mode 100644 doc/install.mdwn create mode 100644 doc/news/version_0.5.2.mdwn create mode 100644 doc/news/version_0.5.3.mdwn create mode 100644 doc/news/version_0.6.0.mdwn create mode 100644 doc/news/version_0.7.0.mdwn create mode 100644 doc/news/version_0.8.0.mdwn create mode 100644 doc/security.mdwn create mode 100644 doc/todo.mdwn create mode 100644 doc/todo/better_privdata.mdwn create mode 100644 doc/todo/docker_todo_list.mdwn create mode 100644 doc/todo/docker_todo_list/comment_1_3801d48190c029a8591ab188427b31b6._comment create mode 100644 doc/todo/docker_todo_list/comment_2_441591f9aa106e8d6d1fa7fd6be0fc6f._comment create mode 100644 doc/todo/done.mdwn create mode 100644 doc/todo/hooks.mdwn create mode 100644 doc/todo/info_propigation_out_of_nested_properties.mdwn create mode 100644 doc/todo/metapackage.mdwn create mode 100644 doc/todo/ssh__95__user_+_sudo.mdwn create mode 100644 doc/todo/ssh__95__user_+_sudo/comment_1_3bc008e42587a3313f81ee740d7d80f0._comment create mode 100644 doc/todo/ssh__95__user_+_sudo/comment_2_35722c7d6f6c3e2315fbf72878066c01._comment create mode 100644 doc/todo/ssh__95__user_+_sudo/comment_3_d1e4040677b39342be00359210c02156._comment create mode 100644 doc/todo/ssh_hostkey_Info.mdwn create mode 100644 privdata/keyring.gpg create mode 100644 privdata/privdata.gpg create mode 100644 propellor.cabal create mode 100644 src/Propellor.hs create mode 100644 src/Propellor/CmdLine.hs create mode 100644 src/Propellor/Engine.hs create mode 100644 src/Propellor/Exception.hs create mode 100644 src/Propellor/Info.hs create mode 100644 src/Propellor/Message.hs create mode 100644 src/Propellor/PrivData.hs create mode 100644 src/Propellor/Property.hs create mode 100644 src/Propellor/Property/Apache.hs create mode 100644 src/Propellor/Property/Apt.hs create mode 100644 src/Propellor/Property/Cmd.hs create mode 100644 src/Propellor/Property/Cron.hs create mode 100644 src/Propellor/Property/Dns.hs create mode 100644 src/Propellor/Property/Docker.hs create mode 100644 src/Propellor/Property/Docker/Shim.hs create mode 100644 src/Propellor/Property/File.hs create mode 100644 src/Propellor/Property/Git.hs create mode 100644 src/Propellor/Property/Gpg.hs create mode 100644 src/Propellor/Property/Grub.hs create mode 100644 src/Propellor/Property/HostingProvider/CloudAtCost.hs create mode 100644 src/Propellor/Property/HostingProvider/DigitalOcean.hs create mode 100644 src/Propellor/Property/HostingProvider/Linode.hs create mode 100644 src/Propellor/Property/Hostname.hs create mode 100644 src/Propellor/Property/Network.hs create mode 100644 src/Propellor/Property/Obnam.hs create mode 100644 src/Propellor/Property/OpenId.hs create mode 100644 src/Propellor/Property/Postfix.hs create mode 100644 src/Propellor/Property/Reboot.hs create mode 100644 src/Propellor/Property/Scheduled.hs create mode 100644 src/Propellor/Property/Service.hs create mode 100644 src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs create mode 100644 src/Propellor/Property/SiteSpecific/GitHome.hs create mode 100644 src/Propellor/Property/SiteSpecific/JoeySites.hs create mode 100644 src/Propellor/Property/Ssh.hs create mode 100644 src/Propellor/Property/Sudo.hs create mode 100644 src/Propellor/Property/Tor.hs create mode 100644 src/Propellor/Property/User.hs create mode 100644 src/Propellor/SimpleSh.hs create mode 100644 src/Propellor/Types.hs create mode 100644 src/Propellor/Types/Dns.hs create mode 100644 src/Propellor/Types/Info.hs create mode 100644 src/Propellor/Types/OS.hs create mode 100644 src/Propellor/Types/PrivData.hs create mode 100644 src/Utility/Applicative.hs create mode 100644 src/Utility/Data.hs create mode 100644 src/Utility/Directory.hs create mode 100644 src/Utility/Env.hs create mode 100644 src/Utility/Exception.hs create mode 100644 src/Utility/FileMode.hs create mode 100644 src/Utility/FileSystemEncoding.hs create mode 100644 src/Utility/LinuxMkLibs.hs create mode 100644 src/Utility/Misc.hs create mode 100644 src/Utility/Monad.hs create mode 100644 src/Utility/PartialPrelude.hs create mode 100644 src/Utility/Path.hs create mode 100644 src/Utility/PosixFiles.hs create mode 100644 src/Utility/Process.hs create mode 100644 src/Utility/QuickCheck.hs create mode 100644 src/Utility/SafeCommand.hs create mode 100644 src/Utility/Scheduled.hs create mode 100644 src/Utility/Table.hs create mode 100644 src/Utility/ThreadScheduler.hs create mode 100644 src/Utility/Tmp.hs create mode 100644 src/Utility/UserInfo.hs create mode 120000 src/config.hs create mode 100644 src/wrapper.hs diff --git a/CHANGELOG b/CHANGELOG new file mode 120000 index 00000000..d526672c --- /dev/null +++ b/CHANGELOG @@ -0,0 +1 @@ +debian/changelog \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..712c4586 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright 2014 Joey Hess and contributors. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..d6e8fe6f --- /dev/null +++ b/Makefile @@ -0,0 +1,45 @@ +CABAL?=cabal + +DEBDEPS=gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-quickcheck2-dev libghc-mtl-dev libghc-monadcatchio-transformers-dev + +run: deps build + ./propellor + +dev: build tags + +build: dist/setup-config + if ! $(CABAL) build; then $(CABAL) configure; $(CABAL) build; fi + ln -sf dist/build/propellor-config/propellor-config propellor + +deps: + @if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install $(DEBDEPS) || (apt-get update && apt-get --no-upgrade --no-install-recommends -y install $(DEBDEPS)); fi || true + @if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install libghc-async-dev || (cabal update; cabal install async); fi || true + +dist/setup-config: propellor.cabal + if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi + $(CABAL) configure + +install: + install -d $(DESTDIR)/usr/bin $(DESTDIR)/usr/src/propellor + install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor + $(CABAL) sdist + cat dist/propellor-*.tar.gz | \ + (cd $(DESTDIR)/usr/src/propellor && tar zx --strip-components=1) + +clean: + rm -rf dist Setup tags propellor privdata/local + find -name \*.o -exec rm {} \; + find -name \*.hi -exec rm {} \; + +# hothasktags chokes on some template haskell etc, so ignore errors +# 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 | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags 2>/dev/null + +# Upload to hackage. +hackage: + @cabal sdist + @cabal upload dist/*.tar.gz + +.PHONY: tags diff --git a/README.md b/README.md new file mode 120000 index 00000000..75370e22 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +doc/README.mdwn \ No newline at end of file diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 00000000..daf5717a --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +{- cabal setup file -} + +import Distribution.Simple + +main = defaultMain diff --git a/config-joey.hs b/config-joey.hs new file mode 100644 index 00000000..18f0a32b --- /dev/null +++ b/config-joey.hs @@ -0,0 +1,416 @@ +-- This is the live config file used by propellor's author. +module Main where + +import Propellor +import Propellor.CmdLine +import Propellor.Property.Scheduled +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Network as Network +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.Sudo as Sudo +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Hostname as Hostname +--import qualified Propellor.Property.Reboot as Reboot +import qualified Propellor.Property.Tor as Tor +import qualified Propellor.Property.Dns as Dns +import qualified Propellor.Property.OpenId as OpenId +import qualified Propellor.Property.Docker as Docker +import qualified Propellor.Property.Git as Git +import qualified Propellor.Property.Apache as Apache +import qualified Propellor.Property.Postfix as Postfix +import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.Grub as Grub +import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean +import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost +import qualified Propellor.Property.HostingProvider.Linode as Linode +import qualified Propellor.Property.SiteSpecific.GitHome as GitHome +import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder +import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites + + +main :: IO () -- _ ______`| ,-.__ +main = defaultMain hosts -- / \___-=O`/|O`/__| (____.' + {- Propellor -- \ / | / ) _.-"-._ + Deployed -} -- `/-==__ _/__|/__=-| ( \_ +hosts :: [Host] -- * \ | | '--------' +hosts = -- (o) ` + [ host "darkstar.kitenet.net" + & ipv6 "2001:4830:1600:187::2" -- sixxs tunnel + + & Apt.buildDep ["git-annex"] `period` Daily + & Docker.configured + & Docker.docked hosts "android-git-annex" + + , standardSystem "clam.kitenet.net" Unstable "amd64" + [ "Unreliable server. Anything here may be lost at any time!" ] + & ipv4 "162.248.9.29" + + & CloudAtCost.decruft + & Apt.unattendedUpgrades + & Network.ipv6to4 + & Tor.isBridge + & Postfix.satellite + + & Docker.configured + & Docker.garbageCollected `period` Daily + + -- Orca is the main git-annex build box. + , standardSystem "orca.kitenet.net" Unstable "amd64" + [ "Main git-annex build box." ] + & ipv4 "138.38.108.179" + + & Hostname.sane + & Apt.unattendedUpgrades + & Postfix.satellite + & Docker.configured + & Docker.docked hosts "amd64-git-annex-builder" + & Docker.docked hosts "i386-git-annex-builder" + & Docker.docked hosts "armel-git-annex-builder-companion" + & Docker.docked hosts "armel-git-annex-builder" + & Docker.docked hosts "android-git-annex-builder" + & Docker.garbageCollected `period` Daily + & Apt.buildDep ["git-annex"] `period` Daily + + , standardSystem "kite.kitenet.net" Unstable "amd64" + [ "Welcome to the new kitenet.net server!" + , "This is still under construction and not yet live.." + ] + & ipv4 "66.228.36.95" + & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" + + & Apt.installed ["linux-image-amd64"] + & Linode.chainPVGrub 5 + & Hostname.sane + & Apt.unattendedUpgrades + & Apt.installed ["systemd"] + & Ssh.hostKeys (Context "kitenet.net") + + , standardSystem "diatom.kitenet.net" Stable "amd64" + [ "Important stuff that needs not too much memory or CPU." ] + & ipv4 "107.170.31.195" + + & DigitalOcean.distroKernel + & Hostname.sane + & Ssh.hostKeys (Context "diatom.kitenet.net") + & Apt.unattendedUpgrades + & Apt.serviceInstalledRunning "ntp" + & Postfix.satellite + + -- Diatom has 500 mb of memory, so tune for that. + & JoeySites.obnamLowMem + & Apt.serviceInstalledRunning "swapspace" + + & Apt.serviceInstalledRunning "apache2" + & File.hasPrivContent "/etc/ssl/certs/web.pem" (Context "kitenet.net") + & File.hasPrivContent "/etc/ssl/private/web.pem" (Context "kitenet.net") + & File.hasPrivContent "/etc/ssl/certs/startssl.pem" (Context "kitenet.net") + & Apache.modEnabled "ssl" + & Apache.multiSSL + & File.ownerGroup "/srv/web" "joey" "joey" + & Apt.installed ["analog"] + + & alias "git.kitenet.net" + & alias "git.joeyh.name" + & JoeySites.gitServer hosts + + & alias "downloads.kitenet.net" + & JoeySites.annexWebSite hosts "/srv/git/downloads.git" + "downloads.kitenet.net" + "840760dc-08f0-11e2-8c61-576b7e66acfd" + [("turtle", "ssh://turtle.kitenet.net/~/lib/downloads/")] + & JoeySites.gitAnnexDistributor + + & alias "tmp.kitenet.net" + & JoeySites.annexWebSite hosts "/srv/git/joey/tmp.git" + "tmp.kitenet.net" + "26fd6e38-1226-11e2-a75f-ff007033bdba" + [] + & JoeySites.twitRss + + & alias "nntp.olduse.net" + & alias "resources.olduse.net" + & JoeySites.oldUseNetServer hosts + + & alias "ns2.kitenet.net" + & myDnsPrimary "kitenet.net" [] + & myDnsPrimary "joeyh.name" [] + & myDnsPrimary "ikiwiki.info" [] + & myDnsPrimary "olduse.net" + [ (RelDomain "article", + CNAME $ AbsDomain "virgil.koldfront.dk") ] + + & alias "ns3.branchable.com" + & branchableSecondary + + & Dns.secondaryFor ["animx"] hosts "animx.eu.org" + + , let ctx = Context "elephant.kitenet.net" + in standardSystem "elephant.kitenet.net" Unstable "amd64" + [ "Storage, big data, and backups, omnomnom!" ] + & ipv4 "193.234.225.114" + + & Grub.chainPVGrub "hd0,0" "xen/xvda1" 30 + & Hostname.sane + & Postfix.satellite + & Apt.unattendedUpgrades + & Ssh.hostKeys ctx + & Ssh.keyImported SshRsa "joey" ctx + & Apt.serviceInstalledRunning "swapspace" + + & alias "eubackup.kitenet.net" + & Apt.installed ["obnam", "sshfs", "rsync"] + & JoeySites.githubBackup + & JoeySites.obnamRepos ["wren", "pell"] + & Ssh.knownHost hosts "usw-s002.rsync.net" "joey" + + & alias "podcatcher.kitenet.net" + & Apt.installed ["git-annex"] + + & alias "znc.kitenet.net" + & JoeySites.ircBouncer + + -- I'd rather this were on diatom, but it needs unstable. + & alias "kgb.kitenet.net" + & JoeySites.kgbServer + + & alias "mumble.kitenet.net" + & JoeySites.mumbleServer hosts + + & alias "ns3.kitenet.net" + & myDnsSecondary + + & Docker.configured + + & Docker.docked hosts "oldusenet-shellbox" + & Docker.docked hosts "openid-provider" + `requires` Apt.serviceInstalledRunning "ntp" + & Docker.docked hosts "ancient-kitenet" + + & Docker.garbageCollected `period` (Weekly (Just 1)) + + -- For https port 443, shellinabox with ssh login to + -- kitenet.net + & alias "shell.kitenet.net" + & JoeySites.kiteShellBox + -- Nothing is using http port 80, so listen on + -- that port for ssh, for traveling on bad networks that + -- block 22. + & "/etc/ssh/sshd_config" `File.containsLine` "Port 80" + `onChange` Service.restarted "ssh" + + -- temp + & Docker.docked hosts "amd64-git-annex-builder" + & Docker.docked hosts "i386-git-annex-builder" + & Docker.docked hosts "android-git-annex-builder" + + + --' __|II| ,. + ---- __|II|II|__ ( \_,/\ + ------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'- + ----------------------- | [Docker] / ---------------------- + ----------------------- : / ----------------------- + ------------------------ \____, o ,' ------------------------ + ------------------------- '--,___________,' ------------------------- + + -- Simple web server, publishing the outside host's /var/www + , standardContainer "webserver" Stable "amd64" + & Docker.publish "8080:80" + & Docker.volume "/var/www:/var/www" + & Apt.serviceInstalledRunning "apache2" + + -- My own openid provider. Uses php, so containerized for security + -- and administrative sanity. + , standardContainer "openid-provider" Stable "amd64" + & alias "openid.kitenet.net" + & Docker.publish "8081:80" + & OpenId.providerFor ["joey", "liw"] + "openid.kitenet.net:8081" + + -- Exhibit: kite's 90's website. + , standardContainer "ancient-kitenet" Stable "amd64" + & alias "ancient.kitenet.net" + & Docker.publish "1994:80" + & Apt.serviceInstalledRunning "apache2" + & Git.cloned "root" "git://kitenet-net.branchable.com/" "/var/www" + (Just "remotes/origin/old-kitenet.net") + + , standardContainer "oldusenet-shellbox" Stable "amd64" + & alias "shell.olduse.net" + & Docker.publish "4200:4200" + & JoeySites.oldUseNetShellBox + + -- git-annex autobuilder containers + , GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h" + , GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h" + , GitAnnexBuilder.armelCompanionContainer dockerImage + , GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h" + , GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h" + + -- for development of git-annex for android, using my git-annex + -- work tree + , let gitannexdir = GitAnnexBuilder.homedir "git-annex" + in GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir + & Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir) + + -- temp for an acquantance + ] ++ monsters + +type Motd = [String] + +-- This is my standard system setup. +standardSystem :: HostName -> DebianSuite -> Architecture -> Motd -> Host +standardSystem hn suite arch motd = host hn + & os (System (Debian suite) arch) + & File.hasContent "/etc/motd" ("":motd++[""]) + & Apt.stdSourcesList `onChange` Apt.upgrade + & Apt.cacheCleaned + & Apt.installed ["etckeeper"] + & Apt.installed ["ssh"] + & GitHome.installedFor "root" + & User.hasSomePassword "root" (Context hn) + -- Harden the system, but only once root's authorized_keys + -- is safely in place. + & check (Ssh.hasAuthorizedKeys "root") + (Ssh.passwordAuthentication False) + & User.accountFor "joey" + & User.hasSomePassword "joey" (Context hn) + & Sudo.enabledFor "joey" + & GitHome.installedFor "joey" + & Apt.installed ["vim", "screen", "less"] + & Cron.runPropellor "30 * * * *" + -- I use postfix, or no MTA. + & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] + `onChange` Apt.autoRemove + +-- This is my standard container setup, featuring automatic upgrades. +standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host +standardContainer name suite arch = Docker.container name (dockerImage system) + & os system + & Apt.stdSourcesList `onChange` Apt.upgrade + & Apt.installed ["systemd"] + & Apt.unattendedUpgrades + & Apt.cacheCleaned + where + system = System (Debian suite) arch + +-- Docker images I prefer to use. +dockerImage :: System -> Docker.Image +dockerImage (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch +dockerImage (System (Debian Testing) arch) = "joeyh/debian-unstable-" ++ arch +dockerImage (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch +dockerImage _ = "debian-stable-official" -- does not currently exist! + +myDnsSecondary :: Property +myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp + [ Dns.secondary hosts "kitenet.net" + , Dns.secondary hosts "joeyh.name" + , Dns.secondary hosts "ikiwiki.info" + , Dns.secondary hosts "olduse.net" + ] + +branchableSecondary :: RevertableProperty +branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com" + +-- Currently using diatom (ns2) as primary with secondaries +-- elephant (ns3) and gandi. +-- kite handles all mail. +myDnsPrimary :: Domain -> [(BindDomain, Record)] -> RevertableProperty +myDnsPrimary domain extras = Dns.primary hosts domain + (Dns.mkSOA "ns2.kitenet.net" 100) $ + [ (RootDomain, NS $ AbsDomain "ns2.kitenet.net") + , (RootDomain, NS $ AbsDomain "ns3.kitenet.net") + , (RootDomain, NS $ AbsDomain "ns6.gandi.net") + , (RootDomain, MX 0 $ AbsDomain "kitenet.net") + , (RootDomain, TXT "v=spf1 a ?all") + ] ++ extras + + + -- o + -- ___ o o + {-----\ / o \ ___o o + { \ __ \ / _ (X___>-- __o + _____________________{ ______\___ \__/ | \__/ \____ |X__> + < \___//|\\___/\ \____________ _ + \ ___/ | \___ # # \ (-) + \ O O O # | \ # >=) + \______________________________# # / #__________________/ (-} + + +monsters :: [Host] -- Systems I don't manage with propellor, +monsters = -- but do want to track their public keys etc. + [ host "usw-s002.rsync.net" + & sshPubKey "ssh-dss AAAAB3NzaC1kc3MAAAEBAI6ZsoW8a+Zl6NqUf9a4xXSMcV1akJHDEKKBzlI2YZo9gb9YoCf5p9oby8THUSgfh4kse7LJeY7Nb64NR6Y/X7I2/QzbE1HGGl5mMwB6LeUcJ74T3TQAlNEZkGt/MOIVLolJHk049hC09zLpkUDtX8K0t1yaCirC9SxDGLTCLEhvU9+vVdVrdQlKZ9wpLUNbdAzvbra+O/IVvExxDZ9WCHrnfNA8ddVZIGEWMqsoNgiuCxiXpi8qL+noghsSQNFTXwo7W2Vp9zj1JkCt3GtSz5IzEpARQaXEAWNEM0n1nJ686YUOhou64iRM8bPC1lp3QXvvZNgj3m+QHhIempx+de8AAAAVAKB5vUDaZOg14gRn7Bp81ja/ik+RAAABACPH/bPbW912x1NxNiikzGR6clLh+bLpIp8Qie3J7DwOr8oC1QOKjNDK+UgQ7mDQEgr4nGjNKSvpDi4c1QCw4sbLqQgx1y2VhT0SmUPHf5NQFldRQyR/jcevSSwOBxszz3aq9AwHiv9OWaO3XY18suXPouiuPTpIcZwc2BLDNHFnDURQeGEtmgqj6gZLIkTY0iw7q9Tj5FOyl4AkvEJC5B4CSzaWgey93Wqn1Imt7KI8+H9lApMKziVL1q+K7xAuNkGmx5YOSNlE6rKAPtsIPHZGxR7dch0GURv2jhh0NQYvBRn3ukCjuIO5gx56HLgilq59/o50zZ4NcT7iASF76TcAAAEAC6YxX7rrs8pp13W4YGiJHwFvIO1yXLGOdqu66JM0plO4J1ItV1AQcazOXLiliny3p2/W+wXZZKd5HIRt52YafCA8YNyMk/sF7JcTR4d4z9CfKaAxh0UpzKiAk+0j/Wu3iPoTOsyt7N0j1+dIyrFodY2sKKuBMT4TQ0yqQpbC+IDQv2i1IlZAPneYGfd5MIGygs2QMfaMQ1jWAKJvEO0vstZ7GB6nDAcg4in3ZiBHtomx3PL5w+zg48S4Ed69BiFXLZ1f6MnjpUOP75pD4MP6toS0rgK9b93xCrEQLgm4oD/7TCHHBo2xR7wwcsN2OddtwWsEM2QgOkt/jdCAoVCqwQ==" + , host "github.com" + & sshPubKey "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ==" + , host "ns6.gandi.net" + & ipv4 "217.70.177.40" + , host "turtle.kitenet.net" + & ipv4 "67.223.19.96" + & ipv6 "2001:4978:f:2d9::2" + & alias "backup.kitenet.net" + & sshPubKey "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAokMXQiX/NZjA1UbhMdgAscnS5dsmy+Q7bWrQ6tsTZ/o+6N/T5cbjoBHOdpypXJI3y/PiJTDJaQtXIhLa8gFg/EvxMnMz/KG9skADW1361JmfCc4BxicQIO2IOOe6eilPr+YsnOwiHwL0vpUnuty39cppuMWVD25GzxXlS6KQsLCvXLzxLLuNnGC43UAM0q4UwQxDtAZEK1dH2o3HMWhgMP2qEQupc24dbhpO3ecxh2C9678a3oGDuDuNf7mLp3s7ptj5qF3onitpJ82U5o7VajaHoygMaSRFeWxP2c13eM57j3bLdLwxVXFhePcKXARu1iuFTLS5uUf3hN6MkQcOGw==" + , host "wren.kitenet.net" + & ipv4 "80.68.85.49" + & ipv6 "2001:41c8:125:49::10" + & alias "kitenet.net" + & alias "ns1.kitenet.net" + & alias "ftp.kitenet.net" + & alias "mail.kitenet.net" + & alias "smtp.kitenet.net" + & alias "sows-ear.kitenet.net" + & alias "www.sows-ear.kitenet.net" + & alias "wortroot.kitenet.net" + & alias "www.wortroot.kitenet.net" + & alias "joey.kitenet.net" + & alias "anna.kitenet.net" + & alias "bitlbee.kitenet.net" + {- Remaining services on kite: + - + - mail + - postfix + - postgrey + - mailman + - spamassassin + - sqwebmail + - courier + - imap + - tls + - apache + - some static websites + - bitlbee + - prosody + - (used by daddy's git-annex) + - named + - (branchable is still pushing to here + - (thinking it's ns2.branchable.com), but it's no + - longer a primary or secondary for anything) + - ftpd (EOL) + - + - user shell stuff: + - pine, zsh, make, git-annex, myrepos, ... + -} + , host "mouse.kitenet.net" + & ipv6 "2001:4830:1600:492::2" + , host "beaver.kitenet.net" + & ipv6 "2001:4830:1600:195::2" + , host "hydra.kitenet.net" + & ipv4 "192.25.206.60" + , host "branchable.com" + & ipv4 "66.228.46.55" + & ipv6 "2600:3c03::f03c:91ff:fedf:c0e5" + & alias "olduse.net" + & alias "www.olduse.net" + & alias "www.kitenet.net" + & alias "joeyh.name" + & alias "campaign.joeyh.name" + & alias "ikiwiki.info" + & alias "git.ikiwiki.info" + & alias "l10n.ikiwiki.info" + & alias "dist-bugs.kitenet.net" + & alias "family.kitenet.net" + , host "animx" + & ipv4 "76.7.162.101" + & ipv4 "76.7.162.186" + ] diff --git a/config-simple.hs b/config-simple.hs new file mode 100644 index 00000000..35eae40c --- /dev/null +++ b/config-simple.hs @@ -0,0 +1,49 @@ +-- This is the main configuration file for Propellor, and is used to build +-- the propellor program. + +import Propellor +import Propellor.CmdLine +import Propellor.Property.Scheduled +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Network as Network +--import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Cron as Cron +--import qualified Propellor.Property.Sudo as Sudo +import qualified Propellor.Property.User as User +--import qualified Propellor.Property.Hostname as Hostname +--import qualified Propellor.Property.Reboot as Reboot +--import qualified Propellor.Property.Tor as Tor +import qualified Propellor.Property.Docker as Docker + +main :: IO () +main = defaultMain hosts + +-- The hosts propellor knows about. +-- Edit this to configure propellor! +hosts :: [Host] +hosts = + [ host "mybox.example.com" + & os (System (Debian Unstable) "amd64") + & Apt.stdSourcesList + & Apt.unattendedUpgrades + & Apt.installed ["etckeeper"] + & Apt.installed ["ssh"] + & User.hasSomePassword "root" (Context "mybox.example.com") + & Network.ipv6to4 + & File.dirExists "/var/www" + & Docker.docked hosts "webserver" + & Docker.garbageCollected `period` Daily + & Cron.runPropellor "30 * * * *" + + -- A generic webserver in a Docker container. + , Docker.container "webserver" "joeyh/debian-stable" + & os (System (Debian Stable) "amd64") + & Apt.stdSourcesList + & Docker.publish "80:80" + & Docker.volume "/var/www:/var/www" + & Apt.serviceInstalledRunning "apache2" + + -- add more hosts here... + --, host "foo.example.com" = ... + ] diff --git a/config.hs b/config.hs new file mode 120000 index 00000000..ec313725 --- /dev/null +++ b/config.hs @@ -0,0 +1 @@ +config-simple.hs \ No newline at end of file diff --git a/debian/README.Debian b/debian/README.Debian new file mode 100644 index 00000000..e32a0ee3 --- /dev/null +++ b/debian/README.Debian @@ -0,0 +1,7 @@ +The Debian package of propellor ships its full source code because +propellor is configured by rebuilding it, and embraces modification of any +of the source code. + +/usr/bin/propellor is a wrapper which will set up a propellor git +repository in ~/.propellor/, and run ~/.propellor/propellor if it exists. +Edit ~/.propellor/config.hs to configure it. diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 00000000..54923662 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,194 @@ +propellor (0.8.1) unstable; urgency=medium + + * Run apt-get update in initial bootstrap. + * --list-fields now includes a table of fields that are not currently set, + but would be used if they got set. + * Remove .gitignore from cabal file list, to avoid build failure on Debian. + Closes: #754334 + + -- Joey Hess Wed, 09 Jul 2014 22:11:31 -0400 + +propellor (0.8.0) unstable; urgency=medium + + * Completely reworked privdata storage. There is now a single file, + and each host is sent only the privdata that its Properties actually use. + + To transition existing privdata, run propellor against a host and + watch out for the red failure messages, and run the suggested commands + to store the privdata using the new storage scheme. You may find + it useful to run the old version of propellor to extract data from the old + privdata files during this migration. + + Several properties that use privdata now require a context to be + specified. If in doubt, you can use anyContext, or + Context "hostname.example.com" + + * Add --edit to edit a privdata value in $EDITOR. + * Add --list-fields to list all currently set privdata fields, along with + the hosts that use them. + * Fix randomHostKeys property to run openssh-server's postinst in a + non-failing way. + * Hostname.sane now cleans up the 127.0.0.1 localhost line in /etc/hosts, + to avoid eg, apache complaining "Could not reliably determine the + server's fully qualified domain name". + + -- Joey Hess Sun, 06 Jul 2014 18:28:08 -0400 + +propellor (0.7.0) unstable; urgency=medium + + * combineProperties no longer stops when a property fails; now it continues + trying to satisfy all properties on the list before propigating the + failure. + * Attr is renamed to Info. + * Renamed wrapper to propellor to make cabal installation of propellor work. + * When git gpg signature of a fetched git branch cannot be verified, + propellor will now continue running, but without merging in that branch. + + -- Joey Hess Fri, 13 Jun 2014 10:06:40 -0400 + +propellor (0.6.0) unstable; urgency=medium + + * Docker containers now propagate DNS attributes out to the host they're + docked in. So if a docker container sets a DNS alias, every container + it's docked in will automatically be added to a DNS round-robin, + when propellor is used to manage DNS for the domain. + * Apt.stdSourcesList no longer needs a suite to be specified. + * Added --dump to dump out a field of a host's privdata. Useful for editing + it. + * Propellor's output now includes the hostname being provisioned, or + when provisioning a docker container, the container name. + + -- Joey Hess Thu, 05 Jun 2014 17:32:14 -0400 + +propellor (0.5.3) unstable; urgency=medium + + * Fix unattended-upgrades config for !stable. + * Ensure that kernel hostname is same as /etc/hostname when configuring + hostname. + * Added modules for some hosting providers (DigitalOcean, CloudAtCost). + + -- Joey Hess Thu, 29 May 2014 14:29:53 -0400 + +propellor (0.5.2) unstable; urgency=medium + + * A bug that caused propellor to hang when updating a running docker + container appears to have been fixed. Note that since it affects + the propellor process that serves as "init" of docker containers, + they have to be restarted for the fix to take effect. + * Licence changed from GPL to BSD. + * A few changes to allow building Propellor on OSX. One user reports + successfully using it there. + + -- Joey Hess Sat, 17 May 2014 16:42:55 -0400 + +propellor (0.5.1) unstable; urgency=medium + + * Primary DNS servers now have allow-transfer automatically populated + with the IP addresses of secondary dns servers. So, it's important + that all secondary DNS servers have an ipv4 (and/or ipv6) property + configured. + * Deal with old ssh connection caching sockets. + * Add missing build deps and deps. Closes: #745459 + + -- Joey Hess Thu, 24 Apr 2014 18:09:58 -0400 + +propellor (0.5.0) unstable; urgency=medium + + * Removed root domain records from SOA. Instead, use RootDomain + when calling Dns.primary. + * Dns primary and secondary properties are now revertable. + * When unattendedUpgrades is enabled on an Unstable or Testing system, + configure it to allow the upgrades. + * New website, https://propellor.branchable.com/ + + -- Joey Hess Sat, 19 Apr 2014 17:38:02 -0400 + +propellor (0.4.0) unstable; urgency=medium + + * Propellor can configure primary DNS servers, including generating + zone files, which is done by looking at the properties of hosts + in a domain. + * The `cname` property was renamed to `alias` as it does not always + generate CNAME in the DNS. + * Constructor of Property has changed (use `property` function instead). + * All Property combinators now combine together their Attr settings. + So Attr settings can be made inside a propertyList, for example. + * Run all cron jobs under chronic from moreutils to avoid unnecessary + mails. + + -- Joey Hess Sat, 19 Apr 2014 02:09:56 -0400 + +propellor (0.3.1) unstable; urgency=medium + + * Merge scheduler bug fix from git-annex. + * Support for provisioning hosts with ssh and gpg keys. + * Obnam support. + * Apache support. + * Postfix satellite system support. + * Properties can now be satisfied differently on different operating + systems. + * Standard apt configuration for stable now includes backports. + * Cron jobs generated by propellor use flock(1) to avoid multiple + instances running at a time. + * Add support for SSH ed25519 keys. + (Thanks, Franz Pletz.) + + -- Joey Hess Thu, 17 Apr 2014 20:07:33 -0400 + +propellor (0.3.0) unstable; urgency=medium + + * ipv6to4: Ensure interface is brought up automatically on boot. + * Enabling unattended upgrades now ensures that cron is installed and + running to perform them. + * Properties can be scheduled to only be checked after a given time period. + * Fix bootstrapping of dependencies. + * Fix compilation on Debian stable. + * Include security updates in sources.list for stable and testing. + * Use ssh connection caching, especially when bootstrapping. + * Properties now run in a Propellor monad, which provides access to + attributes of the host. + + -- Joey Hess Fri, 11 Apr 2014 01:19:05 -0400 + +propellor (0.2.3) unstable; urgency=medium + + * docker: Fix laziness bug that caused running containers to be + unnecessarily stopped and committed. + * Add locking so only one propellor can run at a time on a host. + * docker: When running as effective init inside container, wait on zombies. + * docker: Added support for configuring shared volumes and linked + containers. + + -- Joey Hess Tue, 08 Apr 2014 02:07:37 -0400 + +propellor (0.2.2) unstable; urgency=medium + + * Now supports provisioning docker containers with architecture/libraries + that do not match the host. + * Fixed a bug that caused file modes to be set to 600 when propellor + modified the file (did not affect newly created files). + + -- Joey Hess Fri, 04 Apr 2014 01:07:32 -0400 + +propellor (0.2.1) unstable; urgency=medium + + * First release with Debian package. + + -- Joey Hess Thu, 03 Apr 2014 01:43:14 -0400 + +propellor (0.2.0) unstable; urgency=low + + * Added support for provisioning Docker containers. + * Bootstrap deployment now pushes the git repo to the remote host + over ssh, securely. + * propellor --add-key configures a gpg key, and makes propellor refuse + to pull commits from git repositories not signed with that key. + This allows propellor to be securely used with public, non-encrypted + git repositories without the possibility of MITM. + * Added support for type-safe reversions. Only some properties can be + reverted; the type checker will tell you if you try something that won't + work. + * New syntactic sugar for building a list of properties, including + revertable properties. + + -- Joey Hess Wed, 02 Apr 2014 13:57:42 -0400 diff --git a/debian/compat b/debian/compat new file mode 100644 index 00000000..ec635144 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +9 diff --git a/debian/control b/debian/control new file mode 100644 index 00000000..a4dc2466 --- /dev/null +++ b/debian/control @@ -0,0 +1,44 @@ +Source: propellor +Section: admin +Priority: optional +Build-Depends: + debhelper (>= 9), + ghc (>= 7.4), + cabal-install, + libghc-async-dev, + libghc-missingh-dev, + libghc-hslogger-dev, + libghc-unix-compat-dev, + libghc-ansi-terminal-dev, + libghc-ifelse-dev, + libghc-network-dev, + libghc-quickcheck2-dev, + libghc-mtl-dev, + libghc-monadcatchio-transformers-dev, +Maintainer: Joey Hess +Standards-Version: 3.9.5 +Vcs-Git: git://git.kitenet.net/propellor +Homepage: http://joeyh.name/code/propellor/ + +Package: propellor +Architecture: any +Section: admin +Depends: ${misc:Depends}, ${shlibs:Depends}, + ghc (>= 7.4), + cabal-install, + libghc-async-dev, + libghc-missingh-dev, + libghc-hslogger-dev, + libghc-unix-compat-dev, + libghc-ansi-terminal-dev, + libghc-ifelse-dev, + libghc-network-dev, + libghc-quickcheck2-dev, + libghc-mtl-dev, + libghc-monadcatchio-transformers-dev, + git, +Description: property-based host configuration management in haskell + Propellor enures that the system it's run in satisfies a list of + properties, taking action as necessary when a property is not yet met. + . + It is configured using haskell. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 00000000..3bdd0103 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,28 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Source: native package + +Files: * +Copyright: © 2010-2014 Joey Hess +License: BSD-2-clause + +License: BSD-2-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + . + THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. diff --git a/debian/lintian-overrides b/debian/lintian-overrides new file mode 100644 index 00000000..a5ccccae --- /dev/null +++ b/debian/lintian-overrides @@ -0,0 +1,2 @@ +# These files are used in a git repository that propellor sets up. +propellor: package-contains-vcs-control-file usr/src/propellor/.gitignore diff --git a/debian/propellor.1 b/debian/propellor.1 new file mode 100644 index 00000000..3ee3bf4a --- /dev/null +++ b/debian/propellor.1 @@ -0,0 +1,15 @@ +.\" -*- nroff -*- +.TH propellor 1 "Commands" +.SH NAME +propellor \- property-based host configuration management in haskell +.SH SYNOPSIS +.B propellor [options] host +.SH DESCRIPTION +.I propellor +is a property-based host configuration management program written +and configured in haskell. +.PP +The first time you run propellor, it will set up a ~/.propellor/ +repository. Edit ~/.propellor/config.hs to configure it. +.SH AUTHOR +Joey Hess diff --git a/debian/rules b/debian/rules new file mode 100755 index 00000000..f5025b3f --- /dev/null +++ b/debian/rules @@ -0,0 +1,18 @@ +#!/usr/bin/make -f + +# Avoid using cabal, as it writes to $HOME +export CABAL=./Setup + +%: + dh $@ + +override_dh_auto_build: + $(MAKE) build +override_dh_installdocs: + dh_installdocs doc/README.mdwn +override_dh_installman: + dh_installman debian/propellor.1 + +# Not intended for use by anyone except the author. +announcedir: + @echo ${HOME}/src/propellor/doc/news diff --git a/doc/README.mdwn b/doc/README.mdwn new file mode 100644 index 00000000..71b265f5 --- /dev/null +++ b/doc/README.mdwn @@ -0,0 +1,71 @@ +[Propellor](https://propellor.branchable.com/) is a +configuration management system using Haskell and Git. +Each system has a list of properties, which Propellor ensures +are satisfied. + +Propellor is configured via a git repository, which typically lives +in `~/.propellor/` on your development machine. Propellor clones the +repository to each host it manages, in a +[secure](http://propellor.branchable.com/security/) way. The git repository +contains the full source code to Propellor, along with its config file. + +Properties are defined using Haskell. Edit `~/.propellor/config.hs` +to get started. There is fairly complete +[API documentation](http://hackage.haskell.org/package/propellor/), +which includes many built-in Properties for dealing with +[Apt](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apt.html) +and +[Apache](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apache.html) +, +[Cron](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Cron.html) +and +[Commands](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Cmd.html) +, +[Dns](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Dns.html) +and +[Docker](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Docker.html), etc. + +There is no special language as used in puppet, chef, ansible, etc.. just +the full power of Haskell. Hopefully that power can be put to good use in +making declarative properties that are powerful, nicely idempotent, and +easy to adapt to a system's special needs! + +If using Haskell to configure Propellor seems intimidating, +see [configuration for the Haskell newbie](https://propellor.branchable.com/haskell_newbie/). + +## quick start + +1. Get propellor installed + `cabal install propellor` + or + `apt-get install propellor` +2. Run propellor for the first time. It will set up a `~/.propellor/` git + repository for you. +3. If you don't have a gpg private key already, generate one: `gpg --gen-key` +4. Run: `propellor --add-key $KEYID`, which will make propellor trust + your gpg key, and will sign your `~/.propellor` repository using it. +5. `cd ~/.propellor/`; use git to push the repository to a central + server (github, or your own git server). Configure that central + server as the origin remote of the repository. +6. Edit `~/.propellor/config.hs`, and add a host you want to manage. + You can start by not adding any properties, or only a few. +7. Pick a host and run: `propellor --spin $HOST` +8. Now you have a simple propellor deployment, but it doesn't do + much to the host yet, besides installing propellor. + + So, edit `~/.propellor/config.hs` to configure the host (maybe + start with a few simple properties), and re-run step 7. + Repeat until happy and move on to the next host. :) +9. To move beyond manually running `propellor --spin` against hosts + when you change their properties, add a property to your hosts + like: `Cron.runPropellor "30 * * * *"` + + Now they'll automatically update every 30 minutes, and you can + `git commit -S` and `git push` changes that affect any number of + hosts. +10. Write some neat new properties and send patches to ! + +## debugging + +Set `PROPELLOR_DEBUG=1` to make propellor print out all the commands it runs +and any other debug messages that Properties choose to emit. diff --git a/doc/comments.mdwn b/doc/comments.mdwn new file mode 100644 index 00000000..e19962b9 --- /dev/null +++ b/doc/comments.mdwn @@ -0,0 +1,9 @@ +[[!sidebar content=""" +[[!inline pages="comment_pending(*)" feedfile=pendingmoderation +description="comments pending moderation" show=-1]] +Comments in the [[!commentmoderation desc="moderation queue"]]: +[[!pagecount pages="comment_pending(*)"]] +"""]] + +Recent comments posted to this site: +[[!inline pages="comment(*)" template="comment"]] diff --git a/doc/forum.mdwn b/doc/forum.mdwn new file mode 100644 index 00000000..414b335d --- /dev/null +++ b/doc/forum.mdwn @@ -0,0 +1,4 @@ +This is a place to discuss using propellor, share tips and tricks, etc. +If you need help, advice, or anything, post about it here. + +[[!inline pages="forum/* and !*/Discussion" archive=yes rootpage=forum postformtext="Add a new thread titled:"]] diff --git a/doc/forum/cabal_install_problem.mdwn b/doc/forum/cabal_install_problem.mdwn new file mode 100644 index 00000000..50525e03 --- /dev/null +++ b/doc/forum/cabal_install_problem.mdwn @@ -0,0 +1,5 @@ +I just did a cabal install of propellor + +The binaries it installs are called wrapper and config, although the makefile/documentation say that at least one of them should be called propellor. + +Is this correct? diff --git a/doc/forum/cabal_install_problem/comment_1_2201805f80683575c4675e3268dfabc0._comment b/doc/forum/cabal_install_problem/comment_1_2201805f80683575c4675e3268dfabc0._comment new file mode 100644 index 00000000..4cd56232 --- /dev/null +++ b/doc/forum/cabal_install_problem/comment_1_2201805f80683575c4675e3268dfabc0._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + ip="2001:4830:1600:187::2" + subject="comment 1" + date="2014-06-09T16:34:29Z" + content=""" +wrapper should be named propellor. This is fixed in git. +"""]] diff --git a/doc/forum/remote.origin_not_copied_to_managed_host__63__.mdwn b/doc/forum/remote.origin_not_copied_to_managed_host__63__.mdwn new file mode 100644 index 00000000..6efdbae8 --- /dev/null +++ b/doc/forum/remote.origin_not_copied_to_managed_host__63__.mdwn @@ -0,0 +1,95 @@ +The only remote which seems to be copied to /root/.propellor/.git/config is upstream... My /home/user/.propellor/.git/config contains a "origin" remote, but this part (as well as the master branch part) of my git config is not copied to the /root/.propellor/.git/config of a host I'm trying to manage... + +propellor fails with the following message: + + user@laptop:~$ PROPELLOR_DEBUG=1 propellor --spin laptop.localdomain + if ! cabal build; then cabal configure; cabal build; fi + Building propellor-0.5.0... + Preprocessing library propellor-0.5.0... + In-place registering propellor-0.5.0... + Preprocessing executable 'propellor' for propellor-0.5.0... + Preprocessing executable 'config' for propellor-0.5.0... + ln -sf dist/build/config/config propellor + + + [2014-04-21 18:07:45 CEST] command line: Spin "laptop.localdomain" + [2014-04-21 18:07:45 CEST] call: make ["build"] + if ! cabal build; then cabal configure; cabal build; fi + Building propellor-0.5.0... + Preprocessing library propellor-0.5.0... + In-place registering propellor-0.5.0... + Preprocessing executable 'propellor' for propellor-0.5.0... + Preprocessing executable 'config' for propellor-0.5.0... + ln -sf dist/build/config/config propellor + Propellor build ... done + [2014-04-21 18:07:48 CEST] read: git ["config","remote.deploy.url"] + [2014-04-21 18:07:48 CEST] read: git ["config","remote.origin.url"] + [2014-04-21 18:07:48 CEST] call: git ["commit","--gpg-sign","--allow-empty","-a","-m","propellor spin"] + + You need a passphrase to unlock the secret key for + ... + + [master ee393d6] propellor spin + [2014-04-21 18:07:48 CEST] call: git ["push"] + Counting objects: 1, done. + Writing objects: 100% (1/1), 852 bytes | 0 bytes/s, done. + Total 1 (delta 0), reused 0 (delta 0) + To git@remote-origin:propellor.git + 16a1f8b..ee393d6 master -> master + [2014-04-21 18:08:21 CEST] chat: ssh ["-o","ControlPath=/home/user/.ssh/propellor/laptop.localdomain.sock","-o","ControlMaster=auto","-o","ControlPersist=yes","root@laptop.localdomain","sh -c 'if [ ! -d /usr/local/propellor ] ; then apt-get --no-install-recommends --no-upgrade -y install git make && echo STATUSNeedGitClone ; else cd /usr/local/propellor && if ! test -x ./propellor; then make deps build; fi && ./propellor --boot laptop.localdomain ; fi'"] + Initialized empty Git repository in /root/.propellor/.git/ + warning: no common commits + From https://github.com/joeyh/propellor + * [new branch] joeyconfig -> upstream/joeyconfig + * [new branch] master -> upstream/master + * [new branch] setup -> upstream/setup + * [new tag] 0.1 -> 0.1 + * [new tag] 0.1.1 -> 0.1.1 + * [new tag] 0.1.2 -> 0.1.2 + * [new tag] 0.2.0 -> 0.2.0 + * [new tag] 0.2.1 -> 0.2.1 + * [new tag] 0.2.2 -> 0.2.2 + * [new tag] 0.2.3 -> 0.2.3 + * [new tag] 0.3.0 -> 0.3.0 + * [new tag] 0.3.1 -> 0.3.1 + * [new tag] 0.4.0 -> 0.4.0 + * [new tag] 0.5.0 -> 0.5.0 + * [new tag] debian/0.3.1 -> debian/0.3.1 + * [new tag] debian/0.4.0 -> debian/0.4.0 + * [new tag] debian/0.5.0 -> debian/0.5.0 + Merge made by the 'ours' strategy. + if [ "cabal" = ./Setup ]; then ghc --make Setup; fi + cabal configure + Warning: The package list for 'hackage.haskell.org' does not exist. Run 'cabal + update' to download it. + Resolving dependencies... + Configuring propellor-0.5.0... + if ! cabal build; then cabal configure; cabal build; fi + Building propellor-0.5.0... + Preprocessing executable 'propellor' for propellor-0.5.0... + [ 1 of 14] Compiling Utility.Env ( Utility/Env.hs, dist/build/propellor/propellor-tmp/Utility/Env.o ) + ... + [14 of 14] Compiling Main ( propellor.hs, dist/build/propellor/propellor-tmp/Main.o ) + Linking dist/build/propellor/propellor ... + Preprocessing library propellor-0.5.0... + [ 1 of 58] Compiling Utility.QuickCheck ( Utility/QuickCheck.hs, dist/build/Utility/QuickCheck.o ) + ... + [58 of 58] Compiling Propellor.CmdLine ( Propellor/CmdLine.hs, dist/build/Propellor/CmdLine.o ) + In-place registering propellor-0.5.0... + Preprocessing executable 'config' for propellor-0.5.0... + [ 1 of 44] Compiling Utility.QuickCheck ( Utility/QuickCheck.hs, dist/build/config/config-tmp/Utility/QuickCheck.o ) + ... + [44 of 44] Compiling Main ( config.hs, dist/build/config/config-tmp/Main.o ) + Linking dist/build/config/config ... + ln -sf dist/build/config/config propellor + fatal: No remote repository specified. Please, specify either a URL or a + remote name from which new revisions should be fetched. + Git fetch ... failed + merge: origin/master - not something we can merge + propellor: /usr/local/propellor/.lock: openFd: does not exist (No such file or directory) + Setting up your propellor repo in /root/.propellor + + + + ** error: protocol error (perhaps the remote propellor failed to run?) + propellor: user error (ssh ["-o","ControlPath=/home/user/.ssh/propellor/laptop.localdomain.sock","-o","ControlMaster=auto","-o","ControlPersist=yes","root@laptop.localdomain","sh -c 'if [ ! -d /usr/local/propellor ] ; then apt-get --no-install-recommends --no-upgrade -y install git make && echo STATUSNeedGitClone ; else cd /usr/local/propellor && if ! test -x ./propellor; then make deps build; fi && ./propellor --boot laptop.localdomain ; fi'"] exited 1) diff --git a/doc/forum/remote.origin_not_copied_to_managed_host__63__/comment_1_e9e7e5e728ec23fd6025203a1aa0596b._comment b/doc/forum/remote.origin_not_copied_to_managed_host__63__/comment_1_e9e7e5e728ec23fd6025203a1aa0596b._comment new file mode 100644 index 00000000..df403694 --- /dev/null +++ b/doc/forum/remote.origin_not_copied_to_managed_host__63__/comment_1_e9e7e5e728ec23fd6025203a1aa0596b._comment @@ -0,0 +1,25 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + ip="209.250.56.114" + subject="comment 1" + date="2014-04-24T17:47:41Z" + content=""" +I tried using propellor from scratch on a fresh system, and I cannot reproduce this problem. + +/root/.propellor should only be created if /usr/bin/propellor is run as root. A normal use of propellor does not run /usr/bin/propellor as root (and your commands don't show you doing that). + +This is the instant where something unexplained happens: + +
+[2014-04-21 18:08:21 CEST] chat: ssh [\"-o\",\"ControlPath=/home/user/.ssh/propellor/laptop.localdomain.sock\",\"-o\",\"ControlMaster=auto\",\"-o\",\"ControlPersist=yes\",\"root@laptop.localdomain\",\"sh -c 'if [ ! -d /usr/local/propellor ] ; then apt-get --no-install-recommends --no-upgrade -y install git make && echo STATUSNeedGitClone ; else cd /usr/local/propellor && if ! test -x ./propellor; then make deps build; fi && ./propellor --boot laptop.localdomain ; fi'\"]
+Initialized empty Git repository in /root/.propellor/.git/
+
+ +It ssh's in, and it apparently runs propellor. But apparently without running \"make deps build\" first, which is weird. (And as we see later, without /usr/local/propellor existing at all, which is weirder!) +The ./propellor (in /usr/local/propellor) that it's supposed to run should be a symlink to dist/build/config/config, which is the program built from config.hs. It's not the same program as /usr/bin/propellor, which is a wrapper build from propellor.hs. However, it appears that in your case, when it sshed in, it ran /usr/bin/propellor, or something that behaves a lot like it.. + +My guesses: + +1. Perhaps you modified the source tree in some strange way. (Doubtful) +2. Perhaps you have some other configuration, eg a ssh authorized keys file for root with a forced command that runs /usr/bin/propellor. This will defeat propellor's own bootstrap code, and would exactly explain what you pasted. +"""]] diff --git a/doc/haskell_newbie.mdwn b/doc/haskell_newbie.mdwn new file mode 100644 index 00000000..f1a81e40 --- /dev/null +++ b/doc/haskell_newbie.mdwn @@ -0,0 +1,120 @@ +[[!meta title="Propellor configuration for the Haskell newbie"]] + +Propellor's config file is written in Haskell, and +[Haskell](http://www.haskell.org/) is invaluable to extend Propellor with +your own custom properties. But you don't need to know about monads to +configure Propellor! + +Let's take a quick tour of the `config.hs` file.. + +[[!format haskell """ +-- | This is the main configuration file for Propellor, and is used to build +-- the propellor program. +"""]] + +So, `-- ` starts a comment in this file. + +[[!format haskell """ +import Propellor +import Propellor.CmdLine +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Cron as Cron +"""]] + +This loads up Propellor's modules. You'll almost certainly want these; +many more can be found in the [API documentation](http://hackage.haskell.org/package/propellor). + +[[!format haskell """ +main :: IO () +main = defaultMain hosts +"""]] + +This config file *is* the Propellor program, and so it needs a little +stub to go run itself. No need to ever change this part. +`hosts` is the list of hosts that you configure, and it comes next: + +[[!format haskell """ +-- The hosts propellor knows about. +-- Edit this to configure propellor! +hosts :: [Host] +hosts = + [ host "mybox.example.com" + & os (System (Debian Unstable) "amd64") + & Apt.stdSourcesList + , host "server.example.com" + & os (System (Debian Stable) "amd64") + & Apt.stdSourcesList + & Apt.installed ["ssh"] + ] +"""]] + +This defines a list of hosts, with two hosts in it. + +The configuration for the mybox host first tells propellor what +OS it's running. Then the `stdSourcesList` line tells propellor to +configure its `/etc/apt/sources.list`, using its OS. +(Of course you might want to change that `Unstable` to `Stable`.) + +Each property of the host is prefixed with an "&" operator. This just makes +a list of properties. + +Some other properties you may find in your config.hs, or want to add: + +[[!format haskell """ + & Apt.unattendedUpgrades + & User.hasSomePassword "root" + & "/etc/default/foodaemon" `File.containsLine` "ENABLED=yes" + & Cron.runPropellor "30 * * * *" +"""]] + +Some of these properties can be reverted -- this makes Propellor undo whatever +effects they might have. For example, unattended upgrades can be scary, so +maybe you turned that on, but want to disable it now. To do so, just change +the "&" to a "!" + +[[!format haskell """ + ! Apt.unattendedUpgrades +"""]] + +Some properties cannot be reverted. Yet. It takes coding to implement +revertability. If you try to revert a property that does not support +reversion, propellor will **fail to compile**! This is a good thing.. +it avoids you getting confused or bad things happening. + +The error message when this happens might look a little scary. But if +you read through it, it's remarkably precise about what and where the problem +is. + +
+config.hs:30:19:
+    Couldn't match expected type `RevertableProperty'
+                with actual type `Property'
+    In the return type of a call of `Apt.installed'
+    In the second argument of `(!)', namely `Apt.installed ["ssh"]'
+    In the first argument of `(&)', namely
+      `host "mybox.example.com" & Apt.stdSourcesList Unstable
+       & Apt.unattendedUpgrades
+       ! Apt.installed ["ssh"]'
+
+ +Similarly, if you make a typo in the config file, you'll probably get a long +but informative error message. + +
+config.hs:27:19:
+    Not in scope: `Apt.standardSourcesList'
+    Perhaps you meant one of these:
+      `Apt.stdSourcesList' (imported from Propellor.Property.Apt)
+...
+
+ +That's really all there is to configuring Propellor. Once you +have a `config.hs` ready to try out, you can run `propellor --spin $host` +on one of the hosts configured in it. + +See the [[README]] for a further quick start. + +(If you'd like to learn a little Haskell after all, check out +[Learn You a Haskell for Great Good](http://learnyouahaskell.com/).) diff --git a/doc/index.mdwn b/doc/index.mdwn new file mode 100644 index 00000000..5311baf7 --- /dev/null +++ b/doc/index.mdwn @@ -0,0 +1,31 @@ +[[!meta title="propellor: property-based host configuration management in haskell"]] + +[[!sidebar content=""" +[[Install]] +[API documentation](http://hackage.haskell.org/package/propellor) +[Sample config file](http://git.joeyh.name/?p=propellor.git;a=blob;f=config-joey.hs) +[[Security]] +[[Todo]] +[[Forum]] +"""]] + +[[!inline raw=yes pages="README"]] + +## enjoy + +Hope you find Propellor fun and useful! + +
+                      --     _         ______`|                          ,-.__ 
+ {- Propellor          --  /   \___-=O`/|O`/__|                         (____.'
+    Deployed -}         -- \          / | /    )             _.-"-._
+                        --  `/-==__ _/__|/__=-|             (       \_
+hosts :: [Host]        --   *             \ | |              '--------'
+hosts =               --                  (o)  `
+
+ +Propellor is free software, licensed under the BSD license. + +## news + +[[!inline pages="news/* and !*/Discussion" show="4" archive=yes]] diff --git a/doc/install.mdwn b/doc/install.mdwn new file mode 100644 index 00000000..ad87cedc --- /dev/null +++ b/doc/install.mdwn @@ -0,0 +1,4 @@ +`git clone git://propellor.branchable.com/ propellor` +Or get it [from github](https://github.com/joeyh/propellor). + +Propellor is recently available in Debian. diff --git a/doc/news/version_0.5.2.mdwn b/doc/news/version_0.5.2.mdwn new file mode 100644 index 00000000..b1a01738 --- /dev/null +++ b/doc/news/version_0.5.2.mdwn @@ -0,0 +1,9 @@ +propellor 0.5.2 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * A bug that caused propellor to hang when updating a running docker + container appears to have been fixed. Note that since it affects + the propellor process that serves as "init" of docker containers, + they have to be restarted for the fix to take effect. + * Licence changed from GPL to BSD. + * A few changes to allow building Propellor on OSX. One user reports + successfully using it there."""]] \ No newline at end of file diff --git a/doc/news/version_0.5.3.mdwn b/doc/news/version_0.5.3.mdwn new file mode 100644 index 00000000..805e0d55 --- /dev/null +++ b/doc/news/version_0.5.3.mdwn @@ -0,0 +1,6 @@ +propellor 0.5.3 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Fix unattended-upgrades config for !stable. + * Ensure that kernel hostname is same as /etc/hostname when configuring + hostname. + * Added modules for some hosting providers (DigitalOcean, CloudAtCost)."""]] \ No newline at end of file diff --git a/doc/news/version_0.6.0.mdwn b/doc/news/version_0.6.0.mdwn new file mode 100644 index 00000000..5179f1cb --- /dev/null +++ b/doc/news/version_0.6.0.mdwn @@ -0,0 +1,11 @@ +propellor 0.6.0 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Docker containers now propagate DNS attributes out to the host they're + docked in. So if a docker container sets a DNS alias, every container + it's docked in will automatically be added to a DNS round-robin, + when propellor is used to manage DNS for the domain. + * Apt.stdSourcesList no longer needs a suite to be specified. + * Added --dump to dump out a field of a host's privdata. Useful for editing + it. + * Propellor's output now includes the hostname being provisioned, or + when provisioning a docker container, the container name."""]] \ No newline at end of file diff --git a/doc/news/version_0.7.0.mdwn b/doc/news/version_0.7.0.mdwn new file mode 100644 index 00000000..6ce0b517 --- /dev/null +++ b/doc/news/version_0.7.0.mdwn @@ -0,0 +1,9 @@ +propellor 0.7.0 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * combineProperties no longer stops when a property fails; now it continues + trying to satisfy all properties on the list before propigating the + failure. + * Attr is renamed to Info. + * Renamed wrapper to propellor to make cabal installation of propellor work. + * When git gpg signature of a fetched git branch cannot be verified, + propellor will now continue running, but without merging in that branch."""]] \ No newline at end of file diff --git a/doc/news/version_0.8.0.mdwn b/doc/news/version_0.8.0.mdwn new file mode 100644 index 00000000..69dbb927 --- /dev/null +++ b/doc/news/version_0.8.0.mdwn @@ -0,0 +1,20 @@ +propellor 0.8.0 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Completely reworked privdata storage. There is now a single file, + and each host is sent only the privdata that its Properties actually use. + To transition existing privdata, run propellor against a host and + watch out for the red failure messages, and run the suggested commands + to store the privdata using the new storage scheme. You may find + it useful to run the old version of propellor to extract data from the old + privdata files during this migration. + Several properties that use privdata now require a context to be + specified. If in doubt, you can use anyContext, or + Context "hostname.example.com" + * Add --edit to edit a privdata value in $EDITOR. + * Add --list-fields to list all currently set privdata fields, along with + the hosts that use them. + * Fix randomHostKeys property to run openssh-server's postinst in a + non-failing way. + * Hostname.sane now cleans up the 127.0.0.1 localhost line in /etc/hosts, + to avoid eg, apache complaining "Could not reliably determine the + server's fully qualified domain name"."""]] \ No newline at end of file diff --git a/doc/security.mdwn b/doc/security.mdwn new file mode 100644 index 00000000..075d68ec --- /dev/null +++ b/doc/security.mdwn @@ -0,0 +1,37 @@ +Propellor's security model is that the hosts it's used to deploy are +untrusted, and that the central git repository server is untrusted too. + +The only trusted machine is the laptop where you run `propellor --spin` +to connect to a remote host. And that one only because you have a ssh key +or login password to the host. + +Since the hosts propellor deploys are not trusted by the central git +repository, they have to use git:// or http:// to pull from the central +git repository, rather than ssh://. + +So, to avoid a MITM attack, propellor checks that any commit it fetches +from origin is gpg signed by a trusted gpg key, and refuses to deploy it +otherwise. + +That is only done when privdata/keyring.gpg exists. To set it up: + + gpg --gen-key # only if you don't already have a gpg key + propellor --add-key $MYKEYID + +In order to be secure from the beginning, when `propellor --spin` is used +to bootstrap propellor on a new host, it transfers the local git repositry +to the remote host over ssh. After that, the remote host knows the +gpg key, and will use it to verify git fetches. + +Since the propoellor git repository is public, you can't store +in cleartext private data such as passwords, ssh private keys, etc. + +Instead, `propellor --spin $host` looks for a +`~/.propellor/privdata/privdata.gpg` file and if found decrypts it, +extracts the private that that the $host needs, and sends it to to the +$host using ssh. This lets a host know its own private data, without +seeing all the rest. + +To securely store private data, use: `propellor --set $field $context` +Propellor will tell you the details when you use a Property that needs +PrivData. diff --git a/doc/todo.mdwn b/doc/todo.mdwn new file mode 100644 index 00000000..06e3db4f --- /dev/null +++ b/doc/todo.mdwn @@ -0,0 +1,6 @@ +This is propellor's todo list. Link items to [[todo/done]] when done. + +See also: [Debian BTS](http://bugs.debian.org/propellor). + +[[!inline pages="./todo/* and !./todo/done and !link(done) +and !*/Discussion" actions=yes postform=yes show=0 archive=yes]] diff --git a/doc/todo/better_privdata.mdwn b/doc/todo/better_privdata.mdwn new file mode 100644 index 00000000..1ee9e14f --- /dev/null +++ b/doc/todo/better_privdata.mdwn @@ -0,0 +1,12 @@ +It can be annoying to need to move privdata values around when moving +services between hosts, which is otherwise often just a cut-n-paste +of a line in config.hs. + +It would be better if privdata were all stored in one Map, and the set of +privdata that a host's current properties need were sent to it +automatically, rather than the current 1-file-per-host separation. + +For this to work though, each property that uses privdata would need to add +to the host's Info the privdata field it uses. + +> [[done]]! --[[Joey]] diff --git a/doc/todo/docker_todo_list.mdwn b/doc/todo/docker_todo_list.mdwn new file mode 100644 index 00000000..1321445d --- /dev/null +++ b/doc/todo/docker_todo_list.mdwn @@ -0,0 +1,3 @@ +* There is no way for a property of a docker container to require + some property be met outside the container. For example, some servers + need ntp installed for a good date source. diff --git a/doc/todo/docker_todo_list/comment_1_3801d48190c029a8591ab188427b31b6._comment b/doc/todo/docker_todo_list/comment_1_3801d48190c029a8591ab188427b31b6._comment new file mode 100644 index 00000000..ff217423 --- /dev/null +++ b/doc/todo/docker_todo_list/comment_1_3801d48190c029a8591ab188427b31b6._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="gueux" + ip="109.190.19.251" + subject="CMD" + date="2014-04-21T13:49:08Z" + content=""" +It would be great to be able to set the CMD of a docker container. + +http://docs.docker.io/reference/builder/#cmd +"""]] diff --git a/doc/todo/docker_todo_list/comment_2_441591f9aa106e8d6d1fa7fd6be0fc6f._comment b/doc/todo/docker_todo_list/comment_2_441591f9aa106e8d6d1fa7fd6be0fc6f._comment new file mode 100644 index 00000000..24ec5da3 --- /dev/null +++ b/doc/todo/docker_todo_list/comment_2_441591f9aa106e8d6d1fa7fd6be0fc6f._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + ip="209.250.56.114" + subject="comment 2" + date="2014-04-24T23:31:09Z" + content=""" +propellor does not build docker containers, I think that's the point where a CMD is set. + +It would probably make sense to have a mode where docker run is not passed any explicit command to run, which would let the predefined CMD be used. Although this would not let propellor run inside the container, so it could not perform any provisioning of it. In this mode, propellor would only be able to ensure that a container was installed and start it running with its default configuration. +"""]] diff --git a/doc/todo/done.mdwn b/doc/todo/done.mdwn new file mode 100644 index 00000000..e7c98081 --- /dev/null +++ b/doc/todo/done.mdwn @@ -0,0 +1,4 @@ +recently fixed [[todo]] items. + +[[!inline pages="./* and link(./done) and !*/Discussion" sort=mtime show=10 +archive=yes]] diff --git a/doc/todo/hooks.mdwn b/doc/todo/hooks.mdwn new file mode 100644 index 00000000..a62aa5e7 --- /dev/null +++ b/doc/todo/hooks.mdwn @@ -0,0 +1,7 @@ +* Need a way to run an action when a property changes, but only + run it once for the whole. For example, may want to restart apache, + but only once despite many config changes being made to satisfy + properties. onChange is a poor substitute.a +* Relatedly, a property that say, installs systemd needs to have a way + to reboot the system when a change is made. But this should only + happen at the very end, after everything else. diff --git a/doc/todo/info_propigation_out_of_nested_properties.mdwn b/doc/todo/info_propigation_out_of_nested_properties.mdwn new file mode 100644 index 00000000..9e69b0b4 --- /dev/null +++ b/doc/todo/info_propigation_out_of_nested_properties.mdwn @@ -0,0 +1,28 @@ +Currently, Info about a Host's Properties is manually gathered and +propigated. propertyList combines the Info of the Properties in the list. +Docker.docked extracts relevant Info from the Properties of the container +(but not al of it, intentionally!). + +This works, but it's error-prone. Consider this example: + + withOS desc $ \o -> case o of + (Just (System (Debian Unstable) _)) -> ensureProperty foo + _ -> ensureProperty bar + +Here, the Info of `foo` is not propigated out. Nor is `bar`'s Info. +Of course, only one of them will be run, and only its info should be propigated +out.. + +One approach might be to make the Propellor monad be able to be run in two +modes. In one mode, it actually perform IO, etc. In the other mode, all +liftIO is a no-op, but all Info encountered is accumulated using a Reader +monad. This might need two separate monad definitions. + +That is surely doable, but the withOS example above shows a problem with it -- +the OS is itself part of a Host's info, so won't be known until all its +properties have been examined for info! + +Perhaps that can be finessed. We don't really need to propigate out OS info. +Just DNS and PrivDataField Info. So info could be collected in 2 passes, +first as it's done now by static propertyInfo values. Then by running +the Properties in the Reader monad. diff --git a/doc/todo/metapackage.mdwn b/doc/todo/metapackage.mdwn new file mode 100644 index 00000000..bd14f858 --- /dev/null +++ b/doc/todo/metapackage.mdwn @@ -0,0 +1,5 @@ +* Should be possible to generate a metapackage of all packages that + properties direct apt to install. Then any other packages can be + auto-removed. This would just be a matter of storing the apt-installed + packages in to Info or somewhere. Although not removing essential and base packages + could be problimatic. diff --git a/doc/todo/ssh__95__user_+_sudo.mdwn b/doc/todo/ssh__95__user_+_sudo.mdwn new file mode 100644 index 00000000..2269cecd --- /dev/null +++ b/doc/todo/ssh__95__user_+_sudo.mdwn @@ -0,0 +1 @@ +It would be great to be able to ssh to a user different from root, and then to use sudo to run commands. diff --git a/doc/todo/ssh__95__user_+_sudo/comment_1_3bc008e42587a3313f81ee740d7d80f0._comment b/doc/todo/ssh__95__user_+_sudo/comment_1_3bc008e42587a3313f81ee740d7d80f0._comment new file mode 100644 index 00000000..e0dc1d7f --- /dev/null +++ b/doc/todo/ssh__95__user_+_sudo/comment_1_3bc008e42587a3313f81ee740d7d80f0._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + ip="209.250.56.214" + subject="comment 1" + date="2014-04-21T13:31:13Z" + content=""" +Running propellor that way would probably need ssh to allocate a tty in order for sudo's password prompt to work. And it adds complexity. Does it add security? I don't think so, PermitRootLogin=without-password or PasswordAuthentication=no is not going to let anyone brute force the root account. + +PermitRootLogin=forced-commands-only might be worth making easy to set up, so the only command that can be run with some special propellor-specific ssh key is propellor. +"""]] diff --git a/doc/todo/ssh__95__user_+_sudo/comment_2_35722c7d6f6c3e2315fbf72878066c01._comment b/doc/todo/ssh__95__user_+_sudo/comment_2_35722c7d6f6c3e2315fbf72878066c01._comment new file mode 100644 index 00000000..8dc6299b --- /dev/null +++ b/doc/todo/ssh__95__user_+_sudo/comment_2_35722c7d6f6c3e2315fbf72878066c01._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="gueux" + ip="109.190.19.251" + subject="comment 2" + date="2014-04-21T13:54:39Z" + content=""" +I didn't knew \"PermitRootLogin=forced-commands-only\", it seems great! +"""]] diff --git a/doc/todo/ssh__95__user_+_sudo/comment_3_d1e4040677b39342be00359210c02156._comment b/doc/todo/ssh__95__user_+_sudo/comment_3_d1e4040677b39342be00359210c02156._comment new file mode 100644 index 00000000..506b543a --- /dev/null +++ b/doc/todo/ssh__95__user_+_sudo/comment_3_d1e4040677b39342be00359210c02156._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + ip="209.250.56.114" + subject="comment 3" + date="2014-04-24T22:17:31Z" + content=""" +Except that it led you to run into the failure mode described at [[forum/remote.origin_not_copied_to_managed_host?]] + +So now we have a concrete change to make: Make /usr/bin/propellor work if it's forced as the only command that can be run. Including making propellor's host bootstrapping work via it. +"""]] diff --git a/doc/todo/ssh_hostkey_Info.mdwn b/doc/todo/ssh_hostkey_Info.mdwn new file mode 100644 index 00000000..a7f8a66a --- /dev/null +++ b/doc/todo/ssh_hostkey_Info.mdwn @@ -0,0 +1,7 @@ +* Either `Ssh.hostKey` should set the sshPubKey info + (which seems hard, as info needs to be able to be calculated without + running any IO code, and here IO is needed along with decrypting the + PrivData..), or the public key should not be stored in + the PrivData, and instead configured using the info. + Getting the ssh host key into the info will allow automatically + exporting it via DNS (SSHFP record) diff --git a/privdata/keyring.gpg b/privdata/keyring.gpg new file mode 100644 index 00000000..01dd24e7 Binary files /dev/null and b/privdata/keyring.gpg differ diff --git a/privdata/privdata.gpg b/privdata/privdata.gpg new file mode 100644 index 00000000..afafeee5 --- /dev/null +++ b/privdata/privdata.gpg @@ -0,0 +1,439 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v1 + +hQIMA7ODiaEXBlRZAQ//aeJpq25yXbayk/fuqQZITiC+BVuslYxKMo0lBC5D8d5D +EkTAEvqHLUip3Ikl3nTVDMabdisxzAjwl6nDBzUwTMxPMAh89gOOwxmsfFbdioGn +dbKweCAuZ0qXZGo8viM8ZjA9kag3sOQzqnmLdVa77Fj8WnfNEsEAFXZFU6aXLlG2 +n60+bhdo5858uK1dEItdhT0I2gi2SOEIJ3ojRs5jvV94X6+imSfpgrp9hwKBrffK +Ao9nL9e15KHG39wx/ZgBMxP74HgdQsfmzdRh1eW8hqj0F4SnBzPoG9x/cTrufavC +ZViSTngiROE22iEeAFHnPgyS1fo4pD1Vm0CxpqThhVn5yaEKBliRsOtOP3wIlAXH +7YKtSbBlHx1d2jRQdT4y3S6f8BdP5feYXjOj1BO8AvK+nJEcU2YhVEuhigXgNMDa +kbOTB11DId6WkxORvcVmXM4mcSESTVerLdqH2otpa7dxv+EWIj3mpCxLIB5w558T +0gagUVobw1ee8y6FxktCj93KE75AjawvcPqub7Yoc7J4PdzbrGPweepxjtGcgi8L +WNSkMzNk5d9wnm72TopaTQam5g5RndgRL1o4yqgchHr3fdzmA5CfACxitXTUwQsV +sAEjo9nelmYin81seJalwLFUr3Uo638dvu4RjZZLmm0HQ24RIFXPBsClY9HAhAPS +7QGPa3cOY7PkqS6gGA/ypN6/XkPsvq0QasFZbnQ26F0DQnvLXQroPFxeOgz9CG1A +WHXdet0KkYB5e+MRcnDTDjOwfPlaxCzSsduwNR4tMqVuZ78gDbMALUH+utYL8pUY +FojAnt5nigbwcEN0vaUY8WKTrOCUv4nQiu6jT/6YFDWRDHPVqytSA6rfWew0iO7j +K2VbqSvOq3EkD6Yi4N2CNH1cZKo13eQ17gQ1sIntOip1YYbUDYLml0vpfXMVRGb2 +1ed7SR2xmrMk+s5bUtoNtX/IQLB/fcsuCzRmBQY+PJKkRlj8lW3t8xTNheGoTu6g +EmK/LIf97PrIO/PzEDAjrHGD46V6L6qukH97k8HDkHNl7aox1ANYj5i/Y/DR/Jdp +qP3rtlmiHgpLX8i375JxJqGkIQ+ZzH1v86HrxVKFsPS8A7lILVkFkvI//H/TrcoV +KaF/LdOqQsd0OuKd0Gs3gxLytjaKHxK/AMHz51/VAgOZ11SfMvQpZRdt1D6ygAzl +PDdb6Nugu/Jt6GIe2hDmWHhxbWvW85sGxJft8tpZPvRNPolFnf5VjYluQSQq1JAl +QAX5RE3yY6ngW6KRmSbfWRFRNSXC9B1lxQ0CDgIPaz96KrzAH9M83Vv5RPQSICn7 +8F+t4YOrZrg4gD5qMT8sHIrBkvognvoT60ILz8qTR1Ou2w4xPlQUVPIfC1YCOY30 +gNo4XsrsjJxMtjOsx4fr6eLCaqzSVm9/gcxMJJQqE+ukPVHlX67WrDwEufBsSxZr +Dx9ZkCoiiVE+i4UiBztmd6r68yWFMNT2d8VHw66Y1IbLNZS8ZjZqo/OQtQwbnCnv +01Rn4xpBnjasMClGOBt+gNbpc6uziTORKjTLOIxazoVqoeWekM2ELrFCvpGS6YOz +rZr2psYRP6TO3AG4+MsqkK72+YcMMqtAnq6IM9nv3wEddAz7MQn9VLc+xGYbiXdX +yfEQxx7Gc0J6TJnIzASpRiwbpPlGvE4DtuFpigFzjjnyms/usj2d8HrZLhiN9xnS +q9O4ODIvEECGm2H6/DRjCbLPbKpEMqFu4OLW+2lUW9IK6YPBRJLjhepLHzEHZDrD +FPGvj3X3psMsT/nc6v3Rj+r5GqQeTySEBPkfgon5gs2kaBFbmAlzdOEimZJXKnC3 +zE6c6WdpiNs9tCNvxzkEu4TGk0KOE7NvVEgEKETMjTMYmccoueZFRIM0cdzg8s6Q +Sx1KeSHjJ7Z1L+aIFLZ6UyL7pFejjroh+1MzMf+ml7hLt/mrOcg2f+zm+cgJUQzy +hoMxXKNGc8w9aIsjSWcPhsuLJZLSIG/AQdd7fY7xJDIJ1fd2osX67ixXEiydz8BN +DiDlMVkNKzQp+r74RmNmJpziMBMtzIfHuk4YKmqS9EKiAMn+3APsFr/adyP+RBE6 +qBnvnDclbqviLkiXg2b6eQ0NZDN4NTEq8I6BSFKXFxoSJzeG/GkF8SvHUQaAHkCq +EmUxfMYw8cbQlYeRl/gtCiWz1WH2LBRulZvHVfiUzqjFY0GhnJzpLo/Pwjj2EzYz ++kONv2jdLmSa7Ub80XzngODjkun0xwIWCjMHa2F7GioZwyYSmxP2UiCCGAnOzDsZ +J/x7Y7/QQbDAaBQwpLPu4Ozx/7rEAxoBKTqjUWJ/VaQ+jrOhWuWCHWc3WIOo7YXz +HUK2kkw/7z7+l/I8w/RkX9uAxRIdD4c2SOAiDjK0EHTk0+e2bSGr4AMLfbtOQMOz +hiLLeMLXfT6uH/Dcp69URnfwH2h2CsRRK7w91/0gx4W8maxKbJXOXX8G+q6mGHZa +G6CPprGunt1Ycnb+CD0pmuPl8+4/jlkrz5vp0h4SBHEf47OgqwEuhqIvBeFJBQR3 +nccoOyNPkmFi131Drl9W+KSBZB6saXgOBqSDs/68zU843N9OyFLcGZANmwvTuA0S +LXom64j94cYrt4kq8uI2RYbNqxAGie7q593cbdnlj9nY4/tNolrphTiC/eFi7Ksr +113g2B2kvoH5lAupBr/LVUTMiit0wEWLcxTCN7rfYelcuBakRvkJwMu2UhG40EGQ +tMrWeBpJr4MeupSqFOvvVZwzIU/zA3X39cQm94SPv0N2gemeWj53IxzvP44GBENc +t7pFgNnnvPBCn7EeURviumAaBTWppTl77mz+eOlHdY2mnhV6M/3Gbw3PCflVQ+sb +r9Xvjhk6PZ3b0fQuQI1Lh8wWlwNDwJ9KkiIW9nfBYVFguKuDAwq/1P994Al4ae9U +C9XlhdNofWO9FhYdv6EK4lHFtsu8kx/Q1ilBTqqSCpm70ua5MtSYd1+Qk1eugelO +gvD3Q2GCIxhzd/gEIJcMpapeGJrLhr5YF5w3kInI78vNbZzESPZzR5pt0xzO0odK +xtYlXOGyc6bdq9pMZXLOGfsiom7IY+TZd1vRMKSbjuM2cFODSmwJus0/R0fSqL2r +2qhrL5bxR7v2mV1DM7mBFdFKSOVenrnX2QOgmZu41CoDyBXi+Y0Nosemjk9PTqs6 +ZQFu6malOyvWpOcnXNc51gcHDtQAgJ3efky5h/mXDem+8lWKT2zGT9sFN3p+6/Sy +oMJ2/Uu+XyaxkHOE8PW5qYFLopwkt8vmPBTmfT7368wVCTmIbmyxW164GbL3N0oE +aqM2/QnVLYXzhv7WXaPNuUDxWNeXhyoN9zZcDaeBYyctbLm8dFTEEbeZvFF5g4+U +ItTEZd0+b9DycF4C5Yw3wieuKFtzX3DikJ07i4TU0HwkFIBXZDDGMtsHB2DUvpeK +Ijk0tIVDyBfambdm6Is7OKtpmuHhPhtHZVPA/GDK7n1t1csmDV+HnXF6w6oRfsbK +aAptfc4mkeGlijFxOCS8DWLxKMXF3PhWHPQZI3x91hhujUDe4X8kAvOA+k+/iwbL +ZNXTXaoxbVLUaKLm8Y9PKNW63WzVsC8zgP262N/o+eJ+Fq+HJnTzsWAUDHvrV2XR +hcKUVxM9EivLNwURHeu1GrWJ3M/775Qyo+AB1eJ9IjPPLxM0h7LJV8KYyku+GMWn +P1UnlMlbqojj+qPezn2MGZggP0Nh8dD9HbFbFNzZI0MF8OWNAsvHD1F0IwJ89E11 +Kkx4uiQW0TEY7oghIUpRqKqsMIdAhfFwHTzkqDmXcu1JxMayAteAclTmWiuLapje +Z86RLF+d6HPr9qIluOJPONYsA8aFp9S9xqJ/PWcn3BRXxNJWv2PREo/TnGVo765r +hHfiIj7DL8kE3TR+CWg9Y3zjhpScXaqmzMbU6EhS01EIdFLNibEh5sKyqdzhMzxu +8dWAASbfzWDwugIoTIPPdBixIAfMQYFjUoi6SBaZ1peRVvBop3tN78WD5Ql5Qw4n +LY00EKpXuMPdS/2XrFXmRMxWLqRyIKYaGgNP0dGLMuvlUgHcl4GWGjIkEYw7jQen +/bs6GYTmrciXLPEWarZtv0qYMHENWvWMYWeTgstSbvSx8/uqn6tjQhywOkMoAOlf +WxVMqZwx94nDC/+6RPiTXfiD9vJ9SduLvAk989GWndkJJr6ZGunNtQKap+EBMMpW +HoLW9v+Yp7emm5uJPgvho6a/aTFeXQ7UsEq1uBGRxrRwaOyxlRxyiLF87upbiN4D +Ngs+RD792PsCiex45taJPeFchDmFQLjlj8+mY8sHOh2OlsfpIl5qq0CtU2Jr4RN6 +saXnQi8pKPW1V1sOvYcp0/vTx2B7eiIJP0JHxm4SgACU8S7UE/Avqkb09h9EGIlq +EPaq+wWOk8MnLW4YYNPDUNdTnb8iyduHVe2o6HwI67rNsstKpeaKudiFM6vFLkWh +3uiRoi1ZFYH+Y3vd34aSHV3K65h/N+Sv+X+6DP03+vZ6zg84mveHaOyI3VLTpadO +QicabiXcJpsU6trG+C/5Q4Z78O0Y+ZsLAFYP3Ro6KTpnV2XZKebHNQMfMJ3bClmV +2YIxDP6Iwss/PEUaG5R6Cg0YWcqzU0BuEeZelSpvOsfqh97T+yf73v108nz7CbbE +PIXCnf9uYBF2lDhO312NjfjkkpV88QX3OHqOMuIX4ULK4xIXMTm+ZoOI0RjS/VhC +5tbaE7rTH6L7vGG8ZxVSNA/u4QeqHTACJ18DhiPWWVnbeSWe19t2DWSU3+vFJiec +TsegBPogtW7KRcWul3eqwPvVRd0WtE0EHeh/vWKVE90VmPw7SfTkSAW7tl7//yt7 +83oEpj6Ze3mxQ6nXFDX8zwugClkIP6E8cC63x04ObKUaSIrAYBfgSlT2UxPg9MJk +lbNvDAjtar26ZmP/6ifYqhHQydiZoypN1ccMPjbtKTrmjY9/ZfKpB75KLRj25ZfG +2PAkcLHPRHDuhl0T4S+w+Wye3ollrO3OA7pI3TvEk22fS1GNUjmphUhGq9/EFVdF +D6T4e+feVI3sqepmOge1GgCaBrUEpt3w51p20GDLv9C/DfmIrOlZILAq+xXH1aNB +7QZTMzJ3RmPWvPrZTusic3ah1jO9vP2+WkB9DxysLp+DW9UVmW8LkVJsLoL0VuuU +CwBNoSKmIiWhTr2b+XUr/GnIzsssjQkalGDXtobDYz/LvQmMjHc2QNH0dL6GRvKe +33in7A7VbswE76Pbuof/OtICHuPI3fg+SlQK2vKLTFJOyLKKKvUqK1ZtLGX86IDq +f71oJT4MApic6Ep+Cd8aGsz5hFdy5KfRZX0rJ4+lwsCew3USh1GyOK7/a2EoPw7E +iTVmAQ2KVWjF6dADDRbmLsoTT4eWLb8TOlSnF6LCAe4eCwcmgRLKJSJYhkpp7JVB +e3g9qRkLzv6ypRJD7GTwubVyJJL7vW/c1v8PokTHYGfn/cM4r2iZTrxDiMvk1+0n +1HKA0jhco5gjTSrah8gBFD496VCklhLr8kqcxK3TGZgim0KstF2drrnKtT5xfL6+ +8EHY7e+Z1AdqYj8bINOKDs2x1rWNMZEkhxn8GUDodh2rE7Gfide9PARrZclwupo8 +0I1MmzxXCuoXSGMAoDGRRCykjEbeFmIvprBO9WiP9SC0ruhg2nEElxlLuri4Uen8 +nV3Age5IVcXLHl1Tsruc459glWmXY52k3WaJk4Up+pk7KpsTVEO47O11tYwtFBR3 +B4HRAOTWVEA89iXYTVlYFJzzrB2KEFJ1qEZHdLxHhOzLKjaXKFNwJikW3oAvVpPp +vOX3dgNPfnUA0vZoczEQW/A4oSPM21vTqcOs0tceHQ1pjE5ZL0iO4TMHTwbeY6cl +iq5SR3rC4O9N/uTYX3DWPU1JY7ovqMqjokDNkMOFHoN5AUsCMxRXj5IeQOP7jxyX +CTIbr59HfaC9+Y7w9VpNDW74SNxjccbTA9tUgfBX8DtCGdF5sDWpBo3JOD1pmZIu +EB1aoZbRnwKvv/6I7mFfeBV0CojwbbEaYhgQYX+l13KIuyonIFybEWUUVK45LdtV +pLoOyh3VgzknPWNqE8NTyfw40DIlkIA8i6wvRpAw8kmnx9Pdg2XuMEJYYb+CP2Sj +nR7asXXPsyWdm+qxgJqSCxU7RupFD72sereADF1rIgwU+UFiLCEIoi06bzAS0QDe +cijeTI4v6ZLr6lTjeXqoNcJlYaQZvH5Sh3RWLcR+XeYXZsstRbpVDITMb9/fAKMv +ohu5DeGEJnx0Da6wdOW8Cz8xtxe+yuwxkqyd2lVB77bkzYjfWW26LAKhVVKiEyR3 +QqJPF53TeXjh4RDxrQF5iYJkBJ98jPAUxGaTzupDTxIxVMRgKrNbK/rYmFCyeE5o +DAawqg1/NPISUMjgHNijCMg+dVPHDgP9bRdDrUPCimQ8mfmum+1gS+kmyhxCj4op +0TEB/XnC6QlTrK/kCCxv8q2gSBdR9bA95LkWBtHkI8GTDhnEWl4R2uL8DR3y13wt +dPe8yQgQIY41UZEAQzBu3Y1hBxhLlRRcPtz4/C4BH/8JqVasZe/XA3J9As2dmSZD +7lGFerfkHVMAoworZa8qf941JxWue7HP7kweos5KsEbtyHhF86Rq2l6DiUT5BWFR +Pwge6+rK39jSnqSGHRSASrE7/M9ZTD2f7tPHqUnrLQcxFfjWE3DOo8muwZOYOFWG +ZpzRli3k9pvtQpfyrexJ254OuKgvViRWmOQgrbJEsQ7VisbwGLalLUCr7Oi3Y/gV +EV2H9NcJkhXr7S1ObXSPc75j5q0wgeV57bSgsMIbNqSaVeIqL2ncWH4Ga+VFir22 +BvHXUcMXT+FyKq+tUHK/Ot/qFmS0D5Y/QvXg1xDSg7zEePA8NlC6sibYxFklh6qE +PgVnJ0PTm9dv3hDcO1NpRPGHi9fbFJ1oy4q7XiYOmux2hDM3+dkJGkGS4+Ir0vPj ++WrQ1UTaKf5GCSL5pUP/zc0BsXlxvyrQ8Eczs/Nk5BZx7UmT8NlK0RsFqpGV3CG6 +VyEjVJ4D5avDV0P4zB4xIisLKvGbM1GcQp8WKbMjzuOhueI3UzpcpgJPzgjgdayE +bz0Qk2FgkwB0oxHmN4fEzcIFLk4t3OzVGcP4uSjEJsmH33jAS/1FhNd/8FJr0dtN +CWkPhZmc0PG4GtLcBvgag4nvwY+9D3Hgl0o8FpV/nesWAl0ySVxhJMM9Y/37TQyl +fLDgmpQjYLshUfmWWGYwCqHa/Ov5PBITuPOZWK5kE0bIKLTl64l7cd9A8lMYrMe/ +23bCPxZMe5ZIInB1EP5jfuiAVFbSAu/rPlSQVlK7iXtrYTC0pSNsuVxzpU5unsG0 ++tqKE1NDBTJOVvmiw11bmC11HIdl+75gJ+hWnlHs78o5gJFuMpJsv7koDustEkJx +I/+DB0i9s8De2QGuy1dpZo7IpitvckaAQIFQ45lidaAaZv3CT5wxEhB5Sl0kbrR5 +tguQ/y50S/RRdklx2AtocJfnJVmR0Pc9CxxYPreHx8fC3uVV6d026GFnUXRPlWKW +ftiyL/lwGb0iEt3Y5K0CUucDjSi0iCNEjx1J9QBXc8hg/WjFih6egnvrvZWx8J5B +/sc4VukW4kHjs6ulJ+cg/by64uTc6jmsAR9vzVC7mIJPfWp0f7VABrPyTEmcFBJd +5eoyPUyGIu8C5rnOBOmcjYM/NNEtx4EqukVLha5YZwbVGYa+rC+xN07NNLQbFvWG +RZVSyt3pVioLfjQ8faHHRIu7qolrICvLP7LaV5jyPyrKcwpb46IIYHOk+/iJ6MOF +NsUjPJvfraYoeRVqpm1itIXCcM1g7uyTmc6Fg264+LVAYIlvLwCWlOyM1QeoqBVG +PL+k1xY50jwg5hkejFRDaE8I9+0Pa/bNF/XknDcZRv+sHjVpTU/DMEIN1jK9TM2G +SsltNHQTzYgKr3kYL0ud5lTRgSMU4tA0UuVOqn6OuObXeswsonfU2fqvXXrqE+W+ +Wofr3xJMphG3c4cnMmyDjUVOsl1AyL21ZB0R8kCqBDJLG7yyVTHjf/avpeTUfZwx +HBIpiZKkhdVkFo/du9wO0CfvHB89l8VnK0+js2OXZzDwPB8KCWTO8VllHAosqULI +Cp/p7F++Eyq9PKg6vOw43ZDbpKBoacHUgLNFd5OJMScQdKSGDCZtT7NRXzxGsoFa +KkxMCc8VMN3hwjP00EP9cHVfiqQ4d65lDE11yK3IQsBOKaF3q59doHxWOBH3NMPB +g3wJ+dEFDcMwwhhkbIjNPkROHeUY0C/6L7m3DKpV/44seVk6EhsGGNpsu/L+nDvc +pZwRmpWnioB2QTDbs21vTfr8iI1rh0bO2Kc5lfFXEvZYVxMizrjdPNCSty3aX+oy +e5oeDUOXafHSZhtbgrHEWXSzZv/7/endB7/ZYkSx7/5jBFsVZcMdWHnP4dkIBtLz +gTimwG5XHWiIMs1Jsunu+BUQfzTzTGv94o5E688XtsZRPYasb2JRdrDaGFdW8P3Q +w1bxyUMpqh3GcsD/d88I2HQFZ1Pt/4IBF0ooh8WZFurZtX59tF8eaYLeBBEkIKX+ +N9KHxNZHcXV8sCez8HUFKzTm18m2V/PeHxV6zQ7wq20MEHbq3EjrdVme9/iJbHjL +KBmqztjnkb+ux1QTV1871W7B+Xx06bnvBPPI5R3GvWbN7nY227C7FtMbQg6Lrgxu +FX5ARg/QhSgvTzJW4sOkZHYx8qDFbzovjWJxtsEGwsUnlfvAnL3FoK/3lpH5AXNW +mFjprgSYMZFRGuPEbUHd7kROwZU73Lazzu9vOpVvGaBYxz1U9JhK1NYyvo9VBP1x +euTv4yMGek7aWyICeFOZZqHa4OVymwN/HzHEzxaRBQ67garIbTzIGi2eDLkh2qFN +TzDIEAV0k5SyiBNCmFFYi2/qXhNRFOkz8BrlUGoB5/s/nn/aWT8Ll84TdxzJLVfx +atL/28krtafQIb8a6VniGzy5ij/wL+nKLzkNaGxvwOLVD+CurdnvJVOkeGatmhfN +AxDm5j7Hxrd9rZfblkyBbo+tarLYaCwc0AqKAEfKiJse8tOEPokJfJXeICwmCZJ/ +ttoaEEKkRpJSGSQxwezAz8QpkmCxW3wfBapJKOtNJLR6iIKxqa72lzIM9utV5tUi +n4sQh9hWMgb0pc8mx+MyEVjScN3f47IQqh9BSI7xadl9ZnKXPPc+SFqjqZAHbum6 +gWYLv54sIKu8g7sAPbXfxVpWK8FR7d/ODWkwK4L7v3nMFre6r1Y/QnX//ZAvX12L +LFj5FI9iS6RCeU2pPetyD/crxWOgzsJG4UGuC+6nQVBN35uGgHOtMQa3NedWVB4B +zTd88JJIylpAl5al4cIQ8HXZvMgOparfYAUR7E22jkg8+ikLTwmO7dnmUI2farQL +THksb4pB9P5XVAWkq6xhmXFOlrK/jm1jnmfxrLf6Hs8Ef8GTDXBcNLrMnrCZLMvf +hrL4Ou6zPz91dPmSy9fPExUVKut22JIefS4DGeUgEVWVGUvxb5hp/ZvQ028/VQA6 +D+ylOL11ZaCW6elpJkcTe5KtJkzM0+Q41QycYLdLOkxW6um/60wcMSiOoDOC0X59 +31fQsvAPLFiCGemnN7euge3cwsZjgBK4CL8wmQ7s/GwzB1WkJ7iPdA1qIUqRXuYa +0sB66fGx/12bbW7l+Waj/9GSe7Cx7PL7Re1EZOhy+n39PWmKB9KeFmlmKwd9U5g7 +cK1V62wuPn9M+0bbXpc5jzHI9C85PyTJ7iRb4hEFZG+pd4ITEG57EFeEd2/+HoJr +vW2OBFEnBSxfU89THqvIZPVhpsS/eo/7liq8P6MVlkEC36vtiUgC6mS36LaRGSMK +LB3EP6/TAXz39Q0qLll2dT9Tytn1OndC9MdOst/svD7QcobH4UdzdjITiPhXEmYK +1M3augOGh9NOO/rd5i1QATHOMr8meazQdN592tTdmP0u359PoM/AYXnZjzSz36oZ ++uz4GeYwW33JAelM/Eva+stf8D2t9jrdACA3PG/bammASMQgK5tihrxnRC9s4MoO +KyOCW2V/sZWIR6x/3lId8r7g2SwfUf6QRKIkcz6CsqR6TFGhOfsAOz9vIHVr+Q3Q +8V/ZmoVoyKgGlbsXq3tc8cThYnDl/WdcUT2DFIZxyOJsxIt00mo3+qnHN4lQb3Az +DLaPxefTAENXQK4lce5VdkwIPCOF5TXghpS/BwP+fY0ECPvhvLZ0UkHmdMr6frqx +1IzKF2Dhs/un0sZYHTFtQaH9/orcDe/8EfyzpAFXN1tBf1G8is2tX0rW0W28LA2O +EUNPc+T6dtPVFSWuj0nBkEUxBwtU6/1o9RmkRqx5JFnJFergALwShQIyLhs8KAaI +BQndkiGpZfsM454/boaBe3mgUXBHk62CeHb6DtptV7tim889kpAocv+kLqYSAUr4 +igUX/07Dkqa/TdTFiEzsiGAeBY5UeLN5KLuxkSj71cS7F9rQhbDHMc67YuIA2Jft +NjQBZB6RwEEOfhgpenHlLBQNMaBpAb9XGZbefwBJc3c3kZmTR8idk6YRYgZOHYcc +h6ocLXs6AXzu4D55uzpa8gT0nwop4SrcTQCINo0N1TsEH4Q8AZh/uBqJirCB/tNk +eXbUsKUloK/McpWvQJdDtqRNFhYVwALANk9RQa3SQXf+AcbMbRKD2bZ17Lzn914T +sbEiVnUFLDPA1DcJc+yfr9jrY8AOqriXpguob48XfODmhsb6+fzpRpAaY9kOuu04 +WWddWWcYIgLmD0gQPRk32NmTHhQQ3ngrULFS3Uklhbg9qi2C2lBgJwlH42W7lVen +zBqabgdivz/ojc24qDMV91P+MEk7VeSs3qFhz0jDcQNNtPbq1VnLp/dHDVqC3x+L +faUVrZ/jwpeQEJx96VtHU9+4mx5OMEtb6uosFwCBa0EsdtimF3twpTW3WedTiDHZ +S0ZfcnPIqqZ6gHMAwU7If8JdvlMq79G4rxYpFKd0tSbyKQm8zJO3fIn2oRS62Wop +5eUyigVB5XltTK1jTzJcOvDc4skh7GxDQUtDcpBbKxpze+hjjt3loNKIRnn9Kd0k +/BgenFgID9ujB0Ym4h5cjeZoSHanE3PBLFBO88IH6PBjEErKkCjomD4h0IMN90/0 +2g8yYwKFUfKbxeTlVYxGqdBXpjt1zbogeyAafzIs7rJlXdjARYoi7wo4GzPgHvlQ +EKA6aAWo0uNfmqhQOyT+yV41BDC+B5/HlxDNY9KCqHfR+wQbqqxwNbxm6oIH7Sax +DSNV0pYsroo2KIOn+SaxukY82wvj1Jp8D8hkyS7MNnpVlHgV58GbIurGUe/bsBxa +cNEM+DynNxZ6BYCZthiioSjCd/dq74WUvrh35kpnYUmprZH1a4ihbbUPauDCuo6k +jRWw3GSbycRF13J64iIr8CwmhOE8XkSklRIsTIv7QmPg/wIMlHX2DMSDV4QqVxeF +kI/1/a7Ef/Wxc2L9U+bW4jxcdyvN2pDs3B5WsACN0ari1JFoKAtSe9nJJ+LLBcrC +H5Q+jagOEc9y1wHs4Rj8Ck22muIhusOOHF6b2hDJBgnwukewUxiicKd8Z99PIGIn +yBcAJ7b64biQLFLRqZLD4t/myp578Cg/0Ic0BeQw1I3d7VPhkI8L4ge3Hz8rbegQ +bIvzB3YFUptYpubP3yB0/zWo4OrWT7FwvtTvajLcHa2HZONpRP5SpXDG2FqGVqAJ +R4W9Kk4pu7wOtFkh1viA1dkgltYZhz71CAUrpSfFf0DlPyf6BggMxcTHs2TT0Te8 +dkQaJxKkXrvEppCJQrxhamaeRliyje4IFL85ROZK28gH/Z6YIC18/JqphNCjVm1V +s+zEZIr08hyB9gVhkOWApUA4Wz7jvAeIWQiVZg4MxyYr8o7yqt6619iBiNL602kf +aFRw2DDWy1vHKTdLR+ldm3o8dHgF41k3BSVt915kaBLf7awpyiic93d/uOxyO4Qh +XLfMq3yFlbdg5vAAHhM6V93CKJIvem3njcCHH7gb46s6EyHqAhVNTL5HmmtmWx+/ +/EHRusq8Aljx4yXO0mMw+E/MGaprPPZ/Vrbajb+Sa/OKUu0zBGEX8nQTEyRCz5pB +OmlUBXSAlXDxeL10urj/ZrmRzaTfedYL4/tH0Z87JuyphuDk/7yxm5vM5cV0NP6K +WDIHkX2GNBqjGLm9FXXVwDhbJ6/rnWZjdNHqT1UyvM1u5DrKbLqwbYtGOxvJwmC+ +UsHLOewDhHIusbHjdFMh4YZ7jURR1VCGc5mr9OtbEBSwI8s2zroKiEhxwjlvzbI3 +LIh0Bq64GQ4PlMOwc8++mqlY1jnq/UR/Nf1zEx+b/fBL6PJb6M1cpG3T7sq+habl +61IQdstNigRQdiXxgxmqQ5H3T/r0HBCIabThSS2jZorjK6qyZOY/onTnxLo41NUM +V4DHMht/pqk6qszK0v2bdb0Llew23JgE0BqKgoqAAbUDrjdN/c8Z1EEp9eHIZPOH +sl7GIz23OPggXUPwcay2mRYp5PJfCt3yOmAWEjBGv3Tm/gcs0vNtCmNvFr8yuTI6 +5zAlDx+JBdKMPewTNQ4BdtRGM1aBm6dEclgRJ+Mw2WcuhqJo35YBdthf3GtAfvqT +9pp5+RN3KcUXQfsvHOoDf31BElP6sJzzQdDaQt2yEfZ2O+dFZ8iob+8lGCp+Xl5s +ROOVZy669Mn5Y7ZMsGEmqppU9+dGjrnXYwQHzTZvGuc/9QPe53L+cplfEkA1b2Eq +4mYadKChYjFkLViUfwBC53tzbbT31khTMM7nHAKyubEjOnHukzMVHW5Ta1a++OQT +3SRWjKGMW9O+nDbzH3CQMfuCakJpqzh/TBvWyowKxpCcLml+Hw14XkPHFdYJlrG/ +AU19YTmlhdysXEradLbVxgNhqK3+QM+B6FEAgHwDEFW7SyOH7tqwtDuO0ql3lLjL +DF/LDEKyzIud+Jv0Ib+XP4v3nyj3pCg4gtATOdo/XPPppVbRLjdTAFDTsjv0f72M +oNnvRAvlyDxYSXalRQ0wKK6OeL5rOtPDFj2n2McmGWx+DExC+hkdsSa9JzfrNibT +KG6V4DEjC2sjJEDXxuKsLxaWtUwXa2sb7ttDwOQ5BBR1IN8+vznLl4ygM9DMdZX8 +mEPFPDwCYWC5yPwiVnYU+OdKTlcOkjqTO2EX45pB4vgYdjJcOTteIHEEAIM1o8QX +w0IwGoBTWBRzYUw8Gcde/KVBH0A9CMV9qe9h3+9blRhSpYW/1vkoO5EMIEmn4C9T +k3fcM+e+3TIF/1eTFbYPTctGa+RrrGz30PReXQ0ukyL0zGWzplPQxeqKUpFA/P29 +5HhgFYXgPft5HlI3ZYZ2vlTLho+mCwx4p7M6WT6c88vMXx48N5OAlafzGP/ClYfb +Gv631Zf/8fkQzx80xqwB8o1E+YLyuSsS+8E55s48XZ/77aKA+IrWK9vUmtFacshU +cVZlgQtL3vHO1EwkSJSoQwEXJ0rscIW1YqKAAQuS5QhZl0CffKJb6V77oc/tyhxP +qdEa8wKvF4TKBtQHlyCiZQPt1WR50k1QmjU9wrynq+MFHZ0FedQ4wsnQHbUWNvjt +Cr+7lLaFXZpk+5trckiMVKBbpxHYcwW7mc2RI28es75GGQKuaEMJ7riIw3Nxllkx +5mvIUlUy3d6mEAsjB3SolI9jjlg1RgKkqnyX3E606XNaTrTWBr4dAnrXw+GqqAFt +2G6/G5V9ge5ovbbhCzZDJcz97mj0OiVzWR+R3WE6RERUqvMKso8AnNqLAi7YmWQK +8aRgXKkJiSTTOJDIFfi1XXilJhH9Ek7rfyvy4h+6xF3U26W0sIc12eV2HRgDqAJA +1MAxPIc8HytjLoCtiZEfBA38JkbymY/Vfm1ZP/LyZpEGtLX6Og6bcrLKTvm5C+gL +OYXKIf6eYfV6BDhjlyUqkHf/sJCpWUyfAuSVFhu8CrO3S4dx3dPuEsifSptmPjKC +HTo4Rj9SfZoLCwiX/L8VFOvanU9aFSLmZjkuymS/6WMV93UlfbxvItKTcyhmuiBq +nk5ee3P0elLSFe56cvC9D1AcM4zIwXcfmTxyIzfigXrp53IyY154R5nOe1NDjnVb +D5sm6FrfKvHIhUU0E03ez5XyFZccwc49Kj640R9JKXa2RMXav3f8xlIctC6JzCJJ +v8QECi7m5plkKszvl/7HEMfS2r02ph7NJjcb3Or/jTG402N8+23x/IpOh+HJK5ee +B39f35IIDd1chF0sHulelIIxOQi98GYffJD1r7ygONMVmhEAV2P3fV2i9pfOqrjV +QCXpq8ULShb3lgAKm5JfjSOTkwRjTIE144gvvIO7UuVjFZUYHniXCPT4X9ojnQ+p +abNxf0mqqbISPgUL9AUxfmkbnsBskIAp2l2eDqrSYxvyJ8F7UprbtdaMTXRw5PJR +j+SSZbCoIS4HB3PUZLHly4X2xvr5ZJXBp3eQqQ4uOlrN7VqH9MV3l9FCz1XTo80v +5esl1B7In0poQqI2kYPyYrC1fV9tZsb6j47CDELEOR+n3U+4ExBwlWkj54FGFDiC +SPMMyi4PwMyFlvO/Rdyk06bxS6siAbWQOS8ajQI07UZRCm4kEAr+TZqdH5ueOf/N +YCeDQhJONsEzhgT7hgsXz4HAlGrFeoKoJKsaTL6oDLaeWt4ZrUbK8bpuY8JAbh2e +VEgP3QNxnnnqukRTpCl/L6slWrM3kgu+0/6PW1OlZjFLbvHoqtE7PfRRoFE6bqd6 +CyEgC8OqWK1+XWQQnVAv8DnBonE65Eu2oqShOgtx8LEbZ4K/FebfSMCa+saA8sIS +i9IfWF4v8Ll4wy2+IPCploaCPcMfhYtu9iaIn+uO5ZDC6SJRhUiD0JTb2v6cK8zP +KO0AwQS8PB67H9wAgL48B3ssP5HRj9lGmA1gFeyTAxlVF9Dey7eqirhM8z89/LX9 +3bW5HW+MKbM8CwF83B4+tQaOjjGMfid8ckwcBvRor+pAiS3gAOfBDFgi0ykwC0bA +f8vsgPfmDPyIiOI7TtQpEpqRvaYA7veK9IxZNETs59vbt/mLcqHP0WotB5t7y9eT +/h6NFK7fXK8YwCVO0Yf59JA4gyhi0d0N89kbRg+0nmO2eCbMHVAGKZw/cm0Zosow +G8VdZP0si6usJPQ5xFoF/8Ku6hMw+VPR76F5NBNRDzaJOpFCnhYlNtJfwLwhMy/B +53nWQ3R0wx2gh7uqNaIXHI24ZQ35gluWeb+6KMrAjZ/vpVl7mEjZgL5cViEIKWXK +JK7dLRW1Kxujf+tj0+7ohpLhMn1DhzVT7nys2CttTla9rW48ix2mYjYHI26UXoTq ++CXjPe8WqfEUDoc7v99AqUMbHHW5s7AfgdHYlTj3dcZJkfariEsfdTVxrQ6QZAvo +PNvPjpewXm/PgpSYj4DeGMxx2VobogUc3rUE074p7Q4IsErFMkvBfiNBDkEBiLT1 +6WDKQnypZLCOGgCrUXbVlgxQkmJHcz9thQYlrDbBoagZf4GDrhU4Fv4lmHJKrEXc +1bolRCwEm46igHrft6C+YoP5F1Bxa+D5L3O5iy77ypumnoouznPpqFfmHyfTDD0B +GDdBs2OMcTlg5tfLP6SpGVgmTMokD20RJ+9THE8WQX404nLE7UZXZGyUKhbxlCGv +ZIZDHltDMtOu5giRQfbiR8cp3nhYAhNVCxbZWLEujpT2S9vPhcs/J8XWkc3v7X/0 +cbnli1bRniYe+BU7FAVGUz21RpkHlqBABO/jhJ3NDuINkr8c55UF+FT0AmCxL5Wr +iG1uWAhMNXX4lkKM7pQjONU2OkrEjs5JC6kyrbZeRgzlKg29vk1gR5TdQFt4Yb19 +XLVKk4m1owXRcn3S3KjFKwX3FmXNXcgE+KhBH69PDGU/b1bqoc+Md+9SxED+IdSp +MZEVfO421wl6hrIOO7KKGNze5Iqq2rOVfNwmyqWFiryuPozoLXkB7juXjV46+Rp8 +7phq3w/XX5E+YBDUErWkwFNgEsyzrL4IibML2zsSlr/H+Cx8oGvpcYKnpvydM6qU +sfENcf9ppNjA2W9RU+XN/HYNG+PajVRonXkcvs/y7DVrZiGHa3ZGXkSmVZuZ4POk +9M0njwzSQTRS8B8kzq4iExn5nzjcG7AJN2NtWY7EcpIjJr528PJqNw0Dy5X2DJH5 +qag2HTiSzVVreC+e1Zs2NeK4XJokFNe3GSxacZOpcAmzHzFGRgyx3nbI+i20/gIG +XWtkMqeT3PV1LhmvjTPcYlCWEbwzJk5khY5GWu4PratEyoYkRi0fBDFDPIewCR+U +NRfucK6xnUzSSzNmHJxWSaRD41V6LmozctsljVWQzPY978qxoVFRkirj0JG+EfrH +2iuT/RAbEwZP2a8cDME90xxtCLARqlLAfUujvaqK+hyxs6oYQzEkCsvp6evRDMfr +KlmDfWJonIacUpFKF4j/F+KaebX6TJEHY4e0OmGSTaKuEcwQoeek+PtIgghAXte0 +xpOUSnX65Zj0FDSyEKTcG7sb2/a67vmobRdrPS8PeGfHKgCVwUP7RN5K/mz61I0t +ltNv+RsnXHwboI75DdkUfbet8O3TYlvEz0qUiyBBKnmADComXwXjV9TuMjDgcjVk +dXRy9GXFwu3rxK76YKMniRp4ktr0oZ6LUd9PazD3JCaAAMCmt+w35A/G2rREGsZ7 +B6XKZW/MQi7tehS0qRDOIU/xhMt5nQkJB/ifipnrdY8yfe0M8+cALjVq+L0lRIZn +esAF2fQJ576KL9TApL6MeivhvagbTfYWiGMC6w0urLqMZQr63SEHmpAzAScr/fLS +R1zcvqnFKV0+GnbeGbgcNEzfIPrhfKFWJjmIHK4Y1NsxHUe1VWQVA4veFwwmUZg6 +RQB/WqyEUht6ea2XC7gTDOzDrHPbX04PW8F0apZFSydNmQU1bkxAwcCbKys/bqRu +rtusoQBUVRIcsAqN51J0GufqBqS9AD6Wa8vRhqhvlXasHsWcdgjG6s3/r0p7QeI3 +guBuz8t3G2esomWxOYazaGCstxcj9f/LQpyRY4VA9dbGHZ7G7C1Og/Qh3yCoEqyx +6EFwt5wtytH+5gt4L79EVePeqyczMTiW4PXS9lMpmOmzzdYwwOq0IMNKYak2KLrJ +EUqzkKT+H7o8G1sjX6+/pwok50ULsjYOPiFg03xzo8Z9NL9eIgrA5lQT5PjY6RZ1 +hwoME4Nn7J2lESntey1B/UtocUCFlEzrtSV5QhtCovDs+U6fqmO2+BTGaRMKlqOj +PqeQG9BTPWBOLym5+qASbsNtmK1e0MFdLpqW7X6by4D09PJJ9blQtRLxpfJXCm2A +7Zl7t5KHiOoUXhaX4X4rm3JcaA2v3oRW5oqQBV7q22N+mWEQwXMMr3BQl8UUUXTA +ZhNBS9r7z+Epw79jPyW2lUttINtYaDrc1RmflT26BPUNxaAUoxYv//QOKkpMvkNB +hueQIGKoHdRTjcbVCwv18o9KtARk67M+3j0jyS7h5D/W3T/SQfIHBer2SmkJvkK5 +EeicPQy1g/nP6mLV+RGuYXBijZOADfcTHLkXhGmDNNgtYXgW02gV7XV6x6IxyGuD +80xHBH3oPwU3hyWwDVegKhZCF9NUv9sOwCpawG1RD+K/MczfsZTRc6cRjaXlYmll +OplhRGJ/cumFbTULaIhcsH6iG2zUEfsrTEtbXUmp/p4dQ1O++VpVUw3itUjLmaPZ +bI7tVb3PKwH0G16Y1anZmaRCjkOWtuBezFXDxn+ooHhlJE9H/hJZSu7b5pVcv+Me +PV2uaFPlkhfh9+kzhp8jBK64KQUOfWdQSdPHAA9uN/ZM9ZgSZoY4kTr5OuI76WoP +6Da5lcmglg9B9YIHwFa2wjguF9QFcF2e/8ooeGYRtuLCDYP9Ym6WMc9NqEjW4JQR +3F17BYHd0Dnj0WoepqhnToC2qVNqCT2gTDbTCk07qHR1IkDKmE7T9K582rNwjAzy +Sj+c7Rw2MBB9cZcGiu6U/ja7kGLDyhhS1YmYZ3luvWDR58Mc97DPGYofgDpIY3l6 +v02MQTgxf7VOlzczNEcYh3Y9RqfUS6KK7OyP/GH+YHoCfS/Rbp1jW4TI+Nam6Kjv +tl7m/TQH9tadWanLxTKLYq8zSPJNdpkDXWyl6LwCPKm2R5FBrweoExJo3M2eH6ln +WL08ymCW4mKd8ARGKEwfk5rKcFx4at5Myoqtdkuv9I1NBeDsgao4Lufi2whedOUe +rnWK/hJTvDRlTYz6cyGEpF8ksR5RFcQbJyoZJYFuuRNQFuESMa6WUAsIK1L7VGGs +l45UIu4FR+51J3KavXwZ1AcGw1eUSDzF+b5iEVhEvHrizPxd76qrFAzjM5SJ4eiM +Tf2EEHzwYfA1XVUoa4b0sqkEDa14ok2sdAR6HLzlhow6m84IVtI/euUVc2iuOJNR +dKUNAVoe8cM/uxyxOFvJIPL/epTppbEeKzPX7eJZPSvlnquhiQ/qzdHBfL9QLa2F +FvUnQr3zibDi3Kjn1uPh1Guc683wKU+C4wP0++KUFvI19z3XgUu7NIHnQUtgfMFE +olpjxudGQLDVr2x67VrL8mrvqxyzTpokwHy/2nkzB9rPlRacozCE/VALFFedsJT6 +UREgIXbAOh4e4WXVRXcCjXSPm+ydsrD9k0txjjFVUvSd2JzEYQvWvjuG0QDibny6 +nSVBmwXANslve/DQnHQTVzsrP6DL7h2m078aayLBWbJun+zQfOVYXGUthyPSZIDY +enegzKURe7u0gJlL3NCNLRj/aWxPZCr+D1phl18T2ES9mUJ8Ms8dAKpPusYxS8En +Hm2bYWZGrbQ3mGuVlBuvdJs2jS71a8X0tIDr1khDXGcTqAY2teLLFlXHlWbu5YJe +3/fDAgCV3q4s7Y4voUE8hTn9MuSJMzeKeTy8bcEMLtssdZTlp5kEdR/bHVSEQZGG +po7TiGfa4yCySfpc+/bglgd3q98dwe2Ouoq4EtmZkfnAU1dTbthnO1AUs77ymCy6 +V6ANPZALhq2qObQugcpinkDDZBdCnFj+nQLUwCyA7SSr8RqEUGxJpCJT6lpTL/rO +0MMXPVFtq9r9Y38+cCl+kRbecMNkJ21EjlLHb1s7wA6RiMJr3MzrasWkmParfHE+ +7hiAFdVtW7/sdRPo4BwAkIyK5vTZbi0jeRwF89IFdB/VlhOT3cJ0stXRVaNgfqP/ +vq9Ag9sSq+j7J2GFgdfZ8UZLteBEK9tHH8jwQIKfGqfpZXa2uknRaw3sX9S1EDhL +dYh9Le0CzPie/BRBtBJlulw2OnMJzT5bD4O7CRlrop4AOVqVA/vjlqZbCdvsF5o2 +oEymUUsPl8K4kdOmdH9E1/CgGjHgFb12cMMFTum83ElOJi28nR6nXuaizkd0NTxz +o47d0iZa6rv+oyJ0qZ4nO8SI8YpFUlkaWkX/WIB8Od3j9Dd8BM98vuR/xGnKElvr +OsxR9CxarGFdmF/Zua0vHJU3yoAwPpt6QpUQPPOscvC/L7ztG+mYvGQ3gA21u7n2 +2RXhr20M/htxgr9tP79iDUZ8dyVP7tgIATmeb1lzMOIWkxJ+S/hjCX13TKNREf3p +tNEFsjsep2HwOOKwZIYBq5fD6jrxyHY2d4LVYTYaDWwRL1gCEt2ILXXVZ4p2MRfY +qGFQAZglry7gfotoTDMfFNJ39LmoOoLM78k/vU1wUuNRMUvuikn8oJbVoPhtrnK9 +oAi43XBudv0GldxHu+hlImEbP4Hcz4AadJxNlo5lMEqAMP5tORMRTcp7WXV2XojE +sSk5J2JXM//kKkYqmtpoJ2EmDc4xCIPGAPGfan68ID8rV3Cd38IOKkaLzgLn5pxb +QibTuTkd7w+cqFIsG/ex1WZQW9I+UhROTYd9qfz/HGkQH+I9PleP1oHSZpacViPx +zON1uCvZksp2QoMMaR1iqW6A9ZL+psntexMePQ0gqReNHpdAAc6VTxVapsmH4Qeg +bbmenCXhh1FAc4gVGvjtv7fG0w92WxQTnKZAUsXUeRtFPcj6vkzqBqFwIGRREmmy +ZfkhpmNYarWSAGkmE/07NIjsHYuHLw4LkAKrVbUIHEoBvVnItIoBW2X1MhZDm9Ro +2c6p6DUvJ+XceZxS4y7jOImmDFHRadIZTLQ8D+yhg9jhdRf9Lodus8z7Xu6fjErm +i6n9fqbWpoirjXQIDXk/j37jaKGeZW0YtWoqjzYSaIKjybsPQWz5GHMioNRJnxHD +Bn3GIKkO2QdoGlwq80OI1O3bzq8/nqap3h6adiBjEWloxkYVjr5ieKpSLDomYMF3 +nS+XpyPCJe8h3uEbOfk0gay3hrEPE4HZk0RdKJDg/RMWKwheMCsB81O2IwpTdg0R +RC9QLtQUaUGS5hjJQfYPeP9b6Spio5j1g+y2OtQU8jZgoafq2cuYzicUUUmbJ13D +3P4opfobxBuFi0H0FubDnfOf93Y35Uh+dS4tNNbTOsn/Swnpk3/ZeCVErz9BISM5 +1insLN/3TLfK8LTVM/lOB8BfLQNkdXeZTM5E/rV+LXGrVkQf8M2pAf1QUWXmQ1h9 +tQy302ikaBC43A8SUhWDVRuLiW9tItIGCZKEqs6xDtPz7T1Jr2TwUeCtqmNxQaFW +F61bBz5uEBeVXOdb184/0yn499rOKUri1Gq+E4TVAy241KtDKEQ0bGTdQjI6mzLf +H6fxkt1pExYc8L/JzvyB4nwbaaE2gTM8cl9U5/vwmxPyDsFpYi91dInZjb5lwQ+0 +pxZsU0z9uLnkiO2bHK/WdyJpvYPR4zt2XCjwCl2EFYt64Ib/hhSJ6hH/fIm5W1/R +L5wpPIu/Dp4c0BsQW44wP7BPJkAWzJrDVHC0mMw1XbchQuBOnLtM3V+VHVAAM/M2 +95Wt97EZyEQGrx3+w1+DHbmPpZJADxhPBJiNjFhW8h4ekzXuVScC9oJprZoPPVYt +3C7OKRpPQbhkzVP/m8f3Bm+jhcD2gbNe40lsi5X4Qq6bzRhLJprU2XsVc2O5Fq8J +Uyj1BN4nKq3ZGXvu9A70uavjRY8ru8/jxAfckLgqnfrc2GBcTbx+1sPmxz1BwH7h +fNV2esyXI4sthJ1FsOpf8nqKYnsNfclScNzx48qqbbj205202jj/HFBuY8/gw1FH +b/hZUKT2QRcxo+JfeGkMQag9GxSJztENLkBCiMdg84Byyrvfqm/+eEGthOk0LJwz +yEKY5zHlqi9zItCrbNglq6yeNn7NuAlN9Jh+iLqGRwrcjDDZX1wUroeQ3IlK0u0W +VraBfM3bpXaoENqHxGR4Kr7l+dUMdvNLcMnnHPYsBrcIdsjOKdA3B6lnYvg5wK2s +gGTiXtJtePb01AEuWK3az8EghCCvEN9bhd7KMBA3sQXdGPUqrcKHagP/z9b/dbEQ ++KzcNykjUqlA/m5Xc0YsND3K7D01wwgU124e5LBfR12xs6n3Y5MJ0SXU9eAxWPwg +5JN0I6uKDu3hJeJsIbghEFrFNPfdNYPXZx78yrYO7dX1yylSfVK36gPeD5YYAOds +DxdujWuPTRHlaKTTUAGinYF2RHN6/ewQyQF1SWNHG7nXPlrGPAXT8r+UdGGwghmM +KElGesVmyIf0mb5WiyZ4dV0r1zc7SqL24qVKLfmOzjgxylH5JVdrhNzoBYTlaUZe +Zuz21vja3HZvGHOqpa55k7106ajVPfjcQdsRYqs8T4rlmu+YIeqL57GD7fj9O3r5 +buSCjGzWM+icFp5QamfFE1/o2W7LHZmK/3tT2kTh/+6wksRn6FVnmQWTOQb4wwIY +zIKuNnNPDjmxapUL07QmatlVs2XxQ9d7JfkpfzkKLNCC1tVGguowQvWxG5ChTfxf +5i0/mQQie5gVggPylqx5PQ3qtExZF/0VyL1QO3H4+dk3ksvpiWz7x6NZJjplancS +CIEYmV+0G4uYQe1bVMHOdBOkAcMbvcGSE+FKmFX0XljzGNosSfW24mozjp7j5OwE +SxVXwTELn4ocBjHwp4xUCZ/a7UGj4P7FReyOFMkHSyqrpeTfIteMCwL251v/KsgO +KP9otmx7ri7kN2YdkS+6z12wvXEiqvakCobbcZ9WDpTgmK1UWHe5GycmrhsGoA/0 +B+v08hOwMnn8amCKWkiC4H9ElU/LAQpSjNmzkeICtX7V+PIz7CpA1e8MrFdvgdzf +Sla44zXWpRYCXznlneDnJ3/7DwWkSFXma9/PE2ORMaFkDWus4AZa4wp+8LzXyS94 +rFz4dDSoh4NZ3oC4245yggcMNOVgf4nmSquM5qc+EOgV34nT/M2cJuQqMoHKKTnb +8caEl8YFWCj4VuCYgUxE6MQN5F1egqa4mkr0KSIS9oLqwTeC1dVkj6WDNyHVaiL+ +5a0Yf/RMf8ARjb7g8tM3O+2R1V59GuPGvZUOKLdma9wNn62e6wgg9UQCMZPzOck/ +NlQIi5Hs+kxeLE3n8ILVmwDZC0uZhhyLyFbSNZnYZ7lY8x6OQmAR0lbwM/+fGkh0 +tJZ+brC/z6etHyG75UXJqgl1tXcmm7tCIufbVYcWJ70ZG3dZ4u8ngiUuCqjGhX5z +r7JOU/gGkoDeTuLqL08eqKfd8FbaWEcvmkY/XPUdUOdDbHwI72axL3Iz8BqPhmM3 +dgN3YHfIK0gk/NP30LKL6JGs63HD7CvBtu9tC17rKlwTKUo5+VQZwNQtnI2Sl9t8 +/lnJppcHAftsye8b+RIHvQUu3Ev/y3J71eYMDbFBepLeoH/ufgNGbUt2h2dlfmZI +sNEvQ66rONz8gsBdRn38mYvpRGopFfLgjDaGokn5sJ+McEWROHWu1sjy4KRQv1j+ +skZOaMTCMd0cAyCwwatmpuQOsOAiM2XG9IiQ3LuJ5u1ixwFuWVmPnDfLQgYixJ9p +QcmAi333zKxmQHrLCLH+2leqI7TWn767pJTJuKsgGFRLsTWIOLFwaebxo0oq5JyL +QNkU5zQ3nI316i31qXx8WwKQohTRvM7LQ6poOVukibtzC3qEeIUGRYiKZbtAmFvH +Ff9pABj0V3FgeZfICQRpe1Bz5TDO4OXz7u8QnzZrKf1lvRp0ALtij9YwPXs/B9Or +De4xl9OEx4u7oaShCmUp0lcjHmNDpfPGE/L3GhsQ9f6PY6tQzmY1EhIIzomDT4pA +zCxjf7q9mETZoopbpU/d9nGbgMGJlXWMBI1SpcHkdorGR5EmPVwm3prJcLvEw2ew +C6Y6atpLvQHxra80zQvCFZJ6oTZeB3glYWiukjBFDJlbUXN5xxHDkng4UvOpSZvN +MsFOXpoEKedcMvSP++Nl0fchPdQo7zcrY4VoVoGcFVV0zHabFnK7157VSUYH3WIZ +HLTBrIQtClmfZqXhz+cTzDKUdLkZEGxrdCBGYF3Euo/4X6s1GRcqm1Lf4h/ho14Y +5m8q9fR9K71yPzzUpkOvzgpNirip4lxmFKJqely6rviWfkMeshvpre/2b4tOS/BF +huI7kvA7RdeyT+2zoogvfwbdFpMltu3XY4qLlZ5stzDVjY8EMOdOwUZ0uwZtbXn9 +v0+7GLSSlAsa5ikcttSgMj+Ico9sXSD+1kTfu0Ub4pB+Dqxr0lJrqBhhABuMxYqk +oNEdAk56DqGVy15mVs+M85Oat8Xxz7VtgWZomynMtTUwskZYcMQA2YC41GF92Rt7 +L4+dww0C80S6S3DzIq1F0AXBIVUqHYL5ZxWUiyQV1fqgTi4gZs7Z6Axjww+Eauf/ +UgwX7B+iJZMWfg0T9QBhsJAGKgB9vV/iZhkiaLS+2I7J1wybyq++2URa9Dq66gYp +JPtuNSKpSJf329qo6LUjUGBodpEes7sA99S8NCek1oTQ8NHKeGHX3UrkvECU4Vly +mjmVg8eSJzYFtbR7+hPurJHr9me4lj+szB0XwO6wJ7SVgeEn//cpGFTeJ7s+w6Yu +TOolk9MbSVdGviWZ36zDI1eaatg5jDHt0EsjvaS9S8TK74CPpcugzOLCfNKjwVJw +kKmAnATg8khtRYVMPI6X2/uL3LLS8Q2vJY0uv1SS2pCrha4MTRisZ0d7QdNNCzMj +C/DDAM5qzJ/xXUEz9/XFjkLMGfnvivEGuOrF3SaYLoTIXhf8iBuP0EBTkI6ljjDS +jfyeBIA8YQ2Iy8fFD5/PjrssemJBOims0bfNAJQocfCr6S/MARi5R0Rlg4ylqHXL +F2K0wiM/K4gpzl0AX65VRTZktMEaoyJ5hdvwyDMnyzv9cXePBjnb5YLuJPSdw10/ +8fdEWedqkZlgNSka7Yv3uY1hZzySCxYxB6FZ/PZRsSUvf07DLKGgm2Vw5bI9SOOR ++0gZ3YollK50HKOH61uQmmLl9ONwhSdvMnAgAFCT4hm7roYZcYVyH9rFaL7vb5Ih +i6ZTJidr1LqyY4+MbBvc0fJjuJ2YYhqUzg/IYp8KdmBbXDz79uqpjOkJQxWngQke +LBiMO63D/KRP9krtkdnyUH8O9luPp412csoxFADE3pKWcSEtiigmIOHm+YzU5H92 +UM/8A9gCFm4c/4+AEay/Gif9GYtaBHFWgTCHKfJ01Hzny5WhapaNDkpe9FExRxV1 +541fwKud2kKcVQNIgx0VQ+uinhnv+Nf9wv6WfiHYUtA0UJSj85yW7MO/GCViFydb +A1mHZ9owUOGrNdxX0smxJXkcM4aXZUfzeT5jjYa2SNFB+mX+biqgWP0BfUhAxEX0 +a1E/ojJzT7PTfXKxoUiVVZOlCgZU0saHJK6HIw2i45LruUGQOQgVKEAst36a7GVH +HX3UkPG2CIXO8X0pJ1QfCd0FndMyNcHPVa5z6yPs890FMjxTg6wZdpkMymnMeTW3 +/EJ+KRGMbfHn3h8eXcXEPyGVj6JfkAhbqsZGtgCByPWq/6NIhuLDTPDu+mzON/2u +Zbga4vPLm7/g+UKPXe9ZI8eIO79cRqfqJwVBZSst6Aoj11F5Ub67FlfHdba6xHIi +S21QS881+aRSu7oDPPa1kB/A+atdzm8NBOUFHvhNQ4jSCsMWcNaERICjrJas5Jjk +899bsJz/iX1sJnX/k1NYQzB6zKZIUhcjPob02LkROA9cD48R/gOB3KZBIYGs60Bt +NzO9H5oSNYhJH/7Bq5Tv+Gnvb42MWcHKqgYeb/1zVnW7IppDMCli7WKxbwfQxbkL +vI/E/0z5utGhuKAi8hEFIigbaXvtdjJlrHMru7S1WYWUHjU4TtkVnjByfkddf9wh +sjeNgWDUgdD7UOS+mOI+k5xXeAADDaCGZd85byFvMWfv7roWdcuhScheB6MzgY7d +q+yWbeWg7fyRtsQcIGc4tw0DE+OYE52Z2IJWTEq0UYX0bQqZNXgYswdD0HckqilE +0iRoZKJvmub0tEma2Ugqu51gx2RbNM7RLzlRXCupVS9JlYuKY3fpFT8QobGuA2Pw +dJDh6iM59TkQGf2fc9SpUs46SutJaSVRf+nNAfh9nDHcLN4hkWaVzz/23jVwBjzW +JAyPEPJGd0Y6TEZus4dP/ED43H9kzcXAVzocfxeoMGPmxWX+JAGcsqj1eUSx0Fj7 +SLlJEreQuVmzpOVo7xBB/7ZC5XYRKOxgDa6aAMg7d6jAT27L5TwTfmNpM9fKfMza +KhqWzncuvQ7ggTnjxQ184498HQP6wnwVkE92dKlNnA3XSpehhkEaqOoj5zAfWSSC +oghpsk2aSEVoJn7NZ8Ii5BDcgW2GnIMs3XZVWNmSByqxMLSCR3MvJzEgjcgKXSfV +wHpjfjfKnJoG6DUVhElk0ywXQEWN7JNJMx+8Xq5DIPFdYRKhjczqifPa0OhcJxQh +PPayhJk8AAmPXqHNW4qKOjfBzSjOKV+K3AfwUQgvfc9ZAiyaGIKJZQmZQtuMQtRb +0EiW2MsAlFyoDJzliZYO4+yqwieUfYPMInuW60rNW8cXKDBLZiC5gbLMSdA+kZZd +ATaJTH3sTN0+i0ZrU5MInP02ERfrXJzHvkn/QFxG1NYtqpP664n0rYyO5Dhq55cN +JCD7JOXs466Ids1mCMH5FyChw7u2aWGK06diUELk9sZyboLO/kw2R0q75AZ7OMhU +IDoMfawrp81WHKQ7r66FAmHMOca1Y2tzrLdf29INzCXqXztoSHQ6vmEM1iNEcyu2 +Wczp8DuC5v2gM88QcN6CiwriIxcFyYbgr8WTaVG33iK+JVYwORwMvUKppi32Ityx +zaybZtkYhfJJOi98sK8DFEFA5z3hB50MpVDHBs0cYMc66XHRs2HXOIYpRhvFCN0f +G7VAMSit3sJ8VfOheTZaGCwKaT3k8l8LTd6VyrBz2ZlxnmGXR/9gJfUFT+U0i9m8 +Etogz+ftf8xMW5o1oCHDOpzS8s369hdBmpqd92kcITjHZy0FxK709SnAVY42tNhZ +BUXVUvpqkcgP8GRWHP1o+eNGFNDGxtedSkoLzeFTITUFOh1STZuJmL/2VQ8IFSkM +KodxW495lNZ3gjOWmAMgelhrpQ9OHJcp9+iHat7Whp0RNrN2T6wjuEC9rnl+zHF8 +EhfYxn9iKpYeGADY2tV5EVE1EPDSD8byv0zNG0lq6adU+w5tae+5g1QKkXzyCs8e +ri5ac2T93Fho0WdAObZJV2JIeS8NfUA5bkogXYRQjEkCSSBKTx6LFUpwfTUdNQYT +z+IHu76MDe1aZD8EQiMfwC6hVtzH66yQtte4rG39nYoqJF8ws/NxWDNBzhv6g/Vi +KuNxO47KjOoYEJ64A9ACdjtt8F46wy4HhLzBCKKF/S2f9GYleOCHMmtAwGwL90sW +dA0zP9ZZT7SkYU03Nk0bcwu3W7LpldLbyYFoo2PjeBHGWEu7sUsf9w2WxaDxTXvx +vUZ0hBaFlZ6BVOyWivTaSEl/BOAAteZBPJ3hakY2r2dZaFkbp2JF2jPhD3e05eMR +cK4JCbn6QzBaHb/Zave7g+F3rfrDr8hCVlA6WSi1Mmb4mTMF9t1r+l9/PgF7iXgC +b7cfHje8r5bR/OrQIbM6BkfR5rRQVSzQHoxmUNBOSjXybRnLr9ZCuY8krU1eZ33l +3nRLER3E1ao2NuQWORHwcwzGWyr1GNR3h8uJ6dXqlj4biBVcwHr6qLdkcoolb+1N +2NIcqmvD9C/m/YcdCNf99RNBdGuT7o3JPGV8lcWvGBA3SG7fH0RaUm098K8B7sDZ +m8aOiNsJx2UoX1lTVOG2CeSYrHKomB0rMtPa7Dczi0eBgLBswqIRNfJulQnLZyGB ++nFq+Dy5puMs26Zgzx0UzgI+JDoyFefAve/V8cGZnT2iBarzZGL5unqPxshq2r+a +e+HswcgpFlCuHEgRPDpCuodcWRoZ+V9V5qdid/H5yzFqzAkgUbsxZvsyBjoN3Dq6 +1+7fArlKVEYCIDHyIV2D8EHBrZErbnTPPcLVgv4eAM514aOpzMJpJbHeTkuWuDRt +y/sHtjHklXcBrgFODjN0Rd6LZmLza3fWYq8dERFCeJpBD06xR6AvZWEQegMBwDkW +y0ewgozAdtcKQjJ9FeNPbzh50rTTC4HEhpHcq6nVj80JzuxjoiaMKP/V2vmt/LCI +9S2gySRpNMCrhrpbOcpiW8i5ZZdFOFtEGgd54hPedyG7LTTbVaKNsTSs0UGdUlKJ +Src4YU5Et6yHaS3JCpIPV6fia89UKF6b+LQCdNGDVrNJLlyvMqrxSUYnG5lv8W3X +7nQZAZMhwgOq7m+uGH87o2H814X/9z9JpEbXwIgcw7nuTQ65H44F8pLKwvQg1fMW +y7wownaEA+iu5FH+mXDtMddPeHC/jFwe6Ky58EVWE0me9I9Lmi1ImB3p4116Bujm +3ptybxOCYN+8x5BPjsO+i2Mmke1FsM4CK/+L0430h5BET2LDqyTUVbWgcxSEC1Uc +7pa2HSH3ZFmSC8g5gt5ZA3TSQv8iY/7xD5cMsbk= +=6HOm +-----END PGP MESSAGE----- diff --git a/propellor.cabal b/propellor.cabal new file mode 100644 index 00000000..50067b8d --- /dev/null +++ b/propellor.cabal @@ -0,0 +1,139 @@ +Name: propellor +Version: 0.8.1 +Cabal-Version: >= 1.6 +License: BSD3 +Maintainer: Joey Hess +Author: Joey Hess +Stability: Stable +Copyright: 2014 Joey Hess +License-File: LICENSE +Build-Type: Simple +Homepage: https://propellor.branchable.com/ +Category: Utility +Extra-Source-Files: + README.md + doc/README.mdwn + CHANGELOG + Makefile + config-simple.hs + config-joey.hs + debian/changelog + debian/README.Debian + debian/propellor.1 + debian/compat + debian/control + debian/copyright + debian/rules + debian/lintian-overrides +Synopsis: property-based host configuration management in haskell +Description: + Propellor enures that the system it's run in satisfies a list of + properties, taking action as necessary when a property is not yet met. + . + It is configured using haskell. + +Executable propellor + Main-Is: wrapper.hs + GHC-Options: -Wall -threaded -O0 + Hs-Source-Dirs: src + Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, + IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, + containers, network, async, time, QuickCheck, mtl, + MonadCatchIO-transformers + + if (! os(windows)) + Build-Depends: unix + +Executable propellor-config + Main-Is: config.hs + GHC-Options: -Wall -threaded -O0 + Hs-Source-Dirs: src + Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, + IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, + containers, network, async, time, QuickCheck, mtl, + MonadCatchIO-transformers + + if (! os(windows)) + Build-Depends: unix + +Library + GHC-Options: -Wall -O0 + Hs-Source-Dirs: src + Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, + IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, + containers, network, async, time, QuickCheck, mtl, + MonadCatchIO-transformers + + if (! os(windows)) + Build-Depends: unix + + Exposed-Modules: + Propellor + Propellor.Property + Propellor.Property.Apache + Propellor.Property.Apt + Propellor.Property.Cmd + Propellor.Property.Hostname + Propellor.Property.Cron + Propellor.Property.Dns + Propellor.Property.Docker + Propellor.Property.File + Propellor.Property.Git + Propellor.Property.Gpg + Propellor.Property.Grub + Propellor.Property.Network + Propellor.Property.Obnam + Propellor.Property.OpenId + Propellor.Property.Postfix + Propellor.Property.Reboot + Propellor.Property.Scheduled + Propellor.Property.Service + Propellor.Property.Ssh + Propellor.Property.Sudo + Propellor.Property.Tor + Propellor.Property.User + Propellor.Property.HostingProvider.CloudAtCost + Propellor.Property.HostingProvider.DigitalOcean + Propellor.Property.HostingProvider.Linode + Propellor.Property.SiteSpecific.GitHome + Propellor.Property.SiteSpecific.JoeySites + Propellor.Property.SiteSpecific.GitAnnexBuilder + Propellor.Info + Propellor.Message + Propellor.PrivData + Propellor.Engine + Propellor.Exception + Propellor.Types + Propellor.Types.OS + Propellor.Types.Dns + Propellor.Types.PrivData + Other-Modules: + Propellor.Types.Info + Propellor.CmdLine + Propellor.SimpleSh + Propellor.Property.Docker.Shim + Utility.Applicative + Utility.Data + Utility.Directory + Utility.Env + Utility.Exception + Utility.FileMode + Utility.FileSystemEncoding + Utility.LinuxMkLibs + Utility.Misc + Utility.Monad + Utility.Path + Utility.PartialPrelude + Utility.PosixFiles + Utility.Process + Utility.SafeCommand + Utility.Scheduled + Utility.Table + Utility.ThreadScheduler + Utility.Tmp + Utility.UserInfo + Utility.QuickCheck + +source-repository head + type: git + location: git://git.kitenet.net/propellor.git diff --git a/src/Propellor.hs b/src/Propellor.hs new file mode 100644 index 00000000..c0ef14f4 --- /dev/null +++ b/src/Propellor.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE PackageImports #-} + +-- | Pulls in lots of useful modules for building and using Properties. +-- +-- When propellor runs on a Host, it ensures that its list of Properties +-- is satisfied, taking action as necessary when a Property is not +-- currently satisfied. +-- +-- A simple propellor program example: +-- +-- > import Propellor +-- > import Propellor.CmdLine +-- > import qualified Propellor.Property.File as File +-- > import qualified Propellor.Property.Apt as Apt +-- > +-- > main :: IO () +-- > main = defaultMain hosts +-- > +-- > hosts :: [Host] +-- > hosts = +-- > [ host "example.com" +-- > & Apt.installed ["mydaemon"] +-- > & "/etc/mydaemon.conf" `File.containsLine` "secure=1" +-- > `onChange` cmdProperty "service" ["mydaemon", "restart"] +-- > ! Apt.installed ["unwantedpackage"] +-- > ] +-- +-- See config.hs for a more complete example, and clone Propellor's +-- git repository for a deployable system using Propellor: +-- git clone + +module Propellor ( + module Propellor.Types + , module Propellor.Property + , module Propellor.Property.Cmd + , module Propellor.Info + , module Propellor.PrivData + , module Propellor.Engine + , module Propellor.Exception + , module Propellor.Message + , localdir + + , module X +) where + +import Propellor.Types +import Propellor.Property +import Propellor.Engine +import Propellor.Property.Cmd +import Propellor.PrivData +import Propellor.Message +import Propellor.Exception +import Propellor.Info + +import Utility.PartialPrelude as X +import Utility.Process as X +import Utility.Exception as X +import Utility.Env as X +import Utility.Directory as X +import Utility.Tmp as X +import Utility.Monad as X +import Utility.Misc as X + +import System.Directory as X +import System.IO as X +import System.FilePath as X +import Data.Maybe as X +import Data.Either as X +import Control.Applicative as X +import Control.Monad as X +import Data.Monoid as X +import Control.Monad.IfElse as X +import "mtl" Control.Monad.Reader as X + +-- | This is where propellor installs itself when deploying a host. +localdir :: FilePath +localdir = "/usr/local/propellor" diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs new file mode 100644 index 00000000..7b39cd24 --- /dev/null +++ b/src/Propellor/CmdLine.hs @@ -0,0 +1,405 @@ +module Propellor.CmdLine where + +import System.Environment (getArgs) +import Data.List +import System.Exit +import System.Log.Logger +import System.Log.Formatter +import System.Log.Handler (setFormatter, LogHandler) +import System.Log.Handler.Simple +import System.PosixCompat +import Control.Exception (bracket) +import System.Posix.IO +import Data.Time.Clock.POSIX + +import Propellor +import qualified Propellor.Property.Docker as Docker +import qualified Propellor.Property.Docker.Shim as DockerShim +import Utility.FileMode +import Utility.SafeCommand +import Utility.UserInfo + +usage :: IO a +usage = do + putStrLn $ unlines + [ "Usage:" + , " propellor" + , " propellor hostname" + , " propellor --spin hostname" + , " propellor --add-key keyid" + , " propellor --set field context" + , " propellor --dump field context" + , " propellor --edit field context" + , " propellor --list-fields" + ] + exitFailure + +processCmdLine :: IO CmdLine +processCmdLine = go =<< getArgs + where + go ("--help":_) = usage + go ("--spin":h:[]) = return $ Spin h + go ("--boot":h:[]) = return $ Boot h + go ("--add-key":k:[]) = return $ AddKey k + go ("--set":f:c:[]) = withprivfield f c Set + go ("--dump":f:c:[]) = withprivfield f c Dump + go ("--edit":f:c:[]) = withprivfield f c Edit + go ("--list-fields":[]) = return ListFields + go ("--continue":s:[]) = case readish s of + Just cmdline -> return $ Continue cmdline + Nothing -> errorMessage "--continue serialization failure" + go ("--chain":h:[]) = return $ Chain h + go ("--docker":h:[]) = return $ Docker h + go (h:[]) + | "--" `isPrefixOf` h = usage + | otherwise = return $ Run h + go [] = do + s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] + if null s + then errorMessage "Cannot determine hostname! Pass it on the command line." + else return $ Run s + go _ = usage + + withprivfield s c f = case readish s of + Just pf -> return $ f pf (Context c) + Nothing -> errorMessage $ "Unknown privdata field " ++ s + +defaultMain :: [Host] -> IO () +defaultMain hostlist = do + DockerShim.cleanEnv + checkDebugMode + cmdline <- processCmdLine + debug ["command line: ", show cmdline] + go True cmdline + where + go _ (Continue cmdline) = go False cmdline + go _ (Set field context) = setPrivData field context + go _ (Dump field context) = dumpPrivData field context + go _ (Edit field context) = editPrivData field context + go _ ListFields = listPrivDataFields hostlist + go _ (AddKey keyid) = addKey keyid + go _ (Chain hn) = withhost hn $ \h -> do + r <- runPropellor h $ ensureProperties $ hostProperties h + putStrLn $ "\n" ++ show r + go _ (Docker hn) = Docker.chain hn + go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline + go True cmdline = updateFirst cmdline $ go False cmdline + go False (Spin hn) = withhost hn $ spin hn + go False (Run hn) = ifM ((==) 0 <$> getRealUserID) + ( onlyProcess $ withhost hn mainProperties + , go True (Spin hn) + ) + go False (Boot hn) = onlyProcess $ withhost hn boot + + withhost :: HostName -> (Host -> IO ()) -> IO () + withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) + +onlyProcess :: IO a -> IO a +onlyProcess a = bracket lock unlock (const a) + where + lock = do + l <- createFile lockfile stdFileMode + setLock l (WriteLock, AbsoluteSeek, 0, 0) + `catchIO` const alreadyrunning + return l + unlock = closeFd + alreadyrunning = error "Propellor is already running on this host!" + lockfile = localdir ".lock" + +unknownhost :: HostName -> [Host] -> IO a +unknownhost h hosts = errorMessage $ unlines + [ "Propellor does not know about host: " ++ h + , "(Perhaps you should specify the real hostname on the command line?)" + , "(Or, edit propellor's config.hs to configure this host)" + , "Known hosts: " ++ unwords (map hostName hosts) + ] + +buildFirst :: CmdLine -> IO () -> IO () +buildFirst cmdline next = do + oldtime <- getmtime + ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"]) + ( do + newtime <- getmtime + if newtime == oldtime + then next + else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)] + , errorMessage "Propellor build failed!" + ) + where + getmtime = catchMaybeIO $ getModificationTime "propellor" + +getCurrentBranch :: IO String +getCurrentBranch = takeWhile (/= '\n') + <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"] + +updateFirst :: CmdLine -> IO () -> IO () +updateFirst cmdline next = do + branchref <- getCurrentBranch + let originbranch = "origin" branchref + + void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"] + + oldsha <- getCurrentGitSha1 branchref + + whenM (doesFileExist keyring) $ do + {- To verify origin branch commit's signature, have to + - convince gpg to use our keyring. While running git log. + - Which has no way to pass options to gpg. + - Argh! -} + let gpgconf = privDataDir "gpg.conf" + writeFile gpgconf $ unlines + [ " keyring " ++ keyring + , "no-auto-check-trustdb" + ] + -- gpg is picky about perms + modifyFileMode privDataDir (removeModes otherGroupModes) + s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch] + (Just [("GNUPGHOME", privDataDir)]) + nukeFile $ privDataDir "trustdb.gpg" + nukeFile $ privDataDir "pubring.gpg" + nukeFile $ privDataDir "gpg.conf" + if s == "U\n" || s == "G\n" + then do + putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging" + hFlush stdout + void $ boolSystem "git" [Param "merge", Param originbranch] + else warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)" + + newsha <- getCurrentGitSha1 branchref + + if oldsha == newsha + then next + else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"]) + ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)] + , errorMessage "Propellor build failed!" + ) + +getCurrentGitSha1 :: String -> IO String +getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref] + +spin :: HostName -> Host -> IO () +spin hn hst = do + url <- getUrl + void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] + void $ boolSystem "git" [Param "push"] + cacheparams <- toCommand <$> sshCachingParams hn + go cacheparams url =<< hostprivdata + where + hostprivdata = show . filterPrivData hst <$> decryptPrivData + + go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do + let finish = do + senddata toh "privdata" privDataMarker privdata + hClose toh + + -- Display remaining output. + void $ tryIO $ forever $ + showremote =<< hGetLine fromh + hClose fromh + status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)") + case status of + Ready -> finish + NeedGitClone -> do + hClose toh + hClose fromh + sendGitClone hn url + go cacheparams url privdata + + user = "root@"++hn + + bootstrapcmd = shellWrap $ intercalate " ; " + [ "if [ ! -d " ++ localdir ++ " ]" + , "then " ++ intercalate " && " + [ "apt-get update" + , "apt-get --no-install-recommends --no-upgrade -y install git make" + , "echo " ++ toMarked statusMarker (show NeedGitClone) + ] + , "else " ++ intercalate " && " + [ "cd " ++ localdir + , "if ! test -x ./propellor; then make deps build; fi" + , "./propellor --boot " ++ hn + ] + , "fi" + ] + + getstatus :: Handle -> IO BootStrapStatus + getstatus h = do + l <- hGetLine h + case readish =<< fromMarked statusMarker l of + Nothing -> do + showremote l + getstatus h + Just status -> return status + + showremote s = putStrLn s + senddata toh desc marker s = void $ + actionMessage ("Sending " ++ desc ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do + sendMarked toh marker s + return True + +sendGitClone :: HostName -> String -> IO () +sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do + branch <- getCurrentBranch + cacheparams <- sshCachingParams hn + withTmpFile "propellor.git" $ \tmp _ -> allM id + [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] + , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] + , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] + ] + where + remotebundle = "/usr/local/propellor.git" + unpackcmd branch = shellWrap $ intercalate " && " + [ "git clone " ++ remotebundle ++ " " ++ localdir + , "cd " ++ localdir + , "git checkout -b " ++ branch + , "git remote rm origin" + , "rm -f " ++ remotebundle + , "git remote add origin " ++ url + -- same as --set-upstream-to, except origin branch + -- has not been pulled yet + , "git config branch."++branch++".remote origin" + , "git config branch."++branch++".merge refs/heads/"++branch + ] + +data BootStrapStatus = Ready | NeedGitClone + deriving (Read, Show, Eq) + +type Marker = String +type Marked = String + +statusMarker :: Marker +statusMarker = "STATUS" + +privDataMarker :: String +privDataMarker = "PRIVDATA " + +toMarked :: Marker -> String -> String +toMarked marker = intercalate "\n" . map (marker ++) . lines + +sendMarked :: Handle -> Marker -> String -> IO () +sendMarked h marker s = do + -- Prefix string with newline because sometimes a + -- incomplete line is output. + hPutStrLn h ("\n" ++ toMarked marker s) + hFlush h + +fromMarked :: Marker -> Marked -> Maybe String +fromMarked marker s + | null matches = Nothing + | otherwise = Just $ intercalate "\n" $ + map (drop len) matches + where + len = length marker + matches = filter (marker `isPrefixOf`) $ lines s + +boot :: Host -> IO () +boot h = do + sendMarked stdout statusMarker $ show Ready + reply <- hGetContentsStrict stdin + + makePrivDataDir + maybe noop (writeFileProtected privDataLocal) $ + fromMarked privDataMarker reply + mainProperties h + +addKey :: String -> IO () +addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ] + where + gpg = do + createDirectoryIfMissing True privDataDir + boolSystem "sh" + [ Param "-c" + , Param $ "gpg --export " ++ keyid ++ " | gpg " ++ + unwords (gpgopts ++ ["--import"]) + ] + gitadd = boolSystem "git" + [ Param "add" + , File keyring + ] + + gitconfig = boolSystem "git" + [ Param "config" + , Param "user.signingkey" + , Param keyid + ] + + gitcommit = gitCommit + [ File keyring + , Param "-m" + , Param "propellor addkey" + ] + +{- Automatically sign the commit if there'a a keyring. -} +gitCommit :: [CommandParam] -> IO Bool +gitCommit ps = do + k <- doesFileExist keyring + boolSystem "git" $ catMaybes $ + [ Just (Param "commit") + , if k then Just (Param "--gpg-sign") else Nothing + ] ++ map Just ps + +keyring :: FilePath +keyring = privDataDir "keyring.gpg" + +gpgopts :: [String] +gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring] + +getUrl :: IO String +getUrl = maybe nourl return =<< getM get urls + where + urls = ["remote.deploy.url", "remote.origin.url"] + nourl = errorMessage $ "Cannot find deploy url in " ++ show urls + get u = do + v <- catchMaybeIO $ + takeWhile (/= '\n') + <$> readProcess "git" ["config", u] + return $ case v of + Just url | not (null url) -> Just url + _ -> Nothing + +checkDebugMode :: IO () +checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" + where + go (Just s) + | s == "1" = do + f <- setFormatter + <$> streamHandler stderr DEBUG + <*> pure (simpleLogFormatter "[$time] $msg") + updateGlobalLogger rootLoggerName $ + setLevel DEBUG . setHandlers [f] + go _ = noop + +-- Parameters can be passed to both ssh and scp, to enable a ssh connection +-- caching socket. +-- +-- If the socket already exists, check if its mtime is older than 10 +-- minutes, and if so stop that ssh process, in order to not try to +-- use an old stale connection. (atime would be nicer, but there's +-- a good chance a laptop uses noatime) +sshCachingParams :: HostName -> IO [CommandParam] +sshCachingParams hn = do + home <- myHomeDir + let cachedir = home ".ssh" "propellor" + createDirectoryIfMissing False cachedir + let socketfile = cachedir hn ++ ".sock" + let ps = + [ Param "-o", Param ("ControlPath=" ++ socketfile) + , Params "-o ControlMaster=auto -o ControlPersist=yes" + ] + + maybe noop (expireold ps socketfile) + =<< catchMaybeIO (getFileStatus socketfile) + + return ps + + where + expireold ps f s = do + now <- truncate <$> getPOSIXTime :: IO Integer + if modificationTime s > fromIntegral now - tenminutes + then touchFile f + else do + void $ boolSystem "ssh" $ + [ Params "-O stop" ] ++ ps ++ + [ Param "localhost" ] + nukeFile f + tenminutes = 600 diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs new file mode 100644 index 00000000..a3fc0f30 --- /dev/null +++ b/src/Propellor/Engine.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Engine where + +import System.Exit +import System.IO +import Data.Monoid +import Control.Applicative +import System.Console.ANSI +import "mtl" Control.Monad.Reader + +import Propellor.Types +import Propellor.Message +import Propellor.Exception +import Propellor.Info + +runPropellor :: Host -> Propellor a -> IO a +runPropellor host a = runReaderT (runWithHost a) host + +mainProperties :: Host -> IO () +mainProperties host = do + r <- runPropellor host $ + ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty] + setTitle "propellor: done" + hFlush stdout + case r of + FailedChange -> exitWith (ExitFailure 1) + _ -> exitWith ExitSuccess + +ensureProperties :: [Property] -> Propellor Result +ensureProperties ps = ensure ps NoChange + where + ensure [] rs = return rs + ensure (l:ls) rs = do + hn <- asks hostName + r <- actionMessageOn hn (propertyDesc l) (ensureProperty l) + ensure ls (r <> rs) + +ensureProperty :: Property -> Propellor Result +ensureProperty = catchPropellor . propertySatisfy + +-- | Lifts an action into a different host. +-- +-- For example, `fromHost hosts "otherhost" getSshPubKey` +fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) +fromHost l hn getter = case findHost l hn of + Nothing -> return Nothing + Just h -> liftIO $ Just <$> + runReaderT (runWithHost getter) h diff --git a/src/Propellor/Exception.hs b/src/Propellor/Exception.hs new file mode 100644 index 00000000..f6fd15f1 --- /dev/null +++ b/src/Propellor/Exception.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Exception where + +import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M +import Control.Exception + +import Propellor.Types +import Propellor.Message + +-- | Catches IO exceptions and returns FailedChange. +catchPropellor :: Propellor Result -> Propellor Result +catchPropellor a = either err return =<< tryPropellor a + where + err e = warningMessage (show e) >> return FailedChange + +tryPropellor :: Propellor a -> Propellor (Either IOException a) +tryPropellor = M.try diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs new file mode 100644 index 00000000..00f1b0e9 --- /dev/null +++ b/src/Propellor/Info.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Info where + +import Propellor.Types +import Propellor.Types.Info + +import "mtl" Control.Monad.Reader +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Control.Applicative + +pureInfoProperty :: Desc -> Info -> Property +pureInfoProperty desc = Property ("has " ++ desc) (return NoChange) + +askInfo :: (Info -> Val a) -> Propellor (Maybe a) +askInfo f = asks (fromVal . f . hostInfo) + +os :: System -> Property +os system = pureInfoProperty ("Operating " ++ show system) $ + mempty { _os = Val system } + +getOS :: Propellor (Maybe System) +getOS = askInfo _os + +-- | Indidate that a host has an A record in the DNS. +-- +-- TODO check at run time if the host really has this address. +-- (Can't change the host's address, but as a sanity check.) +ipv4 :: String -> Property +ipv4 = addDNS . Address . IPv4 + +-- | Indidate that a host has an AAAA record in the DNS. +ipv6 :: String -> Property +ipv6 = addDNS . Address . IPv6 + +-- | Indicates another name for the host in the DNS. +-- +-- When the host's ipv4/ipv6 addresses are known, the alias is set up +-- to use their address, rather than using a CNAME. This avoids various +-- problems with CNAMEs, and also means that when multiple hosts have the +-- same alias, a DNS round-robin is automatically set up. +alias :: Domain -> Property +alias = addDNS . CNAME . AbsDomain + +addDNS :: Record -> Property +addDNS r = pureInfoProperty (rdesc r) $ + mempty { _dns = S.singleton r } + where + rdesc (CNAME d) = unwords ["alias", ddesc d] + rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr] + rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr] + rdesc (MX n d) = unwords ["MX", show n, ddesc d] + rdesc (NS d) = unwords ["NS", ddesc d] + rdesc (TXT s) = unwords ["TXT", s] + rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d] + + ddesc (AbsDomain domain) = domain + ddesc (RelDomain domain) = domain + ddesc RootDomain = "@" + +sshPubKey :: String -> Property +sshPubKey k = pureInfoProperty ("ssh pubkey known") $ + mempty { _sshPubKey = Val k } + +getSshPubKey :: Propellor (Maybe String) +getSshPubKey = askInfo _sshPubKey + +hostMap :: [Host] -> M.Map HostName Host +hostMap l = M.fromList $ zip (map hostName l) l + +findHost :: [Host] -> HostName -> Maybe Host +findHost l hn = M.lookup hn (hostMap l) + +getAddresses :: Info -> [IPAddr] +getAddresses = mapMaybe getIPAddr . S.toList . _dns + +hostAddresses :: HostName -> [Host] -> [IPAddr] +hostAddresses hn hosts = case hostInfo <$> findHost hosts hn of + Nothing -> [] + Just info -> mapMaybe getIPAddr $ S.toList $ _dns info diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs new file mode 100644 index 00000000..afbed1ca --- /dev/null +++ b/src/Propellor/Message.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Message where + +import System.Console.ANSI +import System.IO +import System.Log.Logger +import "mtl" Control.Monad.Reader + +import Propellor.Types + +-- | Shows a message while performing an action, with a colored status +-- display. +actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r +actionMessage = actionMessage' Nothing + +-- | Shows a message while performing an action on a specified host, +-- with a colored status display. +actionMessageOn :: (MonadIO m, ActionResult r) => HostName -> Desc -> m r -> m r +actionMessageOn = actionMessage' . Just + +actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r +actionMessage' mhn desc a = do + liftIO $ do + setTitle $ "propellor: " ++ desc + hFlush stdout + + r <- a + + liftIO $ do + setTitle "propellor: running" + showhn mhn + putStr $ desc ++ " ... " + let (msg, intensity, color) = getActionResult r + colorLine intensity color msg + hFlush stdout + + return r + where + showhn Nothing = return () + showhn (Just hn) = do + setSGR [SetColor Foreground Dull Cyan] + putStr (hn ++ " ") + setSGR [] + +warningMessage :: MonadIO m => String -> m () +warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s + +colorLine :: ColorIntensity -> Color -> String -> IO () +colorLine intensity color msg = do + setSGR [SetColor Foreground intensity color] + putStr msg + setSGR [] + -- Note this comes after the color is reset, so that + -- the color set and reset happen in the same line. + putStrLn "" + hFlush stdout + +errorMessage :: String -> IO a +errorMessage s = do + liftIO $ colorLine Vivid Red $ "** error: " ++ s + error "Cannot continue!" + +-- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1 +debug :: [String] -> IO () +debug = debugM "propellor" . unwords diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs new file mode 100644 index 00000000..f85ded15 --- /dev/null +++ b/src/Propellor/PrivData.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.PrivData where + +import Control.Applicative +import System.FilePath +import System.IO +import System.Directory +import Data.Maybe +import Data.Monoid +import Data.List +import Control.Monad +import Control.Monad.IfElse +import "mtl" Control.Monad.Reader +import qualified Data.Map as M +import qualified Data.Set as S + +import Propellor.Types +import Propellor.Types.Info +import Propellor.Message +import Propellor.Info +import Utility.Monad +import Utility.PartialPrelude +import Utility.Exception +import Utility.Process +import Utility.Tmp +import Utility.SafeCommand +import Utility.Misc +import Utility.FileMode +import Utility.Env +import Utility.Table + +-- | Allows a Property to access the value of a specific PrivDataField, +-- for use in a specific Context. +-- +-- Example use: +-- +-- > withPrivData (PrivFile pemfile) (Context "joeyh.name") $ \getdata -> +-- > property "joeyh.name ssl cert" $ getdata $ \privdata -> +-- > liftIO $ writeFile pemfile privdata +-- > where pemfile = "/etc/ssl/certs/web.pem" +-- +-- Note that if the value is not available, the action is not run +-- and instead it prints a message to help the user make the necessary +-- private data available. +-- +-- The resulting Property includes Info about the PrivDataField +-- being used, which is necessary to ensure that the privdata is sent to +-- the remote host by propellor. +withPrivData + :: PrivDataField + -> Context + -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property) + -> Property +withPrivData field context@(Context cname) mkprop = addinfo $ mkprop $ \a -> + maybe missing a =<< liftIO (getLocalPrivData field context) + where + missing = liftIO $ do + warningMessage $ "Missing privdata " ++ show field ++ " (for " ++ cname ++ ")" + putStrLn $ "Fix this by running: propellor --set '" ++ show field ++ "' '" ++ cname ++ "'" + return FailedChange + addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = S.singleton (field, context) } } + +addPrivDataField :: (PrivDataField, Context) -> Property +addPrivDataField v = pureInfoProperty (show v) $ + mempty { _privDataFields = S.singleton v } + +{- Gets the requested field's value, in the specified context if it's + - available, from the host's local privdata cache. -} +getLocalPrivData :: PrivDataField -> Context -> IO (Maybe PrivData) +getLocalPrivData field context = + getPrivData field context . fromMaybe M.empty <$> localcache + where + localcache = catchDefaultIO Nothing $ readish <$> readFile privDataLocal + +type PrivMap = M.Map (PrivDataField, Context) PrivData + +{- Get only the set of PrivData that the Host's Info says it uses. -} +filterPrivData :: Host -> PrivMap -> PrivMap +filterPrivData host = M.filterWithKey (\k _v -> S.member k used) + where + used = _privDataFields $ hostInfo host + +getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData +getPrivData field context = M.lookup (field, context) + +setPrivData :: PrivDataField -> Context -> IO () +setPrivData field context = do + putStrLn "Enter private data on stdin; ctrl-D when done:" + setPrivDataTo field context =<< hGetContentsStrict stdin + +dumpPrivData :: PrivDataField -> Context -> IO () +dumpPrivData field context = + maybe (error "Requested privdata is not set.") putStrLn + =<< (getPrivData field context <$> decryptPrivData) + +editPrivData :: PrivDataField -> Context -> IO () +editPrivData field context = do + v <- getPrivData field context <$> decryptPrivData + v' <- withTmpFile "propellorXXXX" $ \f h -> do + hClose h + maybe noop (writeFileProtected f) v + editor <- getEnvDefault "EDITOR" "vi" + unlessM (boolSystem editor [File f]) $ + error "Editor failed; aborting." + readFile f + setPrivDataTo field context v' + +listPrivDataFields :: [Host] -> IO () +listPrivDataFields hosts = do + m <- decryptPrivData + showtable "Currently set data:" $ + map mkrow (M.keys m) + showtable "Data that would be used if set:" $ + map mkrow (M.keys $ M.difference wantedmap m) + where + header = ["Field", "Context", "Used by"] + mkrow k@(field, (Context context)) = + [ shellEscape $ show field + , shellEscape context + , intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby + ] + mkhostmap host = M.fromList $ map (\k -> (k, [hostName host])) $ + S.toList $ _privDataFields $ hostInfo host + usedby = M.unionsWith (++) $ map mkhostmap hosts + wantedmap = M.fromList $ zip (M.keys usedby) (repeat "") + showtable desc rows = do + putStrLn $ "\n" ++ desc + putStr $ unlines $ formatTable $ tableWithHeader header rows + +setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () +setPrivDataTo field context value = do + makePrivDataDir + m <- decryptPrivData + let m' = M.insert (field, context) (chomp value) m + gpgEncrypt privDataFile (show m') + putStrLn "Private data set." + void $ boolSystem "git" [Param "add", File privDataFile] + where + chomp s + | end s == "\n" = chomp (beginning s) + | otherwise = s + +decryptPrivData :: IO PrivMap +decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile + +makePrivDataDir :: IO () +makePrivDataDir = createDirectoryIfMissing False privDataDir + +privDataDir :: FilePath +privDataDir = "privdata" + +privDataFile :: FilePath +privDataFile = privDataDir "privdata.gpg" + +privDataLocal :: FilePath +privDataLocal = privDataDir "local" + +gpgDecrypt :: FilePath -> IO String +gpgDecrypt f = ifM (doesFileExist f) + ( readProcess "gpg" ["--decrypt", f] + , return "" + ) + +gpgEncrypt :: FilePath -> String -> IO () +gpgEncrypt f s = do + encrypted <- writeReadProcessEnv "gpg" + [ "--default-recipient-self" + , "--armor" + , "--encrypt" + ] + Nothing + (Just $ flip hPutStr s) + Nothing + viaTmp writeFile f encrypted diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs new file mode 100644 index 00000000..68b6f6a9 --- /dev/null +++ b/src/Propellor/Property.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Property where + +import System.Directory +import Control.Monad +import Data.Monoid +import Control.Monad.IfElse +import "mtl" Control.Monad.Reader + +import Propellor.Types +import Propellor.Info +import Propellor.Engine +import Utility.Monad +import System.FilePath + +-- Constructs a Property. +property :: Desc -> Propellor Result -> Property +property d s = Property d s mempty + +-- | Combines a list of properties, resulting in a single property +-- that when run will run each property in the list in turn, +-- and print out the description of each as it's run. Does not stop +-- on failure; does propigate overall success/failure. +propertyList :: Desc -> [Property] -> Property +propertyList desc ps = Property desc (ensureProperties ps) (combineInfos ps) + +-- | Combines a list of properties, resulting in one property that +-- ensures each in turn. Does not stop on failure; does propigate +-- overall success/failure. +combineProperties :: Desc -> [Property] -> Property +combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps) + where + go [] rs = return rs + go (l:ls) rs = do + r <- ensureProperty l + case r of + FailedChange -> return FailedChange + _ -> go ls (r <> rs) + +-- | Combines together two properties, resulting in one property +-- that ensures the first, and if the first succeeds, ensures the second. +-- The property uses the description of the first property. +before :: Property -> Property -> Property +p1 `before` p2 = p2 `requires` p1 + `describe` (propertyDesc p1) + +-- | Makes a perhaps non-idempotent Property be idempotent by using a flag +-- file to indicate whether it has run before. +-- Use with caution. +flagFile :: Property -> FilePath -> Property +flagFile p = flagFile' p . return + +flagFile' :: Property -> IO FilePath -> Property +flagFile' p getflagfile = adjustProperty p $ \satisfy -> do + flagfile <- liftIO getflagfile + go satisfy flagfile =<< liftIO (doesFileExist flagfile) + where + go _ _ True = return NoChange + go satisfy flagfile False = do + r <- satisfy + when (r == MadeChange) $ liftIO $ + unlessM (doesFileExist flagfile) $ do + createDirectoryIfMissing True (takeDirectory flagfile) + writeFile flagfile "" + return r + +--- | Whenever a change has to be made for a Property, causes a hook +-- Property to also be run, but not otherwise. +onChange :: Property -> Property -> Property +p `onChange` hook = Property (propertyDesc p) satisfy (combineInfo p hook) + where + satisfy = do + r <- ensureProperty p + case r of + MadeChange -> do + r' <- ensureProperty hook + return $ r <> r' + _ -> return r + +(==>) :: Desc -> Property -> Property +(==>) = flip describe +infixl 1 ==> + +-- | Makes a Property only need to do anything when a test succeeds. +check :: IO Bool -> Property -> Property +check c p = adjustProperty p $ \satisfy -> ifM (liftIO c) + ( satisfy + , return NoChange + ) + +-- | Marks a Property as trivial. It can only return FailedChange or +-- NoChange. +-- +-- Useful when it's just as expensive to check if a change needs +-- to be made as it is to just idempotently assure the property is +-- satisfied. For example, chmodding a file. +trivial :: Property -> Property +trivial p = adjustProperty p $ \satisfy -> do + r <- satisfy + if r == MadeChange + then return NoChange + else return r + +doNothing :: Property +doNothing = property "noop property" noChange + +-- | Makes a property that is satisfied differently depending on the host's +-- operating system. +-- +-- Note that the operating system may not be declared for some hosts. +withOS :: Desc -> (Maybe System -> Propellor Result) -> Property +withOS desc a = property desc $ a =<< getOS + +boolProperty :: Desc -> IO Bool -> Property +boolProperty desc a = property desc $ ifM (liftIO a) + ( return MadeChange + , return FailedChange + ) + +-- | Undoes the effect of a property. +revert :: RevertableProperty -> RevertableProperty +revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 + +-- | Starts accumulating the properties of a Host. +-- +-- > host "example.com" +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +host :: HostName -> Host +host hn = Host hn [] mempty + +-- | Adds a property to a Host +-- +-- Can add Properties and RevertableProperties +(&) :: IsProp p => Host -> p -> Host +(Host hn ps as) & p = Host hn (ps ++ [toProp p]) (as <> getInfo p) + +infixl 1 & + +-- | Adds a property to the Host in reverted form. +(!) :: Host -> RevertableProperty -> Host +h ! p = h & revert p + +infixl 1 ! + +-- Changes the action that is performed to satisfy a property. +adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property +adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } + +-- Combines the Info of two properties. +combineInfo :: (IsProp p, IsProp q) => p -> q -> Info +combineInfo p q = getInfo p <> getInfo q + +combineInfos :: IsProp p => [p] -> Info +combineInfos = mconcat . map getInfo + +makeChange :: IO () -> Propellor Result +makeChange a = liftIO a >> return MadeChange + +noChange :: Propellor Result +noChange = return NoChange diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs new file mode 100644 index 00000000..cf3e62cc --- /dev/null +++ b/src/Propellor/Property/Apache.hs @@ -0,0 +1,62 @@ +module Propellor.Property.Apache where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +type ConfigFile = [String] + +siteEnabled :: HostName -> ConfigFile -> RevertableProperty +siteEnabled hn cf = RevertableProperty enable disable + where + enable = trivial $ cmdProperty "a2ensite" ["--quiet", hn] + `describe` ("apache site enabled " ++ hn) + `requires` siteAvailable hn cf + `requires` installed + `onChange` reloaded + disable = trivial $ File.notPresent (siteCfg hn) + `describe` ("apache site disabled " ++ hn) + `onChange` cmdProperty "a2dissite" ["--quiet", hn] + `requires` installed + `onChange` reloaded + +siteAvailable :: HostName -> ConfigFile -> Property +siteAvailable hn cf = siteCfg hn `File.hasContent` (comment:cf) + `describe` ("apache site available " ++ hn) + where + comment = "# deployed with propellor, do not modify" + +modEnabled :: String -> RevertableProperty +modEnabled modname = RevertableProperty enable disable + where + enable = trivial $ cmdProperty "a2enmod" ["--quiet", modname] + `describe` ("apache module enabled " ++ modname) + `requires` installed + `onChange` reloaded + disable = trivial $ cmdProperty "a2dismod" ["--quiet", modname] + `describe` ("apache module disabled " ++ modname) + `requires` installed + `onChange` reloaded + +siteCfg :: HostName -> FilePath +siteCfg hn = "/etc/apache2/sites-available/" ++ hn + +installed :: Property +installed = Apt.installed ["apache2"] + +restarted :: Property +restarted = cmdProperty "service" ["apache2", "restart"] + +reloaded :: Property +reloaded = Service.reloaded "apache2" + +-- | Configure apache to use SNI to differentiate between +-- https hosts. +multiSSL :: Property +multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent` + [ "NameVirtualHost *:443" + , "SSLStrictSNIVHostCheck off" + ] + `describe` "apache SNI enabled" + `onChange` reloaded diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs new file mode 100644 index 00000000..7e02a335 --- /dev/null +++ b/src/Propellor/Property/Apt.hs @@ -0,0 +1,269 @@ +module Propellor.Property.Apt where + +import Data.Maybe +import Control.Applicative +import Data.List +import System.IO +import Control.Monad + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Service as Service +import Propellor.Property.File (Line) + +sourcesList :: FilePath +sourcesList = "/etc/apt/sources.list" + +type Url = String +type Section = String + +type SourcesGenerator = DebianSuite -> [Line] + +showSuite :: DebianSuite -> String +showSuite Stable = "stable" +showSuite Testing = "testing" +showSuite Unstable = "unstable" +showSuite Experimental = "experimental" +showSuite (DebianRelease r) = r + +backportSuite :: String +backportSuite = showSuite stableRelease ++ "-backports" + +debLine :: String -> Url -> [Section] -> Line +debLine suite mirror sections = unwords $ + ["deb", mirror, suite] ++ sections + +srcLine :: Line -> Line +srcLine l = case words l of + ("deb":rest) -> unwords $ "deb-src" : rest + _ -> "" + +stdSections :: [Section] +stdSections = ["main", "contrib", "non-free"] + +binandsrc :: String -> SourcesGenerator +binandsrc url suite + | isStable suite = [l, srcLine l, bl, srcLine bl] + | otherwise = [l, srcLine l] + where + l = debLine (showSuite suite) url stdSections + bl = debLine backportSuite url stdSections + +debCdn :: SourcesGenerator +debCdn = binandsrc "http://cdn.debian.net/debian" + +kernelOrg :: SourcesGenerator +kernelOrg = binandsrc "http://mirrors.kernel.org/debian" + +-- | Only available for Stable and Testing +securityUpdates :: SourcesGenerator +securityUpdates suite + | isStable suite || suite == Testing = + let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections + in [l, srcLine l] + | otherwise = [] + +-- | Makes sources.list have a standard content using the mirror CDN, +-- with the Debian suite configured by the os. +-- +-- Since the CDN is sometimes unreliable, also adds backup lines using +-- kernel.org. +stdSourcesList :: Property +stdSourcesList = withOS ("standard sources.list") $ \o -> + case o of + (Just (System (Debian suite) _)) -> + ensureProperty $ stdSourcesListFor suite + _ -> error "os is not declared to be Debian" + +stdSourcesListFor :: DebianSuite -> Property +stdSourcesListFor suite = stdSourcesList' suite [] + +-- | Adds additional sources.list generators. +-- +-- Note that if a Property needs to enable an apt source, it's better +-- to do so via a separate file in /etc/apt/sources.list.d/ +stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property +stdSourcesList' suite more = setSourcesList + (concatMap (\gen -> gen suite) generators) + `describe` ("standard sources.list for " ++ show suite) + where + generators = [debCdn, kernelOrg, securityUpdates] ++ more + +setSourcesList :: [Line] -> Property +setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update + +setSourcesListD :: [Line] -> FilePath -> Property +setSourcesListD ls basename = f `File.hasContent` ls `onChange` update + where + f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" + +runApt :: [String] -> Property +runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv + +noninteractiveEnv :: [(String, String)] +noninteractiveEnv = + [ ("DEBIAN_FRONTEND", "noninteractive") + , ("APT_LISTCHANGES_FRONTEND", "none") + ] + +update :: Property +update = runApt ["update"] + `describe` "apt update" + +upgrade :: Property +upgrade = runApt ["-y", "dist-upgrade"] + `describe` "apt dist-upgrade" + +type Package = String + +installed :: [Package] -> Property +installed = installed' ["-y"] + +installed' :: [String] -> [Package] -> Property +installed' params ps = robustly $ check (isInstallable ps) go + `describe` (unwords $ "apt installed":ps) + where + go = runApt $ params ++ ["install"] ++ ps + +installedBackport :: [Package] -> Property +installedBackport ps = trivial $ withOS desc $ \o -> case o of + Nothing -> error "cannot install backports; os not declared" + (Just (System (Debian suite) _)) + | isStable suite -> + ensureProperty $ runApt $ + ["install", "-t", backportSuite, "-y"] ++ ps + _ -> error $ "backports not supported on " ++ show o + where + desc = (unwords $ "apt installed backport":ps) + +-- | Minimal install of package, without recommends. +installedMin :: [Package] -> Property +installedMin = installed' ["--no-install-recommends", "-y"] + +removed :: [Package] -> Property +removed ps = check (or <$> isInstalled' ps) go + `describe` (unwords $ "apt removed":ps) + where + go = runApt $ ["-y", "remove"] ++ ps + +buildDep :: [Package] -> Property +buildDep ps = robustly go + `describe` (unwords $ "apt build-dep":ps) + where + go = runApt $ ["-y", "build-dep"] ++ ps + +-- | Installs the build deps for the source package unpacked +-- in the specifed directory, with a dummy package also +-- installed so that autoRemove won't remove them. +buildDepIn :: FilePath -> Property +buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] + where + go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"] + noninteractiveEnv + +-- | Package installation may fail becuse the archive has changed. +-- Run an update in that case and retry. +robustly :: Property -> Property +robustly p = adjustProperty p $ \satisfy -> do + r <- satisfy + if r == FailedChange + then ensureProperty $ p `requires` update + else return r + +isInstallable :: [Package] -> IO Bool +isInstallable ps = do + l <- isInstalled' ps + return $ any (== False) l && not (null l) + +isInstalled :: Package -> IO Bool +isInstalled p = (== [True]) <$> isInstalled' [p] + +-- | Note that the order of the returned list will not always +-- correspond to the order of the input list. The number of items may +-- even vary. If apt does not know about a package at all, it will not +-- be included in the result list. +isInstalled' :: [Package] -> IO [Bool] +isInstalled' ps = catMaybes . map parse . lines + <$> readProcess "apt-cache" ("policy":ps) + where + parse l + | "Installed: (none)" `isInfixOf` l = Just False + | "Installed: " `isInfixOf` l = Just True + | otherwise = Nothing + +autoRemove :: Property +autoRemove = runApt ["-y", "autoremove"] + `describe` "apt autoremove" + +-- | Enables unattended upgrades. Revert to disable. +unattendedUpgrades :: RevertableProperty +unattendedUpgrades = RevertableProperty enable disable + where + enable = setup True + `before` Service.running "cron" + `before` configure + disable = setup False + + setup enabled = (if enabled then installed else removed) ["unattended-upgrades"] + `onChange` reConfigure "unattended-upgrades" + [("unattended-upgrades/enable_auto_updates" , "boolean", v)] + `describe` ("unattended upgrades " ++ v) + where + v + | enabled = "true" + | otherwise = "false" + + configure = withOS "unattended upgrades configured" $ \o -> + case o of + -- the package defaults to only upgrading stable + (Just (System (Debian suite) _)) + | not (isStable suite) -> ensureProperty $ + "/etc/apt/apt.conf.d/50unattended-upgrades" + `File.containsLine` + ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") + _ -> noChange + +-- | Preseeds debconf values and reconfigures the package so it takes +-- effect. +reConfigure :: Package -> [(String, String, String)] -> Property +reConfigure package vals = reconfigure `requires` setselections + `describe` ("reconfigure " ++ package) + where + setselections = property "preseed" $ makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "debconf-set-selections" []) $ \h -> do + forM_ vals $ \(tmpl, tmpltype, value) -> + hPutStrLn h $ unwords [package, tmpl, tmpltype, value] + hClose h + reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv + +-- | Ensures that a service is installed and running. +-- +-- Assumes that there is a 1:1 mapping between service names and apt +-- package names. +serviceInstalledRunning :: Package -> Property +serviceInstalledRunning svc = Service.running svc `requires` installed [svc] + +data AptKey = AptKey + { keyname :: String + , pubkey :: String + } + +trustsKey :: AptKey -> RevertableProperty +trustsKey k = RevertableProperty trust untrust + where + desc = "apt trusts key " ++ keyname k + f = "/etc/apt/trusted.gpg.d" keyname k ++ ".gpg" + untrust = File.notPresent f + trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do + withHandle StdinHandle createProcessSuccess + (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do + hPutStr h (pubkey k) + hClose h + nukeFile $ f ++ "~" -- gpg dropping + +-- | Cleans apt's cache of downloaded packages to avoid using up disk +-- space. +cacheCleaned :: Property +cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"] + `describe` "apt cache cleaned" diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs new file mode 100644 index 00000000..bcd08246 --- /dev/null +++ b/src/Propellor/Property/Cmd.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Property.Cmd ( + cmdProperty, + cmdProperty', + scriptProperty, + userScriptProperty, +) where + +import Control.Applicative +import Data.List +import "mtl" Control.Monad.Reader + +import Propellor.Types +import Propellor.Property +import Utility.Monad +import Utility.SafeCommand +import Utility.Env + +-- | A property that can be satisfied by running a command. +-- +-- The command must exit 0 on success. +cmdProperty :: String -> [String] -> Property +cmdProperty cmd params = cmdProperty' cmd params [] + +-- | A property that can be satisfied by running a command, +-- with added environment. +cmdProperty' :: String -> [String] -> [(String, String)] -> Property +cmdProperty' cmd params env = property desc $ liftIO $ do + env' <- addEntries env <$> getEnvironment + ifM (boolSystemEnv cmd (map Param params) (Just env')) + ( return MadeChange + , return FailedChange + ) + where + desc = unwords $ cmd : params + +-- | A property that can be satisfied by running a series of shell commands. +scriptProperty :: [String] -> Property +scriptProperty script = cmdProperty "sh" ["-c", shellcmd] + where + shellcmd = intercalate " ; " ("set -e" : script) + +-- | A property that can satisfied by running a series of shell commands, +-- as user (cd'd to their home directory). +userScriptProperty :: UserName -> [String] -> Property +userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user] + where + shellcmd = intercalate " ; " ("set -e" : "cd" : script) diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs new file mode 100644 index 00000000..5b070eff --- /dev/null +++ b/src/Propellor/Property/Cron.hs @@ -0,0 +1,49 @@ +module Propellor.Property.Cron where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import Utility.SafeCommand + +import Data.Char + +type CronTimes = String + +-- | Installs a cron job, run as a specified user, in a particular +-- directory. Note that the Desc must be unique, as it is used for the +-- cron.d/ filename. +-- +-- Only one instance of the cron job is allowed to run at a time, no matter +-- how long it runs. This is accomplished using flock locking of the cron +-- job file. +-- +-- The cron job's output will only be emailed if it exits nonzero. +job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +job desc times user cddir command = cronjobfile `File.hasContent` + [ "# Generated by propellor" + , "" + , "SHELL=/bin/sh" + , "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" + , "" + , times ++ "\t" ++ user ++ "\t" + ++ "chronic flock -n " ++ shellEscape cronjobfile + ++ " sh -c " ++ shellEscape cmdline + ] + `requires` Apt.serviceInstalledRunning "cron" + `requires` Apt.installed ["util-linux", "moreutils"] + `describe` ("cronned " ++ desc) + where + cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )" + cronjobfile = "/etc/cron.d/" ++ map sanitize desc + sanitize c + | isAlphaNum c = c + | otherwise = '_' + +-- | Installs a cron job, and runs it niced and ioniced. +niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +niceJob desc times user cddir command = job desc times user cddir + ("nice ionice -c 3 " ++ command) + +-- | Installs a cron job to run propellor. +runPropellor :: CronTimes -> Property +runPropellor times = niceJob "propellor" times "root" localdir "make" diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs new file mode 100644 index 00000000..ddfcf8e6 --- /dev/null +++ b/src/Propellor/Property/Dns.hs @@ -0,0 +1,426 @@ +module Propellor.Property.Dns ( + module Propellor.Types.Dns, + primary, + secondary, + secondaryFor, + mkSOA, + writeZoneFile, + nextSerialNumber, + adjustSerialNumber, + serialNumberOffset, + WarningMessage, + genZone, +) where + +import Propellor +import Propellor.Types.Dns +import Propellor.Property.File +import Propellor.Types.Info +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import Utility.Applicative + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.List + +-- | Primary dns server for a domain. +-- +-- Most of the content of the zone file is configured by setting properties +-- of hosts. For example, +-- +-- > host "foo.example.com" +-- > & ipv4 "192.168.1.1" +-- > & alias "mail.exmaple.com" +-- +-- Will cause that hostmame and its alias to appear in the zone file, +-- with the configured IP address. +-- +-- The [(BindDomain, Record)] list can be used for additional records +-- that cannot be configured elsewhere. This often includes NS records, +-- TXT records and perhaps CNAMEs pointing at hosts that propellor does +-- not control. +-- +-- The primary server is configured to only allow zone transfers to +-- secondary dns servers. These are determined in two ways: +-- +-- 1. By looking at the properties of other hosts, to find hosts that +-- are configured as the secondary dns server. +-- +-- 2. By looking for NS Records in the passed list of records. +-- +-- In either case, the secondary dns server Host should have an ipv4 and/or +-- ipv6 property defined. +primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty +primary hosts domain soa rs = RevertableProperty setup cleanup + where + setup = withwarnings (check needupdate baseprop) + `requires` servingZones + `onChange` Service.reloaded "bind9" + cleanup = check (doesFileExist zonefile) $ + property ("removed dns primary for " ++ domain) + (makeChange $ removeZoneFile zonefile) + `requires` namedConfWritten + `onChange` Service.reloaded "bind9" + + (partialzone, zonewarnings) = genZone hosts domain soa + zone = partialzone { zHosts = zHosts partialzone ++ rs } + zonefile = "/etc/bind/propellor/db." ++ domain + baseprop = Property ("dns primary for " ++ domain) + (makeChange $ writeZoneFile zone zonefile) + (addNamedConf conf) + withwarnings p = adjustProperty p $ \satisfy -> do + mapM_ warningMessage $ zonewarnings ++ secondarywarnings + satisfy + conf = NamedConf + { confDomain = domain + , confDnsServerType = Master + , confFile = zonefile + , confMasters = [] + , confAllowTransfer = nub $ + concatMap (\h -> hostAddresses h hosts) $ + secondaries ++ nssecondaries + , confLines = [] + } + secondaries = otherServers Secondary hosts domain + secondarywarnings = map (\h -> "No IP address defined for DNS seconary " ++ h) $ + filter (\h -> null (hostAddresses h hosts)) secondaries + nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords + rootRecords = map snd $ + filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs + needupdate = do + v <- readZonePropellorFile zonefile + return $ case v of + Nothing -> True + Just oldzone -> + -- compare everything except serial + let oldserial = sSerial (zSOA oldzone) + z = zone { zSOA = (zSOA zone) { sSerial = oldserial } } + in z /= oldzone || oldserial < sSerial (zSOA zone) + +-- | Secondary dns server for a domain. +-- +-- The primary server is determined by looking at the properties of other +-- hosts to find which one is configured as the primary. +-- +-- Note that if a host is declared to be a primary and a secondary dns +-- server for the same domain, the primary server config always wins. +secondary :: [Host] -> Domain -> RevertableProperty +secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain + +-- | This variant is useful if the primary server does not have its DNS +-- configured via propellor. +secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty +secondaryFor masters hosts domain = RevertableProperty setup cleanup + where + setup = pureInfoProperty desc (addNamedConf conf) + `requires` servingZones + cleanup = namedConfWritten + + desc = "dns secondary for " ++ domain + conf = NamedConf + { confDomain = domain + , confDnsServerType = Secondary + , confFile = "db." ++ domain + , confMasters = concatMap (\m -> hostAddresses m hosts) masters + , confAllowTransfer = [] + , confLines = [] + } + +otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] +otherServers wantedtype hosts domain = + M.keys $ M.filter wanted $ hostMap hosts + where + wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostInfo h) of + Nothing -> False + Just conf -> confDnsServerType conf == wantedtype + && confDomain conf == domain + +-- | Rewrites the whole named.conf.local file to serve the zones +-- configured by `primary` and `secondary`, and ensures that bind9 is +-- running. +servingZones :: Property +servingZones = namedConfWritten + `onChange` Service.reloaded "bind9" + `requires` Apt.serviceInstalledRunning "bind9" + +namedConfWritten :: Property +namedConfWritten = property "named.conf configured" $ do + zs <- getNamedConf + ensureProperty $ + hasContent namedConfFile $ + concatMap confStanza $ M.elems zs + +confStanza :: NamedConf -> [Line] +confStanza c = + [ "// automatically generated by propellor" + , "zone \"" ++ confDomain c ++ "\" {" + , cfgline "type" (if confDnsServerType c == Master then "master" else "slave") + , cfgline "file" ("\"" ++ confFile c ++ "\"") + ] ++ + mastersblock ++ + allowtransferblock ++ + (map (\l -> "\t" ++ l ++ ";") (confLines c)) ++ + [ "};" + , "" + ] + where + cfgline f v = "\t" ++ f ++ " " ++ v ++ ";" + ipblock name l = + [ "\t" ++ name ++ " {" ] ++ + (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++ + [ "\t};" ] + mastersblock + | null (confMasters c) = [] + | otherwise = ipblock "masters" (confMasters c) + -- an empty block prohibits any transfers + allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c) + +namedConfFile :: FilePath +namedConfFile = "/etc/bind/named.conf.local" + +-- | Generates a SOA with some fairly sane numbers in it. +-- +-- The Domain is the domain to use in the SOA record. Typically +-- something like ns1.example.com. So, not the domain that this is the SOA +-- record for. +-- +-- The SerialNumber can be whatever serial number was used by the domain +-- before propellor started managing it. Or 0 if the domain has only ever +-- been managed by propellor. +-- +-- You do not need to increment the SerialNumber when making changes! +-- Propellor will automatically add the number of commits in the git +-- repository to the SerialNumber. +mkSOA :: Domain -> SerialNumber -> SOA +mkSOA d sn = SOA + { sDomain = AbsDomain d + , sSerial = sn + , sRefresh = hours 4 + , sRetry = hours 1 + , sExpire = 2419200 -- 4 weeks + , sNegativeCacheTTL = hours 8 + } + where + hours n = n * 60 * 60 + +dValue :: BindDomain -> String +dValue (RelDomain d) = d +dValue (AbsDomain d) = d ++ "." +dValue (RootDomain) = "@" + +rField :: Record -> String +rField (Address (IPv4 _)) = "A" +rField (Address (IPv6 _)) = "AAAA" +rField (CNAME _) = "CNAME" +rField (MX _ _) = "MX" +rField (NS _) = "NS" +rField (TXT _) = "TXT" +rField (SRV _ _ _ _) = "SRV" + +rValue :: Record -> String +rValue (Address (IPv4 addr)) = addr +rValue (Address (IPv6 addr)) = addr +rValue (CNAME d) = dValue d +rValue (MX pri d) = show pri ++ " " ++ dValue d +rValue (NS d) = dValue d +rValue (SRV priority weight port target) = unwords + [ show priority + , show weight + , show port + , dValue target + ] +rValue (TXT s) = [q] ++ filter (/= q) s ++ [q] + where + q = '"' + +-- | Adjusts the serial number of the zone to always be larger +-- than the serial number in the Zone record, +-- and always be larger than the passed SerialNumber. +nextSerialNumber :: Zone -> SerialNumber -> Zone +nextSerialNumber z serial = adjustSerialNumber z $ \sn -> succ $ max sn serial + +adjustSerialNumber :: Zone -> (SerialNumber -> SerialNumber) -> Zone +adjustSerialNumber (Zone d soa l) f = Zone d soa' l + where + soa' = soa { sSerial = f (sSerial soa) } + +-- | Count the number of git commits made to the current branch. +serialNumberOffset :: IO SerialNumber +serialNumberOffset = fromIntegral . length . lines + <$> readProcess "git" ["log", "--pretty=%H"] + +-- | Write a Zone out to a to a file. +-- +-- The serial number in the Zone automatically has the serialNumberOffset +-- added to it. Also, just in case, the old serial number used in the zone +-- file is checked, and if it is somehow larger, its succ is used. +writeZoneFile :: Zone -> FilePath -> IO () +writeZoneFile z f = do + oldserial <- oldZoneFileSerialNumber f + offset <- serialNumberOffset + let z' = nextSerialNumber + (adjustSerialNumber z (+ offset)) + oldserial + createDirectoryIfMissing True (takeDirectory f) + writeFile f (genZoneFile z') + writeZonePropellorFile f z' + +removeZoneFile :: FilePath -> IO () +removeZoneFile f = do + nukeFile f + nukeFile (zonePropellorFile f) + +-- | Next to the zone file, is a ".propellor" file, which contains +-- the serialized Zone. This saves the bother of parsing +-- the horrible bind zone file format. +zonePropellorFile :: FilePath -> FilePath +zonePropellorFile f = f ++ ".propellor" + +oldZoneFileSerialNumber :: FilePath -> IO SerialNumber +oldZoneFileSerialNumber = maybe 0 (sSerial . zSOA) <$$> readZonePropellorFile + +writeZonePropellorFile :: FilePath -> Zone -> IO () +writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z) + +readZonePropellorFile :: FilePath -> IO (Maybe Zone) +readZonePropellorFile f = catchDefaultIO Nothing $ + readish <$> readFileStrict (zonePropellorFile f) + +-- | Generating a zone file. +genZoneFile :: Zone -> String +genZoneFile (Zone zdomain soa rs) = unlines $ + header : genSOA soa ++ map (genRecord zdomain) rs + where + header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit." + +genRecord :: Domain -> (BindDomain, Record) -> String +genRecord zdomain (domain, record) = intercalate "\t" + [ domainHost zdomain domain + , "IN" + , rField record + , rValue record + ] + +genSOA :: SOA -> [String] +genSOA soa = + -- "@ IN SOA ns1.example.com. root (" + [ intercalate "\t" + [ dValue RootDomain + , "IN" + , "SOA" + , dValue (sDomain soa) + , "root" + , "(" + ] + , headerline sSerial "Serial" + , headerline sRefresh "Refresh" + , headerline sRetry "Retry" + , headerline sExpire "Expire" + , headerline sNegativeCacheTTL "Negative Cache TTL" + , inheader ")" + ] + where + headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment + inheader l = "\t\t\t" ++ l + +-- | Comment line in a zone file. +com :: String -> String +com s = "; " ++ s + +type WarningMessage = String + +-- | Generates a Zone for a particular Domain from the DNS properies of all +-- hosts that propellor knows about that are in that Domain. +genZone :: [Host] -> Domain -> SOA -> (Zone, [WarningMessage]) +genZone hosts zdomain soa = + let (warnings, zhosts) = partitionEithers $ concat $ map concat + [ map hostips inzdomain + , map hostrecords inzdomain + , map addcnames (M.elems m) + ] + in (Zone zdomain soa (simplify zhosts), warnings) + where + m = hostMap hosts + -- Known hosts with hostname located in the zone's domain. + inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m + + -- Each host with a hostname located in the zdomain + -- should have 1 or more IPAddrs in its Info. + -- + -- If a host lacks any IPAddr, it's probably a misconfiguration, + -- so warn. + hostips :: Host -> [Either WarningMessage (BindDomain, Record)] + hostips h + | null l = [Left $ "no IP address defined for host " ++ hostName h] + | otherwise = map Right l + where + info = hostInfo h + l = zip (repeat $ AbsDomain $ hostName h) + (map Address $ getAddresses info) + + -- Any host, whether its hostname is in the zdomain or not, + -- may have cnames which are in the zdomain. The cname may even be + -- the same as the root of the zdomain, which is a nice way to + -- specify IP addresses for a SOA record. + -- + -- Add Records for those.. But not actually, usually, cnames! + -- Why not? Well, using cnames doesn't allow doing some things, + -- including MX and round robin DNS, and certianly CNAMES + -- shouldn't be used in SOA records. + -- + -- We typically know the host's IPAddrs anyway. + -- So we can just use the IPAddrs. + addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] + addcnames h = concatMap gen $ filter (inDomain zdomain) $ + mapMaybe getCNAME $ S.toList (_dns info) + where + info = hostInfo h + gen c = case getAddresses info of + [] -> [ret (CNAME c)] + l -> map (ret . Address) l + where + ret record = Right (c, record) + + -- Adds any other DNS records for a host located in the zdomain. + hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)] + hostrecords h = map Right l + where + info = hostInfo h + l = zip (repeat $ AbsDomain $ hostName h) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns info)) + + -- Simplifies the list of hosts. Remove duplicate entries. + -- Also, filter out any CHAMES where the same domain has an + -- IP address, since that's not legal. + simplify :: [(BindDomain, Record)] -> [(BindDomain, Record)] + simplify l = nub $ filter (not . dupcname ) l + where + dupcname (d, CNAME _) | any (matchingaddr d) l = True + dupcname _ = False + matchingaddr d (d', (Address _)) | d == d' = True + matchingaddr _ _ = False + +inDomain :: Domain -> BindDomain -> Bool +inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d +inDomain _ _ = False -- can't tell, so assume not + +-- | Gets the hostname of the second domain, relative to the first domain, +-- suitable for using in a zone file. +domainHost :: Domain -> BindDomain -> String +domainHost _ (RelDomain d) = d +domainHost _ RootDomain = "@" +domainHost base (AbsDomain d) + | dotbase `isSuffixOf` d = take (length d - length dotbase) d + | base == d = "@" + | otherwise = d + where + dotbase = '.':base + +addNamedConf :: NamedConf -> Info +addNamedConf conf = mempty { _namedconf = NamedConfMap (M.singleton domain conf) } + where + domain = confDomain conf + +getNamedConf :: Propellor (M.Map Domain NamedConf) +getNamedConf = asks $ fromNamedConfMap . _namedconf . hostInfo diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs new file mode 100644 index 00000000..4307b850 --- /dev/null +++ b/src/Propellor/Property/Docker.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Docker support for propellor +-- +-- The existance of a docker container is just another Property of a system, +-- which propellor can set up. See config.hs for an example. + +module Propellor.Property.Docker ( + -- * Host properties + installed, + configured, + container, + docked, + memoryLimited, + garbageCollected, + Image, + ContainerName, + -- * Container configuration + dns, + hostname, + name, + publish, + expose, + user, + volume, + volumes_from, + workdir, + memory, + cpuShares, + link, + ContainerAlias, + -- * Internal use + chain, +) where + +import Propellor +import Propellor.SimpleSh +import Propellor.Types.Info +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Docker.Shim as Shim +import Utility.SafeCommand +import Utility.Path + +import Control.Concurrent.Async hiding (link) +import System.Posix.Directory +import System.Posix.Process +import Data.List +import Data.List.Utils +import qualified Data.Set as S + +installed :: Property +installed = Apt.installed ["docker.io"] + +-- | Configures docker with an authentication file, so that images can be +-- pushed to index.docker.io. Optional. +configured :: Property +configured = prop `requires` installed + where + prop = withPrivData DockerAuthentication anyContext $ \getcfg -> + property "docker configured" $ getcfg $ \cfg -> ensureProperty $ + "/root/.dockercfg" `File.hasContent` (lines cfg) + +-- | A short descriptive name for a container. +-- Should not contain whitespace or other unusual characters, +-- only [a-zA-Z0-9_-] are allowed +type ContainerName = String + +-- | Starts accumulating the properties of a Docker container. +-- +-- > container "web-server" "debian" +-- > & publish "80:80" +-- > & Apt.installed {"apache2"] +-- > & ... +container :: ContainerName -> Image -> Host +container cn image = Host hn [] info + where + info = dockerInfo $ mempty { _dockerImage = Val image } + hn = cn2hn cn + +cn2hn :: ContainerName -> HostName +cn2hn cn = cn ++ ".docker" + +-- | Ensures that a docker container is set up and running, finding +-- its configuration in the passed list of hosts. +-- +-- The container has its own Properties which are handled by running +-- propellor inside the container. +-- +-- When the container's Properties include DNS info, such as a CNAME, +-- that is propigated to the Info of the host(s) it's docked in. +-- +-- Reverting this property ensures that the container is stopped and +-- removed. +docked + :: [Host] + -> ContainerName + -> RevertableProperty +docked hosts cn = RevertableProperty + ((maybe id propigateInfo mhost) (go "docked" setup)) + (go "undocked" teardown) + where + go desc a = property (desc ++ " " ++ cn) $ do + hn <- asks hostName + let cid = ContainerId hn cn + ensureProperties [findContainer mhost cid cn $ a cid] + + mhost = findHost hosts (cn2hn cn) + + setup cid (Container image runparams) = + provisionContainer cid + `requires` + runningContainer cid image runparams + `requires` + installed + + teardown cid (Container image _runparams) = + combineProperties ("undocked " ++ fromContainerId cid) + [ stoppedContainer cid + , property ("cleaned up " ++ fromContainerId cid) $ + liftIO $ report <$> mapM id + [ removeContainer cid + , removeImage image + ] + ] + +propigateInfo :: Host -> Property -> Property +propigateInfo (Host _ _ containerinfo) p = + combineProperties (propertyDesc p) $ p : dnsprops ++ privprops + where + dnsprops = map addDNS (S.toList $ _dns containerinfo) + privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo) + +findContainer + :: Maybe Host + -> ContainerId + -> ContainerName + -> (Container -> Property) + -> Property +findContainer mhost cid cn mk = case mhost of + Nothing -> cantfind + Just h -> maybe cantfind mk (mkContainer cid h) + where + cantfind = containerDesc cid $ property "" $ do + liftIO $ warningMessage $ + "missing definition for docker container \"" ++ cn2hn cn + return FailedChange + +mkContainer :: ContainerId -> Host -> Maybe Container +mkContainer cid@(ContainerId hn _cn) h = Container + <$> fromVal (_dockerImage info) + <*> pure (map (\a -> a hn) (_dockerRunParams info)) + where + info = _dockerinfo $ hostInfo h' + h' = h + -- expose propellor directory inside the container + & volume (localdir++":"++localdir) + -- name the container in a predictable way so we + -- and the user can easily find it later + & name (fromContainerId cid) + +-- | Causes *any* docker images that are not in use by running containers to +-- be deleted. And deletes any containers that propellor has set up +-- before that are not currently running. Does not delete any containers +-- that were not set up using propellor. +-- +-- Generally, should come after the properties for the desired containers. +garbageCollected :: Property +garbageCollected = propertyList "docker garbage collected" + [ gccontainers + , gcimages + ] + where + gccontainers = property "docker containers garbage collected" $ + liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) + gcimages = property "docker images garbage collected" $ do + liftIO $ report <$> (mapM removeImage =<< listImages) + +-- | Configures the kernel to respect docker memory limits. +-- +-- This assumes the system boots using grub 2. And that you don't need any +-- other GRUB_CMDLINE_LINUX_DEFAULT settings. +-- +-- Only takes effect after reboot. (Not automated.) +memoryLimited :: Property +memoryLimited = "/etc/default/grub" `File.containsLine` cfg + `describe` "docker memory limited" + `onChange` cmdProperty "update-grub" [] + where + cmdline = "cgroup_enable=memory swapaccount=1" + cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\"" + +data Container = Container Image [RunParam] + +-- | Parameters to pass to `docker run` when creating a container. +type RunParam = String + +-- | A docker image, that can be used to run a container. +type Image = String + +-- | Set custom dns server for container. +dns :: String -> Property +dns = runProp "dns" + +-- | Set container host name. +hostname :: String -> Property +hostname = runProp "hostname" + +-- | Set name for container. (Normally done automatically.) +name :: String -> Property +name = runProp "name" + +-- | Publish a container's port to the host +-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) +publish :: String -> Property +publish = runProp "publish" + +-- | Expose a container's port without publishing it. +expose :: String -> Property +expose = runProp "expose" + +-- | Username or UID for container. +user :: String -> Property +user = runProp "user" + +-- | Mount a volume +-- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] +-- With just a directory, creates a volume in the container. +volume :: String -> Property +volume = runProp "volume" + +-- | Mount a volume from the specified container into the current +-- container. +volumes_from :: ContainerName -> Property +volumes_from cn = genProp "volumes-from" $ \hn -> + fromContainerId (ContainerId hn cn) + +-- | Work dir inside the container. +workdir :: String -> Property +workdir = runProp "workdir" + +-- | Memory limit for container. +-- Format: , where unit = b, k, m or g +-- +-- Note: Only takes effect when the host has the memoryLimited property +-- enabled. +memory :: String -> Property +memory = runProp "memory" + +-- | CPU shares (relative weight). +-- +-- By default, all containers run at the same priority, but you can tell +-- the kernel to give more CPU time to a container using this property. +cpuShares :: Int -> Property +cpuShares = runProp "cpu-shares" . show + +-- | Link with another container on the same host. +link :: ContainerName -> ContainerAlias -> Property +link linkwith calias = genProp "link" $ \hn -> + fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias + +-- | A short alias for a linked container. +-- Each container has its own alias namespace. +type ContainerAlias = String + +-- | A container is identified by its name, and the host +-- on which it's deployed. +data ContainerId = ContainerId HostName ContainerName + deriving (Eq, Read, Show) + +-- | Two containers with the same ContainerIdent were started from +-- the same base image (possibly a different version though), and +-- with the same RunParams. +data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] + deriving (Read, Show, Eq) + +toContainerId :: String -> Maybe ContainerId +toContainerId s + | myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of + (cn, hn) + | null hn || null cn -> Nothing + | otherwise -> Just $ ContainerId hn cn + | otherwise = Nothing + where + desuffix = reverse . drop len . reverse + len = length myContainerSuffix + +fromContainerId :: ContainerId -> String +fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix + +containerHostName :: ContainerId -> HostName +containerHostName (ContainerId _ cn) = cn2hn cn + +myContainerSuffix :: String +myContainerSuffix = ".propellor" + +containerDesc :: ContainerId -> Property -> Property +containerDesc cid p = p `describe` desc + where + desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p + +runningContainer :: ContainerId -> Image -> [RunParam] -> Property +runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do + l <- liftIO $ listContainers RunningContainers + if cid `elem` l + then do + -- Check if the ident has changed; if so the + -- parameters of the container differ and it must + -- be restarted. + runningident <- liftIO $ getrunningident + if runningident == Just ident + then noChange + else do + void $ liftIO $ stopContainer cid + restartcontainer + else ifM (liftIO $ elem cid <$> listContainers AllContainers) + ( restartcontainer + , go image + ) + where + ident = ContainerIdent image hn cn runps + + restartcontainer = do + oldimage <- liftIO $ fromMaybe image <$> commitContainer cid + void $ liftIO $ removeContainer cid + go oldimage + + getrunningident :: IO (Maybe ContainerIdent) + getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do + let !v = extractident rs + return v + + extractident :: [Resp] -> Maybe ContainerIdent + extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout + + go img = do + liftIO $ do + clearProvisionedFlag cid + createDirectoryIfMissing True (takeDirectory $ identFile cid) + shim <- liftIO $ Shim.setup (localdir "propellor") (localdir shimdir cid) + liftIO $ writeFile (identFile cid) (show ident) + ensureProperty $ boolProperty "run" $ runContainer img + (runps ++ ["-i", "-d", "-t"]) + [shim, "--docker", fromContainerId cid] + +-- | Called when propellor is running inside a docker container. +-- The string should be the container's ContainerId. +-- +-- This process is effectively init inside the container. +-- It even needs to wait on zombie processes! +-- +-- Fork a thread to run the SimpleSh server in the background. +-- In the foreground, run an interactive bash (or sh) shell, +-- so that the user can interact with it when attached to the container. +-- +-- When the system reboots, docker restarts the container, and this is run +-- again. So, to make the necessary services get started on boot, this needs +-- to provision the container then. However, if the container is already +-- being provisioned by the calling propellor, it would be redundant and +-- problimatic to also provisoon it here. +-- +-- The solution is a flag file. If the flag file exists, then the container +-- was already provisioned. So, it must be a reboot, and time to provision +-- again. If the flag file doesn't exist, don't provision here. +chain :: String -> IO () +chain s = case toContainerId s of + Nothing -> error $ "Invalid ContainerId: " ++ s + Just cid -> do + changeWorkingDirectory localdir + writeFile propellorIdent . show =<< readIdentFile cid + -- Run boot provisioning before starting simpleSh, + -- to avoid ever provisioning twice at the same time. + whenM (checkProvisionedFlag cid) $ do + let shim = Shim.file (localdir "propellor") (localdir shimdir cid) + unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $ + warningMessage "Boot provision failed!" + void $ async $ job reapzombies + void $ async $ job $ simpleSh $ namedPipe cid + job $ do + void $ tryIO $ ifM (inPath "bash") + ( boolSystem "bash" [Param "-l"] + , boolSystem "/bin/sh" [] + ) + putStrLn "Container is still running. Press ^P^Q to detach." + where + job = forever . void . tryIO + reapzombies = void $ getAnyProcessStatus True False + +-- | Once a container is running, propellor can be run inside +-- it to provision it. +-- +-- Note that there is a race here, between the simplesh +-- server starting up in the container, and this property +-- being run. So, retry connections to the client for up to +-- 1 minute. +provisionContainer :: ContainerId -> Property +provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do + let shim = Shim.file (localdir "propellor") (localdir shimdir cid) + r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing) + when (r /= FailedChange) $ + setProvisionedFlag cid + return r + where + params = ["--continue", show $ Chain $ containerHostName cid] + + go lastline (v:rest) = case v of + StdoutLine s -> do + maybe noop putStrLn lastline + hFlush stdout + go (Just s) rest + StderrLine s -> do + maybe noop putStrLn lastline + hFlush stdout + hPutStrLn stderr s + hFlush stderr + go Nothing rest + Done -> ret lastline + go lastline [] = ret lastline + + ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline + +stopContainer :: ContainerId -> IO Bool +stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] + +stoppedContainer :: ContainerId -> Property +stoppedContainer cid = containerDesc cid $ property desc $ + ifM (liftIO $ elem cid <$> listContainers RunningContainers) + ( liftIO cleanup `after` ensureProperty + (boolProperty desc $ stopContainer cid) + , return NoChange + ) + where + desc = "stopped" + cleanup = do + nukeFile $ namedPipe cid + nukeFile $ identFile cid + removeDirectoryRecursive $ shimdir cid + clearProvisionedFlag cid + +removeContainer :: ContainerId -> IO Bool +removeContainer cid = catchBoolIO $ + snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing + +removeImage :: Image -> IO Bool +removeImage image = catchBoolIO $ + snd <$> processTranscript dockercmd ["rmi", image ] Nothing + +runContainer :: Image -> [RunParam] -> [String] -> IO Bool +runContainer image ps cmd = boolSystem dockercmd $ map Param $ + "run" : (ps ++ image : cmd) + +commitContainer :: ContainerId -> IO (Maybe Image) +commitContainer cid = catchMaybeIO $ + takeWhile (/= '\n') + <$> readProcess dockercmd ["commit", fromContainerId cid] + +data ContainerFilter = RunningContainers | AllContainers + deriving (Eq) + +-- | Only lists propellor managed containers. +listContainers :: ContainerFilter -> IO [ContainerId] +listContainers status = + catMaybes . map toContainerId . concat . map (split ",") + . catMaybes . map (lastMaybe . words) . lines + <$> readProcess dockercmd ps + where + ps + | status == AllContainers = baseps ++ ["--all"] + | otherwise = baseps + baseps = ["ps", "--no-trunc"] + +listImages :: IO [Image] +listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] + +runProp :: String -> RunParam -> Property +runProp field val = pureInfoProperty (param) $ dockerInfo $ + mempty { _dockerRunParams = [\_ -> "--"++param] } + where + param = field++"="++val + +genProp :: String -> (HostName -> RunParam) -> Property +genProp field mkval = pureInfoProperty field $ dockerInfo $ + mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] } + +dockerInfo :: DockerInfo -> Info +dockerInfo i = mempty { _dockerinfo = i } + +-- | The ContainerIdent of a container is written to +-- /.propellor-ident inside it. This can be checked to see if +-- the container has the same ident later. +propellorIdent :: FilePath +propellorIdent = "/.propellor-ident" + +-- | Named pipe used for communication with the container. +namedPipe :: ContainerId -> FilePath +namedPipe cid = "docker" fromContainerId cid + +provisionedFlag :: ContainerId -> FilePath +provisionedFlag cid = "docker" fromContainerId cid ++ ".provisioned" + +clearProvisionedFlag :: ContainerId -> IO () +clearProvisionedFlag = nukeFile . provisionedFlag + +setProvisionedFlag :: ContainerId -> IO () +setProvisionedFlag cid = do + createDirectoryIfMissing True (takeDirectory (provisionedFlag cid)) + writeFile (provisionedFlag cid) "1" + +checkProvisionedFlag :: ContainerId -> IO Bool +checkProvisionedFlag = doesFileExist . provisionedFlag + +shimdir :: ContainerId -> FilePath +shimdir cid = "docker" fromContainerId cid ++ ".shim" + +identFile :: ContainerId -> FilePath +identFile cid = "docker" fromContainerId cid ++ ".ident" + +readIdentFile :: ContainerId -> IO ContainerIdent +readIdentFile cid = fromMaybe (error "bad ident in identFile") + . readish <$> readFile (identFile cid) + +dockercmd :: String +dockercmd = "docker.io" + +report :: [Bool] -> Result +report rmed + | or rmed = MadeChange + | otherwise = NoChange + diff --git a/src/Propellor/Property/Docker/Shim.hs b/src/Propellor/Property/Docker/Shim.hs new file mode 100644 index 00000000..c2f35d0c --- /dev/null +++ b/src/Propellor/Property/Docker/Shim.hs @@ -0,0 +1,61 @@ +-- | Support for running propellor, as built outside a docker container, +-- inside the container. +-- +-- Note: This is currently Debian specific, due to glibcLibs. + +module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where + +import Propellor +import Utility.LinuxMkLibs +import Utility.SafeCommand +import Utility.Path +import Utility.FileMode + +import Data.List +import System.Posix.Files + +-- | Sets up a shimmed version of the program, in a directory, and +-- returns its path. +setup :: FilePath -> FilePath -> IO FilePath +setup propellorbin dest = do + createDirectoryIfMissing True dest + + libs <- parseLdd <$> readProcess "ldd" [propellorbin] + glibclibs <- glibcLibs + let libs' = nub $ libs ++ glibclibs + libdirs <- map (dest ++) . nub . catMaybes + <$> mapM (installLib installFile dest) libs' + + let linker = (dest ++) $ + fromMaybe (error "cannot find ld-linux linker") $ + headMaybe $ filter ("ld-linux" `isInfixOf`) libs' + let gconvdir = (dest ++) $ parentDir $ + fromMaybe (error "cannot find gconv directory") $ + headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs + let linkerparams = ["--library-path", intercalate ":" libdirs ] + let shim = file propellorbin dest + writeFile shim $ unlines + [ "#!/bin/sh" + , "GCONV_PATH=" ++ shellEscape gconvdir + , "export GCONV_PATH" + , "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ + " " ++ shellEscape propellorbin ++ " \"$@\"" + ] + modifyFileMode shim (addModes executeModes) + return shim + +cleanEnv :: IO () +cleanEnv = void $ unsetEnv "GCONV_PATH" + +file :: FilePath -> FilePath -> FilePath +file propellorbin dest = dest takeFileName propellorbin + +installFile :: FilePath -> FilePath -> IO () +installFile top f = do + createDirectoryIfMissing True destdir + nukeFile dest + createLink f dest `catchIO` (const copy) + where + copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest] + destdir = inTop top $ parentDir f + dest = inTop top f diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs new file mode 100644 index 00000000..0e738f25 --- /dev/null +++ b/src/Propellor/Property/File.hs @@ -0,0 +1,95 @@ +module Propellor.Property.File where + +import Propellor +import Utility.FileMode + +import System.Posix.Files +import System.PosixCompat.Types + +type Line = String + +-- | Replaces all the content of a file. +hasContent :: FilePath -> [Line] -> Property +f `hasContent` newcontent = fileProperty ("replace " ++ f) + (\_oldcontent -> newcontent) f + +-- | Ensures a file has contents that comes from PrivData. +-- +-- The file's permissions are preserved if the file already existed. +-- Otherwise, they're set to 600. +hasPrivContent :: FilePath -> Context -> Property +hasPrivContent f context = withPrivData (PrivFile f) context $ \getcontent -> + property desc $ getcontent $ \privcontent -> + ensureProperty $ fileProperty' writeFileProtected desc + (\_oldcontent -> lines privcontent) f + where + desc = "privcontent " ++ f + +-- | Leaves the file world-readable. +hasPrivContentExposed :: FilePath -> Context -> Property +hasPrivContentExposed f context = hasPrivContent f context `onChange` + mode f (combineModes (ownerWriteMode:readModes)) + +-- | Ensures that a line is present in a file, adding it to the end if not. +containsLine :: FilePath -> Line -> Property +f `containsLine` l = f `containsLines` [l] + +containsLines :: FilePath -> [Line] -> Property +f `containsLines` l = fileProperty (f ++ " contains:" ++ show l) go f + where + go ls + | all (`elem` ls) l = ls + | otherwise = ls++l + +-- | Ensures that a line is not present in a file. +-- Note that the file is ensured to exist, so if it doesn't, an empty +-- file will be written. +lacksLine :: FilePath -> Line -> Property +f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f + +-- | Removes a file. Does not remove symlinks or non-plain-files. +notPresent :: FilePath -> Property +notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ + makeChange $ nukeFile f + +fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty = fileProperty' writeFile +fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) + where + go True = do + ls <- liftIO $ lines <$> readFile f + let ls' = a ls + if ls' == ls + then noChange + else makeChange $ viaTmp updatefile f (unlines ls') + go False = makeChange $ writer f (unlines $ a []) + + -- viaTmp makes the temp file mode 600. + -- Replicate the original file's owner and mode. + updatefile f' content = do + writer f' content + s <- getFileStatus f + setFileMode f' (fileMode s) + setOwnerAndGroup f' (fileOwner s) (fileGroup s) + +-- | Ensures a directory exists. +dirExists :: FilePath -> Property +dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ + makeChange $ createDirectoryIfMissing True d + +-- | Ensures that a file/dir has the specified owner and group. +ownerGroup :: FilePath -> UserName -> GroupName -> Property +ownerGroup f owner group = property (f ++ " owner " ++ og) $ do + r <- ensureProperty $ cmdProperty "chown" [og, f] + if r == FailedChange + then return r + else noChange + where + og = owner ++ ":" ++ group + +-- | Ensures that a file/dir has the specfied mode. +mode :: FilePath -> FileMode -> Property +mode f v = property (f ++ " mode " ++ show v) $ do + liftIO $ modifyFileMode f (\_old -> v) + noChange diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs new file mode 100644 index 00000000..e5df7e48 --- /dev/null +++ b/src/Propellor/Property/Git.hs @@ -0,0 +1,93 @@ +module Propellor.Property.Git where + +import Propellor +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import Utility.SafeCommand + +import Data.List + +-- | Exports all git repos in a directory (that user nobody can read) +-- using git-daemon, run from inetd. +-- +-- Note that reverting this property does not remove or stop inetd. +daemonRunning :: FilePath -> RevertableProperty +daemonRunning exportdir = RevertableProperty setup unsetup + where + setup = containsLine conf (mkl "tcp4") + `requires` + containsLine conf (mkl "tcp6") + `requires` + dirExists exportdir + `requires` + Apt.serviceInstalledRunning "openbsd-inetd" + `onChange` + Service.running "openbsd-inetd" + `describe` ("git-daemon exporting " ++ exportdir) + unsetup = lacksLine conf (mkl "tcp4") + `requires` + lacksLine conf (mkl "tcp6") + `onChange` + Service.reloaded "openbsd-inetd" + + conf = "/etc/inetd.conf" + + mkl tcpv = intercalate "\t" + [ "git" + , "stream" + , tcpv + , "nowait" + , "nobody" + , "/usr/bin/git" + , "git" + , "daemon" + , "--inetd" + , "--export-all" + , "--base-path=" ++ exportdir + , exportdir + ] + +installed :: Property +installed = Apt.installed ["git"] + +type RepoUrl = String + +type Branch = String + +-- | Specified git repository is cloned to the specified directory. +-- +-- If the firectory exists with some other content, it will be recursively +-- deleted. +-- +-- A branch can be specified, to check out. +cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property +cloned owner url dir mbranch = check originurl (property desc checkout) + `requires` installed + where + desc = "git cloned " ++ url ++ " to " ++ dir + gitconfig = dir ".git/config" + originurl = ifM (doesFileExist gitconfig) + ( do + v <- catchDefaultIO Nothing $ headMaybe . lines <$> + readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"] + return (v /= Just url) + , return True + ) + checkout = do + liftIO $ do + whenM (doesDirectoryExist dir) $ + removeDirectoryRecursive dir + createDirectoryIfMissing True (takeDirectory dir) + ensureProperty $ userScriptProperty owner $ catMaybes + -- The mbranch + -- In case this repo is exposted via the web, + -- although the hook to do this ongoing is not + -- installed here. + , Just "git update-server-info" + ] diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs new file mode 100644 index 00000000..b4698663 --- /dev/null +++ b/src/Propellor/Property/Gpg.hs @@ -0,0 +1,44 @@ +module Propellor.Property.Gpg where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import Utility.FileSystemEncoding + +import System.PosixCompat + +installed :: Property +installed = Apt.installed ["gnupg"] + +type GpgKeyId = String + +-- | Sets up a user with a gpg key from the privdata. +-- +-- Note that if a secret key is exported using gpg -a --export-secret-key, +-- the public key is also included. Or just a public key could be +-- exported, and this would set it up just as well. +-- +-- Recommend only using this for low-value dedicated role keys. +-- No attempt has been made to scrub the key out of memory once it's used. +-- +-- The GpgKeyId does not have to be a numeric id; it can just as easily +-- be a description of the key. +keyImported :: GpgKeyId -> UserName -> Property +keyImported keyid user = flagFile' prop genflag + `requires` installed + where + desc = user ++ " has gpg key " ++ show keyid + genflag = do + d <- dotDir user + return $ d ".propellor-imported-keyid-" ++ keyid + prop = withPrivData GpgKey (Context keyid) $ \getkey -> + property desc $ getkey $ \key -> makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "su" ["-c", "gpg --import", user]) $ \h -> do + fileEncoding h + hPutStr h key + hClose h + +dotDir :: UserName -> IO FilePath +dotDir user = do + home <- homeDirectory <$> getUserEntryForName user + return $ home ".gnupg" diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs new file mode 100644 index 00000000..841861f4 --- /dev/null +++ b/src/Propellor/Property/Grub.hs @@ -0,0 +1,39 @@ +module Propellor.Property.Grub where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +-- | Eg, hd0,0 or xen/xvda1 +type GrubDevice = String + +type TimeoutSecs = Int + +-- | Use PV-grub chaining to boot +-- +-- Useful when the VPS's pv-grub is too old to boot a modern kernel image. +-- +-- http://notes.pault.ag/linode-pv-grub-chainning/ +-- +-- The rootdev should be in the form "hd0", while the bootdev is in the form +-- "xen/xvda". +chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property +chainPVGrub rootdev bootdev timeout = combineProperties desc + [ File.dirExists "/boot/grub" + , "/boot/grub/menu.lst" `File.hasContent` + [ "default 1" + , "timeout " ++ show timeout + , "" + , "title grub-xen shim" + , "root (" ++ rootdev ++ ")" + , "kernel /boot/xen-shim" + , "boot" + ] + , "/boot/load.cf" `File.hasContent` + [ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ] + , Apt.installed ["grub-xen"] + , flagFile (scriptProperty ["update-grub; grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]) "/boot/xen-shim" + `describe` "/boot-xen-shim" + ] + where + desc = "chain PV-grub" diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs new file mode 100644 index 00000000..003bd3c5 --- /dev/null +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -0,0 +1,24 @@ +module Propellor.Property.HostingProvider.CloudAtCost where + +import Propellor +import qualified Propellor.Property.Hostname as Hostname +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.User as User + +-- Clean up a system as installed by cloudatcost.com +decruft :: Property +decruft = propertyList "cloudatcost cleanup" + [ Hostname.sane + , Ssh.randomHostKeys + , "worked around grub/lvm boot bug #743126" ==> + "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" + `onChange` cmdProperty "update-grub" [] + `onChange` cmdProperty "update-initramfs" ["-u"] + , combineProperties "nuked cloudatcost cruft" + [ File.notPresent "/etc/rc.local" + , File.notPresent "/etc/init.d/S97-setup.sh" + , User.nuked "user" User.YesReallyDeleteHome + ] + ] + diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs new file mode 100644 index 00000000..4565935f --- /dev/null +++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -0,0 +1,21 @@ +module Propellor.Property.HostingProvider.DigitalOcean where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File + +-- Digital Ocean does not provide any way to boot +-- the kernel provided by the distribution, except using kexec. +-- Without this, some old, and perhaps insecure kernel will be used. +-- +-- Note that this only causes the new kernel to be loaded on reboot. +-- If the power is cycled, the old kernel still boots up. +-- TODO: detect this and reboot immediately? +distroKernel :: Property +distroKernel = propertyList "digital ocean distro kernel hack" + [ Apt.installed ["grub-pc", "kexec-tools"] + , "/etc/default/kexec" `File.containsLines` + [ "LOAD_KEXEC=true" + , "USE_GRUB_CONFIG=true" + ] `describe` "kexec configured" + ] diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs new file mode 100644 index 00000000..34d72184 --- /dev/null +++ b/src/Propellor/Property/HostingProvider/Linode.hs @@ -0,0 +1,10 @@ +module Propellor.Property.HostingProvider.Linode where + +import Propellor +import qualified Propellor.Property.Grub as Grub + +-- | Linode's pv-grub-x86_64 does not currently support booting recent +-- Debian kernels compressed with xz. This sets up pv-grub chaing to enable +-- it. +chainPVGrub :: Grub.TimeoutSecs -> Property +chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda" diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs new file mode 100644 index 00000000..1cce4e60 --- /dev/null +++ b/src/Propellor/Property/Hostname.hs @@ -0,0 +1,39 @@ +module Propellor.Property.Hostname where + +import Propellor +import qualified Propellor.Property.File as File + +-- | Ensures that the hostname is set using best practices. +-- +-- Configures /etc/hostname and the current hostname. +-- +-- /etc/hosts is also configured, with an entry for 127.0.1.1, which is +-- standard at least on Debian to set the FDQN. +-- +-- Also, the /etc/hosts 127.0.0.1 line is set to localhost. Putting any +-- other hostnames there is not best practices and can lead to annoying +-- messages from eg, apache. +sane :: Property +sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName) + +setTo :: HostName -> Property +setTo hn = combineProperties desc go + where + desc = "hostname " ++ hn + (basehost, domain) = separate (== '.') hn + + go = catMaybes + [ Just $ "/etc/hostname" `File.hasContent` [basehost] + , if null domain + then Nothing + else Just $ trivial $ hostsline "127.0.1.1" [hn, basehost] + , Just $ trivial $ hostsline "127.0.0.1" ["localhost"] + , Just $ trivial $ cmdProperty "hostname" [basehost] + ] + + hostsline ip names = File.fileProperty desc + (addhostsline ip names) + "/etc/hosts" + addhostsline ip names ls = + (ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls + hasip ip l = headMaybe (words l) == Just ip diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs new file mode 100644 index 00000000..6009778a --- /dev/null +++ b/src/Propellor/Property/Network.hs @@ -0,0 +1,30 @@ +module Propellor.Property.Network where + +import Propellor +import Propellor.Property.File + +interfaces :: FilePath +interfaces = "/etc/network/interfaces" + +-- | 6to4 ipv6 connection, should work anywhere +ipv6to4 :: Property +ipv6to4 = fileProperty "ipv6to4" go interfaces + `onChange` ifUp "sit0" + where + go ls + | all (`elem` ls) stanza = ls + | otherwise = ls ++ stanza + stanza = + [ "# Automatically added by propeller" + , "iface sit0 inet6 static" + , "\taddress 2002:5044:5531::1" + , "\tnetmask 64" + , "\tgateway ::192.88.99.1" + , "auto sit0" + , "# End automatically added by propeller" + ] + +type Interface = String + +ifUp :: Interface -> Property +ifUp iface = cmdProperty "ifup" [iface] diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs new file mode 100644 index 00000000..15a8494c --- /dev/null +++ b/src/Propellor/Property/Obnam.hs @@ -0,0 +1,159 @@ +module Propellor.Property.Obnam where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import Utility.SafeCommand + +import Data.List + +type ObnamParam = String + +-- | An obnam repository can be used by multiple clients. Obnam uses +-- locking to allow only one client to write at a time. Since stale lock +-- files can prevent backups from happening, it's more robust, if you know +-- a repository has only one client, to force the lock before starting a +-- backup. Using OnlyClient allows propellor to do so when running obnam. +data NumClients = OnlyClient | MultipleClients + deriving (Eq) + +-- | Installs a cron job that causes a given directory to be backed +-- up, by running obnam 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. +-- And since Obnam encrypts, just make this property depend on a gpg +-- key, and tell obnam to use the key, and your data will be backed +-- up securely. For example: +-- +-- > & Obnam.backup "/srv/git" "33 3 * * *" +-- > [ "--repository=sftp://2318@usw-s002.rsync.net/~/mygitrepos.obnam" +-- > , "--encrypt-with=1B169BE1" +-- > ] Obnam.OnlyClient +-- > `requires` Gpg.keyImported "1B169BE1" "root" +-- > `requires` Ssh.keyImported SshRsa "root" +-- +-- How awesome is that? +backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property +backup dir crontimes params numclients = backup' dir crontimes params numclients + `requires` restored dir params + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property +backup' dir crontimes params numclients = cronjob `describe` desc + where + desc = dir ++ " backed up by obnam" + cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $ + intercalate ";" $ catMaybes + [ if numclients == OnlyClient + then Just $ unwords $ + [ "obnam" + , "force-lock" + ] ++ map shellEscape params + else Nothing + , Just $ unwords $ + [ "obnam" + , "backup" + , shellEscape dir + ] ++ map shellEscape params + ] + +-- | Restores a directory from an obnam 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 -> [ObnamParam] -> Property +restored dir params = property (dir ++ " restored by obnam") go + `requires` installed + where + go = ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "obnam-restore" $ \tmpdir -> do + ok <- boolSystem "obnam" $ + [ Param "restore" + , Param "--to" + , Param tmpdir + ] ++ map Param params + let restoreddir = tmpdir ++ "/" ++ dir + ifM (pure ok <&&> doesDirectoryExist restoreddir) + ( do + void $ tryIO $ removeDirectory dir + renameDirectory restoreddir dir + return MadeChange + , return FailedChange + ) + +installed :: Property +installed = Apt.installed ["obnam"] + +-- | Ensures that a recent version of obnam gets installed. +-- +-- Only does anything for Debian Stable. +latestVersion :: Property +latestVersion = withOS "obnam latest version" $ \o -> case o of + (Just (System (Debian suite) _)) | isStable suite -> ensureProperty $ + Apt.setSourcesListD stablesources "obnam" + `requires` toProp (Apt.trustsKey key) + _ -> noChange + where + stablesources = + [ "deb http://code.liw.fi/debian " ++ Apt.showSuite stableRelease ++ " main" + ] + -- gpg key used by the code.liw.fi repository. + key = Apt.AptKey "obnam" $ unlines + [ "-----BEGIN PGP PUBLIC KEY BLOCK-----" + , "Version: GnuPG v1.4.9 (GNU/Linux)" + , "" + , "mQGiBEfzuTgRBACcVNG/H6QJqLx5qiQs2zmPe6D6BWOWHfgNgG4IWzNstm21YDxb" + , "KqwFG0gxcnZJGHkXAhkSfqTokYd0lc5eBemcA1pkceNjzMEX8wwiZ810HzJD4eEH" + , "sjoWR8+qKrZeixzZqReAfqztcXoBGKQ0u1R1vpg1txUa75OM4BUqaUbsmwCgmS4x" + , "DjMxSaUSPuu6vQ7ZGZBXSP0D/RQw8DBHMfsv3DiaqFqk8tkuUkpMFPIekHidSHlO" + , "EACbncqbbyHksyCpFNVNcQIDHrOLjOZK9BAXkSd8I3ww7U+nLdDcCblrW8CZnJtm" + , "ZYrxfaXaHZ/It9/RCAsQ+c8xtmyUPjsf//4Vf8olxNQHzgBSe5/LJRi4Vd53he+K" + , "YP4LA/9IZbjvVmm8+8Y0pQrTHlI6nTImtzdBXHc4+T3lLBj9XODHLozC2kSBOQky" + , "q/EisTITHTXL8vYg4NsKm5RTbPAuBwdtxcny8CXfOqKtGOdrebmKotGllTozzdPv" + , "9p53cuce6oJ2oMUodc074JOGTWwDSgLiJX4nViGcU1wy/vtQnrQkY29kZS5saXcu" + , "ZmkgYXJjaGl2ZSBrZXkgPGxpd0BsaXcuZmk+iGAEExECACAFAkfzuTgCGwMGCwkI" + , "BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRBG53tJR95LscKrAJ0ZtKqa2x6Kplwa2mzx" + , "ItImbIGMJACdETqofDYzUN91yLAFlOnxAyrE+UyIRgQQEQIABgUCSFd5GgAKCRAf" + , "u5W/LZrMjqr8AJ4xPVHpW8ZNlgMwDSVb075RnA2DiACgg2SR69jAHFQOWV6xfLRr" + , "vh0bLKGJAhwEEAEIAAYFAktEyIwACgkQ61zh116FEfm7Lg//Wiy3TjWAk8YHUddv" + , "zOioYzCxQ985GsVhJGAVPqSGOc9vfTWBJZ8J3l0NnYTRpEGucmbF9G+mAt9iGXu6" + , "7yZkxyFdvbo7EDsqMU1wLOM6PiU+Un63MKlbTNmFn7OKE8aXPRAFgcyUO/qjdqoD" + , "sa9FgU5Z0f60m9qah6BPXH6IzMLHYoiP7t8rCBIwLgyl3w2w+Fjt1DFpbW9Kb7jz" + , "i8jFvC8jPmxV8xh2OSgVZyNk4qg6hIV8GVQY7AJt8OurZSckgQd7ifHK9JTGohtF" + , "tXCiqeDEvnMF4A9HI/TcXJBzonZ8ds1JCq42nSSKmL+8TyjtUSD/xHygazuc0CK0" + , "hFnQWBub60IfyV6F0oTagJ8cmARv2sezHAeHDkzPHE8RdjgktazH1eJrA4LheEd6" + , "KeSnVtYWpw8dgMv5PleFyQiAj/t3C/N50fd15tUyfnH15G7nFjMQV2Yx35uwSxOj" + , "376OWnDN/YGTNk283XXULbyVJYR8Q2unso20XQ94yQ2A5EpHHPrHoLxrL/ydM08d" + , "nvKstLZIZtal1seiMkymtlSiGz25A5oqsclwS6VZCKdWA8HO/wlElOMcaHyl6Y1y" + , "gYP7y9O5yFYKFOrCH0nFjJbwmkRiBLsxuuWsYgJigVGq/atSrtawkHdshpCw0HCY" + , "N/RFcWkJ864BdsO0C0sDzueNkQO5Ag0ER/O5RBAIAJiwPH9tyJTgXcC2Y4XWboOq" + , "rx5CkOnr5b45oS9cK2eIJ8TKxE3XgKLxUr3mIH0QR2kZgDOwNl0WY+7/CXjn+Spn" + , "BokPg54rafEUePodGpGdUXdgrHhAMHYjh8fXFJ1SlQcg46/zc1wDI7jBCkGrK3V8" + , "5cXDqwTFTN5LcjoSRWeM4Voa6pEfDdL3rMlnOw9R9gDHRBBb6CDSjWXqM86pR889" + , "5QrR0SDwiJNrMoyxSjMXFKGBQAsYHJ82myZrlbuZbroZjVp5Uh7eB1ZiPljNVtcr" + , "sksACIWBCo1rvLzrPXsLYOeV3cDDtYAkSwGfuzC1Etbe+qgfIroFTOqdefMw4s8A" + , "AwUH/0KLXm4MS54QQspg3evu4Q4U/E8Hem5/FqB0GhBCitQ4rUsucKyY8/ItpUn5" + , "ismLE60bQqka+Mzd/Zw18TCTzImv0ozAaZ2sNtBado7f6jcC8EDfY5zzK1ukcsAr" + , "Qc5hdLHYuTQW5KpA6fKaW969OUzIwPbdVaCOLOBpxKC6N6iBspQYd6uiQtLw6EUO" + , "50oQqUiJABf0eOocvdw5e2KQQpuC3205+VMYtyl4w3pdJihK8NK0AikGXzDVsbQt" + , "l8kmB5ZrN4WIKhMke1FxbqQC5Q3XATvYRzpzzisZb/HYGNti8W6du5EUwJ0D2NRh" + , "cu+twocOzW0VKfmrDApfifJ9OsSISQQYEQIACQUCR/O5RAIbDAAKCRBG53tJR95L" + , "seQOAJ95KUyzjRjdYgZkDC69Mgu25L86UACdGduINUaRly43ag4kwUXxpqswBBM=" + , "=i2c3" + , "-----END PGP PUBLIC KEY BLOCK-----" + ] diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs new file mode 100644 index 00000000..39cb6ff0 --- /dev/null +++ b/src/Propellor/Property/OpenId.hs @@ -0,0 +1,30 @@ +module Propellor.Property.OpenId where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +import Data.List + +providerFor :: [UserName] -> String -> Property +providerFor users baseurl = propertyList desc $ + [ Apt.serviceInstalledRunning "apache2" + , Apt.installed ["simpleid"] + `onChange` Service.restarted "apache2" + , File.fileProperty (desc ++ " configured") + (map setbaseurl) "/etc/simpleid/config.inc" + ] ++ map identfile users + where + url = "http://"++baseurl++"/simpleid" + desc = "openid provider " ++ url + setbaseurl l + | "SIMPLEID_BASE_URL" `isInfixOf` l = + "define('SIMPLEID_BASE_URL', '"++url++"');" + | otherwise = l + + -- the identitites directory controls access, so open up + -- file mode + identfile u = File.hasPrivContentExposed + (concat [ "/var/lib/simpleid/identities/", u, ".identity" ]) + (Context baseurl) diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs new file mode 100644 index 00000000..ef96e086 --- /dev/null +++ b/src/Propellor/Property/Postfix.hs @@ -0,0 +1,25 @@ +module Propellor.Property.Postfix where + +import Propellor +import qualified Propellor.Property.Apt as Apt + +installed :: Property +installed = Apt.serviceInstalledRunning "postfix" + +-- | Configures postfix as a satellite system, which +-- relats all mail through a relay host, which defaults to smtp.domain. +-- +-- The smarthost may refuse to relay mail on to other domains, without +-- futher coniguration/keys. But this should be enough to get cron job +-- mail flowing to a place where it will be seen. +satellite :: Property +satellite = setup `requires` installed + where + setup = trivial $ property "postfix satellite system" $ do + hn <- asks hostName + ensureProperty $ Apt.reConfigure "postfix" + [ ("postfix/main_mailer_type", "select", "Satellite system") + , ("postfix/root_address", "string", "root") + , ("postfix/destinations", "string", " ") + , ("postfix/mailname", "string", hn) + ] diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs new file mode 100644 index 00000000..25e53159 --- /dev/null +++ b/src/Propellor/Property/Reboot.hs @@ -0,0 +1,7 @@ +module Propellor.Property.Reboot where + +import Propellor + +now :: Property +now = cmdProperty "reboot" [] + `describe` "reboot now" diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs new file mode 100644 index 00000000..f2911e50 --- /dev/null +++ b/src/Propellor/Property/Scheduled.hs @@ -0,0 +1,67 @@ +module Propellor.Property.Scheduled + ( period + , periodParse + , Recurrance(..) + , WeekDay + , MonthDay + , YearDay + ) where + +import Propellor +import Utility.Scheduled + +import Data.Time.Clock +import Data.Time.LocalTime +import qualified Data.Map as M + +-- | Makes a Property only be checked every so often. +-- +-- This uses the description of the Property to keep track of when it was +-- last run. +period :: Property -> Recurrance -> Property +period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do + lasttime <- liftIO $ getLastChecked (propertyDesc prop) + nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime + t <- liftIO localNow + if Just t >= nexttime + then do + r <- satisfy + liftIO $ setLastChecked t (propertyDesc prop) + return r + else noChange + where + schedule = Schedule recurrance AnyTime + desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" + +-- | Like period, but parse a human-friendly string. +periodParse :: Property -> String -> Property +periodParse prop s = case toRecurrance s of + Just recurrance -> period prop recurrance + Nothing -> property "periodParse" $ do + liftIO $ warningMessage $ "failed periodParse: " ++ s + noChange + +lastCheckedFile :: FilePath +lastCheckedFile = localdir ".lastchecked" + +getLastChecked :: Desc -> IO (Maybe LocalTime) +getLastChecked desc = M.lookup desc <$> readLastChecked + +localNow :: IO LocalTime +localNow = do + now <- getCurrentTime + tz <- getTimeZone now + return $ utcToLocalTime tz now + +setLastChecked :: LocalTime -> Desc -> IO () +setLastChecked time desc = do + m <- readLastChecked + writeLastChecked (M.insert desc time m) + +readLastChecked :: IO (M.Map Desc LocalTime) +readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go + where + go = readish <$> readFileStrict lastCheckedFile + +writeLastChecked :: M.Map Desc LocalTime -> IO () +writeLastChecked = writeFile lastCheckedFile . show diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs new file mode 100644 index 00000000..14e769d0 --- /dev/null +++ b/src/Propellor/Property/Service.hs @@ -0,0 +1,31 @@ +module Propellor.Property.Service where + +import Propellor +import Utility.SafeCommand + +type ServiceName = String + +-- | Ensures that a service is running. Does not ensure that +-- any package providing that service is installed. See +-- Apt.serviceInstalledRunning +-- +-- Note that due to the general poor state of init scripts, the best +-- we can do is try to start the service, and if it fails, assume +-- this means it's already running. +running :: ServiceName -> Property +running svc = property ("running " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"] + return NoChange + +restarted :: ServiceName -> Property +restarted svc = property ("restarted " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"] + return NoChange + +reloaded :: ServiceName -> Property +reloaded svc = property ("reloaded " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"] + return NoChange diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs new file mode 100644 index 00000000..4cb26a50 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -0,0 +1,178 @@ +module Propellor.Property.SiteSpecific.GitAnnexBuilder where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Docker as Docker +import Propellor.Property.Cron (CronTimes) + +builduser :: UserName +builduser = "builder" + +homedir :: FilePath +homedir = "/home/builder" + +gitbuilderdir :: FilePath +gitbuilderdir = homedir "gitbuilder" + +builddir :: FilePath +builddir = gitbuilderdir "build" + +type TimeOut = String -- eg, 5h + +autobuilder :: Architecture -> CronTimes -> TimeOut -> Property +autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" + [ Apt.serviceInstalledRunning "cron" + , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $ + "git pull ; timeout " ++ timeout ++ " ./autobuild" + -- The builduser account does not have a password set, + -- instead use the password privdata to hold the rsync server + -- password used to upload the built image. + , withPrivData (Password builduser) context $ \getpw -> + property "rsync password" $ getpw $ \pw -> do + oldpw <- liftIO $ catchDefaultIO "" $ + readFileStrict pwfile + if pw /= oldpw + then makeChange $ writeFile pwfile pw + else noChange + ] + where + context = Context ("gitannexbuilder " ++ arch) + pwfile = homedir "rsyncpassword" + +tree :: Architecture -> Property +tree buildarch = combineProperties "gitannexbuilder tree" + [ Apt.installed ["git"] + -- gitbuilderdir directory already exists when docker volume is used, + -- but with wrong owner. + , File.dirExists gitbuilderdir + , File.ownerGroup gitbuilderdir builduser builduser + , check (not <$> (doesDirectoryExist (gitbuilderdir ".git"))) $ + userScriptProperty builduser + [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir + , "cd " ++ gitbuilderdir + , "git checkout " ++ buildarch + ] + `describe` "gitbuilder setup" + , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser + [ "git clone git://git-annex.branchable.com/ " ++ builddir + ] + ] + +buildDepsApt :: Property +buildDepsApt = combineProperties "gitannexbuilder build deps" + [ Apt.buildDep ["git-annex"] + , buildDepsNoHaskellLibs + , "git-annex source build deps installed" ==> Apt.buildDepIn builddir + ] + +buildDepsNoHaskellLibs :: Property +buildDepsNoHaskellLibs = Apt.installed + ["git", "rsync", "moreutils", "ca-certificates", + "debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt", + "liblockfile-simple-perl", "cabal-install", "vim", "less", + -- needed by haskell libs + "libxml2-dev", "libidn11-dev", "libgsasl7-dev", "libgnutls-dev", + "alex", "happy", "c2hs" + ] + +-- Installs current versions of git-annex's deps from cabal, but only +-- does so once. +cabalDeps :: Property +cabalDeps = flagFile go cabalupdated + where + go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"] + cabalupdated = homedir ".cabal" "packages" "hackage.haskell.org" "00-index.cache" + +standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host +standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder") + (dockerImage $ System (Debian Testing) arch) + & os (System (Debian Testing) arch) + & Apt.stdSourcesList + & Apt.installed ["systemd"] + & Apt.unattendedUpgrades + & User.accountFor builduser + & tree arch + & buildDepsApt + & autobuilder arch (show buildminute ++ " * * * *") timeout + +androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host +androidAutoBuilderContainer dockerImage crontimes timeout = + androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir + & Apt.unattendedUpgrades + & autobuilder "android" crontimes timeout + +-- Android is cross-built in a Debian i386 container, using the Android NDK. +androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host +androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name + (dockerImage $ System (Debian Stable) "i386") + & os (System (Debian Stable) "i386") + & Apt.stdSourcesList + & Apt.installed ["systemd"] + & User.accountFor builduser + & File.dirExists gitbuilderdir + & File.ownerGroup homedir builduser builduser + & buildDepsNoHaskellLibs + & flagFile chrootsetup ("/chrootsetup") + `requires` setupgitannexdir + -- TODO: automate installing haskell libs + -- (Currently have to run + -- git-annex/standalone/android/install-haskell-packages + -- which is not fully automated.) + where + -- Use git-annex's android chroot setup script, which will install + -- ghc-android and the NDK, all build deps, etc, in the home + -- directory of the builder user. + chrootsetup = scriptProperty + [ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot" + ] + +-- armel builder has a companion container using amd64 that +-- runs the build first to get TH splices. They need +-- to have the same versions of all haskell libraries installed. +armelCompanionContainer :: (System -> Docker.Image) -> Host +armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion" + (dockerImage $ System (Debian Unstable) "amd64") + & os (System (Debian Testing) "amd64") + & Apt.stdSourcesList + & Apt.installed ["systemd"] + & Apt.unattendedUpgrades + -- This volume is shared with the armel builder. + & Docker.volume gitbuilderdir + & User.accountFor builduser + -- Install current versions of build deps from cabal. + & tree "armel" + & buildDepsNoHaskellLibs + & cabalDeps + -- The armel builder can ssh to this companion. + & Docker.expose "22" + & Apt.serviceInstalledRunning "ssh" + & Ssh.authorizedKeys builduser (Context "armel-git-annex-builder") + +armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host +armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder" + (dockerImage $ System (Debian Unstable) "armel") + & os (System (Debian Testing) "armel") + & Apt.stdSourcesList + & Apt.unattendedUpgrades + & Apt.installed ["systemd"] + & Apt.installed ["openssh-client"] + & Docker.link "armel-git-annex-builder-companion" "companion" + & Docker.volumes_from "armel-git-annex-builder-companion" + & User.accountFor builduser + -- TODO: automate installing haskell libs + -- (Currently have to run + -- git-annex/standalone/linux/install-haskell-packages + -- which is not fully automated.) + & buildDepsNoHaskellLibs + & autobuilder "armel" crontimes timeout + `requires` tree "armel" + & Ssh.keyImported SshRsa builduser (Context "armel-git-annex-builder") + & trivial writecompanionaddress + where + writecompanionaddress = scriptProperty + [ "echo \"$COMPANION_PORT_22_TCP_ADDR\" > " ++ homedir "companion_address" + ] `describe` "companion_address file" diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs new file mode 100644 index 00000000..6ed02146 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -0,0 +1,34 @@ +module Propellor.Property.SiteSpecific.GitHome where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.User +import Utility.SafeCommand + +-- | Clones Joey Hess's git home directory, and runs its fixups script. +installedFor :: UserName -> Property +installedFor user = check (not <$> hasGitDir user) $ + property ("githome " ++ user) (go =<< liftIO (homedir user)) + `requires` Apt.installed ["git"] + where + go home = do + let tmpdir = home "githome" + ensureProperty $ combineProperties "githome setup" + [ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir] + , property "moveout" $ makeChange $ void $ + moveout tmpdir home + , property "rmdir" $ makeChange $ void $ + catchMaybeIO $ removeDirectory tmpdir + , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"] + ] + moveout tmpdir home = do + fs <- dirContents tmpdir + forM fs $ \f -> boolSystem "mv" [File f, File home] + +url :: String +url = "git://git.kitenet.net/joey/home" + +hasGitDir :: UserName -> IO Bool +hasGitDir user = go =<< homedir user + where + go home = doesDirectoryExist (home ".git") diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs new file mode 100644 index 00000000..c770907b --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -0,0 +1,362 @@ +-- | Specific configuation for Joey Hess's sites. Probably not useful to +-- others except as an example. + +module Propellor.Property.SiteSpecific.JoeySites where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Gpg as Gpg +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Git as Git +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Obnam as Obnam +import qualified Propellor.Property.Apache as Apache +import Utility.SafeCommand +import Utility.FileMode +import Utility.Path + +import Data.List +import System.Posix.Files + +oldUseNetServer :: [Host] -> Property +oldUseNetServer hosts = propertyList ("olduse.net server") + [ oldUseNetInstalled "oldusenet-server" + , Obnam.latestVersion + , Obnam.backup datadir "33 4 * * *" + [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" + , "--client-name=spool" + ] Obnam.OnlyClient + `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net") + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" + , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $ + property "olduse.net spool in place" $ makeChange $ do + removeDirectoryRecursive newsspool + createSymbolicLink (datadir "news") newsspool + , Apt.installed ["leafnode"] + , "/etc/news/leafnode/config" `File.hasContent` + [ "# olduse.net configuration (deployed by propellor)" + , "expire = 1000000" -- no expiry via texpire + , "server = " -- no upstream server + , "debugmode = 1" + , "allowSTRANGERS = 42" -- lets anyone connect + , "nopost = 1" -- no new posting (just gather them) + ] + , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" + , Apt.serviceInstalledRunning "openbsd-inetd" + , File.notPresent "/etc/cron.daily/leafnode" + , File.notPresent "/etc/cron.d/leafnode" + , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";" + [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm" + , "find -type d -empty | xargs --no-run-if-empty rmdir" + ] + , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $ + "/usr/bin/uucp " ++ datadir + , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False + [ " DocumentRoot " ++ datadir ++ "/" + , " " + , " Options Indexes FollowSymlinks" + , " AllowOverride None" + -- I had this in the file before. + -- This may be needed by a newer version of apache? + --, " Require all granted" + , " " + ] + ] + where + newsspool = "/var/spool/news" + datadir = "/var/spool/oldusenet" + +oldUseNetShellBox :: Property +oldUseNetShellBox = oldUseNetInstalled "oldusenet" + +oldUseNetInstalled :: Apt.Package -> Property +oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ + propertyList ("olduse.net " ++ pkg) + [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") + `describe` "olduse.net build deps" + , scriptProperty + [ "rm -rf /root/tmp/oldusenet" -- idenpotency + , "git clone git://olduse.net/ /root/tmp/oldusenet/source" + , "cd /root/tmp/oldusenet/source/" + , "dpkg-buildpackage -us -uc" + , "dpkg -i ../" ++ pkg ++ "_*.deb || true" + , "apt-get -fy install" -- dependencies + , "rm -rf /root/tmp/oldusenet" + -- screen fails unless the directory has this mode. + -- not sure what's going on. + , "chmod 777 /var/run/screen" + ] `describe` "olduse.net built" + ] + + +kgbServer :: Property +kgbServer = propertyList desc + [ withOS desc $ \o -> case o of + (Just (System (Debian Unstable) _)) -> + ensureProperty $ propertyList desc + [ Apt.serviceInstalledRunning "kgb-bot" + , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1" + `describe` "kgb bot enabled" + `onChange` Service.running "kgb-bot" + ] + _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" + , File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext + `onChange` Service.restarted "kgb-bot" + ] + where + desc = "kgb.kitenet.net setup" + +mumbleServer :: [Host] -> Property +mumbleServer hosts = combineProperties hn + [ Apt.serviceInstalledRunning "mumble-server" + , Obnam.latestVersion + , Obnam.backup "/var/lib/mumble-server" "55 5 * * *" + [ "--repository=sftp://joey@turtle.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam" + , "--client-name=mumble" + ] Obnam.OnlyClient + `requires` Ssh.keyImported SshRsa "root" (Context hn) + `requires` Ssh.knownHost hosts "turtle.kitenet.net" "root" + , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] + ] + where + hn = "mumble.debian.net" + +obnamLowMem :: Property +obnamLowMem = combineProperties "obnam tuned for low memory use" + [ Obnam.latestVersion + , "/etc/obnam.conf" `File.containsLines` + [ "[config]" + , "# Suggested by liw to keep Obnam memory consumption down (at some speed cost)." + , "upload-queue-size = 128" + , "lru-size = 128" + ] + ] + +-- git.kitenet.net and git.joeyh.name +gitServer :: [Host] -> Property +gitServer hosts = propertyList "git.kitenet.net setup" + [ Obnam.latestVersion + , Obnam.backup "/srv/git" "33 3 * * *" + [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" + , "--encrypt-with=1B169BE1" + , "--client-name=wren" + ] Obnam.OnlyClient + `requires` Gpg.keyImported "1B169BE1" "root" + `requires` Ssh.keyImported SshRsa "root" (Context "git.kitenet.net") + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" + `requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net") + `requires` User.accountFor "family" + , Apt.installed ["git", "rsync", "gitweb"] + -- backport avoids channel flooding on branch merge + , Apt.installedBackport ["kgb-client"] + -- backport supports ssh event notification + , Apt.installedBackport ["git-annex"] + , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext + , toProp $ Git.daemonRunning "/srv/git" + , "/etc/gitweb.conf" `File.containsLines` + [ "$projectroot = '/srv/git';" + , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');" + , "# disable snapshot download; overloads server" + , "$feature{'snapshot'}{'default'} = [];" + ] + `describe` "gitweb configured" + -- Repos push on to github. + , Ssh.knownHost hosts "github.com" "joey" + -- I keep the website used for gitweb checked into git.. + , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing + , website "git.kitenet.net" + , website "git.joeyh.name" + , toProp $ Apache.modEnabled "cgi" + ] + where + website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True + [ " DocumentRoot /srv/web/git.kitenet.net/" + , " " + , " Options Indexes ExecCGI FollowSymlinks" + , " AllowOverride None" + , " AddHandler cgi-script .cgi" + , " DirectoryIndex index.cgi" + , " " + , "" + , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/" + , " " + , " SetHandler cgi-script" + , " Options ExecCGI" + , " " + ] + +type AnnexUUID = String + +-- | A website, with files coming from a git-annex repository. +annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property +annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex") + [ Git.cloned "joey" origin dir Nothing + `onChange` setup + , postupdatehook `File.hasContent` + [ "#!/bin/sh" + , "exec git update-server-info" + ] `onChange` + (postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) + , setupapache + ] + where + dir = "/srv/web/" ++ hn + postupdatehook = dir ".git/hooks/post-update" + setup = userScriptProperty "joey" setupscript + `requires` Ssh.keyImported SshRsa "joey" (Context hn) + `requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey" + setupscript = + [ "cd " ++ shellEscape dir + , "git config annex.uuid " ++ shellEscape uuid + ] ++ map addremote remotes ++ + [ "git annex get" + ] + addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url + setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ + [ " ServerAlias www."++hn + , "" + , " DocumentRoot /srv/web/"++hn + , " " + , " Options FollowSymLinks" + , " AllowOverride None" + , " " + , " " + , " Options Indexes FollowSymLinks ExecCGI" + , " AllowOverride None" + , " AddHandler cgi-script .cgi" + , " DirectoryIndex index.html index.cgi" + , " Order allow,deny" + , " allow from all" + , " " + ] + +apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile +apachecfg hn withssl middle + | withssl = vhost False ++ vhost True + | otherwise = vhost False + where + vhost ssl = + [ "" + , " ServerAdmin grue@joeyh.name" + , " ServerName "++hn++":"++show port + ] + ++ mainhttpscert ssl + ++ middle ++ + [ "" + , " ErrorLog /var/log/apache2/error.log" + , " LogLevel warn" + , " CustomLog /var/log/apache2/access.log combined" + , " ServerSignature On" + , " " + , " " + , " Options Indexes MultiViews" + , " AllowOverride None" + , " Order allow,deny" + , " Allow from all" + , " " + , "" + ] + where + port = if ssl then 443 else 80 :: Int + +mainhttpscert :: Bool -> Apache.ConfigFile +mainhttpscert False = [] +mainhttpscert True = + [ " SSLEngine on" + , " SSLCertificateFile /etc/ssl/certs/web.pem" + , " SSLCertificateKeyFile /etc/ssl/private/web.pem" + , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" + ] + +gitAnnexDistributor :: Property +gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" + [ Apt.installed ["rsync"] + , File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") + `onChange` Service.restarted "rsync" + , File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") + `onChange` Service.restarted "rsync" + , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" + `onChange` Service.running "rsync" + , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" + , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" + -- git-annex distribution signing key + , Gpg.keyImported "89C809CB" "joey" + ] + where + endpoint d = combineProperties ("endpoint " ++ d) + [ File.dirExists d + , File.ownerGroup d "joey" "joey" + ] + +-- Twitter, you kill us. +twitRss :: Property +twitRss = combineProperties "twitter rss" + [ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing + , check (not <$> doesFileExist (dir "twitRss")) $ + userScriptProperty "joey" + [ "cd " ++ dir + , "ghc --make twitRss" + ] + `requires` Apt.installed + [ "libghc-xml-dev" + , "libghc-feed-dev" + , "libghc-tagsoup-dev" + ] + , feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" + , feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" + ] + where + dir = "/srv/web/tmp.kitenet.net/twitrss" + crontime = "15 * * * *" + feed url desc = Cron.job desc crontime "joey" dir $ + "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") + +ircBouncer :: Property +ircBouncer = propertyList "IRC bouncer" + [ Apt.installed ["znc"] + , User.accountFor "znc" + , File.dirExists (parentDir conf) + , File.hasPrivContent conf anyContext + , File.ownerGroup conf "znc" "znc" + , Cron.job "znconboot" "@reboot" "znc" "~" "znc" + -- ensure running if it was not already + , trivial $ userScriptProperty "znc" ["znc || true"] + `describe` "znc running" + ] + where + conf = "/home/znc/.znc/configs/znc.conf" + +kiteShellBox :: Property +kiteShellBox = propertyList "kitenet.net shellinabox" + [ Apt.installed ["shellinabox"] + , File.hasContent "/etc/default/shellinabox" + [ "# Deployed by propellor" + , "SHELLINABOX_DAEMON_START=1" + , "SHELLINABOX_PORT=443" + , "SHELLINABOX_ARGS=\"--no-beep --service=/:SSH:kitenet.net\"" + ] + `onChange` Service.restarted "shellinabox" + , Service.running "shellinabox" + ] + +githubBackup :: Property +githubBackup = propertyList "github-backup box" + [ Apt.installed ["github-backup", "moreutils"] + , let f = "/home/joey/.github-keys" + in File.hasPrivContent f anyContext + `onChange` File.ownerGroup f "joey" "joey" + ] + +obnamRepos :: [String] -> Property +obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) + (mkbase : map mkrepo rs) + where + mkbase = mkdir "/home/joey/lib/backup" + `requires` mkdir "/home/joey/lib" + mkrepo r = mkdir ("/home/joey/lib/backup/" ++ r ++ ".obnam") + mkdir d = File.dirExists d + `before` File.ownerGroup d "joey" "joey" + diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs new file mode 100644 index 00000000..5a260476 --- /dev/null +++ b/src/Propellor/Property/Ssh.hs @@ -0,0 +1,166 @@ +module Propellor.Property.Ssh ( + setSshdConfig, + permitRootLogin, + passwordAuthentication, + hasAuthorizedKeys, + restartSshd, + randomHostKeys, + hostKeys, + hostKey, + keyImported, + knownHost, + authorizedKeys +) where + +import Propellor +import qualified Propellor.Property.File as File +import Propellor.Property.User +import Utility.SafeCommand +import Utility.FileMode + +import System.PosixCompat + +sshBool :: Bool -> String +sshBool True = "yes" +sshBool False = "no" + +sshdConfig :: FilePath +sshdConfig = "/etc/ssh/sshd_config" + +setSshdConfig :: String -> Bool -> Property +setSshdConfig setting allowed = combineProperties "sshd config" + [ sshdConfig `File.lacksLine` (sshline $ not allowed) + , sshdConfig `File.containsLine` (sshline allowed) + ] + `onChange` restartSshd + `describe` unwords [ "ssh config:", setting, sshBool allowed ] + where + sshline v = setting ++ " " ++ sshBool v + +permitRootLogin :: Bool -> Property +permitRootLogin = setSshdConfig "PermitRootLogin" + +passwordAuthentication :: Bool -> Property +passwordAuthentication = setSshdConfig "PasswordAuthentication" + +dotDir :: UserName -> IO FilePath +dotDir user = do + h <- homedir user + return $ h ".ssh" + +dotFile :: FilePath -> UserName -> IO FilePath +dotFile f user = do + d <- dotDir user + return $ d f + +hasAuthorizedKeys :: UserName -> IO Bool +hasAuthorizedKeys = go <=< dotFile "authorized_keys" + where + go f = not . null <$> catchDefaultIO "" (readFile f) + +restartSshd :: Property +restartSshd = cmdProperty "service" ["ssh", "restart"] + +-- | Blows away existing host keys and make new ones. +-- Useful for systems installed from an image that might reuse host keys. +-- A flag file is used to only ever do this once. +randomHostKeys :: Property +randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" + `onChange` restartSshd + where + prop = property "ssh random host keys" $ do + void $ liftIO $ boolSystem "sh" + [ Param "-c" + , Param "rm -f /etc/ssh/ssh_host_*" + ] + ensureProperty $ scriptProperty + [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] + +-- | Sets all types of ssh host keys from the privdata. +hostKeys :: Context -> Property +hostKeys ctx = propertyList "known ssh host keys" + [ hostKey SshDsa ctx + , hostKey SshRsa ctx + , hostKey SshEcdsa ctx + ] + +-- | Sets a single ssh host key from the privdata. +hostKey :: SshKeyType -> Context -> Property +hostKey keytype context = combineProperties desc + [ installkey (SshPubKey keytype "") (install writeFile ".pub") + , installkey (SshPrivKey keytype "") (install writeFileProtected "") + ] + `onChange` restartSshd + where + desc = "known ssh host key (" ++ fromKeyType keytype ++ ")" + installkey p a = withPrivData p context $ \getkey -> + property desc $ getkey a + install writer ext key = do + let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext + s <- liftIO $ readFileStrict f + if s == key + then noChange + else makeChange $ writer f key + +-- | Sets up a user with a ssh private key and public key pair from the +-- PrivData. +keyImported :: SshKeyType -> UserName -> Context -> Property +keyImported keytype user context = combineProperties desc + [ installkey (SshPubKey keytype user) (install writeFile ".pub") + , installkey (SshPrivKey keytype user) (install writeFileProtected "") + ] + where + desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")" + installkey p a = withPrivData p context $ \getkey -> + property desc $ getkey a + install writer ext key = do + f <- liftIO $ keyfile ext + ifM (liftIO $ doesFileExist f) + ( noChange + , ensureProperties + [ property desc $ makeChange $ do + createDirectoryIfMissing True (takeDirectory f) + writer f key + , File.ownerGroup f user user + , File.ownerGroup (takeDirectory f) user user + ] + ) + keyfile ext = do + home <- homeDirectory <$> getUserEntryForName user + return $ home ".ssh" "id_" ++ fromKeyType keytype ++ ext + +fromKeyType :: SshKeyType -> String +fromKeyType SshRsa = "rsa" +fromKeyType SshDsa = "dsa" +fromKeyType SshEcdsa = "ecdsa" +fromKeyType SshEd25519 = "ed25519" + +-- | Puts some host's ssh public key into the known_hosts file for a user. +knownHost :: [Host] -> HostName -> UserName -> Property +knownHost hosts hn user = property desc $ + go =<< fromHost hosts hn getSshPubKey + where + desc = user ++ " knows ssh key for " ++ hn + go (Just (Just k)) = do + f <- liftIO $ dotFile "known_hosts" user + ensureProperty $ combineProperties desc + [ File.dirExists (takeDirectory f) + , f `File.containsLine` (hn ++ " " ++ k) + , File.ownerGroup f user user + ] + go _ = do + warningMessage $ "no configred sshPubKey for " ++ hn + return FailedChange + +-- | Makes a user have authorized_keys from the PrivData +authorizedKeys :: UserName -> Context -> Property +authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get -> + property (user ++ " has authorized_keys") $ get $ \v -> do + f <- liftIO $ dotFile "authorized_keys" user + liftIO $ do + createDirectoryIfMissing True (takeDirectory f) + writeFileProtected f v + ensureProperties + [ File.ownerGroup f user user + , File.ownerGroup (takeDirectory f) user user + ] diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs new file mode 100644 index 00000000..68b56608 --- /dev/null +++ b/src/Propellor/Property/Sudo.hs @@ -0,0 +1,32 @@ +module Propellor.Property.Sudo where + +import Data.List + +import Propellor +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.User + +-- | Allows a user to sudo. If the user has a password, sudo is configured +-- to require it. If not, NOPASSWORD is enabled for the user. +enabledFor :: UserName -> Property +enabledFor user = property desc go `requires` Apt.installed ["sudo"] + where + go = do + locked <- liftIO $ isLockedPassword user + ensureProperty $ + fileProperty desc + (modify locked . filter (wanted locked)) + "/etc/sudoers" + desc = user ++ " is sudoer" + sudobaseline = user ++ " ALL=(ALL:ALL)" + sudoline True = sudobaseline ++ " NOPASSWD:ALL" + sudoline False = sudobaseline ++ " ALL" + wanted locked l + -- TOOD: Full sudoers file format parse.. + | not (sudobaseline `isPrefixOf` l) = True + | "NOPASSWD" `isInfixOf` l = locked + | otherwise = True + modify locked ls + | sudoline locked `elem` ls = ls + | otherwise = ls ++ [sudoline locked] diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs new file mode 100644 index 00000000..78e35c89 --- /dev/null +++ b/src/Propellor/Property/Tor.hs @@ -0,0 +1,19 @@ +module Propellor.Property.Tor where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +isBridge :: Property +isBridge = setup `requires` Apt.installed ["tor"] + `describe` "tor bridge" + where + setup = "/etc/tor/torrc" `File.hasContent` + [ "SocksPort 0" + , "ORPort 443" + , "BridgeRelay 1" + , "Exitpolicy reject *:*" + ] `onChange` restartTor + +restartTor :: Property +restartTor = cmdProperty "service" ["tor", "restart"] diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs new file mode 100644 index 00000000..f9c400a8 --- /dev/null +++ b/src/Propellor/Property/User.hs @@ -0,0 +1,62 @@ +module Propellor.Property.User where + +import System.Posix + +import Propellor + +data Eep = YesReallyDeleteHome + +accountFor :: UserName -> Property +accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser" + [ "--disabled-password" + , "--gecos", "" + , user + ] + `describe` ("account for " ++ user) + +-- | Removes user home directory!! Use with caution. +nuked :: UserName -> Eep -> Property +nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel" + [ "-r" + , user + ] + `describe` ("nuked user " ++ user) + +-- | Only ensures that the user has some password set. It may or may +-- not be the password from the PrivData. +hasSomePassword :: UserName -> Context -> Property +hasSomePassword user context = check ((/= HasPassword) <$> getPasswordStatus user) $ + hasPassword user context + +hasPassword :: UserName -> Context -> Property +hasPassword user context = withPrivData (Password user) context $ \getpassword -> + property (user ++ " has password") $ + getpassword $ \password -> makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "chpasswd" []) $ \h -> do + hPutStrLn h $ user ++ ":" ++ password + hClose h + +lockedPassword :: UserName -> Property +lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd" + [ "--lock" + , user + ] + `describe` ("locked " ++ user ++ " password") + +data PasswordStatus = NoPassword | LockedPassword | HasPassword + deriving (Eq) + +getPasswordStatus :: UserName -> IO PasswordStatus +getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user] + where + parse (_:"L":_) = LockedPassword + parse (_:"NP":_) = NoPassword + parse (_:"P":_) = HasPassword + parse _ = NoPassword + +isLockedPassword :: UserName -> IO Bool +isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user + +homedir :: UserName -> IO FilePath +homedir user = homeDirectory <$> getUserEntryForName user diff --git a/src/Propellor/SimpleSh.hs b/src/Propellor/SimpleSh.hs new file mode 100644 index 00000000..7ba30b0e --- /dev/null +++ b/src/Propellor/SimpleSh.hs @@ -0,0 +1,101 @@ +-- | Simple server, using a named pipe. Client connects, sends a command, +-- and gets back all the output from the command, in a stream. +-- +-- This is useful for eg, docker. + +module Propellor.SimpleSh where + +import Network.Socket +import Control.Concurrent +import Control.Concurrent.Async +import System.Process (std_in, std_out, std_err) + +import Propellor +import Utility.FileMode +import Utility.ThreadScheduler + +data Cmd = Cmd String [String] + deriving (Read, Show) + +data Resp = StdoutLine String | StderrLine String | Done + deriving (Read, Show) + +simpleSh :: FilePath -> IO () +simpleSh namedpipe = do + nukeFile namedpipe + let dir = takeDirectory namedpipe + createDirectoryIfMissing True dir + modifyFileMode dir (removeModes otherGroupModes) + s <- socket AF_UNIX Stream defaultProtocol + bindSocket s (SockAddrUnix namedpipe) + listen s 2 + forever $ do + (client, _addr) <- accept s + forkIO $ do + h <- socketToHandle client ReadWriteMode + maybe noop (run h) . readish =<< hGetLine h + where + run h (Cmd cmd params) = do + chan <- newChan + let runwriter = do + v <- readChan chan + hPutStrLn h (show v) + hFlush h + case v of + Done -> noop + _ -> runwriter + writer <- async runwriter + + flip catchIO (\_e -> writeChan chan Done) $ do + let p = (proc cmd params) + { std_in = Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } + (Nothing, Just outh, Just errh, pid) <- createProcess p + + let mkreader t from = maybe noop (const $ mkreader t from) + =<< catchMaybeIO (writeChan chan . t =<< hGetLine from) + void $ concurrently + (mkreader StdoutLine outh) + (mkreader StderrLine errh) + + void $ tryIO $ waitForProcess pid + + writeChan chan Done + + hClose outh + hClose errh + + wait writer + hClose h + +simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a +simpleShClient namedpipe cmd params handler = do + s <- socket AF_UNIX Stream defaultProtocol + connect s (SockAddrUnix namedpipe) + h <- socketToHandle s ReadWriteMode + hPutStrLn h $ show $ Cmd cmd params + hFlush h + resps <- catMaybes . map readish . lines <$> hGetContents h + v <- hClose h `after` handler resps + return v + +simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a +simpleShClientRetry retries namedpipe cmd params handler = go retries + where + run = simpleShClient namedpipe cmd params handler + go n + | n < 1 = run + | otherwise = do + v <- tryIO run + case v of + Right r -> return r + Left e -> do + debug ["simplesh connection retry", show e] + threadDelaySeconds (Seconds 1) + go (n - 1) + +getStdout :: Resp -> Maybe String +getStdout (StdoutLine s) = Just s +getStdout _ = Nothing diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs new file mode 100644 index 00000000..037cd962 --- /dev/null +++ b/src/Propellor/Types.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Propellor.Types + ( Host(..) + , Info + , getInfo + , Propellor(..) + , Property(..) + , RevertableProperty(..) + , IsProp + , describe + , toProp + , requires + , Desc + , Result(..) + , ActionResult(..) + , CmdLine(..) + , PrivDataField(..) + , PrivData + , Context(..) + , anyContext + , SshKeyType(..) + , module Propellor.Types.OS + , module Propellor.Types.Dns + ) where + +import Data.Monoid +import Control.Applicative +import System.Console.ANSI +import "mtl" Control.Monad.Reader +import "MonadCatchIO-transformers" Control.Monad.CatchIO + +import Propellor.Types.Info +import Propellor.Types.OS +import Propellor.Types.Dns +import Propellor.Types.PrivData + +-- | Everything Propellor knows about a system: Its hostname, +-- properties and other info. +data Host = Host + { hostName :: HostName + , hostProperties :: [Property] + , hostInfo :: Info + } + deriving (Show) + +-- | Propellor's monad provides read-only access to info about the host +-- it's running on. +newtype Propellor p = Propellor { runWithHost :: ReaderT Host IO p } + deriving + ( Monad + , Functor + , Applicative + , MonadReader Host + , MonadIO + , MonadCatchIO + ) + +-- | The core data type of Propellor, this represents a property +-- that the system should have, and an action to ensure it has the +-- property. +data Property = Property + { propertyDesc :: Desc + , propertySatisfy :: Propellor Result + -- ^ must be idempotent; may run repeatedly + , propertyInfo :: Info + -- ^ a property can add info to the host. + } + +instance Show Property where + show p = "property " ++ show (propertyDesc p) + +-- | A property that can be reverted. +data RevertableProperty = RevertableProperty Property Property + +class IsProp p where + -- | Sets description. + describe :: p -> Desc -> p + toProp :: p -> Property + -- | Indicates that the first property can only be satisfied + -- once the second one is. + requires :: p -> Property -> p + getInfo :: p -> Info + +instance IsProp Property where + describe p d = p { propertyDesc = d } + toProp p = p + getInfo = propertyInfo + x `requires` y = Property (propertyDesc x) satisfy info + where + info = getInfo y <> getInfo x + satisfy = do + r <- propertySatisfy y + case r of + FailedChange -> return FailedChange + _ -> propertySatisfy x + + +instance IsProp RevertableProperty where + -- | Sets the description of both sides. + describe (RevertableProperty p1 p2) d = + RevertableProperty (describe p1 d) (describe p2 ("not " ++ d)) + toProp (RevertableProperty p1 _) = p1 + (RevertableProperty p1 p2) `requires` y = + RevertableProperty (p1 `requires` y) p2 + -- | Return the Info of the currently active side. + getInfo (RevertableProperty p1 _p2) = getInfo p1 + +type Desc = String + +data Result = NoChange | MadeChange | FailedChange + deriving (Read, Show, Eq) + +instance Monoid Result where + mempty = NoChange + + mappend FailedChange _ = FailedChange + mappend _ FailedChange = FailedChange + mappend MadeChange _ = MadeChange + mappend _ MadeChange = MadeChange + mappend NoChange NoChange = NoChange + +-- | Results of actions, with color. +class ActionResult a where + getActionResult :: a -> (String, ColorIntensity, Color) + +instance ActionResult Bool where + getActionResult False = ("failed", Vivid, Red) + getActionResult True = ("done", Dull, Green) + +instance ActionResult Result where + getActionResult NoChange = ("ok", Dull, Green) + getActionResult MadeChange = ("done", Vivid, Green) + getActionResult FailedChange = ("failed", Vivid, Red) + +data CmdLine + = Run HostName + | Spin HostName + | Boot HostName + | Set PrivDataField Context + | Dump PrivDataField Context + | Edit PrivDataField Context + | ListFields + | AddKey String + | Continue CmdLine + | Chain HostName + | Docker HostName + deriving (Read, Show, Eq) diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs new file mode 100644 index 00000000..66fbd1a4 --- /dev/null +++ b/src/Propellor/Types/Dns.hs @@ -0,0 +1,112 @@ +module Propellor.Types.Dns where + +import Propellor.Types.OS (HostName) + +import Data.Word +import Data.Monoid +import qualified Data.Map as M + +type Domain = String + +data IPAddr = IPv4 String | IPv6 String + deriving (Read, Show, Eq, Ord) + +fromIPAddr :: IPAddr -> String +fromIPAddr (IPv4 addr) = addr +fromIPAddr (IPv6 addr) = addr + +-- | Represents a bind 9 named.conf file. +data NamedConf = NamedConf + { confDomain :: Domain + , confDnsServerType :: DnsServerType + , confFile :: FilePath + , confMasters :: [IPAddr] + , confAllowTransfer :: [IPAddr] + , confLines :: [String] + } + deriving (Show, Eq, Ord) + +data DnsServerType = Master | Secondary + deriving (Show, Eq, Ord) + +-- | Represents a bind 9 zone file. +data Zone = Zone + { zDomain :: Domain + , zSOA :: SOA + , zHosts :: [(BindDomain, Record)] + } + deriving (Read, Show, Eq) + +-- | Every domain has a SOA record, which is big and complicated. +data SOA = SOA + { sDomain :: BindDomain + -- ^ Typically ns1.your.domain + , sSerial :: SerialNumber + -- ^ The most important parameter is the serial number, + -- which must increase after each change. + , sRefresh :: Integer + , sRetry :: Integer + , sExpire :: Integer + , sNegativeCacheTTL :: Integer + } + deriving (Read, Show, Eq) + +-- | Types of DNS records. +-- +-- This is not a complete list, more can be added. +data Record + = Address IPAddr + | CNAME BindDomain + | MX Int BindDomain + | NS BindDomain + | TXT String + | SRV Word16 Word16 Word16 BindDomain + deriving (Read, Show, Eq, Ord) + +getIPAddr :: Record -> Maybe IPAddr +getIPAddr (Address addr) = Just addr +getIPAddr _ = Nothing + +getCNAME :: Record -> Maybe BindDomain +getCNAME (CNAME d) = Just d +getCNAME _ = Nothing + +getNS :: Record -> Maybe BindDomain +getNS (NS d) = Just d +getNS _ = Nothing + +-- | Bind serial numbers are unsigned, 32 bit integers. +type SerialNumber = Word32 + +-- | Domains in the zone file must end with a period if they are absolute. +-- +-- Let's use a type to keep absolute domains straight from relative +-- domains. +-- +-- The RootDomain refers to the top level of the domain, so can be used +-- to add nameservers, MX's, etc to a domain. +data BindDomain = RelDomain Domain | AbsDomain Domain | RootDomain + deriving (Read, Show, Eq, Ord) + +domainHostName :: BindDomain -> Maybe HostName +domainHostName (RelDomain d) = Just d +domainHostName (AbsDomain d) = Just d +domainHostName RootDomain = Nothing + +newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf) + deriving (Eq, Ord, Show) + +-- | Adding a Master NamedConf stanza for a particulr 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 Monoid NamedConfMap where + mempty = NamedConfMap M.empty + mappend (NamedConfMap old) (NamedConfMap new) = NamedConfMap $ + M.unionWith combiner new old + where + combiner n o = case (confDnsServerType n, confDnsServerType o) of + (Secondary, Master) -> o + _ -> n + +fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf +fromNamedConfMap (NamedConfMap m) = m diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs new file mode 100644 index 00000000..8856e06f --- /dev/null +++ b/src/Propellor/Types/Info.hs @@ -0,0 +1,68 @@ +module Propellor.Types.Info where + +import Propellor.Types.OS +import Propellor.Types.PrivData +import qualified Propellor.Types.Dns as Dns + +import qualified Data.Set as S +import Data.Monoid + +-- | Information about a host. +data Info = Info + { _os :: Val System + , _privDataFields :: S.Set (PrivDataField, Context) + , _sshPubKey :: Val String + , _dns :: S.Set Dns.Record + , _namedconf :: Dns.NamedConfMap + , _dockerinfo :: DockerInfo + } + deriving (Eq, Show) + +instance Monoid Info where + mempty = Info mempty mempty mempty mempty mempty mempty + mappend old new = Info + { _os = _os old <> _os new + , _privDataFields = _privDataFields old <> _privDataFields new + , _sshPubKey = _sshPubKey old <> _sshPubKey new + , _dns = _dns old <> _dns new + , _namedconf = _namedconf old <> _namedconf new + , _dockerinfo = _dockerinfo old <> _dockerinfo new + } + +data Val a = Val a | NoVal + deriving (Eq, Show) + +instance Monoid (Val a) where + mempty = NoVal + mappend old new = case new of + NoVal -> old + _ -> new + +fromVal :: Val a -> Maybe a +fromVal (Val a) = Just a +fromVal NoVal = Nothing + +data DockerInfo = DockerInfo + { _dockerImage :: Val String + , _dockerRunParams :: [HostName -> String] + } + +instance Eq DockerInfo where + x == y = and + [ _dockerImage x == _dockerImage y + , let simpl v = map (\a -> a "") (_dockerRunParams v) + in simpl x == simpl y + ] + +instance Monoid DockerInfo where + mempty = DockerInfo mempty mempty + mappend old new = DockerInfo + { _dockerImage = _dockerImage old <> _dockerImage new + , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + } + +instance Show DockerInfo where + show a = unlines + [ "docker image " ++ show (_dockerImage a) + , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) + ] diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs new file mode 100644 index 00000000..23cc8a29 --- /dev/null +++ b/src/Propellor/Types/OS.hs @@ -0,0 +1,27 @@ +module Propellor.Types.OS where + +type HostName = String +type UserName = String +type GroupName = String + +-- | High level descritption of a operating system. +data System = System Distribution Architecture + deriving (Show, Eq) + +data Distribution + = Debian DebianSuite + | Ubuntu Release + deriving (Show, Eq) + +data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release + deriving (Show, Eq) + +-- | The release that currently corresponds to stable. +stableRelease :: DebianSuite +stableRelease = DebianRelease "wheezy" + +isStable :: DebianSuite -> Bool +isStable s = s == Stable || s == stableRelease + +type Release = String +type Architecture = String diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs new file mode 100644 index 00000000..16d6cdb1 --- /dev/null +++ b/src/Propellor/Types/PrivData.hs @@ -0,0 +1,34 @@ +module Propellor.Types.PrivData where + +import Propellor.Types.OS + +-- | Note that removing or changing field names will break the +-- serialized privdata files, so don't do that! +-- It's fine to add new fields. +data PrivDataField + = DockerAuthentication + | SshPubKey SshKeyType UserName + | SshPrivKey SshKeyType UserName + | SshAuthorizedKeys UserName + | Password UserName + | PrivFile FilePath + | GpgKey + deriving (Read, Show, Ord, Eq) + +-- | Context in which a PrivDataField is used. +-- +-- Often this will be a domain name. For example, +-- Context "www.example.com" could be used for the SSL cert +-- for the web server serving that domain. Multiple hosts might +-- use that privdata. +newtype Context = Context String + deriving (Read, Show, Ord, Eq) + +-- | Use when a PrivDataField is not dependent on any paricular context. +anyContext :: Context +anyContext = Context "any" + +type PrivData = String + +data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519 + deriving (Read, Show, Ord, Eq) diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs new file mode 100644 index 00000000..fd8944b2 --- /dev/null +++ b/src/Utility/Applicative.hs @@ -0,0 +1,16 @@ +{- applicative stuff + - + - Copyright 2012 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Applicative where + +{- Like <$> , but supports one level of currying. + - + - foo v = bar <$> action v == foo = bar <$$> action + -} +(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b +f <$$> v = fmap f . v +infixr 4 <$$> diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs new file mode 100644 index 00000000..2df12b36 --- /dev/null +++ b/src/Utility/Data.hs @@ -0,0 +1,17 @@ +{- utilities for simple data types + - + - Copyright 2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Data where + +{- First item in the list that is not Nothing. -} +firstJust :: Eq a => [Maybe a] -> Maybe a +firstJust ms = case dropWhile (== Nothing) ms of + [] -> Nothing + (md:_) -> md + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe = either (const Nothing) Just diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs new file mode 100644 index 00000000..d92327c0 --- /dev/null +++ b/src/Utility/Directory.hs @@ -0,0 +1,135 @@ +{- directory manipulation + - + - Copyright 2011-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Directory where + +import System.IO.Error +import System.Directory +import Control.Exception (throw) +import Control.Monad +import Control.Monad.IfElse +import System.FilePath +import Control.Applicative +import System.IO.Unsafe (unsafeInterleaveIO) + +import Utility.PosixFiles +import Utility.SafeCommand +import Utility.Tmp +import Utility.Exception +import Utility.Monad +import Utility.Applicative + +dirCruft :: FilePath -> Bool +dirCruft "." = True +dirCruft ".." = True +dirCruft _ = False + +{- Lists the contents of a directory. + - Unlike getDirectoryContents, paths are not relative to the directory. -} +dirContents :: FilePath -> IO [FilePath] +dirContents d = map (d ) . filter (not . dirCruft) <$> getDirectoryContents d + +{- Gets files in a directory, and then its subdirectories, recursively, + - and lazily. + - + - Does not follow symlinks to other subdirectories. + - + - When the directory does not exist, no exception is thrown, + - instead, [] is returned. -} +dirContentsRecursive :: FilePath -> IO [FilePath] +dirContentsRecursive = dirContentsRecursiveSkipping (const False) True + +{- Skips directories whose basenames match the skipdir. -} +dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] +dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] + where + go [] = return [] + go (dir:dirs) + | skipdir (takeFileName dir) = go dirs + | otherwise = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] + =<< catchDefaultIO [] (dirContents dir) + files' <- go (dirs' ++ dirs) + return (files ++ files') + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) + | dirCruft entry = collect files dirs' entries + | otherwise = do + let skip = collect (entry:files) dirs' entries + let recurse = collect files (entry:dirs') entries + ms <- catchMaybeIO $ getSymbolicLinkStatus entry + case ms of + (Just s) + | isDirectory s -> recurse + | isSymbolicLink s && followsubdirsymlinks -> + ifM (doesDirectoryExist entry) + ( recurse + , skip + ) + _ -> skip + +{- Gets the directory tree from a point, recursively and lazily, + - with leaf directories **first**, skipping any whose basenames + - match the skipdir. Does not follow symlinks. -} +dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] + where + go c [] = return c + go c (dir:dirs) + | skipdir (takeFileName dir) = go c dirs + | otherwise = unsafeInterleaveIO $ do + subdirs <- go c + =<< filterM (isDirectory <$$> getSymbolicLinkStatus) + =<< catchDefaultIO [] (dirContents dir) + go (subdirs++[dir]) dirs + +{- Moves one filename to another. + - First tries a rename, but falls back to moving across devices if needed. -} +moveFile :: FilePath -> FilePath -> IO () +moveFile src dest = tryIO (rename src dest) >>= onrename + where + onrename (Right _) = noop + onrename (Left e) + | isPermissionError e = rethrow + | isDoesNotExistError e = rethrow + | otherwise = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the latter. + -- But, mv will move into a directory if + -- dest is one, which is not desired. + whenM (isdir dest) rethrow + viaTmp mv dest undefined + where + rethrow = throw e + mv tmp _ = do + ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + unless ok $ do + -- delete any partial + _ <- tryIO $ removeFile tmp + rethrow + + isdir f = do + r <- tryIO $ getFileStatus f + case r of + (Left _) -> return False + (Right s) -> return $ isDirectory s + +{- Removes a file, which may or may not exist, and does not have to + - be a regular file. + - + - Note that an exception is thrown if the file exists but + - cannot be removed. -} +nukeFile :: FilePath -> IO () +nukeFile file = void $ tryWhenExists go + where +#ifndef mingw32_HOST_OS + go = removeLink file +#else + go = removeFile file +#endif diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs new file mode 100644 index 00000000..6763c24e --- /dev/null +++ b/src/Utility/Env.hs @@ -0,0 +1,81 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Env where + +#ifdef mingw32_HOST_OS +import Utility.Exception +import Control.Applicative +import Data.Maybe +import qualified System.Environment as E +#else +import qualified System.Posix.Env as PE +#endif + +getEnv :: String -> IO (Maybe String) +#ifndef mingw32_HOST_OS +getEnv = PE.getEnv +#else +getEnv = catchMaybeIO . E.getEnv +#endif + +getEnvDefault :: String -> String -> IO String +#ifndef mingw32_HOST_OS +getEnvDefault = PE.getEnvDefault +#else +getEnvDefault var fallback = fromMaybe fallback <$> getEnv var +#endif + +getEnvironment :: IO [(String, String)] +#ifndef mingw32_HOST_OS +getEnvironment = PE.getEnvironment +#else +getEnvironment = E.getEnvironment +#endif + +{- Returns True if it could successfully set the environment variable. + - + - There is, apparently, no way to do this in Windows. Instead, + - environment varuables must be provided when running a new process. -} +setEnv :: String -> String -> Bool -> IO Bool +#ifndef mingw32_HOST_OS +setEnv var val overwrite = do + PE.setEnv var val overwrite + return True +#else +setEnv _ _ _ = return False +#endif + +{- Returns True if it could successfully unset the environment variable. -} +unsetEnv :: String -> IO Bool +#ifndef mingw32_HOST_OS +unsetEnv var = do + PE.unsetEnv var + return True +#else +unsetEnv _ = return False +#endif + +{- Adds the environment variable to the input environment. If already + - present in the list, removes the old value. + - + - This does not really belong here, but Data.AssocList is for some reason + - buried inside hxt. + -} +addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)] +addEntry k v l = ( (k,v) : ) $! delEntry k l + +addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)] +addEntries = foldr (.) id . map (uncurry addEntry) . reverse + +delEntry :: Eq k => k -> [(k, v)] -> [(k, v)] +delEntry _ [] = [] +delEntry k (x@(k1,_) : rest) + | k == k1 = rest + | otherwise = ( x : ) $! delEntry k rest diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs new file mode 100644 index 00000000..1fecf65d --- /dev/null +++ b/src/Utility/Exception.hs @@ -0,0 +1,59 @@ +{- Simple IO exception handling (and some more) + - + - Copyright 2011-2012 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE ScopedTypeVariables #-} + +module Utility.Exception where + +import Control.Exception +import qualified Control.Exception as E +import Control.Applicative +import Control.Monad +import System.IO.Error (isDoesNotExistError) +import Utility.Data + +{- Catches IO errors and returns a Bool -} +catchBoolIO :: IO Bool -> IO Bool +catchBoolIO = catchDefaultIO False + +{- Catches IO errors and returns a Maybe -} +catchMaybeIO :: IO a -> IO (Maybe a) +catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a + +{- Catches IO errors and returns a default value. -} +catchDefaultIO :: a -> IO a -> IO a +catchDefaultIO def a = catchIO a (const $ return def) + +{- Catches IO errors and returns the error message. -} +catchMsgIO :: IO a -> IO (Either String a) +catchMsgIO a = either (Left . show) Right <$> tryIO a + +{- catch specialized for IO errors only -} +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = E.catch + +{- try specialized for IO errors only -} +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +{- Catches all exceptions except for async exceptions. + - This is often better to use than catching them all, so that + - ThreadKilled and UserInterrupt get through. + -} +catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a +catchNonAsync a onerr = a `catches` + [ Handler (\ (e :: AsyncException) -> throw e) + , Handler (\ (e :: SomeException) -> onerr e) + ] + +tryNonAsync :: IO a -> IO (Either SomeException a) +tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left) + +{- Catches only DoesNotExist exceptions, and lets all others through. -} +tryWhenExists :: IO a -> IO (Maybe a) +tryWhenExists a = eitherToMaybe <$> + tryJust (guard . isDoesNotExistError) a diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs new file mode 100644 index 00000000..c2ef683a --- /dev/null +++ b/src/Utility/FileMode.hs @@ -0,0 +1,158 @@ +{- File mode utilities. + - + - Copyright 2010-2012 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.FileMode where + +import System.IO +import Control.Monad +import Control.Exception (bracket) +import System.PosixCompat.Types +import Utility.PosixFiles +#ifndef mingw32_HOST_OS +import System.Posix.Files +#endif +import Foreign (complement) + +import Utility.Exception + +{- Applies a conversion function to a file's mode. -} +modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () +modifyFileMode f convert = void $ modifyFileMode' f convert +modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode +modifyFileMode' f convert = do + s <- getFileStatus f + let old = fileMode s + let new = convert old + when (new /= old) $ + setFileMode f new + return old + +{- Adds the specified FileModes to the input mode, leaving the rest + - unchanged. -} +addModes :: [FileMode] -> FileMode -> FileMode +addModes ms m = combineModes (m:ms) + +{- Removes the specified FileModes from the input mode. -} +removeModes :: [FileMode] -> FileMode -> FileMode +removeModes ms m = m `intersectFileModes` complement (combineModes ms) + +{- Runs an action after changing a file's mode, then restores the old mode. -} +withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a +withModifiedFileMode file convert a = bracket setup cleanup go + where + setup = modifyFileMode' file convert + cleanup oldmode = modifyFileMode file (const oldmode) + go _ = a + +writeModes :: [FileMode] +writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode] + +readModes :: [FileMode] +readModes = [ownerReadMode, groupReadMode, otherReadMode] + +executeModes :: [FileMode] +executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode] + +otherGroupModes :: [FileMode] +otherGroupModes = + [ groupReadMode, otherReadMode + , groupWriteMode, otherWriteMode + ] + +{- Removes the write bits from a file. -} +preventWrite :: FilePath -> IO () +preventWrite f = modifyFileMode f $ removeModes writeModes + +{- Turns a file's owner write bit back on. -} +allowWrite :: FilePath -> IO () +allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] + +{- Turns a file's owner read bit back on. -} +allowRead :: FilePath -> IO () +allowRead f = modifyFileMode f $ addModes [ownerReadMode] + +{- Allows owner and group to read and write to a file. -} +groupSharedModes :: [FileMode] +groupSharedModes = + [ ownerWriteMode, groupWriteMode + , ownerReadMode, groupReadMode + ] + +groupWriteRead :: FilePath -> IO () +groupWriteRead f = modifyFileMode f $ addModes groupSharedModes + +checkMode :: FileMode -> FileMode -> Bool +checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor + +{- Checks if a file mode indicates it's a symlink. -} +isSymLink :: FileMode -> Bool +#ifdef mingw32_HOST_OS +isSymLink _ = False +#else +isSymLink = checkMode symbolicLinkMode +#endif + +{- Checks if a file has any executable bits set. -} +isExecutable :: FileMode -> Bool +isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 + +{- Runs an action without that pesky umask influencing it, unless the + - passed FileMode is the standard one. -} +noUmask :: FileMode -> IO a -> IO a +#ifndef mingw32_HOST_OS +noUmask mode a + | mode == stdFileMode = a + | otherwise = withUmask nullFileMode a +#else +noUmask _ a = a +#endif + +withUmask :: FileMode -> IO a -> IO a +#ifndef mingw32_HOST_OS +withUmask umask a = bracket setup cleanup go + where + setup = setFileCreationMask umask + cleanup = setFileCreationMask + go _ = a +#else +withUmask _ a = a +#endif + +combineModes :: [FileMode] -> FileMode +combineModes [] = undefined +combineModes [m] = m +combineModes (m:ms) = foldl unionFileModes m ms + +isSticky :: FileMode -> Bool +#ifdef mingw32_HOST_OS +isSticky _ = False +#else +isSticky = checkMode stickyMode + +stickyMode :: FileMode +stickyMode = 512 + +setSticky :: FilePath -> IO () +setSticky f = modifyFileMode f $ addModes [stickyMode] +#endif + +{- Writes a file, ensuring that its modes do not allow it to be read + - or written by anyone other than the current user, + - before any content is written. + - + - When possible, this is done using the umask. + - + - On a filesystem that does not support file permissions, this is the same + - as writeFile. + -} +writeFileProtected :: FilePath -> String -> IO () +writeFileProtected file content = withUmask 0o0077 $ + withFile file WriteMode $ \h -> do + void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes + hPutStr h content diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs new file mode 100644 index 00000000..b81fdc53 --- /dev/null +++ b/src/Utility/FileSystemEncoding.hs @@ -0,0 +1,132 @@ +{- GHC File system encoding handling. + - + - Copyright 2012-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.FileSystemEncoding ( + fileEncoding, + withFilePath, + md5FilePath, + decodeBS, + decodeW8, + encodeW8, + truncateFilePath, +) where + +import qualified GHC.Foreign as GHC +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 qualified Data.ByteString.Lazy as L +#ifdef mingw32_HOST_OS +import qualified Data.ByteString.Lazy.UTF8 as L8 +#endif + +{- Sets a Handle to use the filesystem encoding. This causes data + - written or read from it to be encoded/decoded the same + - as ghc 7.4 does to filenames etc. This special encoding + - allows "arbitrary undecodable bytes to be round-tripped through it". + -} +fileEncoding :: Handle -> IO () +#ifndef mingw32_HOST_OS +fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding +#else +{- The file system encoding does not work well on Windows, + - and Windows only has utf FilePaths anyway. -} +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 + - was obtained. -} +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath fp f = Encoding.getFileSystemEncoding + >>= \enc -> GHC.withCString enc fp f + +{- Encodes a FilePath into a String, applying the filesystem encoding. + - + - There are very few things it makes sense to do with such an encoded + - string. It's not a legal filename; it should not be displayed. + - So this function is not exported, but instead used by the few functions + - that can usefully consume it. + - + - This use of unsafePerformIO is belived to be safe; GHC's interface + - only allows doing this conversion with CStrings, and the CString buffer + - is allocated, used, and deallocated within the call, with no side + - effects. + -} +{-# NOINLINE _encodeFilePath #-} +_encodeFilePath :: FilePath -> String +_encodeFilePath fp = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + GHC.withCString enc fp $ GHC.peekCString Encoding.char8 + +{- 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 +decodeBS = encodeW8 . L.unpack +#else +{- On Windows, we assume that the ByteString is utf-8, since Windows + - only uses unicode for filenames. -} +decodeBS = L8.toString +#endif + +{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. + - + - w82c produces a String, which may contain Chars that are invalid + - unicode. From there, this is really a simple matter of applying the + - file system encoding, only complicated by GHC's interface to doing so. + -} +{-# NOINLINE encodeW8 #-} +encodeW8 :: [Word8] -> FilePath +encodeW8 w8 = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc + +{- Useful when you want the actual number of bytes that will be used to + - represent the FilePath on disk. -} +decodeW8 :: FilePath -> [Word8] +decodeW8 = s2w8 . _encodeFilePath + +{- Truncates a FilePath to the given number of bytes (or less), + - as represented on disk. + - + - Avoids returning an invalid part of a unicode byte sequence, at the + - cost of efficiency when running on a large FilePath. + -} +truncateFilePath :: Int -> FilePath -> FilePath +#ifndef mingw32_HOST_OS +truncateFilePath n = go . reverse + where + go f = + let bytes = decodeW8 f + in if length bytes <= n + then reverse f + else go (drop 1 f) +#else +{- On Windows, count the number of bytes used by each utf8 character. -} +truncateFilePath n = reverse . go [] n . L8.fromString + where + go coll cnt bs + | cnt <= 0 = coll + | otherwise = case L8.decode bs of + Just (c, x) | c /= L8.replacement_char -> + let x' = fromIntegral x + in if cnt - x' < 0 + then coll + else go (c:coll) (cnt - x') (L8.drop 1 bs) + _ -> coll +#endif diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs new file mode 100644 index 00000000..1dc4e1ea --- /dev/null +++ b/src/Utility/LinuxMkLibs.hs @@ -0,0 +1,61 @@ +{- Linux library copier and binary shimmer + - + - Copyright 2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.LinuxMkLibs where + +import Control.Applicative +import Data.Maybe +import System.Directory +import Data.List.Utils +import System.Posix.Files +import Data.Char +import Control.Monad.IfElse + +import Utility.PartialPrelude +import Utility.Directory +import Utility.Process +import Utility.Monad +import Utility.Path + +{- Installs a library. If the library is a symlink to another file, + - install the file it links to, and update the symlink to be relative. -} +installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath) +installLib installfile top lib = ifM (doesFileExist lib) + ( do + installfile top lib + checksymlink lib + return $ Just $ parentDir lib + , return Nothing + ) + where + checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do + l <- readSymbolicLink (inTop top f) + let absl = absPathFrom (parentDir f) l + let target = relPathDirToFile (parentDir f) absl + installfile top absl + nukeFile (top ++ f) + createSymbolicLink target (inTop top f) + checksymlink absl + +-- Note that f is not relative, so cannot use +inTop :: FilePath -> FilePath -> FilePath +inTop top f = top ++ f + +{- Parse ldd output, getting all the libraries that the input files + - link to. Note that some of the libraries may not exist + - (eg, linux-vdso.so) -} +parseLdd :: String -> [FilePath] +parseLdd = mapMaybe (getlib . dropWhile isSpace) . lines + where + getlib l = headMaybe . words =<< lastMaybe (split " => " l) + +{- Get all glibc libs and other support files, including gconv files + - + - XXX Debian specific. -} +glibcLibs :: IO [FilePath] +glibcLibs = lines <$> readProcess "sh" + ["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"] diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs new file mode 100644 index 00000000..949f41e7 --- /dev/null +++ b/src/Utility/Misc.hs @@ -0,0 +1,148 @@ +{- misc utility functions + - + - Copyright 2010-2011 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Misc where + +import System.IO +import Control.Monad +import Foreign +import Data.Char +import Data.List +import Control.Applicative +import System.Exit +#ifndef mingw32_HOST_OS +import System.Posix.Process (getAnyProcessStatus) +import Utility.Exception +#endif + +import Utility.FileSystemEncoding +import Utility.Monad + +{- A version of hgetContents that is not lazy. Ensures file is + - all read before it gets closed. -} +hGetContentsStrict :: Handle -> IO String +hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s + +{- A version of readFile that is not lazy. -} +readFileStrict :: FilePath -> IO String +readFileStrict = readFile >=> \s -> length s `seq` return s + +{- Reads a file strictly, and using the FileSystemEncoding, so it will + - never crash on a badly encoded file. -} +readFileStrictAnyEncoding :: FilePath -> IO String +readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do + fileEncoding h + hClose h `after` hGetContentsStrict h + +{- Writes a file, using the FileSystemEncoding so it will never crash + - on a badly encoded content string. -} +writeFileAnyEncoding :: FilePath -> String -> IO () +writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do + fileEncoding h + hPutStr h content + +{- Like break, but the item matching the condition is not included + - in the second result list. + - + - separate (== ':') "foo:bar" = ("foo", "bar") + - separate (== ':') "foobar" = ("foobar", "") + -} +separate :: (a -> Bool) -> [a] -> ([a], [a]) +separate c l = unbreak $ break c l + where + unbreak r@(a, b) + | null b = r + | otherwise = (a, tail b) + +{- Breaks out the first line. -} +firstLine :: String -> String +firstLine = takeWhile (/= '\n') + +{- Splits a list into segments that are delimited by items matching + - a predicate. (The delimiters are not included in the segments.) + - Segments may be empty. -} +segment :: (a -> Bool) -> [a] -> [[a]] +segment p l = map reverse $ go [] [] l + where + go c r [] = reverse $ c:r + go c r (i:is) + | p i = go [] (c:r) is + | otherwise = go (i:c) r is + +prop_segment_regressionTest :: Bool +prop_segment_regressionTest = all id + -- Even an empty list is a segment. + [ segment (== "--") [] == [[]] + -- There are two segements in this list, even though the first is empty. + , segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]] + ] + +{- Includes the delimiters as segments of their own. -} +segmentDelim :: (a -> Bool) -> [a] -> [[a]] +segmentDelim p l = map reverse $ go [] [] l + where + go c r [] = reverse $ c:r + go c r (i:is) + | p i = go [] ([i]:c:r) is + | otherwise = go (i:c) r is + +{- Replaces multiple values in a string. + - + - Takes care to skip over just-replaced values, so that they are not + - mangled. For example, massReplace [("foo", "new foo")] does not + - replace the "new foo" with "new new foo". + -} +massReplace :: [(String, String)] -> String -> String +massReplace vs = go [] vs + where + + go acc _ [] = concat $ reverse acc + go acc [] (c:cs) = go ([c]:acc) vs cs + go acc ((val, replacement):rest) s + | val `isPrefixOf` s = + go (replacement:acc) vs (drop (length val) s) + | otherwise = go acc rest s + +{- Wrapper around hGetBufSome that returns a String. + - + - The null string is returned on eof, otherwise returns whatever + - data is currently available to read from the handle, or waits for + - data to be written to it if none is currently available. + - + - Note on encodings: The normal encoding of the Handle is ignored; + - each byte is converted to a Char. Not unicode clean! + -} +hGetSomeString :: Handle -> Int -> IO String +hGetSomeString h sz = do + fp <- mallocForeignPtrBytes sz + len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz + map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len) + where + peekbytes :: Int -> Ptr Word8 -> IO [Word8] + peekbytes len buf = mapM (peekElemOff buf) [0..pred len] + +{- Reaps any zombie git processes. + - + - Warning: Not thread safe. Anything that was expecting to wait + - on a process and get back an exit status is going to be confused + - if this reap gets there first. -} +reapZombies :: IO () +#ifndef mingw32_HOST_OS +reapZombies = do + -- throws an exception when there are no child processes + catchDefaultIO Nothing (getAnyProcessStatus False True) + >>= maybe (return ()) (const reapZombies) + +#else +reapZombies = return () +#endif + +exitBool :: Bool -> IO a +exitBool False = exitFailure +exitBool True = exitSuccess diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs new file mode 100644 index 00000000..eba3c428 --- /dev/null +++ b/src/Utility/Monad.hs @@ -0,0 +1,69 @@ +{- monadic stuff + - + - Copyright 2010-2012 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Monad where + +import Data.Maybe +import Control.Monad + +{- Return the first value from a list, if any, satisfying the given + - predicate -} +firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +firstM _ [] = return Nothing +firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs) + +{- Runs the action on values from the list until it succeeds, returning + - its result. -} +getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +getM _ [] = return Nothing +getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x + +{- Returns true if any value in the list satisfies the predicate, + - stopping once one is found. -} +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM p = liftM isJust . firstM p + +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM p (x:xs) = p x <&&> allM p xs + +{- Runs an action on values from a list until it succeeds. -} +untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool +untilTrue = flip anyM + +{- if with a monadic conditional. -} +ifM :: Monad m => m Bool -> (m a, m a) -> m a +ifM cond (thenclause, elseclause) = do + c <- cond + if c then thenclause else elseclause + +{- short-circuiting monadic || -} +(<||>) :: Monad m => m Bool -> m Bool -> m Bool +ma <||> mb = ifM ma ( return True , mb ) + +{- short-circuiting monadic && -} +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +ma <&&> mb = ifM ma ( mb , return False ) + +{- Same fixity as && and || -} +infixr 3 <&&> +infixr 2 <||> + +{- Runs an action, passing its value to an observer before returning it. -} +observe :: Monad m => (a -> m b) -> m a -> m a +observe observer a = do + r <- a + _ <- observer r + return r + +{- b `after` a runs first a, then b, and returns the value of a -} +after :: Monad m => m b -> m a -> m a +after = observe . const + +{- do nothing -} +noop :: Monad m => m () +noop = return () diff --git a/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs new file mode 100644 index 00000000..6efa093f --- /dev/null +++ b/src/Utility/PartialPrelude.hs @@ -0,0 +1,68 @@ +{- Parts of the Prelude are partial functions, which are a common source of + - bugs. + - + - This exports functions that conflict with the prelude, which avoids + - them being accidentially used. + -} + +module Utility.PartialPrelude where + +import qualified Data.Maybe + +{- read should be avoided, as it throws an error + - Instead, use: readish -} +read :: Read a => String -> a +read = Prelude.read + +{- head is a partial function; head [] is an error + - Instead, use: take 1 or headMaybe -} +head :: [a] -> a +head = Prelude.head + +{- tail is also partial + - Instead, use: drop 1 -} +tail :: [a] -> [a] +tail = Prelude.tail + +{- init too + - Instead, use: beginning -} +init :: [a] -> [a] +init = Prelude.init + +{- last too + - Instead, use: end or lastMaybe -} +last :: [a] -> a +last = Prelude.last + +{- Attempts to read a value from a String. + - + - Ignores leading/trailing whitespace, and throws away any trailing + - text after the part that can be read. + - + - readMaybe is available in Text.Read in new versions of GHC, + - but that one requires the entire string to be consumed. + -} +readish :: Read a => String -> Maybe a +readish s = case reads s of + ((x,_):_) -> Just x + _ -> Nothing + +{- Like head but Nothing on empty list. -} +headMaybe :: [a] -> Maybe a +headMaybe = Data.Maybe.listToMaybe + +{- Like last but Nothing on empty list. -} +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe v = Just $ Prelude.last v + +{- All but the last element of a list. + - (Like init, but no error on an empty list.) -} +beginning :: [a] -> [a] +beginning [] = [] +beginning l = Prelude.init l + +{- Like last, but no error on an empty list. -} +end :: [a] -> [a] +end [] = [] +end l = [Prelude.last l] diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs new file mode 100644 index 00000000..99c9438b --- /dev/null +++ b/src/Utility/Path.hs @@ -0,0 +1,293 @@ +{- path manipulation + - + - Copyright 2010-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE PackageImports, CPP #-} + +module Utility.Path where + +import Data.String.Utils +import System.FilePath +import System.Directory +import Data.List +import Data.Maybe +import Data.Char +import Control.Applicative + +#ifdef mingw32_HOST_OS +import qualified System.FilePath.Posix as Posix +#else +import System.Posix.Files +#endif + +import qualified "MissingH" System.Path as MissingH +import Utility.Monad +import Utility.UserInfo + +{- Simplifies a path, removing any ".." or ".", and removing the trailing + - path separator. + - + - On Windows, preserves whichever style of path separator might be used in + - the input FilePaths. This is done because some programs in Windows + - demand a particular path separator -- and which one actually varies! + - + - This does not guarantee that two paths that refer to the same location, + - and are both relative to the same location (or both absolute) will + - yeild the same result. Run both through normalise from System.FilePath + - to ensure that. + -} +simplifyPath :: FilePath -> FilePath +simplifyPath path = dropTrailingPathSeparator $ + joinDrive drive $ joinPath $ norm [] $ splitPath path' + where + (drive, path') = splitDrive path + + norm c [] = reverse c + norm c (p:ps) + | p' == ".." = norm (drop 1 c) ps + | p' == "." = norm c ps + | otherwise = norm (p:c) ps + where + p' = dropTrailingPathSeparator p + +{- Makes a path absolute. + - + - The first parameter is a base directory (ie, the cwd) to use if the path + - is not already absolute. + - + - Does not attempt to deal with edge cases or ensure security with + - untrusted inputs. + -} +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. Resulting path will use / separators. -} +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 + +{- Returns the parent directory of a path. + - + - To allow this to be easily used in loops, which terminate upon reaching the + - top, the parent of / is "" -} +parentDir :: FilePath -> FilePath +parentDir dir + | null dirs = "" + | otherwise = joinDrive drive (join s $ 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] + +prop_parentDir_basics :: FilePath -> Bool +prop_parentDir_basics dir + | null dir = True + | dir == "/" = parentDir dir == "" + | otherwise = p /= dir + where + p = parentDir dir + +{- Checks if the first FilePath is, or could be said to contain the second. + - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc + - are all equivilant. + -} +dirContains :: FilePath -> FilePath -> Bool +dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b' + where + a' = norm a + b' = norm b + norm = normalise . simplifyPath + +{- Converts a filename into an absolute path. + - + - Unlike Directory.canonicalizePath, this does not require the path + - already exists. -} +absPath :: FilePath -> IO FilePath +absPath file = do + cwd <- getCurrentDirectory + return $ absPathFrom cwd file + +{- Constructs a relative path from the CWD to a file. + - + - For example, assuming CWD is /tmp/foo/bar: + - relPathCwdToFile "/tmp/foo" == ".." + - relPathCwdToFile "/tmp/foo/bar" == "" + -} +relPathCwdToFile :: FilePath -> IO FilePath +relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f + +{- Constructs a relative path from a directory to a file. + - + - Both must be absolute, and cannot contain .. etc. (eg use absPath first). + -} +relPathDirToFile :: FilePath -> FilePath -> FilePath +relPathDirToFile from to = join s $ dotdots ++ uncommon + where + s = [pathSeparator] + pfrom = split s from + pto = split s to + common = map fst $ takeWhile same $ zip pfrom pto + same (c,d) = c == d + uncommon = drop numcommon pto + dotdots = replicate (length pfrom - numcommon) ".." + numcommon = length common + +prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool +prop_relPathDirToFile_basics from to + | from == to = null r + | otherwise = not (null r) + where + r = relPathDirToFile from to + +prop_relPathDirToFile_regressionTest :: Bool +prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference + where + {- Two paths have the same directory component at the same + - location, but it's not really the same directory. + - Code used to get this wrong. -} + same_dir_shortcurcuits_at_difference = + relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) + (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) + == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] + +{- Given an original list of paths, and an expanded list derived from it, + - generates a list of lists, where each sublist corresponds to one of the + - original paths. When the original path is a directory, any items + - in the expanded list that are contained in that directory will appear in + - its segment. + -} +segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] +segmentPaths [] new = [new] +segmentPaths [_] new = [new] -- optimisation +segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest + where + (found, rest)=partition (l `dirContains`) new + +{- This assumes that it's cheaper to call segmentPaths on the result, + - than it would be to run the action separately with each path. In + - the case of git file list commands, that assumption tends to hold. + -} +runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] +runSegmentPaths a paths = segmentPaths paths <$> a paths + +{- Converts paths in the home directory to use ~/ -} +relHome :: FilePath -> IO String +relHome path = do + home <- myHomeDir + return $ if dirContains home path + then "~/" ++ relPathDirToFile home path + else path + +{- Checks if a command is available in PATH. + - + - The command may be fully-qualified, in which case, this succeeds as + - long as it exists. -} +inPath :: String -> IO Bool +inPath command = isJust <$> searchPath command + +{- Finds a command in PATH and returns the full path to it. + - + - The command may be fully qualified already, in which case it will + - be returned if it exists. + -} +searchPath :: String -> IO (Maybe FilePath) +searchPath command + | isAbsolute command = check command + | otherwise = getSearchPath >>= getM indir + where + indir d = check $ d command + check f = firstM doesFileExist +#ifdef mingw32_HOST_OS + [f, f ++ ".exe"] +#else + [f] +#endif + +{- Checks if a filename is a unix dotfile. All files inside dotdirs + - count as dotfiles. -} +dotfile :: FilePath -> Bool +dotfile file + | f == "." = False + | f == ".." = False + | f == "" = False + | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) + where + f = takeFileName file + +{- Converts a DOS style path to a Cygwin style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' -} +toCygPath :: FilePath -> FilePath +#ifndef mingw32_HOST_OS +toCygPath = id +#else +toCygPath p + | null drive = recombine parts + | otherwise = recombine $ "/cygdrive" : driveletter drive : parts + where + (drive, p') = splitDrive p + parts = splitDirectories p' + driveletter = map toLower . takeWhile (/= ':') + recombine = fixtrailing . Posix.joinPath + fixtrailing s + | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s + | otherwise = s +#endif + +{- Maximum size to use for a file in a specified directory. + - + - Many systems have a 255 byte limit to the name of a file, + - so that's taken as the max if the system has a larger limit, or has no + - limit. + -} +fileNameLengthLimit :: FilePath -> IO Int +#ifdef mingw32_HOST_OS +fileNameLengthLimit _ = return 255 +#else +fileNameLengthLimit dir = do + l <- fromIntegral <$> getPathVar dir FileNameLimit + if l <= 0 + then return 255 + else return $ minimum [l, 255] + where +#endif + +{- Given a string that we'd like to use as the basis for FilePath, but that + - was provided by a third party and is not to be trusted, returns the closest + - sane FilePath. + - + - All spaces and punctuation and other wacky stuff are replaced + - with '_', except for '.' "../" will thus turn into ".._", which is safe. + -} +sanitizeFilePath :: String -> FilePath +sanitizeFilePath = map sanitize + where + sanitize c + | c == '.' = c + | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' + | otherwise = c + +{- Similar to splitExtensions, but knows that some things in FilePaths + - after a dot are too long to be extensions. -} +splitShortExtensions :: FilePath -> (FilePath, [String]) +splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg" +splitShortExtensions' :: Int -> FilePath -> (FilePath, [String]) +splitShortExtensions' maxextension = go [] + where + go c f + | len > 0 && len <= maxextension && not (null base) = + go (ext:c) base + | otherwise = (f, c) + where + (base, ext) = splitExtension f + len = length ext diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs new file mode 100644 index 00000000..5abbb578 --- /dev/null +++ b/src/Utility/PosixFiles.hs @@ -0,0 +1,33 @@ +{- POSIX files (and compatablity wrappers). + - + - This is like System.PosixCompat.Files, except with a fixed rename. + - + - Copyright 2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.PosixFiles ( + module X, + rename +) where + +import System.PosixCompat.Files as X hiding (rename) + +#ifndef mingw32_HOST_OS +import System.Posix.Files (rename) +#else +import qualified System.Win32.File as Win32 +#endif + +{- System.PosixCompat.Files.rename on Windows calls renameFile, + - so cannot rename directories. + - + - Instead, use Win32 moveFile, which can. It needs to be told to overwrite + - any existing file. -} +#ifdef mingw32_HOST_OS +rename :: FilePath -> FilePath -> IO () +rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING +#endif diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs new file mode 100644 index 00000000..cd3826d7 --- /dev/null +++ b/src/Utility/Process.hs @@ -0,0 +1,353 @@ +{- System.Process enhancements, including additional ways of running + - processes, and logging. + - + - Copyright 2012 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP, Rank2Types #-} + +module Utility.Process ( + module X, + CreateProcess, + StdHandle(..), + readProcess, + readProcessEnv, + writeReadProcessEnv, + forceSuccessProcess, + checkSuccessProcess, + ignoreFailureProcess, + createProcessSuccess, + createProcessChecked, + createBackgroundProcess, + processTranscript, + processTranscript', + withHandle, + withBothHandles, + withQuietOutput, + createProcess, + startInteractiveProcess, + stdinHandle, + stdoutHandle, + stderrHandle, + processHandle, + devNull, +) where + +import qualified System.Process +import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) +import System.Process hiding (createProcess, readProcess) +import System.Exit +import System.IO +import System.Log.Logger +import Control.Concurrent +import qualified Control.Exception as E +import Control.Monad +#ifndef mingw32_HOST_OS +import System.Posix.IO +#else +import Control.Applicative +#endif +import Data.Maybe + +import Utility.Misc +import Utility.Exception + +type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a + +data StdHandle = StdinHandle | StdoutHandle | StderrHandle + deriving (Eq) + +{- Normally, when reading from a process, it does not need to be fed any + - standard input. -} +readProcess :: FilePath -> [String] -> IO String +readProcess cmd args = readProcessEnv cmd args Nothing + +readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String +readProcessEnv cmd args environ = + withHandle StdoutHandle createProcessSuccess p $ \h -> do + output <- hGetContentsStrict h + hClose h + return output + where + p = (proc cmd args) + { std_out = CreatePipe + , env = environ + } + +{- Runs an action to write to a process on its stdin, + - returns its output, and also allows specifying the environment. + -} +writeReadProcessEnv + :: FilePath + -> [String] + -> Maybe [(String, String)] + -> (Maybe (Handle -> IO ())) + -> (Maybe (Handle -> IO ())) + -> IO String +writeReadProcessEnv cmd args environ writestdin adjusthandle = do + (Just inh, Just outh, _, pid) <- createProcess p + + maybe (return ()) (\a -> a inh) adjusthandle + maybe (return ()) (\a -> a outh) adjusthandle + + -- fork off a thread to start consuming the output + output <- hGetContents outh + outMVar <- newEmptyMVar + _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar () + + -- now write and flush any input + maybe (return ()) (\a -> a inh >> hFlush inh) writestdin + hClose inh -- done with stdin + + -- wait on the output + takeMVar outMVar + hClose outh + + -- wait on the process + forceSuccessProcess p pid + + return output + + where + p = (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + , env = environ + } + +{- Waits for a ProcessHandle, and throws an IOError if the process + - did not exit successfully. -} +forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () +forceSuccessProcess p pid = do + code <- waitForProcess pid + case code of + ExitSuccess -> return () + ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n + +{- Waits for a ProcessHandle and returns True if it exited successfully. + - Note that using this with createProcessChecked will throw away + - the Bool, and is only useful to ignore the exit code of a process, + - while still waiting for it. -} +checkSuccessProcess :: ProcessHandle -> IO Bool +checkSuccessProcess pid = do + code <- waitForProcess pid + return $ code == ExitSuccess + +ignoreFailureProcess :: ProcessHandle -> IO Bool +ignoreFailureProcess pid = do + void $ waitForProcess pid + return True + +{- Runs createProcess, then an action on its handles, and then + - forceSuccessProcess. -} +createProcessSuccess :: CreateProcessRunner +createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a + +{- Runs createProcess, then an action on its handles, and then + - a checker action on its exit code, which must wait for the process. -} +createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner +createProcessChecked checker p a = do + t@(_, _, _, pid) <- createProcess p + r <- tryNonAsync $ a t + _ <- checker pid + either E.throw return r + +{- Leaves the process running, suitable for lazy streaming. + - Note: Zombies will result, and must be waited on. -} +createBackgroundProcess :: CreateProcessRunner +createBackgroundProcess p a = a =<< createProcess p + +{- Runs a process, optionally feeding it some input, and + - returns a transcript combining its stdout and stderr, and + - whether it succeeded or failed. -} +processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) +processTranscript cmd opts input = processTranscript' cmd opts Nothing input + +processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool) +processTranscript' cmd opts environ input = do +#ifndef mingw32_HOST_OS +{- This implementation interleves stdout and stderr in exactly the order + - the process writes them. -} + (readf, writef) <- createPipe + readh <- fdToHandle readf + writeh <- fdToHandle writef + p@(_, _, _, pid) <- createProcess $ + (proc cmd opts) + { std_in = if isJust input then CreatePipe else Inherit + , std_out = UseHandle writeh + , std_err = UseHandle writeh + , env = environ + } + hClose writeh + + get <- mkreader readh + writeinput input p + transcript <- get + + ok <- checkSuccessProcess pid + return (transcript, ok) +#else +{- This implementation for Windows puts stderr after stdout. -} + p@(_, _, _, pid) <- createProcess $ + (proc cmd opts) + { std_in = if isJust input then CreatePipe else Inherit + , std_out = CreatePipe + , std_err = CreatePipe + , env = environ + } + + getout <- mkreader (stdoutHandle p) + geterr <- mkreader (stderrHandle p) + writeinput input p + transcript <- (++) <$> getout <*> geterr + + ok <- checkSuccessProcess pid + return (transcript, ok) +#endif + where + mkreader h = do + s <- hGetContents h + v <- newEmptyMVar + void $ forkIO $ do + void $ E.evaluate (length s) + putMVar v () + return $ do + takeMVar v + return s + + writeinput (Just s) p = do + let inh = stdinHandle p + unless (null s) $ do + hPutStr inh s + hFlush inh + hClose inh + writeinput Nothing _ = return () + +{- Runs a CreateProcessRunner, on a CreateProcess structure, that + - is adjusted to pipe only from/to a single StdHandle, and passes + - the resulting Handle to an action. -} +withHandle + :: StdHandle + -> CreateProcessRunner + -> CreateProcess + -> (Handle -> IO a) + -> IO a +withHandle h creator p a = creator p' $ a . select + where + base = p + { std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + (select, p') + | h == StdinHandle = + (stdinHandle, base { std_in = CreatePipe }) + | h == StdoutHandle = + (stdoutHandle, base { std_out = CreatePipe }) + | h == StderrHandle = + (stderrHandle, base { std_err = CreatePipe }) + +{- Like withHandle, but passes (stdin, stdout) handles to the action. -} +withBothHandles + :: CreateProcessRunner + -> CreateProcess + -> ((Handle, Handle) -> IO a) + -> IO a +withBothHandles creator p a = creator p' $ a . bothHandles + where + p' = p + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + } + +{- Forces the CreateProcessRunner to run quietly; + - both stdout and stderr are discarded. -} +withQuietOutput + :: CreateProcessRunner + -> CreateProcess + -> IO () +withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do + let p' = p + { std_out = UseHandle nullh + , std_err = UseHandle nullh + } + creator p' $ const $ return () + +devNull :: FilePath +#ifndef mingw32_HOST_OS +devNull = "/dev/null" +#else +devNull = "NUL" +#endif + +{- Extract a desired handle from createProcess's tuple. + - These partial functions are safe as long as createProcess is run + - with appropriate parameters to set up the desired handle. + - Get it wrong and the runtime crash will always happen, so should be + - easily noticed. -} +type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle +stdinHandle :: HandleExtractor +stdinHandle (Just h, _, _, _) = h +stdinHandle _ = error "expected stdinHandle" +stdoutHandle :: HandleExtractor +stdoutHandle (_, Just h, _, _) = h +stdoutHandle _ = error "expected stdoutHandle" +stderrHandle :: HandleExtractor +stderrHandle (_, _, Just h, _) = h +stderrHandle _ = error "expected stderrHandle" +bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +bothHandles (Just hin, Just hout, _, _) = (hin, hout) +bothHandles _ = error "expected bothHandles" + +processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle +processHandle (_, _, _, pid) = pid + +{- Debugging trace for a CreateProcess. -} +debugProcess :: CreateProcess -> IO () +debugProcess p = do + debugM "Utility.Process" $ unwords + [ action ++ ":" + , showCmd p + ] + where + action + | piped (std_in p) && piped (std_out p) = "chat" + | piped (std_in p) = "feed" + | piped (std_out p) = "read" + | otherwise = "call" + piped Inherit = False + piped _ = True + +{- Shows the command that a CreateProcess will run. -} +showCmd :: CreateProcess -> String +showCmd = go . cmdspec + where + go (ShellCommand s) = s + go (RawCommand c ps) = c ++ " " ++ show ps + +{- Starts an interactive process. Unlike runInteractiveProcess in + - System.Process, stderr is inherited. -} +startInteractiveProcess + :: FilePath + -> [String] + -> Maybe [(String, String)] + -> IO (ProcessHandle, Handle, Handle) +startInteractiveProcess cmd args environ = do + let p = (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + , env = environ + } + (Just from, Just to, _, pid) <- createProcess p + return (pid, to, from) + +{- Wrapper around System.Process function that does debug logging. -} +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess p = do + debugProcess p + System.Process.createProcess p diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs new file mode 100644 index 00000000..a498ee61 --- /dev/null +++ b/src/Utility/QuickCheck.hs @@ -0,0 +1,52 @@ +{- QuickCheck with additional instances + - + - Copyright 2012-2014 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Utility.QuickCheck + ( module X + , module Utility.QuickCheck + ) where + +import Test.QuickCheck as X +import Data.Time.Clock.POSIX +import System.Posix.Types +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Applicative + +instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where + arbitrary = M.fromList <$> arbitrary + +instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where + arbitrary = S.fromList <$> arbitrary + +{- Times before the epoch are excluded. -} +instance Arbitrary POSIXTime where + arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral + +instance Arbitrary EpochTime where + arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral + +{- Pids are never negative, or 0. -} +instance Arbitrary ProcessID where + arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) + +{- Inodes are never negative. -} +instance Arbitrary FileID where + arbitrary = nonNegative arbitrarySizedIntegral + +{- File sizes are never negative. -} +instance Arbitrary FileOffset where + arbitrary = nonNegative arbitrarySizedIntegral + +nonNegative :: (Num a, Ord a) => Gen a -> Gen a +nonNegative g = g `suchThat` (>= 0) + +positive :: (Num a, Ord a) => Gen a -> Gen a +positive g = g `suchThat` (> 0) diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs new file mode 100644 index 00000000..04fcf390 --- /dev/null +++ b/src/Utility/SafeCommand.hs @@ -0,0 +1,120 @@ +{- safely running shell commands + - + - Copyright 2010-2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.SafeCommand where + +import System.Exit +import Utility.Process +import System.Process (env) +import Data.String.Utils +import Control.Applicative +import System.FilePath +import Data.Char + +{- A type for parameters passed to a shell command. A command can + - be passed either some Params (multiple parameters can be included, + - whitespace-separated, or a single Param (for when parameters contain + - whitespace), or a File. + -} +data CommandParam = Params String | Param String | File FilePath + deriving (Eq, Show, Ord) + +{- Used to pass a list of CommandParams to a function that runs + - a command and expects Strings. -} +toCommand :: [CommandParam] -> [String] +toCommand = concatMap unwrap + where + unwrap (Param s) = [s] + unwrap (Params s) = filter (not . null) (split " " s) + -- Files that start with a non-alphanumeric that is not a path + -- separator are modified to avoid the command interpreting them as + -- options or other special constructs. + unwrap (File s@(h:_)) + | isAlphaNum h || h `elem` pathseps = [s] + | otherwise = ["./" ++ s] + unwrap (File s) = [s] + -- '/' is explicitly included because it's an alternative + -- path separator on Windows. + pathseps = pathSeparator:"./" + +{- Run a system command, and returns True or False + - if it succeeded or failed. + -} +boolSystem :: FilePath -> [CommandParam] -> IO Bool +boolSystem command params = boolSystemEnv command params Nothing + +boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ + where + dispatch ExitSuccess = True + dispatch _ = False + +{- Runs a system command, returning the exit status. -} +safeSystem :: FilePath -> [CommandParam] -> IO ExitCode +safeSystem command params = safeSystemEnv command params Nothing + +safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode +safeSystemEnv command params environ = do + (_, _, _, pid) <- createProcess (proc command $ toCommand params) + { env = environ } + waitForProcess pid + +{- Wraps a shell command line inside sh -c, allowing it to be run in a + - login shell that may not support POSIX shell, eg csh. -} +shellWrap :: String -> String +shellWrap cmdline = "sh -c " ++ shellEscape cmdline + +{- Escapes a filename or other parameter to be safely able to be exposed to + - the shell. + - + - This method works for POSIX shells, as well as other shells like csh. + -} +shellEscape :: String -> String +shellEscape f = "'" ++ escaped ++ "'" + where + -- replace ' with '"'"' + escaped = join "'\"'\"'" $ split "'" f + +{- Unescapes a set of shellEscaped words or filenames. -} +shellUnEscape :: String -> [String] +shellUnEscape [] = [] +shellUnEscape s = word : shellUnEscape rest + where + (word, rest) = findword "" s + findword w [] = (w, "") + findword w (c:cs) + | c == ' ' = (w, cs) + | c == '\'' = inquote c w cs + | c == '"' = inquote c w cs + | otherwise = findword (w++[c]) cs + inquote _ w [] = (w, "") + inquote q w (c:cs) + | c == q = findword w cs + | otherwise = inquote q (w++[c]) cs + +{- For quickcheck. -} +prop_idempotent_shellEscape :: String -> Bool +prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s +prop_idempotent_shellEscape_multiword :: [String] -> Bool +prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s + +{- Segements a list of filenames into groups that are all below the manximum + - command-line length limit. Does not preserve order. -} +segmentXargs :: [FilePath] -> [[FilePath]] +segmentXargs l = go l [] 0 [] + where + go [] c _ r = c:r + go (f:fs) c accumlen r + | len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r) + | otherwise = go fs (f:c) newlen r + where + len = length f + newlen = accumlen + len + + {- 10k of filenames per command, well under Linux's 20k limit; + - allows room for other parameters etc. -} + maxlen = 10240 diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs new file mode 100644 index 00000000..305410c5 --- /dev/null +++ b/src/Utility/Scheduled.hs @@ -0,0 +1,396 @@ +{- scheduled activities + - + - Copyright 2013-2014 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Scheduled ( + Schedule(..), + Recurrance(..), + ScheduledTime(..), + NextTime(..), + WeekDay, + MonthDay, + YearDay, + nextTime, + calcNextTime, + startTime, + fromSchedule, + fromScheduledTime, + toScheduledTime, + fromRecurrance, + toRecurrance, + toSchedule, + parseSchedule, + prop_schedule_roundtrips, + prop_past_sane, +) where + +import Utility.Data +import Utility.QuickCheck +import Utility.PartialPrelude +import Utility.Misc + +import Control.Applicative +import Data.List +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate +import Data.Time.Calendar.OrdinalDate +import Data.Tuple.Utils +import Data.Char + +{- Some sort of scheduled event. -} +data Schedule = Schedule Recurrance ScheduledTime + deriving (Eq, Read, Show, Ord) + +data Recurrance + = Daily + | Weekly (Maybe WeekDay) + | Monthly (Maybe MonthDay) + | Yearly (Maybe YearDay) + | Divisible Int Recurrance + -- ^ Days, Weeks, or Months of the year evenly divisible by a number. + -- (Divisible Year is years evenly divisible by a number.) + deriving (Eq, Read, Show, Ord) + +type WeekDay = Int +type MonthDay = Int +type YearDay = Int + +data ScheduledTime + = AnyTime + | SpecificTime Hour Minute + deriving (Eq, Read, Show, Ord) + +type Hour = Int +type Minute = Int + +-- | Next time a Schedule should take effect. The NextTimeWindow is used +-- when a Schedule is allowed to start at some point within the window. +data NextTime + = NextTimeExactly LocalTime + | NextTimeWindow LocalTime LocalTime + deriving (Eq, Read, Show) + +startTime :: NextTime -> LocalTime +startTime (NextTimeExactly t) = t +startTime (NextTimeWindow t _) = t + +nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime) +nextTime schedule lasttime = do + now <- getCurrentTime + tz <- getTimeZone now + return $ calcNextTime schedule lasttime $ utcToLocalTime tz now + +-- | Calculate the next time that fits a Schedule, based on the +-- last time it occurred, and the current time. +calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime +calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime + | scheduledtime == AnyTime = do + next <- findfromtoday True + return $ case next of + NextTimeWindow _ _ -> next + NextTimeExactly t -> window (localDay t) (localDay t) + | otherwise = NextTimeExactly . startTime <$> findfromtoday False + where + findfromtoday anytime = findfrom recurrance afterday today + where + today = localDay currenttime + afterday = sameaslastrun || toolatetoday + toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime + sameaslastrun = lastrun == Just today + lastrun = localDay <$> lasttime + nexttime = case scheduledtime of + AnyTime -> TimeOfDay 0 0 0 + SpecificTime h m -> TimeOfDay h m 0 + exactly d = NextTimeExactly $ LocalTime d nexttime + window startd endd = NextTimeWindow + (LocalTime startd nexttime) + (LocalTime endd (TimeOfDay 23 59 0)) + findfrom r afterday candidate + | ynum candidate > (ynum (localDay currenttime)) + 100 = + -- avoid possible infinite recusion + error $ "bug: calcNextTime did not find a time within 100 years to run " ++ + show (schedule, lasttime, currenttime) + | otherwise = findfromChecked r afterday candidate + findfromChecked r afterday candidate = case r of + Daily + | afterday -> Just $ exactly $ addDays 1 candidate + | otherwise -> Just $ exactly candidate + Weekly Nothing + | afterday -> skip 1 + | otherwise -> case (wday <$> lastrun, wday candidate) of + (Nothing, _) -> Just $ window candidate (addDays 6 candidate) + (Just old, curr) + | old == curr -> Just $ window candidate (addDays 6 candidate) + | otherwise -> skip 1 + Monthly Nothing + | afterday -> skip 1 + | maybe True (candidate `oneMonthPast`) lastrun -> + Just $ window candidate (endOfMonth candidate) + | otherwise -> skip 1 + Yearly Nothing + | afterday -> skip 1 + | maybe True (candidate `oneYearPast`) lastrun -> + Just $ window candidate (endOfYear candidate) + | otherwise -> skip 1 + Weekly (Just w) + | w < 0 || w > maxwday -> Nothing + | w == wday candidate -> if afterday + then Just $ exactly $ addDays 7 candidate + else Just $ exactly candidate + | otherwise -> Just $ exactly $ + addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate + Monthly (Just m) + | m < 0 || m > maxmday -> Nothing + -- TODO can be done more efficiently than recursing + | m == mday candidate -> if afterday + then skip 1 + else Just $ exactly candidate + | otherwise -> skip 1 + Yearly (Just y) + | y < 0 || y > maxyday -> Nothing + | y == yday candidate -> if afterday + then skip 365 + else Just $ exactly candidate + | otherwise -> skip 1 + Divisible n r'@Daily -> handlediv n r' yday (Just maxyday) + Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum) + Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum) + Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing + Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate + where + skip n = findfrom r False (addDays n candidate) + handlediv n r' getval mmax + | n > 0 && maybe True (n <=) mmax = + findfromwhere r' (divisible n . getval) afterday candidate + | otherwise = Nothing + findfromwhere r p afterday candidate + | maybe True (p . getday) next = next + | otherwise = maybe Nothing (findfromwhere r p True . getday) next + where + next = findfrom r afterday candidate + getday = localDay . startTime + divisible n v = v `rem` n == 0 + +-- Check if the new Day occurs one month or more past the old Day. +oneMonthPast :: Day -> Day -> Bool +new `oneMonthPast` old = fromGregorian y (m+1) d <= new + where + (y,m,d) = toGregorian old + +-- Check if the new Day occurs one year or more past the old Day. +oneYearPast :: Day -> Day -> Bool +new `oneYearPast` old = fromGregorian (y+1) m d <= new + where + (y,m,d) = toGregorian old + +endOfMonth :: Day -> Day +endOfMonth day = + let (y,m,_d) = toGregorian day + in fromGregorian y m (gregorianMonthLength y m) + +endOfYear :: Day -> Day +endOfYear day = + let (y,_m,_d) = toGregorian day + in endOfMonth (fromGregorian y maxmnum 1) + +-- extracting various quantities from a Day +wday :: Day -> Int +wday = thd3 . toWeekDate +wnum :: Day -> Int +wnum = snd3 . toWeekDate +mday :: Day -> Int +mday = thd3 . toGregorian +mnum :: Day -> Int +mnum = snd3 . toGregorian +yday :: Day -> Int +yday = snd . toOrdinalDate +ynum :: Day -> Int +ynum = fromIntegral . fst . toOrdinalDate + +-- Calendar max values. +maxyday :: Int +maxyday = 366 -- with leap days +maxwnum :: Int +maxwnum = 53 -- some years have more than 52 +maxmday :: Int +maxmday = 31 +maxmnum :: Int +maxmnum = 12 +maxwday :: Int +maxwday = 7 + +fromRecurrance :: Recurrance -> String +fromRecurrance (Divisible n r) = + fromRecurrance' (++ "s divisible by " ++ show n) r +fromRecurrance r = fromRecurrance' ("every " ++) r + +fromRecurrance' :: (String -> String) -> Recurrance -> String +fromRecurrance' a Daily = a "day" +fromRecurrance' a (Weekly n) = onday n (a "week") +fromRecurrance' a (Monthly n) = onday n (a "month") +fromRecurrance' a (Yearly n) = onday n (a "year") +fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used + +onday :: Maybe Int -> String -> String +onday (Just n) s = "on day " ++ show n ++ " of " ++ s +onday Nothing s = s + +toRecurrance :: String -> Maybe Recurrance +toRecurrance s = case words s of + ("every":"day":[]) -> Just Daily + ("on":"day":sd:"of":"every":something:[]) -> withday sd something + ("every":something:[]) -> noday something + ("days":"divisible":"by":sn:[]) -> + Divisible <$> getdivisor sn <*> pure Daily + ("on":"day":sd:"of":something:"divisible":"by":sn:[]) -> + Divisible + <$> getdivisor sn + <*> withday sd something + ("every":something:"divisible":"by":sn:[]) -> + Divisible + <$> getdivisor sn + <*> noday something + (something:"divisible":"by":sn:[]) -> + Divisible + <$> getdivisor sn + <*> noday something + _ -> Nothing + where + constructor "week" = Just Weekly + constructor "month" = Just Monthly + constructor "year" = Just Yearly + constructor u + | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u + | otherwise = Nothing + withday sd u = do + c <- constructor u + d <- readish sd + Just $ c (Just d) + noday u = do + c <- constructor u + Just $ c Nothing + getdivisor sn = do + n <- readish sn + if n > 0 + then Just n + else Nothing + +fromScheduledTime :: ScheduledTime -> String +fromScheduledTime AnyTime = "any time" +fromScheduledTime (SpecificTime h m) = + show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm + where + pad n s = take (n - length s) (repeat '0') ++ s + (h', ampm) + | h == 0 = (12, "AM") + | h < 12 = (h, "AM") + | h == 12 = (h, "PM") + | otherwise = (h - 12, "PM") + +toScheduledTime :: String -> Maybe ScheduledTime +toScheduledTime "any time" = Just AnyTime +toScheduledTime v = case words v of + (s:ampm:[]) + | map toUpper ampm == "AM" -> + go s h0 + | map toUpper ampm == "PM" -> + go s (\h -> (h0 h) + 12) + | otherwise -> Nothing + (s:[]) -> go s id + _ -> Nothing + where + h0 h + | h == 12 = 0 + | otherwise = h + go :: String -> (Int -> Int) -> Maybe ScheduledTime + go s adjust = + let (h, m) = separate (== ':') s + in SpecificTime + <$> (adjust <$> readish h) + <*> if null m then Just 0 else readish m + +fromSchedule :: Schedule -> String +fromSchedule (Schedule recurrance scheduledtime) = unwords + [ fromRecurrance recurrance + , "at" + , fromScheduledTime scheduledtime + ] + +toSchedule :: String -> Maybe Schedule +toSchedule = eitherToMaybe . parseSchedule + +parseSchedule :: String -> Either String Schedule +parseSchedule s = do + r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right + (toRecurrance recurrance) + t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right + (toScheduledTime scheduledtime) + Right $ Schedule r t + where + (rws, tws) = separate (== "at") (words s) + recurrance = unwords rws + scheduledtime = unwords tws + +instance Arbitrary Schedule where + arbitrary = Schedule <$> arbitrary <*> arbitrary + +instance Arbitrary ScheduledTime where + arbitrary = oneof + [ pure AnyTime + , SpecificTime + <$> choose (0, 23) + <*> choose (1, 59) + ] + +instance Arbitrary Recurrance where + arbitrary = oneof + [ pure Daily + , Weekly <$> arbday + , Monthly <$> arbday + , Yearly <$> arbday + , Divisible + <$> positive arbitrary + <*> oneof -- no nested Divisibles + [ pure Daily + , Weekly <$> arbday + , Monthly <$> arbday + , Yearly <$> arbday + ] + ] + where + arbday = oneof + [ Just <$> nonNegative arbitrary + , pure Nothing + ] + +prop_schedule_roundtrips :: Schedule -> Bool +prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s + +prop_past_sane :: Bool +prop_past_sane = and + [ all (checksout oneMonthPast) (mplus1 ++ yplus1) + , all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1)) + , all (checksout oneYearPast) yplus1 + , all (not . (checksout oneYearPast)) (map swap yplus1) + ] + where + mplus1 = -- new date old date, 1+ months before it + [ (fromGregorian 2014 01 15, fromGregorian 2013 12 15) + , (fromGregorian 2014 01 15, fromGregorian 2013 02 15) + , (fromGregorian 2014 02 15, fromGregorian 2013 01 15) + , (fromGregorian 2014 03 01, fromGregorian 2013 01 15) + , (fromGregorian 2014 03 01, fromGregorian 2013 12 15) + , (fromGregorian 2015 01 01, fromGregorian 2010 01 01) + ] + yplus1 = -- new date old date, 1+ years before it + [ (fromGregorian 2014 01 15, fromGregorian 2012 01 16) + , (fromGregorian 2014 01 15, fromGregorian 2013 01 14) + , (fromGregorian 2022 12 31, fromGregorian 2000 01 01) + ] + checksout cmp (new, old) = new `cmp` old + swap (a,b) = (b,a) diff --git a/src/Utility/Table.hs b/src/Utility/Table.hs new file mode 100644 index 00000000..910038e8 --- /dev/null +++ b/src/Utility/Table.hs @@ -0,0 +1,28 @@ +{- text based table generation + - + - Copyright 2014 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Table where + +type Table = [[String]] + +-- | A table with a header that is set off with lines under each +-- header item. +tableWithHeader :: [String] -> [[String]] -> Table +tableWithHeader header rows = header : map linesep header : rows + where + linesep = map (const '-') + +-- | Formats a table to lines, automatically padding rows to the same size. +formatTable :: Table -> [String] +formatTable table = map (\r -> unwords (map pad (zip r rowsizes))) table + where + pad (cell, size) = cell ++ take (size - length cell) padding + padding = repeat ' ' + rowsizes = sumrows (map (map length) table) + sumrows [] = repeat 0 + sumrows [r] = r + sumrows (r1:r2:rs) = sumrows $ map (uncurry max) (zip r1 r2) : rs diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs new file mode 100644 index 00000000..fc026d7e --- /dev/null +++ b/src/Utility/ThreadScheduler.hs @@ -0,0 +1,75 @@ +{- thread scheduling + - + - Copyright 2012, 2013 Joey Hess + - Copyright 2011 Bas van Dijk & Roel van Dijk + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.ThreadScheduler where + +import Control.Monad +import Control.Concurrent +#ifndef mingw32_HOST_OS +import Control.Monad.IfElse +import System.Posix.IO +#endif +#ifndef mingw32_HOST_OS +import System.Posix.Signals +#ifndef __ANDROID__ +import System.Posix.Terminal +#endif +#endif + +newtype Seconds = Seconds { fromSeconds :: Int } + deriving (Eq, Ord, Show) + +type Microseconds = Integer + +{- Runs an action repeatedly forever, sleeping at least the specified number + - of seconds in between. -} +runEvery :: Seconds -> IO a -> IO a +runEvery n a = forever $ do + threadDelaySeconds n + a + +threadDelaySeconds :: Seconds -> IO () +threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond) + +{- Like threadDelay, but not bounded by an Int. + - + - There is no guarantee that the thread will be rescheduled promptly when the + - delay has expired, but the thread will never continue to run earlier than + - specified. + - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines + - of code. + -} +unboundDelay :: Microseconds -> IO () +unboundDelay time = do + let maxWait = min time $ toInteger (maxBound :: Int) + threadDelay $ fromInteger maxWait + when (maxWait /= time) $ unboundDelay (time - maxWait) + +{- Pauses the main thread, letting children run until program termination. -} +waitForTermination :: IO () +waitForTermination = do +#ifdef mingw32_HOST_OS + runEvery (Seconds 600) $ + void getLine +#else + lock <- newEmptyMVar + let check sig = void $ + installHandler sig (CatchOnce $ putMVar lock ()) Nothing + check softwareTermination +#ifndef __ANDROID__ + whenM (queryTerminal stdInput) $ + check keyboardSignal +#endif + takeMVar lock +#endif + +oneSecond :: Microseconds +oneSecond = 1000000 diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs new file mode 100644 index 00000000..0dc9f2c0 --- /dev/null +++ b/src/Utility/Tmp.hs @@ -0,0 +1,100 @@ +{- Temporary files and directories. + - + - Copyright 2010-2013 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Tmp where + +import Control.Exception (bracket) +import System.IO +import System.Directory +import Control.Monad.IfElse +import System.FilePath + +import Utility.Exception +import Utility.FileSystemEncoding +import Utility.PosixFiles + +type Template = String + +{- Runs an action like writeFile, writing to a temp file first and + - then moving it into place. The temp file is stored in the same + - directory as the final file to avoid cross-device renames. -} +viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () +viaTmp a file content = do + let (dir, base) = splitFileName file + createDirectoryIfMissing True dir + (tmpfile, handle) <- openTempFile dir (base ++ ".tmp") + hClose handle + a tmpfile content + rename tmpfile file + +{- Runs an action with a tmp file located in the system's tmp directory + - (or in "." if there is none) then removes the file. -} +withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFile template a = do + tmpdir <- catchDefaultIO "." getTemporaryDirectory + withTmpFileIn tmpdir template a + +{- Runs an action with a tmp file located in the specified directory, + - then removes the file. -} +withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFileIn tmpdir template a = bracket create remove use + where + create = openTempFile tmpdir template + remove (name, handle) = do + hClose handle + catchBoolIO (removeFile name >> return True) + use (name, handle) = a name handle + +{- Runs an action with a tmp directory located within the system's tmp + - directory (or within "." if there is none), then removes the tmp + - directory and all its contents. -} +withTmpDir :: Template -> (FilePath -> IO a) -> IO a +withTmpDir template a = do + tmpdir <- catchDefaultIO "." getTemporaryDirectory + withTmpDirIn tmpdir template a + +{- Runs an action with a tmp directory located within a specified directory, + - then removes the tmp directory and all its contents. -} +withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a +withTmpDirIn tmpdir template = bracket create remove + where + remove d = whenM (doesDirectoryExist d) $ do +#if mingw32_HOST_OS + -- Windows will often refuse to delete a file + -- after a process has just written to it and exited. + -- Because it's crap, presumably. So, ignore failure + -- to delete the temp directory. + _ <- tryIO $ removeDirectoryRecursive d + return () +#else + removeDirectoryRecursive d +#endif + create = do + createDirectoryIfMissing True tmpdir + makenewdir (tmpdir template) (0 :: Int) + makenewdir t n = do + let dir = t ++ "." ++ show n + either (const $ makenewdir t $ n + 1) (const $ return dir) + =<< tryIO (createDirectory dir) + +{- It's not safe to use a FilePath of an existing file as the template + - for openTempFile, because if the FilePath is really long, the tmpfile + - will be longer, and may exceed the maximum filename length. + - + - This generates a template that is never too long. + - (Well, it allocates 20 characters for use in making a unique temp file, + - anyway, which is enough for the current implementation and any + - likely implementation.) + -} +relatedTemplate :: FilePath -> FilePath +relatedTemplate f + | len > 20 = truncateFilePath (len - 20) f + | otherwise = f + where + len = length f diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs new file mode 100644 index 00000000..617c3e94 --- /dev/null +++ b/src/Utility/UserInfo.hs @@ -0,0 +1,55 @@ +{- user info + - + - Copyright 2012 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.UserInfo ( + myHomeDir, + myUserName, + myUserGecos, +) where + +import Control.Applicative +import System.PosixCompat + +import Utility.Env + +{- Current user's home directory. + - + - getpwent will fail on LDAP or NIS, so use HOME if set. -} +myHomeDir :: IO FilePath +myHomeDir = myVal env homeDirectory + where +#ifndef mingw32_HOST_OS + env = ["HOME"] +#else + env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin +#endif + +{- Current user's user name. -} +myUserName :: IO String +myUserName = myVal env userName + where +#ifndef mingw32_HOST_OS + env = ["USER", "LOGNAME"] +#else + env = ["USERNAME", "USER", "LOGNAME"] +#endif + +myUserGecos :: IO String +#ifdef __ANDROID__ +myUserGecos = return "" -- userGecos crashes on Android +#else +myUserGecos = myVal [] userGecos +#endif + +myVal :: [String] -> (UserEntry -> String) -> IO String +myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars + where + check [] = return Nothing + check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v + getpwent = getUserEntryForID =<< getEffectiveUserID diff --git a/src/config.hs b/src/config.hs new file mode 120000 index 00000000..e3af968e --- /dev/null +++ b/src/config.hs @@ -0,0 +1 @@ +../config.hs \ No newline at end of file diff --git a/src/wrapper.hs b/src/wrapper.hs new file mode 100644 index 00000000..4d2c50fc --- /dev/null +++ b/src/wrapper.hs @@ -0,0 +1,93 @@ +-- | Wrapper program for propellor 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 installs propellor's source into ~/.propellor, +-- uses it to build the real propellor program (if not already built), +-- and runs it. +-- +-- The source is either copied from /usr/src/propellor, or is cloned from +-- git over the network. + +module Main where + +import Utility.UserInfo +import Utility.Monad +import Utility.Process +import Utility.SafeCommand +import Utility.Directory + +import Control.Monad +import Control.Monad.IfElse +import System.Directory +import System.FilePath +import System.Environment (getArgs) +import System.Exit +import System.Posix.Directory + +srcdir :: FilePath +srcdir = "/usr/src/propellor" + +-- Using the github mirror of the main propellor repo because +-- it is accessible over https for better security. +srcrepo :: String +srcrepo = "https://github.com/joeyh/propellor.git" + +main :: IO () +main = do + args <- getArgs + home <- myHomeDir + let propellordir = home ".propellor" + let propellorbin = propellordir "propellor" + wrapper args propellordir propellorbin + +wrapper :: [String] -> FilePath -> FilePath -> IO () +wrapper args propellordir propellorbin = do + unlessM (doesDirectoryExist propellordir) $ + makeRepo + buildruncfg + where + chain = do + (_, _, _, pid) <- createProcess (proc propellorbin args) + exitWith =<< waitForProcess pid + makeRepo = do + putStrLn $ "Setting up your propellor repo in " ++ propellordir + putStrLn "" + ifM (doesDirectoryExist srcdir) + ( do + void $ boolSystem "cp" [Param "-a", File srcdir, File propellordir] + changeWorkingDirectory propellordir + void $ boolSystem "git" [Param "init"] + void $ boolSystem "git" [Param "add", Param "."] + setuprepo True + , do + void $ boolSystem "git" [Param "clone", Param srcrepo, File propellordir] + void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"] + setuprepo False + ) + setuprepo fromsrcdir = do + changeWorkingDirectory propellordir + whenM (doesDirectoryExist "privdata") $ + mapM_ nukeFile =<< dirContents "privdata" + void $ boolSystem "git" [Param "commit", Param "--allow-empty", Param "--quiet", Param "-m", Param "setting up propellor git repository"] + void $ boolSystem "git" [Param "remote", Param "add", Param "upstream", Param srcrepo] + -- Connect synthetic git repo with upstream history so + -- merging with upstream will work going forward. + -- Note -s ours is used to avoid getting any divergent + -- changes from upstream. + when fromsrcdir $ do + void $ boolSystem "git" [Param "fetch", Param "upstream"] + version <- readProcess "dpkg-query" ["--showformat", "${Version}", "--show", "propellor"] + void $ boolSystem "git" [Param "merge", Param "-s", Param "ours", Param version] + buildruncfg = do + changeWorkingDirectory propellordir + ifM (boolSystem "make" [Param "build"]) + ( do + putStrLn "" + putStrLn "" + chain + , error "Propellor build failed." + ) -- cgit v1.2.3