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
This commit is contained in:
Joey Hess 2014-07-09 22:11:31 -04:00
commit 82da31b3e0
115 changed files with 9094 additions and 0 deletions

1
CHANGELOG Symbolic link
View File

@ -0,0 +1 @@
debian/changelog

22
LICENSE Normal file
View File

@ -0,0 +1,22 @@
Copyright 2014 Joey Hess <joeyh@debian.org> 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.

45
Makefile Normal file
View File

@ -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

1
README.md Symbolic link
View File

@ -0,0 +1 @@
doc/README.mdwn

5
Setup.hs Normal file
View File

@ -0,0 +1,5 @@
{- cabal setup file -}
import Distribution.Simple
main = defaultMain

416
config-joey.hs Normal file
View File

@ -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"
]

49
config-simple.hs Normal file
View File

@ -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" = ...
]

1
config.hs Symbolic link
View File

@ -0,0 +1 @@
config-simple.hs

7
debian/README.Debian vendored Normal file
View File

@ -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.

194
debian/changelog vendored Normal file
View File

@ -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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> 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 <joeyh@debian.org> Fri, 04 Apr 2014 01:07:32 -0400
propellor (0.2.1) unstable; urgency=medium
* First release with Debian package.
-- Joey Hess <joeyh@debian.org> 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 <joeyh@debian.org> Wed, 02 Apr 2014 13:57:42 -0400

1
debian/compat vendored Normal file
View File

@ -0,0 +1 @@
9

44
debian/control vendored Normal file
View File

@ -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 <joeyh@debian.org>
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.

28
debian/copyright vendored Normal file
View File

@ -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 <joey@kitenet.net>
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.

2
debian/lintian-overrides vendored Normal file
View File

@ -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

15
debian/propellor.1 vendored Normal file
View File

@ -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 <joey@kitenet.net>

18
debian/rules vendored Executable file
View File

@ -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

71
doc/README.mdwn Normal file
View File

@ -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 <propellor@joeyh.name>!
## 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.

9
doc/comments.mdwn Normal file
View File

@ -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"]]

4
doc/forum.mdwn Normal file
View File

@ -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:"]]

View File

@ -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?

View File

@ -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.
"""]]

View File

@ -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)

View File

@ -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:
<pre>
[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/
</pre>
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.
"""]]

120
doc/haskell_newbie.mdwn Normal file
View File

@ -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.
<pre>
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"]'
</pre>
Similarly, if you make a typo in the config file, you'll probably get a long
but informative error message.
<pre>
config.hs:27:19:
Not in scope: `Apt.standardSourcesList'
Perhaps you meant one of these:
`Apt.stdSourcesList' (imported from Propellor.Property.Apt)
...
</pre>
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/).)

31
doc/index.mdwn Normal file
View File

@ -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!
<pre>
-- _ ______`| ,-.__
{- Propellor -- / \___-=O`/|O`/__| (____.'
Deployed -} -- \ / | / ) _.-"-._
-- `/-==__ _/__|/__=-| ( \_
hosts :: [Host] -- * \ | | '--------'
hosts = -- (o) `
</pre>
Propellor is free software, licensed under the BSD license.
## news
[[!inline pages="news/* and !*/Discussion" show="4" archive=yes]]

4
doc/install.mdwn Normal file
View File

@ -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.

View File

@ -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."""]]

View File

@ -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)."""]]

View File

@ -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."""]]

View File

@ -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."""]]

View File

@ -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"."""]]

37
doc/security.mdwn Normal file
View File

@ -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.

6
doc/todo.mdwn Normal file
View File

@ -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]]

View File

@ -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]]

View File

@ -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.

View File

@ -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
"""]]

View File

@ -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.
"""]]

4
doc/todo/done.mdwn Normal file
View File

@ -0,0 +1,4 @@
recently fixed [[todo]] items.
[[!inline pages="./* and link(./done) and !*/Discussion" sort=mtime show=10
archive=yes]]

7
doc/todo/hooks.mdwn Normal file
View File

@ -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.

View File

@ -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.

View File

@ -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.

View File

@ -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.

View File

@ -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.
"""]]

View File

@ -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!
"""]]

View File

@ -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.
"""]]

View File

@ -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)

BIN
privdata/keyring.gpg Normal file

Binary file not shown.

439
privdata/privdata.gpg Normal file
View File

@ -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-----

139
propellor.cabal Normal file
View File

@ -0,0 +1,139 @@
Name: propellor
Version: 0.8.1
Cabal-Version: >= 1.6
License: BSD3
Maintainer: Joey Hess <joey@kitenet.net>
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

77
src/Propellor.hs Normal file
View File

@ -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 <git://git.kitenet.net/propellor>
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"

405
src/Propellor/CmdLine.hs Normal file
View File

@ -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

49
src/Propellor/Engine.hs Normal file
View File

@ -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

View File

@ -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

83
src/Propellor/Info.hs Normal file
View File

@ -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

66
src/Propellor/Message.hs Normal file
View File

@ -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

175
src/Propellor/PrivData.hs Normal file
View File

@ -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

163
src/Propellor/Property.hs Normal file
View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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)

View File

@ -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"

View File

@ -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

View File

@ -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: <number><optional unit>, 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

View File

@ -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

View File

@ -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

View File

@ -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 </dev/null fixes an intermittent
-- "fatal: read error: Bad file descriptor"
-- when run across ssh with propellor --spin
[ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"
, Just $ "cd " ++ shellEscape dir
, ("git checkout " ++) <$> 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"
]

View File

@ -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"

View File

@ -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"

View File

@ -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
]
]

View File

@ -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"
]

View File

@ -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"

View File

@ -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

View File

@ -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]

View File

@ -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-----"
]

View File

@ -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)

View File

@ -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)
]

View File

@ -0,0 +1,7 @@
module Propellor.Property.Reboot where
import Propellor
now :: Property
now = cmdProperty "reboot" []
`describe` "reboot now"

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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")

View File

@ -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 ++ "/"
, " <Directory " ++ 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"
, " </Directory>"
]
]
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/"
, " <Directory /srv/web/git.kitenet.net/>"
, " Options Indexes ExecCGI FollowSymlinks"
, " AllowOverride None"
, " AddHandler cgi-script .cgi"
, " DirectoryIndex index.cgi"
, " </Directory>"
, ""
, " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/"
, " <Directory /usr/lib/cgi-bin>"
, " SetHandler cgi-script"
, " Options ExecCGI"
, " </Directory>"
]
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
, " <Directory /srv/web/"++hn++">"
, " Options FollowSymLinks"
, " AllowOverride None"
, " </Directory>"
, " <Directory /srv/web/"++hn++">"
, " Options Indexes FollowSymLinks ExecCGI"
, " AllowOverride None"
, " AddHandler cgi-script .cgi"
, " DirectoryIndex index.html index.cgi"
, " Order allow,deny"
, " allow from all"
, " </Directory>"
]
apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
apachecfg hn withssl middle
| withssl = vhost False ++ vhost True
| otherwise = vhost False
where
vhost ssl =
[ "<VirtualHost *:"++show port++">"
, " 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"
, " "
, " <Directory \"/usr/share/apache2/icons\">"
, " Options Indexes MultiViews"
, " AllowOverride None"
, " Order allow,deny"
, " Allow from all"
, " </Directory>"
, "</VirtualHost>"
]
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"

View File

@ -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
]

View File

@ -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]

View File

@ -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"]

View File

@ -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

101
src/Propellor/SimpleSh.hs Normal file
View File

@ -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

149
src/Propellor/Types.hs Normal file
View File

@ -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)

112
src/Propellor/Types/Dns.hs Normal file
View File

@ -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

View File

@ -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))
]

27
src/Propellor/Types/OS.hs Normal file
View File

@ -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

View File

@ -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)

View File

@ -0,0 +1,16 @@
{- applicative stuff
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- 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 <$$>

17
src/Utility/Data.hs Normal file
View File

@ -0,0 +1,17 @@
{- utilities for simple data types
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- 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

135
src/Utility/Directory.hs Normal file
View File

@ -0,0 +1,135 @@
{- directory manipulation
-
- Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- 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

81
src/Utility/Env.hs Normal file
View File

@ -0,0 +1,81 @@
{- portable environment variables
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- 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

59
src/Utility/Exception.hs Normal file
View File

@ -0,0 +1,59 @@
{- Simple IO exception handling (and some more)
-
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
-
- 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

158
src/Utility/FileMode.hs Normal file
View File

@ -0,0 +1,158 @@
{- File mode utilities.
-
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- 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

View File

@ -0,0 +1,132 @@
{- GHC File system encoding handling.
-
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- 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

View File

@ -0,0 +1,61 @@
{- Linux library copier and binary shimmer
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- 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'"]

Some files were not shown because too many files have changed in this diff Show More