cadey
/
propellor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'joeyconfig'

This commit is contained in:
Joey Hess 2014-11-20 00:58:51 -04:00
parent f1b2df601e 0d4dd37ee7
commit 02b8b2dec7
24 changed files with 777 additions and 566 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
config-joey.hs
View File

@ -24,6 +24,7 @@ import qualified Propellor.Property.Postfix as Postfix
import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Gpg as Gpg
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean
import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
import qualified Propellor.Property.HostingProvider.Linode as Linode import qualified Propellor.Property.HostingProvider.Linode as Linode
@ -44,7 +45,7 @@ hosts = -- (o) `
, kite , kite
, diatom , diatom
, elephant , elephant
] ++ containers ++ monsters ] ++ monsters
darkstar :: Host darkstar :: Host
darkstar = host "darkstar.kitenet.net" darkstar = host "darkstar.kitenet.net"
@ -52,7 +53,7 @@ darkstar = host "darkstar.kitenet.net"
& Apt.buildDep ["git-annex"] `period` Daily & Apt.buildDep ["git-annex"] `period` Daily
& Docker.configured & Docker.configured
! Docker.docked hosts "android-git-annex" ! Docker.docked gitAnnexAndroidDev
clam :: Host clam :: Host
clam = standardSystem "clam.kitenet.net" Unstable "amd64" clam = standardSystem "clam.kitenet.net" Unstable "amd64"
@ -67,7 +68,7 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
& Docker.configured & Docker.configured
& Docker.garbageCollected `period` Daily & Docker.garbageCollected `period` Daily
& Docker.docked hosts "webserver" & Docker.docked webserver
& File.dirExists "/var/www/html" & File.dirExists "/var/www/html"
& File.notPresent "/var/www/html/index.html" & File.notPresent "/var/www/html/index.html"
& "/var/www/index.html" `File.hasContent` ["hello, world"] & "/var/www/index.html" `File.hasContent` ["hello, world"]
@ -78,6 +79,8 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
& alias "travelling.kitenet.net" & alias "travelling.kitenet.net"
! Ssh.listenPort 80 ! Ssh.listenPort 80
! Ssh.listenPort 443 ! Ssh.listenPort 443
! Debootstrap.built "/tmp/chroot" (System (Debian Unstable) "amd64") []
orca :: Host orca :: Host
orca = standardSystem "orca.kitenet.net" Unstable "amd64" orca = standardSystem "orca.kitenet.net" Unstable "amd64"
@ -87,11 +90,11 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
& Apt.unattendedUpgrades & Apt.unattendedUpgrades
& Postfix.satellite & Postfix.satellite
& Docker.configured & Docker.configured
& Docker.docked hosts "amd64-git-annex-builder" & Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h")
& Docker.docked hosts "i386-git-annex-builder" & Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h")
& Docker.docked hosts "android-git-annex-builder" & Docker.docked (GitAnnexBuilder.armelCompanionContainer dockerImage)
& Docker.docked hosts "armel-git-annex-builder-companion" & Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h")
& Docker.docked hosts "armel-git-annex-builder" & Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h")
& Docker.garbageCollected `period` Daily & Docker.garbageCollected `period` Daily
& Apt.buildDep ["git-annex"] `period` Daily & Apt.buildDep ["git-annex"] `period` Daily
@ -254,11 +257,10 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
& myDnsSecondary & myDnsSecondary
& Docker.configured & Docker.configured
& Docker.docked hosts "oldusenet-shellbox" & Docker.docked oldusenetShellBox
& Docker.docked hosts "openid-provider" & Docker.docked openidProvider
`requires` Apt.serviceInstalledRunning "ntp" `requires` Apt.serviceInstalledRunning "ntp"
& Docker.docked hosts "ancient-kitenet" & Docker.docked ancientKitenet
& Docker.garbageCollected `period` (Weekly (Just 1)) & Docker.garbageCollected `period` (Weekly (Just 1))
-- For https port 443, shellinabox with ssh login to -- For https port 443, shellinabox with ssh login to
@ -280,48 +282,43 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
----------------------- : / ----------------------- ----------------------- : / -----------------------
------------------------ \____, o ,' ------------------------ ------------------------ \____, o ,' ------------------------
------------------------- '--,___________,' ------------------------- ------------------------- '--,___________,' -------------------------
containers :: [Host] -- Simple web server, publishing the outside host's /var/www
containers = webserver :: Docker.Container
-- Simple web server, publishing the outside host's /var/www webserver = standardStableContainer "webserver"
[ standardStableContainer "webserver" & Docker.publish "80:80"
& Docker.publish "80:80" & Docker.volume "/var/www:/var/www"
& Docker.volume "/var/www:/var/www" & Apt.serviceInstalledRunning "apache2"
& Apt.serviceInstalledRunning "apache2"
-- My own openid provider. Uses php, so containerized for security -- My own openid provider. Uses php, so containerized for security
-- and administrative sanity. -- and administrative sanity.
, standardStableContainer "openid-provider" openidProvider :: Docker.Container
& alias "openid.kitenet.net" openidProvider = standardStableContainer "openid-provider"
& Docker.publish "8081:80" & alias "openid.kitenet.net"
& OpenId.providerFor ["joey", "liw"] & Docker.publish "8081:80"
"openid.kitenet.net:8081" & OpenId.providerFor ["joey", "liw"]
"openid.kitenet.net:8081"
-- Exhibit: kite's 90's website. -- Exhibit: kite's 90's website.
, standardStableContainer "ancient-kitenet" ancientKitenet :: Docker.Container
& alias "ancient.kitenet.net" ancientKitenet = standardStableContainer "ancient-kitenet"
& Docker.publish "1994:80" & alias "ancient.kitenet.net"
& Apt.serviceInstalledRunning "apache2" & Docker.publish "1994:80"
& Git.cloned "root" "git://kitenet-net.branchable.com/" "/var/www" & Apt.serviceInstalledRunning "apache2"
(Just "remotes/origin/old-kitenet.net") & Git.cloned "root" "git://kitenet-net.branchable.com/" "/var/www"
(Just "remotes/origin/old-kitenet.net")
, standardStableContainer "oldusenet-shellbox"
& alias "shell.olduse.net"
& Docker.publish "4200:4200"
& JoeySites.oldUseNetShellBox
-- git-annex autobuilder containers oldusenetShellBox :: Docker.Container
, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h" oldusenetShellBox = standardStableContainer "oldusenet-shellbox"
, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h" & alias "shell.olduse.net"
, GitAnnexBuilder.armelCompanionContainer dockerImage & Docker.publish "4200:4200"
, GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h" & JoeySites.oldUseNetShellBox
, GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h"
-- for development of git-annex for android, using my git-annex -- for development of git-annex for android, using my git-annex work tree
-- work tree gitAnnexAndroidDev :: Docker.Container
, let gitannexdir = GitAnnexBuilder.homedir </> "git-annex" gitAnnexAndroidDev = GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir
in GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir & Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir)
& Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir) where
] gitannexdir = GitAnnexBuilder.homedir </> "git-annex"
type Motd = [String] type Motd = [String]
@ -355,11 +352,11 @@ standardSystemUnhardened hn suite arch motd = host hn
& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
`onChange` Apt.autoRemove `onChange` Apt.autoRemove
standardStableContainer :: Docker.ContainerName -> Host standardStableContainer :: Docker.ContainerName -> Docker.Container
standardStableContainer name = standardContainer name (Stable "wheezy") "amd64" standardStableContainer name = standardContainer name (Stable "wheezy") "amd64"
-- This is my standard container setup, featuring automatic upgrades. -- This is my standard container setup, featuring automatic upgrades.
standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container
standardContainer name suite arch = Docker.container name (dockerImage system) standardContainer name suite arch = Docker.container name (dockerImage system)
& os system & os system
& Apt.stdSourcesList `onChange` Apt.upgrade & Apt.stdSourcesList `onChange` Apt.upgrade

19
config-simple.hs
View File

@ -32,18 +32,19 @@ hosts =
& User.hasSomePassword "root" (Context "mybox.example.com") & User.hasSomePassword "root" (Context "mybox.example.com")
& Network.ipv6to4 & Network.ipv6to4
& File.dirExists "/var/www" & File.dirExists "/var/www"
& Docker.docked hosts "webserver" & Docker.docked webserverContainer
& Docker.garbageCollected `period` Daily & Docker.garbageCollected `period` Daily
& Cron.runPropellor "30 * * * *" & Cron.runPropellor "30 * * * *"
-- A generic webserver in a Docker container.
, Docker.container "webserver" "joeyh/debian-stable"
& os (System (Debian (Stable "wheezy")) "amd64")
& Apt.stdSourcesList
& Docker.publish "80:80"
& Docker.volume "/var/www:/var/www"
& Apt.serviceInstalledRunning "apache2"
-- add more hosts here... -- add more hosts here...
--, host "foo.example.com" = ... --, host "foo.example.com" = ...
] ]
-- A generic webserver in a Docker container.
webserverContainer :: Docker.Container
webserverContainer = Docker.container "webserver" "joeyh/debian-stable"
& os (System (Debian (Stable "wheezy")) "amd64")
& Apt.stdSourcesList
& Docker.publish "80:80"
& Docker.volume "/var/www:/var/www"
& Apt.serviceInstalledRunning "apache2"

26
debian/changelog vendored
View File

@ -1,4 +1,4 @@
propellor (0.9.3) UNRELEASED; urgency=medium propellor (1.0.0) UNRELEASED; urgency=medium
* propellor --spin can now be used to update remote hosts, without * propellor --spin can now be used to update remote hosts, without
any central git repository needed. The central git repository is any central git repository needed. The central git repository is
@ -9,13 +9,18 @@ propellor (0.9.3) UNRELEASED; urgency=medium
* Can be used to configure tor hidden services. Thanks, Félix Sipma. * Can be used to configure tor hidden services. Thanks, Félix Sipma.
* When multiple gpg keys are added, ensure that the privdata file * When multiple gpg keys are added, ensure that the privdata file
can be decrypted by all of them. can be decrypted by all of them.
* Convert GpgKeyId to newtype. * Convert GpgKeyId to newtype. (API change)
* DigitalOcean.distroKernel property now reboots into the distribution * DigitalOcean.distroKernel property now reboots into the distribution
kernel when necessary. kernel when necessary.
* Avoid outputting color setting sequences when not run on a terminal. * Avoid outputting color setting sequences when not run on a terminal.
* Run remote propellor --spin with a controlling terminal. * Run remote propellor --spin with a controlling terminal.
* Docker code simplified by using `docker exec`; needs docker 1.3.1.
* Docker containers are now a separate data type, cannot be included
in the main host list, and are instead passed to
Docker.docked. (API change)
* Added support for using debootstrap from propellor.
-- Joey Hess <joeyh@debian.org> Mon, 10 Nov 2014 11:15:27 -0400 -- Joey Hess <id@joeyh.name> Mon, 10 Nov 2014 11:15:27 -0400
propellor (0.9.2) unstable; urgency=medium propellor (0.9.2) unstable; urgency=medium
@ -32,7 +37,7 @@ propellor (0.9.1) unstable; urgency=medium
* Docker: Add ability to control when containers restart. * Docker: Add ability to control when containers restart.
* Docker: Default to always restarting containers, so they come back * Docker: Default to always restarting containers, so they come back
up after reboots and docker daemon upgrades. up after reboots and docker daemon upgrades. (API change)
* Fix loop when a docker host that does not exist was docked. * Fix loop when a docker host that does not exist was docked.
-- Joey Hess <joeyh@debian.org> Fri, 24 Oct 2014 09:57:31 -0400 -- Joey Hess <joeyh@debian.org> Fri, 24 Oct 2014 09:57:31 -0400
@ -45,7 +50,7 @@ propellor (0.9.0) unstable; urgency=medium
Instead, the os property for a stable system includes the suite name Instead, the os property for a stable system includes the suite name
to use, eg Stable "wheezy". to use, eg Stable "wheezy".
* stdSourcesList uses the stable suite name, to avoid unwanted * stdSourcesList uses the stable suite name, to avoid unwanted
immediate upgrades to the next stable release. immediate upgrades to the next stable release. (API change)
* debCdn switched from cdn.debian.net to http.debian.net, which seems to be * debCdn switched from cdn.debian.net to http.debian.net, which seems to be
better managed now. better managed now.
* Docker: Avoid committing container every time it's started up. * Docker: Avoid committing container every time it's started up.
@ -120,7 +125,7 @@ propellor (0.7.0) unstable; urgency=medium
* combineProperties no longer stops when a property fails; now it continues * combineProperties no longer stops when a property fails; now it continues
trying to satisfy all properties on the list before propigating the trying to satisfy all properties on the list before propigating the
failure. failure.
* Attr is renamed to Info. * Attr is renamed to Info. (API change)
* Renamed wrapper to propellor to make cabal installation of propellor work. * Renamed wrapper to propellor to make cabal installation of propellor work.
* When git gpg signature of a fetched git branch cannot be verified, * When git gpg signature of a fetched git branch cannot be verified,
propellor will now continue running, but without merging in that branch. propellor will now continue running, but without merging in that branch.
@ -133,7 +138,7 @@ propellor (0.6.0) unstable; urgency=medium
docked in. So if a docker container sets a DNS alias, every container 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, it's docked in will automatically be added to a DNS round-robin,
when propellor is used to manage DNS for the domain. when propellor is used to manage DNS for the domain.
* Apt.stdSourcesList no longer needs a suite to be specified. * Apt.stdSourcesList no longer needs a suite to be specified. (API change)
* Added --dump to dump out a field of a host's privdata. Useful for editing * Added --dump to dump out a field of a host's privdata. Useful for editing
it. it.
* Propellor's output now includes the hostname being provisioned, or * Propellor's output now includes the hostname being provisioned, or
@ -176,7 +181,7 @@ propellor (0.5.1) unstable; urgency=medium
propellor (0.5.0) unstable; urgency=medium propellor (0.5.0) unstable; urgency=medium
* Removed root domain records from SOA. Instead, use RootDomain * Removed root domain records from SOA. Instead, use RootDomain
when calling Dns.primary. when calling Dns.primary. (API change)
* Dns primary and secondary properties are now revertable. * Dns primary and secondary properties are now revertable.
* When unattendedUpgrades is enabled on an Unstable or Testing system, * When unattendedUpgrades is enabled on an Unstable or Testing system,
configure it to allow the upgrades. configure it to allow the upgrades.
@ -190,8 +195,9 @@ propellor (0.4.0) unstable; urgency=medium
zone files, which is done by looking at the properties of hosts zone files, which is done by looking at the properties of hosts
in a domain. in a domain.
* The `cname` property was renamed to `alias` as it does not always * The `cname` property was renamed to `alias` as it does not always
generate CNAME in the DNS. generate CNAME in the DNS. (API change)
* Constructor of Property has changed (use `property` function instead). * Constructor of Property has changed (use `property` function instead).
(API change)
* All Property combinators now combine together their Attr settings. * All Property combinators now combine together their Attr settings.
So Attr settings can be made inside a propertyList, for example. So Attr settings can be made inside a propertyList, for example.
* Run all cron jobs under chronic from moreutils to avoid unnecessary * Run all cron jobs under chronic from moreutils to avoid unnecessary
@ -227,7 +233,7 @@ propellor (0.3.0) unstable; urgency=medium
* Include security updates in sources.list for stable and testing. * Include security updates in sources.list for stable and testing.
* Use ssh connection caching, especially when bootstrapping. * Use ssh connection caching, especially when bootstrapping.
* Properties now run in a Propellor monad, which provides access to * Properties now run in a Propellor monad, which provides access to
attributes of the host. attributes of the host. (API change)
-- Joey Hess <joeyh@debian.org> Fri, 11 Apr 2014 01:19:05 -0400 -- Joey Hess <joeyh@debian.org> Fri, 11 Apr 2014 01:19:05 -0400

8
propellor.cabal
View File

@ -1,5 +1,5 @@
Name: propellor Name: propellor
Version: 0.9.3 Version: 1.0.0
Cabal-Version: >= 1.6 Cabal-Version: >= 1.6
License: BSD3 License: BSD3
Maintainer: Joey Hess <joey@kitenet.net> Maintainer: Joey Hess <joey@kitenet.net>
@ -75,6 +75,7 @@ Library
Propellor.Property.Cmd Propellor.Property.Cmd
Propellor.Property.Hostname Propellor.Property.Hostname
Propellor.Property.Cron Propellor.Property.Cron
Propellor.Property.Debootstrap
Propellor.Property.Dns Propellor.Property.Dns
Propellor.Property.Docker Propellor.Property.Docker
Propellor.Property.File Propellor.Property.File
@ -101,6 +102,7 @@ Library
Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.JoeySites
Propellor.Property.SiteSpecific.GitAnnexBuilder Propellor.Property.SiteSpecific.GitAnnexBuilder
Propellor.CmdLine
Propellor.Info Propellor.Info
Propellor.Message Propellor.Message
Propellor.PrivData Propellor.PrivData
@ -111,11 +113,9 @@ Library
Propellor.Types.Dns Propellor.Types.Dns
Propellor.Types.PrivData Propellor.Types.PrivData
Other-Modules: Other-Modules:
Propellor.Types.Info
Propellor.CmdLine
Propellor.Git Propellor.Git
Propellor.Gpg Propellor.Gpg
Propellor.SimpleSh Propellor.Server
Propellor.Ssh Propellor.Ssh
Propellor.PrivData.Paths Propellor.PrivData.Paths
Propellor.Protocol Propellor.Protocol

212
src/Propellor/CmdLine.hs
View File

@ -1,24 +1,21 @@
module Propellor.CmdLine where module Propellor.CmdLine (
defaultMain,
processCmdLine,
) where
import System.Environment (getArgs) import System.Environment (getArgs)
import Data.List import Data.List
import System.Exit import System.Exit
import System.PosixCompat import System.PosixCompat
import Control.Exception (bracket)
import System.Posix.IO
import Control.Concurrent.Async
import qualified Data.ByteString as B
import System.Process (std_in, std_out)
import Propellor import Propellor
import Propellor.Protocol import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Gpg import Propellor.Gpg
import Propellor.Git import Propellor.Git
import Propellor.Ssh import Propellor.Ssh
import Propellor.Server
import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Docker.Shim as DockerShim import qualified Propellor.Property.Docker.Shim as DockerShim
import Utility.FileMode
import Utility.SafeCommand import Utility.SafeCommand
usage :: Handle -> IO () usage :: Handle -> IO ()
@ -72,6 +69,7 @@ processCmdLine = go =<< getArgs
Just pf -> return $ f pf (Context c) Just pf -> return $ f pf (Context c)
Nothing -> errorMessage $ "Unknown privdata field " ++ s Nothing -> errorMessage $ "Unknown privdata field " ++ s
-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO () defaultMain :: [Host] -> IO ()
defaultMain hostlist = do defaultMain hostlist = do
DockerShim.cleanEnv DockerShim.cleanEnv
@ -86,39 +84,24 @@ defaultMain hostlist = do
go _ (Edit field context) = editPrivData field context go _ (Edit field context) = editPrivData field context
go _ ListFields = listPrivDataFields hostlist go _ ListFields = listPrivDataFields hostlist
go _ (AddKey keyid) = addKey keyid go _ (AddKey keyid) = addKey keyid
go _ (Chain hn isconsole) = withhost hn $ \h -> do go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
when isconsole forceConsole go _ (DockerInit hn) = Docker.init hn
r <- runPropellor h $ ensureProperties $ hostProperties h go _ (GitPush fin fout) = gitPushHelper fin fout
putStrLn $ "\n" ++ show r go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)
go _ (Docker hn) = Docker.chain hn
go _ (GitPush fin fout) = gitPush fin fout
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin hn) = withhost hn $ spin hn go False (Spin hn) = withhost hn $ spin hn
go False cmdline@(SimpleRun hn) = buildFirst cmdline $ go False cmdline@(SimpleRun hn) = buildFirst cmdline $
go False (Run hn) go False (Run hn)
go False (Run hn) = ifM ((==) 0 <$> getRealUserID) go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyProcess $ withhost hn mainProperties ( onlyprocess $ withhost hn mainProperties
, go True (Spin hn) , go True (Spin hn)
) )
go False (Update _) = do
forceConsole
onlyProcess update
withhost :: HostName -> (Host -> IO ()) -> IO () withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
onlyProcess :: IO a -> IO a onlyprocess = onlyProcess (localdir </> ".lock")
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 :: HostName -> [Host] -> IO a
unknownhost h hosts = errorMessage $ unlines unknownhost h hosts = errorMessage $ unlines
@ -142,42 +125,27 @@ buildFirst cmdline next = do
where where
getmtime = catchMaybeIO $ getModificationTime "propellor" getmtime = catchMaybeIO $ getModificationTime "propellor"
fetchFirst :: IO () -> IO ()
fetchFirst next = do
whenM hasOrigin $
void fetchOrigin
next
updateFirst :: CmdLine -> IO () -> IO () updateFirst :: CmdLine -> IO () -> IO ()
updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next) updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
updateFirst' :: CmdLine -> IO () -> IO () updateFirst' :: CmdLine -> IO () -> IO ()
updateFirst' cmdline next = do updateFirst' cmdline next = ifM fetchOrigin
branchref <- getCurrentBranch ( ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
let originbranch = "origin" </> branchref ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
oldsha <- getCurrentGitSha1 branchref
whenM (doesFileExist keyring) $
ifM (verifyOriginBranch originbranch)
( do
putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
hFlush stdout
void $ boolSystem "git" [Param "merge", Param originbranch]
, 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!" , errorMessage "Propellor build failed!"
) )
, next
)
-- spin handles deploying propellor to a remote host, if it's not already
-- installed there, or updating it if it is. Once the remote propellor is
-- updated, it's run.
spin :: HostName -> Host -> IO () spin :: HostName -> Host -> IO ()
spin hn hst = do spin hn hst = do
void $ actionMessage "Git commit (signed)" $ void $ actionMessage "Git commit" $
gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
-- Push to central origin repo first, if possible. -- Push to central origin repo first, if possible.
-- The remote propellor will pull from there, which avoids -- The remote propellor will pull from there, which avoids
@ -187,16 +155,20 @@ spin hn hst = do
boolSystem "git" [Param "push"] boolSystem "git" [Param "push"]
cacheparams <- toCommand <$> sshCachingParams hn cacheparams <- toCommand <$> sshCachingParams hn
comm hn hst $ withBothHandles createProcessSuccess
(proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) -- Install, or update the remote propellor.
updateServer hn hst $ withBothHandles createProcessSuccess
(proc "ssh" $ cacheparams ++ [user, updatecmd])
-- And now we can run it.
unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $ unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
error $ "remote propellor failed (running: " ++ runcmd ++")" error $ "remote propellor failed"
where where
user = "root@"++hn user = "root@"++hn
mkcmd = shellWrap . intercalate " ; " mkcmd = shellWrap . intercalate " ; "
bootstrapcmd = mkcmd updatecmd = mkcmd
[ "if [ ! -d " ++ localdir ++ " ]" [ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && " , "then " ++ intercalate " && "
[ "apt-get update" [ "apt-get update"
@ -213,119 +185,3 @@ spin hn hst = do
runcmd = mkcmd runcmd = mkcmd
[ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ] [ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ]
-- Update the privdata, repo url, and git repo over the ssh
-- connection from the client that ran propellor --spin.
update :: IO ()
update = do
req NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
req NeedPrivData privDataMarker $
writeFileProtected privDataLocal
req NeedGitPush gitPushMarker $ \_ -> do
hin <- dup stdInput
hout <- dup stdOutput
hClose stdin
hClose stdout
unlessM (boolSystem "git" (pullparams hin hout)) $
errorMessage "git pull from client failed"
where
pullparams hin hout =
[ Param "pull"
, Param "--progress"
, Param "--upload-pack"
, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
, Param "."
]
comm :: HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
comm hn hst connect = connect go
where
go (toh, fromh) = do
let loop = go (toh, fromh)
v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
case v of
(Just NeedRepoUrl) -> do
sendRepoUrl toh
loop
(Just NeedPrivData) -> do
sendPrivData hn hst toh
loop
(Just NeedGitPush) -> do
sendGitUpdate hn fromh toh
-- no more protocol possible after git push
hClose fromh
hClose toh
(Just NeedGitClone) -> do
hClose toh
hClose fromh
sendGitClone hn
comm hn hst connect
Nothing -> return ()
sendRepoUrl :: Handle -> IO ()
sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
sendPrivData :: HostName -> Host -> Handle -> IO ()
sendPrivData hn hst toh = do
privdata <- show . filterPrivData hst <$> decryptPrivData
void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
sendMarked toh privDataMarker privdata
return True
sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
sendGitUpdate hn fromh toh =
void $ actionMessage ("Sending git update to " ++ hn) $ do
sendMarked toh gitPushMarker ""
(Nothing, Nothing, Nothing, h) <- createProcess p
(==) ExitSuccess <$> waitForProcess h
where
p = (proc "git" ["upload-pack", "."])
{ std_in = UseHandle fromh
, std_out = UseHandle toh
}
-- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> IO ()
sendGitClone hn = void $ actionMessage ("Clone 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
]
-- Shim for git push over the propellor ssh channel.
-- Reads from stdin and sends it to hout;
-- reads from hin and sends it to stdout.
gitPush :: Fd -> Fd -> IO ()
gitPush hin hout = void $ fromstdin `concurrently` tostdout
where
fromstdin = do
h <- fdToHandle hout
connect stdin h
tostdout = do
h <- fdToHandle hin
connect h stdout
connect fromh toh = do
hSetBinaryMode fromh True
hSetBinaryMode toh True
b <- B.hGetSome fromh 40960
if B.null b
then do
hClose fromh
hClose toh
else do
B.hPut toh b
hFlush toh
connect fromh toh

15
src/Propellor/Engine.hs
View File

@ -8,11 +8,15 @@ import Data.Monoid
import Control.Applicative import Control.Applicative
import System.Console.ANSI import System.Console.ANSI
import "mtl" Control.Monad.Reader import "mtl" Control.Monad.Reader
import Control.Exception (bracket)
import System.PosixCompat
import System.Posix.IO
import Propellor.Types import Propellor.Types
import Propellor.Message import Propellor.Message
import Propellor.Exception import Propellor.Exception
import Propellor.Info import Propellor.Info
import Utility.Exception
runPropellor :: Host -> Propellor a -> IO a runPropellor :: Host -> Propellor a -> IO a
runPropellor host a = runReaderT (runWithHost a) host runPropellor host a = runReaderT (runWithHost a) host
@ -47,3 +51,14 @@ fromHost l hn getter = case findHost l hn of
Nothing -> return Nothing Nothing -> return Nothing
Just h -> liftIO $ Just <$> Just h -> liftIO $ Just <$>
runReaderT (runWithHost getter) h runReaderT (runWithHost getter) h
onlyProcess :: FilePath -> IO a -> IO a
onlyProcess lockfile 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!"

23
src/Propellor/Git.hs
View File

@ -62,3 +62,26 @@ verifyOriginBranch originbranch = do
nukeFile $ privDataDir </> "pubring.gpg" nukeFile $ privDataDir </> "pubring.gpg"
nukeFile $ privDataDir </> "gpg.conf" nukeFile $ privDataDir </> "gpg.conf"
return (s == "U\n" || s == "G\n") return (s == "U\n" || s == "G\n")
-- Returns True if HEAD is changed by fetching and merging from origin.
fetchOrigin :: IO Bool
fetchOrigin = do
branchref <- getCurrentBranch
let originbranch = "origin" </> branchref
void $ actionMessage "Pull from central git repository" $
boolSystem "git" [Param "fetch"]
oldsha <- getCurrentGitSha1 branchref
whenM (doesFileExist keyring) $
ifM (verifyOriginBranch originbranch)
( do
putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
hFlush stdout
void $ boolSystem "git" [Param "merge", Param originbranch]
, warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
)
newsha <- getCurrentGitSha1 branchref
return $ oldsha /= newsha

1
src/Propellor/Info.hs
View File

@ -3,7 +3,6 @@
module Propellor.Info where module Propellor.Info where
import Propellor.Types import Propellor.Types
import Propellor.Types.Info
import "mtl" Control.Monad.Reader import "mtl" Control.Monad.Reader
import qualified Data.Set as S import qualified Data.Set as S

9
src/Propellor/Message.hs
View File

@ -21,10 +21,11 @@ data MessageHandle
| TextMessageHandle | TextMessageHandle
mkMessageHandle :: IO MessageHandle mkMessageHandle :: IO MessageHandle
mkMessageHandle = ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE")) mkMessageHandle = do
( return ConsoleMessageHandle ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))
, return TextMessageHandle ( return ConsoleMessageHandle
) , return TextMessageHandle
)
forceConsole :: IO () forceConsole :: IO ()
forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True

1
src/Propellor/PrivData.hs
View File

@ -15,7 +15,6 @@ import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
import Propellor.Types import Propellor.Types
import Propellor.Types.Info
import Propellor.Message import Propellor.Message
import Propellor.Info import Propellor.Info
import Propellor.Gpg import Propellor.Gpg

44
src/Propellor/Property.hs
View File

@ -89,6 +89,15 @@ check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
, return NoChange , return NoChange
) )
-- | Tries the first property, but if it fails to work, instead uses
-- the second.
fallback :: Property -> Property -> Property
fallback p1 p2 = adjustProperty p1 $ \satisfy -> do
r <- satisfy
if r == FailedChange
then propertySatisfy p2
else return r
-- | Marks a Property as trivial. It can only return FailedChange or -- | Marks a Property as trivial. It can only return FailedChange or
-- NoChange. -- NoChange.
-- --
@ -122,6 +131,10 @@ boolProperty desc a = property desc $ ifM (liftIO a)
revert :: RevertableProperty -> RevertableProperty revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
-- | Turns a revertable property into a regular property.
unrevertable :: RevertableProperty -> Property
unrevertable (RevertableProperty p1 _p2) = p1
-- | Starts accumulating the properties of a Host. -- | Starts accumulating the properties of a Host.
-- --
-- > host "example.com" -- > host "example.com"
@ -131,27 +144,28 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
host :: HostName -> Host host :: HostName -> Host
host hn = Host hn [] mempty host hn = Host hn [] mempty
-- | Adds a property to a Host class Hostlike h where
-- -- | Adds a property to a Host
-- Can add Properties and RevertableProperties --
(&) :: IsProp p => Host -> p -> Host -- Can add Properties and RevertableProperties
(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) (&) :: IsProp p => h -> p -> h
-- | Like (&), but adds the property as the
-- first property of the host. Normally, property
-- order should not matter, but this is useful
-- when it does.
(&^) :: IsProp p => h -> p -> h
infixl 1 & instance Hostlike Host where
(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
-- | Adds a property to the Host in reverted form. -- | Adds a property to the Host in reverted form.
(!) :: Host -> RevertableProperty -> Host (!) :: Hostlike h => h -> RevertableProperty -> h
h ! p = h & revert p h ! p = h & revert p
infixl 1 !
-- | Like (&), but adds the property as the first property of the host.
-- Normally, property order should not matter, but this is useful
-- when it does.
(&^) :: IsProp p => Host -> p -> Host
(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
infixl 1 &^ infixl 1 &^
infixl 1 &
infixl 1 !
-- Changes the action that is performed to satisfy a property. -- Changes the action that is performed to satisfy a property.
adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property

253
src/Propellor/Property/Debootstrap.hs Normal file
View File

@ -0,0 +1,253 @@
module Propellor.Property.Debootstrap (
Url,
built,
installed,
programPath,
) where
import Propellor
import qualified Propellor.Property.Apt as Apt
import Utility.Path
import Utility.SafeCommand
import Utility.FileMode
import Data.List
import Data.Char
import Control.Exception
import System.Posix.Directory
type Url = String
-- | Builds a chroot in the given directory using debootstrap.
--
-- The System can be any OS and architecture that debootstrap
-- and the kernel support.
--
-- Reverting this property deletes the chroot and all its contents.
-- Anything mounted under the filesystem is first unmounted.
--
-- Note that reverting this property does not stop any processes
-- currently running in the chroot.
built :: FilePath -> System -> [CommandParam] -> RevertableProperty
built target system@(System _ arch) extraparams =
RevertableProperty setup teardown
where
setup = check (unpopulated target <||> ispartial) setupprop
`requires` unrevertable installed
teardown = check (not <$> unpopulated target) teardownprop
unpopulated d = null <$> catchDefaultIO [] (dirContents d)
setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
createDirectoryIfMissing True target
suite <- case extractSuite system of
Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system
Just s -> pure s
let params = extraparams ++
[ Param $ "--arch=" ++ arch
, Param suite
, Param target
]
cmd <- fromMaybe "debootstrap" <$> programPath
ifM (boolSystem cmd params)
( do
fixForeignDev target
return MadeChange
, return FailedChange
)
teardownprop = property ("removed debootstrapped " ++ target) $ liftIO $ do
removetarget
return MadeChange
removetarget = do
submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
. filter (dirContains target)
<$> mountPoints
forM_ submnts $ \mnt ->
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do
errorMessage $ "failed unmounting " ++ mnt
removeDirectoryRecursive target
-- A failed debootstrap run will leave a debootstrap directory;
-- recover by deleting it and trying again.
ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
( do
removetarget
return True
, return False
)
mountPoints :: IO [FilePath]
mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
extractSuite :: System -> Maybe String
extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
extractSuite (System (Ubuntu r) _) = Just r
-- | Ensures debootstrap is installed.
--
-- When necessary, falls back to installing debootstrap from source.
-- Note that installation from source is done by downloading the tarball
-- from a Debian mirror, with no cryptographic verification.
installed :: RevertableProperty
installed = RevertableProperty install remove
where
install = withOS "debootstrap installed" $ \o ->
ifM (liftIO $ isJust <$> programPath)
( return NoChange
, ensureProperty (installon o)
)
installon (Just (System (Debian _) _)) = aptinstall
installon (Just (System (Ubuntu _) _)) = aptinstall
installon _ = sourceInstall
remove = withOS "debootstrap removed" $ ensureProperty . removefrom
removefrom (Just (System (Debian _) _)) = aptremove
removefrom (Just (System (Ubuntu _) _)) = aptremove
removefrom _ = sourceRemove
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
sourceInstall :: Property
sourceInstall = property "debootstrap installed from source"
(liftIO sourceInstall')
sourceInstall' :: IO Result
sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
let indexfile = tmpd </> "index.html"
unlessM (download baseurl indexfile) $
errorMessage $ "Failed to download " ++ baseurl
urls <- reverse . sort -- highest version first
. filter ("debootstrap_" `isInfixOf`)
. filter (".tar." `isInfixOf`)
. extractUrls baseurl <$>
readFileStrictAnyEncoding indexfile
nukeFile indexfile
tarfile <- case urls of
(tarurl:_) -> do
let f = tmpd </> takeFileName tarurl
unlessM (download tarurl f) $
errorMessage $ "Failed to download " ++ tarurl
return f
_ -> errorMessage $ "Failed to find any debootstrap tarballs listed on " ++ baseurl
createDirectoryIfMissing True localInstallDir
bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do
changeWorkingDirectory localInstallDir
unlessM (boolSystem "tar" [Param "xf", File tarfile]) $
errorMessage "Failed to extract debootstrap tar file"
nukeFile tarfile
l <- dirContents "."
case l of
(subdir:[]) -> do
changeWorkingDirectory subdir
makeDevicesTarball
makeWrapperScript (localInstallDir </> subdir)
return MadeChange
_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
sourceRemove :: Property
sourceRemove = property "debootstrap not installed from source" $ liftIO $
ifM (doesDirectoryExist sourceInstallDir)
( do
removeDirectoryRecursive sourceInstallDir
return MadeChange
, return NoChange
)
sourceInstallDir :: FilePath
sourceInstallDir = "/usr/local/propellor/debootstrap"
wrapperScript :: FilePath
wrapperScript = sourceInstallDir </> "debootstrap.wrapper"
-- | Finds debootstrap in PATH, but fall back to looking for the
-- wrapper script that is installed, outside the PATH, when debootstrap
-- is installed from source.
programPath :: IO (Maybe FilePath)
programPath = getM searchPath
[ "debootstrap"
, wrapperScript
]
makeWrapperScript :: FilePath -> IO ()
makeWrapperScript dir = do
createDirectoryIfMissing True (takeDirectory wrapperScript)
writeFile wrapperScript $ unlines
[ "#!/bin/sh"
, "set -e"
, "DEBOOTSTRAP_DIR=" ++ dir
, "export DEBOOTSTRAP_DIR"
, dir </> "debootstrap" ++ " \"$@\""
]
modifyFileMode wrapperScript (addModes $ readModes ++ executeModes)
-- Work around for http://bugs.debian.org/770217
makeDevicesTarball :: IO ()
makeDevicesTarball = do
-- TODO append to tarball; avoid writing to /dev
writeFile foreignDevFlag "1"
ok <- boolSystem "sh" [Param "-c", Param tarcmd]
nukeFile foreignDevFlag
unless ok $
errorMessage "Failed to tar up /dev to generate devices.tar.gz"
where
tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz"
fixForeignDev :: FilePath -> IO ()
fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $
void $ boolSystem "chroot"
[ File target
, Param "sh"
, Param "-c"
, Param $ intercalate " && "
[ "rm -rf /dev"
, "mkdir /dev"
, "cd /dev"
, "/sbin/MAKEDEV std ptmx fd consoleonly"
]
]
foreignDevFlag :: FilePath
foreignDevFlag = "/dev/.propellor-foreign-dev"
localInstallDir :: FilePath
localInstallDir = "/usr/local/debootstrap"
-- This http server directory listing is relied on to be fairly sane,
-- which is one reason why it's using a specific server and not a
-- round-robin address.
baseurl :: Url
baseurl = "http://ftp.debian.org/debian/pool/main/d/debootstrap/"
download :: Url -> FilePath -> IO Bool
download url dest = anyM id
[ boolSystem "curl" [Param "-o", File dest, Param url]
, boolSystem "wget" [Param "-O", File dest, Param url]
]
-- Pretty hackish, but I don't want to pull in a whole html parser
-- or parsec dependency just for this.
--
-- To simplify parsing, lower case everything. This is ok because
-- the filenames are all lower-case anyway.
extractUrls :: Url -> String -> [Url]
extractUrls base = collect [] . map toLower
where
collect l [] = l
collect l ('h':'r':'e':'f':'=':r) = case r of
('"':r') -> findend l r'
_ -> findend l r
collect l (_:cs) = collect l cs
findend l s =
let (u, r) = break (== '"') s
u' = if "http" `isPrefixOf` u
then u
else base </> u
in collect (u':l) r

1
src/Propellor/Property/Dns.hs
View File

@ -15,7 +15,6 @@ module Propellor.Property.Dns (
import Propellor import Propellor
import Propellor.Types.Dns import Propellor.Types.Dns
import Propellor.Property.File import Propellor.Property.File
import Propellor.Types.Info
import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service import qualified Propellor.Property.Service as Service
import Utility.Applicative import Utility.Applicative

202
src/Propellor/Property/Docker.hs
View File

@ -16,6 +16,7 @@ module Propellor.Property.Docker (
tweaked, tweaked,
Image, Image,
ContainerName, ContainerName,
Container,
-- * Container configuration -- * Container configuration
dns, dns,
hostname, hostname,
@ -33,24 +34,26 @@ module Propellor.Property.Docker (
restartOnFailure, restartOnFailure,
restartNever, restartNever,
-- * Internal use -- * Internal use
init,
chain, chain,
) where ) where
import Propellor import Propellor hiding (init)
import Propellor.SimpleSh
import Propellor.Types.Info
import qualified Propellor.Property.File as File import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Docker.Shim as Shim import qualified Propellor.Property.Docker.Shim as Shim
import Utility.SafeCommand import Utility.SafeCommand
import Utility.Path import Utility.Path
import Utility.ThreadScheduler
import Control.Concurrent.Async hiding (link) import Control.Concurrent.Async hiding (link)
import System.Posix.Directory import System.Posix.Directory
import System.Posix.Process import System.Posix.Process
import Data.List import Prelude hiding (init)
import Data.List hiding (init)
import Data.List.Utils import Data.List.Utils
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M
installed :: Property installed :: Property
installed = Apt.installed ["docker.io"] installed = Apt.installed ["docker.io"]
@ -69,55 +72,56 @@ configured = prop `requires` installed
-- only [a-zA-Z0-9_-] are allowed -- only [a-zA-Z0-9_-] are allowed
type ContainerName = String type ContainerName = String
-- | Starts accumulating the properties of a Docker container. -- | A docker container.
data Container = Container Image Host
instance Hostlike Container where
(Container i h) & p = Container i (h & p)
(Container i h) &^ p = Container i (h &^ p)
-- | Builds a Container with a given name, image, and properties.
-- --
-- > container "web-server" "debian" -- > container "web-server" "debian"
-- > & publish "80:80" -- > & publish "80:80"
-- > & Apt.installed {"apache2"] -- > & Apt.installed {"apache2"]
-- > & ... -- > & ...
container :: ContainerName -> Image -> Host container :: ContainerName -> Image -> Container
container cn image = Host hn [] info container cn image = Container image (Host cn [] info)
where where
info = dockerInfo $ mempty { _dockerImage = Val image } info = dockerInfo mempty
hn = cn2hn cn
cn2hn :: ContainerName -> HostName -- | Ensures that a docker container is set up and running.
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 -- The container has its own Properties which are handled by running
-- propellor inside the container. -- propellor inside the container.
-- --
-- When the container's Properties include DNS info, such as a CNAME, -- 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. -- that is propigated to the Info of the Host it's docked in.
-- --
-- Reverting this property ensures that the container is stopped and -- Reverting this property ensures that the container is stopped and
-- removed. -- removed.
docked docked
:: [Host] :: Container
-> ContainerName
-> RevertableProperty -> RevertableProperty
docked hosts cn = RevertableProperty docked ctr@(Container _ h) = RevertableProperty
((maybe id propigateInfo mhost) (go "docked" setup)) (propigateInfo ctr (go "docked" setup))
(go "undocked" teardown) (go "undocked" teardown)
where where
cn = hostName h
go desc a = property (desc ++ " " ++ cn) $ do go desc a = property (desc ++ " " ++ cn) $ do
hn <- asks hostName hn <- asks hostName
let cid = ContainerId hn cn let cid = ContainerId hn cn
ensureProperties [findContainer mhost cid cn $ a cid] ensureProperties [a cid (mkContainerInfo cid ctr)]
mhost = findHostNoAlias hosts (cn2hn cn)
setup cid (Container image runparams) = setup cid (ContainerInfo image runparams) =
provisionContainer cid provisionContainer cid
`requires` `requires`
runningContainer cid image runparams runningContainer cid image runparams
`requires` `requires`
installed installed
teardown cid (Container image _runparams) = teardown cid (ContainerInfo image _runparams) =
combineProperties ("undocked " ++ fromContainerId cid) combineProperties ("undocked " ++ fromContainerId cid)
[ stoppedContainer cid [ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $ , property ("cleaned up " ++ fromContainerId cid) $
@ -127,33 +131,21 @@ docked hosts cn = RevertableProperty
] ]
] ]
propigateInfo :: Host -> Property -> Property propigateInfo :: Container -> Property -> Property
propigateInfo (Host _ _ containerinfo) p = propigateInfo (Container _ h@(Host hn _ containerinfo)) p =
combineProperties (propertyDesc p) $ p : dnsprops ++ privprops combineProperties (propertyDesc p) $ p' : dnsprops ++ privprops
where where
p' = p { propertyInfo = propertyInfo p <> dockerinfo }
dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton hn h }
dnsprops = map addDNS (S.toList $ _dns containerinfo) dnsprops = map addDNS (S.toList $ _dns containerinfo)
privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo) privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo)
findContainer mkContainerInfo :: ContainerId -> Container -> ContainerInfo
:: Maybe Host mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
-> ContainerId ContainerInfo img runparams
-> 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 (\mkparam -> mkparam hn) (_dockerRunParams info))
where where
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
(_dockerRunParams info)
info = _dockerinfo $ hostInfo h' info = _dockerinfo $ hostInfo h'
h' = h h' = h
-- Restart by default so container comes up on -- Restart by default so container comes up on
@ -207,7 +199,7 @@ memoryLimited = "/etc/default/grub" `File.containsLine` cfg
cmdline = "cgroup_enable=memory swapaccount=1" cmdline = "cgroup_enable=memory swapaccount=1"
cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\"" cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
data Container = Container Image [RunParam] data ContainerInfo = ContainerInfo Image [RunParam]
-- | Parameters to pass to `docker run` when creating a container. -- | Parameters to pass to `docker run` when creating a container.
type RunParam = String type RunParam = String
@ -301,7 +293,10 @@ restartNever = runProp "restart" "no"
-- | A container is identified by its name, and the host -- | A container is identified by its name, and the host
-- on which it's deployed. -- on which it's deployed.
data ContainerId = ContainerId HostName ContainerName data ContainerId = ContainerId
{ containerHostName :: HostName
, containerName :: ContainerName
}
deriving (Eq, Read, Show) deriving (Eq, Read, Show)
-- | Two containers with the same ContainerIdent were started from -- | Two containers with the same ContainerIdent were started from
@ -324,22 +319,19 @@ toContainerId s
fromContainerId :: ContainerId -> String fromContainerId :: ContainerId -> String
fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
containerHostName :: ContainerId -> HostName
containerHostName (ContainerId _ cn) = cn2hn cn
myContainerSuffix :: String myContainerSuffix :: String
myContainerSuffix = ".propellor" myContainerSuffix = ".propellor"
containerDesc :: ContainerId -> Property -> Property containerDesc :: ContainerId -> Property -> Property
containerDesc cid p = p `describe` desc containerDesc cid p = p `describe` desc
where where
desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
runningContainer :: ContainerId -> Image -> [RunParam] -> Property runningContainer :: ContainerId -> Image -> [RunParam] -> Property
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers l <- liftIO $ listContainers RunningContainers
if cid `elem` l if cid `elem` l
then checkident =<< liftIO (getrunningident simpleShClient) then checkident =<< liftIO getrunningident
else ifM (liftIO $ elem cid <$> listContainers AllContainers) else ifM (liftIO $ elem cid <$> listContainers AllContainers)
( do ( do
-- The container exists, but is not -- The container exists, but is not
@ -348,9 +340,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
-- starting it up first. -- starting it up first.
void $ liftIO $ startContainer cid void $ liftIO $ startContainer cid
-- It can take a while for the container to -- It can take a while for the container to
-- start up enough to get its ident, so -- start up enough for its ident file to be
-- retry for up to 60 seconds. -- written, so retry for up to 60 seconds.
checkident =<< liftIO (getrunningident (simpleShClientRetry 60)) checkident =<< liftIO (retry 60 $ getrunningident)
, go image , go image
) )
where where
@ -370,12 +362,18 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
void $ liftIO $ removeContainer cid void $ liftIO $ removeContainer cid
go oldimage go oldimage
getrunningident shclient = shclient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do getrunningident = readish
let !v = extractident rs <$> readProcess' (inContainerProcess cid [] ["cat", propellorIdent])
return v
extractident :: [Resp] -> Maybe ContainerIdent retry :: Int -> IO (Maybe a) -> IO (Maybe a)
extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout retry 0 _ = return Nothing
retry n a = do
v <- a
case v of
Just _ -> return v
Nothing -> do
threadDelaySeconds (Seconds 1)
retry (n-1) a
go img = do go img = do
liftIO $ do liftIO $ do
@ -385,7 +383,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
liftIO $ writeFile (identFile cid) (show ident) liftIO $ writeFile (identFile cid) (show ident)
ensureProperty $ boolProperty "run" $ runContainer img ensureProperty $ boolProperty "run" $ runContainer img
(runps ++ ["-i", "-d", "-t"]) (runps ++ ["-i", "-d", "-t"])
[shim, "--continue", show (Docker (fromContainerId cid))] [shim, "--continue", show (DockerInit (fromContainerId cid))]
-- | Called when propellor is running inside a docker container. -- | Called when propellor is running inside a docker container.
-- The string should be the container's ContainerId. -- The string should be the container's ContainerId.
@ -393,7 +391,6 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
-- This process is effectively init inside the container. -- This process is effectively init inside the container.
-- It even needs to wait on zombie processes! -- 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, -- In the foreground, run an interactive bash (or sh) shell,
-- so that the user can interact with it when attached to the container. -- so that the user can interact with it when attached to the container.
-- --
@ -401,25 +398,22 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
-- again. So, to make the necessary services get started on boot, this needs -- again. So, to make the necessary services get started on boot, this needs
-- to provision the container then. However, if the container is already -- to provision the container then. However, if the container is already
-- being provisioned by the calling propellor, it would be redundant and -- being provisioned by the calling propellor, it would be redundant and
-- problimatic to also provisoon it here. -- problimatic to also provisoon it here, when not booting up.
-- --
-- The solution is a flag file. If the flag file exists, then the container -- 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 -- 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. -- again. If the flag file doesn't exist, don't provision here.
chain :: String -> IO () init :: String -> IO ()
chain s = case toContainerId s of init s = case toContainerId s of
Nothing -> error $ "Invalid ContainerId: " ++ s Nothing -> error $ "Invalid ContainerId: " ++ s
Just cid -> do Just cid -> do
changeWorkingDirectory localdir changeWorkingDirectory localdir
writeFile propellorIdent . show =<< readIdentFile cid writeFile propellorIdent . show =<< readIdentFile cid
-- Run boot provisioning before starting simpleSh,
-- to avoid ever provisioning twice at the same time.
whenM (checkProvisionedFlag cid) $ do whenM (checkProvisionedFlag cid) $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain (containerHostName cid) False]) $ unlessM (boolSystem shim [Param "--continue", Param $ show $ toChain cid]) $
warningMessage "Boot provision failed!" warningMessage "Boot provision failed!"
void $ async $ job reapzombies void $ async $ job reapzombies
void $ async $ job $ simpleSh $ namedPipe cid
job $ do job $ do
void $ tryIO $ ifM (inPath "bash") void $ tryIO $ ifM (inPath "bash")
( boolSystem "bash" [Param "-l"] ( boolSystem "bash" [Param "-l"]
@ -432,36 +426,47 @@ chain s = case toContainerId s of
-- | Once a container is running, propellor can be run inside -- | Once a container is running, propellor can be run inside
-- it to provision it. -- 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 :: ContainerId -> Property
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
let params = ["--continue", show $ toChain cid]
msgh <- mkMessageHandle msgh <- mkMessageHandle
let params = ["--continue", show $ Chain (containerHostName cid) (isConsole msgh)] let p = inContainerProcess cid
r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing) [ if isConsole msgh then "-it" else "-i" ]
(shim : params)
r <- withHandle StdoutHandle createProcessSuccess p $
processoutput Nothing
when (r /= FailedChange) $ when (r /= FailedChange) $
setProvisionedFlag cid setProvisionedFlag cid
return r return r
where where
go lastline (v:rest) = case v of processoutput lastline h = do
StdoutLine s -> do v <- catchMaybeIO (hGetLine h)
maybe noop putStrLn lastline case v of
hFlush stdout Nothing -> pure $ fromMaybe FailedChange $
go (Just s) rest readish =<< lastline
StderrLine s -> do Just s -> do
maybe noop putStrLn lastline maybe noop putStrLn lastline
hFlush stdout hFlush stdout
hPutStrLn stderr s processoutput (Just s) h
hFlush stderr
go Nothing rest
Done -> ret lastline
go lastline [] = ret lastline
ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline toChain :: ContainerId -> CmdLine
toChain cid = DockerChain (containerHostName cid) (fromContainerId cid)
chain :: [Host] -> HostName -> String -> IO ()
chain hostlist hn s = case toContainerId s of
Nothing -> errorMessage "bad container id"
Just cid -> case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ _dockerinfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
Just h -> go cid h
where
go cid h = do
changeWorkingDirectory localdir
onlyProcess (provisioningLock cid) $ do
r <- runPropellor h $ ensureProperties $ hostProperties h
putStrLn $ "\n" ++ show r
stopContainer :: ContainerId -> IO Bool stopContainer :: ContainerId -> IO Bool
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
@ -479,7 +484,6 @@ stoppedContainer cid = containerDesc cid $ property desc $
where where
desc = "stopped" desc = "stopped"
cleanup = do cleanup = do
nukeFile $ namedPipe cid
nukeFile $ identFile cid nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid removeDirectoryRecursive $ shimdir cid
clearProvisionedFlag cid clearProvisionedFlag cid
@ -496,6 +500,9 @@ runContainer :: Image -> [RunParam] -> [String] -> IO Bool
runContainer image ps cmd = boolSystem dockercmd $ map Param $ runContainer image ps cmd = boolSystem dockercmd $ map Param $
"run" : (ps ++ image : cmd) "run" : (ps ++ image : cmd)
inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)
commitContainer :: ContainerId -> IO (Maybe Image) commitContainer :: ContainerId -> IO (Maybe Image)
commitContainer cid = catchMaybeIO $ commitContainer cid = catchMaybeIO $
takeWhile (/= '\n') takeWhile (/= '\n')
@ -521,13 +528,13 @@ listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Property runProp :: String -> RunParam -> Property
runProp field val = pureInfoProperty (param) $ dockerInfo $ runProp field val = pureInfoProperty (param) $ dockerInfo $
mempty { _dockerRunParams = [\_ -> "--"++param] } mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where where
param = field++"="++val param = field++"="++val
genProp :: String -> (HostName -> RunParam) -> Property genProp :: String -> (HostName -> RunParam) -> Property
genProp field mkval = pureInfoProperty field $ dockerInfo $ genProp field mkval = pureInfoProperty field $ dockerInfo $
mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] } mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
dockerInfo :: DockerInfo -> Info dockerInfo :: DockerInfo -> Info
dockerInfo i = mempty { _dockerinfo = i } dockerInfo i = mempty { _dockerinfo = i }
@ -538,10 +545,6 @@ dockerInfo i = mempty { _dockerinfo = i }
propellorIdent :: FilePath propellorIdent :: FilePath
propellorIdent = "/.propellor-ident" propellorIdent = "/.propellor-ident"
-- | Named pipe used for communication with the container.
namedPipe :: ContainerId -> FilePath
namedPipe cid = "docker" </> fromContainerId cid
provisionedFlag :: ContainerId -> FilePath provisionedFlag :: ContainerId -> FilePath
provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned" provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
@ -556,6 +559,9 @@ setProvisionedFlag cid = do
checkProvisionedFlag :: ContainerId -> IO Bool checkProvisionedFlag :: ContainerId -> IO Bool
checkProvisionedFlag = doesFileExist . provisionedFlag checkProvisionedFlag = doesFileExist . provisionedFlag
provisioningLock :: ContainerId -> FilePath
provisioningLock cid = "docker" </> fromContainerId cid ++ ".lock"
shimdir :: ContainerId -> FilePath shimdir :: ContainerId -> FilePath
shimdir cid = "docker" </> fromContainerId cid ++ ".shim" shimdir cid = "docker" </> fromContainerId cid ++ ".shim"

10
src/Propellor/Property/Hostname.hs
View File

@ -7,14 +7,14 @@ import Data.List
-- | Ensures that the hostname is set using best practices. -- | Ensures that the hostname is set using best practices.
-- --
-- Configures /etc/hostname and the current hostname. -- Configures `/etc/hostname` and the current hostname.
-- --
-- Configures /etc/mailname with the domain part of the hostname. -- Configures `/etc/mailname` with the domain part of the hostname.
-- --
-- /etc/hosts is also configured, with an entry for 127.0.1.1, which is -- `/etc/hosts` is also configured, with an entry for 127.0.1.1, which is
-- standard at least on Debian to set the FDQN. -- standard at least on Debian to set the FDQN.
-- --
-- Also, the /etc/hosts 127.0.0.1 line is set to localhost. Putting any -- 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 -- other hostnames there is not best practices and can lead to annoying
-- messages from eg, apache. -- messages from eg, apache.
sane :: Property sane :: Property
@ -44,7 +44,7 @@ setTo hn = combineProperties desc go
(ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls (ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls
hasip ip l = headMaybe (words l) == Just ip hasip ip l = headMaybe (words l) == Just ip
-- | Makes /etc/resolv.conf contain search and domain lines for -- | Makes `/etc/resolv.conf` contain search and domain lines for
-- the domain that the hostname is in. -- the domain that the hostname is in.
searchDomain :: Property searchDomain :: Property
searchDomain = property desc (ensureProperty . go =<< asks hostName) searchDomain = property desc (ensureProperty . go =<< asks hostName)

10
src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
View File

@ -88,7 +88,7 @@ cabalDeps = flagFile go cabalupdated
go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"] go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"]
cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache" cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Docker.Container
standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder") standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder")
(dockerImage $ System (Debian Testing) arch) (dockerImage $ System (Debian Testing) arch)
& os (System (Debian Testing) arch) & os (System (Debian Testing) arch)
@ -101,14 +101,14 @@ standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.conta
& autobuilder arch (show buildminute ++ " * * * *") timeout & autobuilder arch (show buildminute ++ " * * * *") timeout
& Docker.tweaked & Docker.tweaked
androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container
androidAutoBuilderContainer dockerImage crontimes timeout = androidAutoBuilderContainer dockerImage crontimes timeout =
androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir
& Apt.unattendedUpgrades & Apt.unattendedUpgrades
& autobuilder "android" crontimes timeout & autobuilder "android" crontimes timeout
-- Android is cross-built in a Debian i386 container, using the Android NDK. -- Android is cross-built in a Debian i386 container, using the Android NDK.
androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container
androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
(dockerImage osver) (dockerImage osver)
& os osver & os osver
@ -137,7 +137,7 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe
-- armel builder has a companion container using amd64 that -- armel builder has a companion container using amd64 that
-- runs the build first to get TH splices. They need -- runs the build first to get TH splices. They need
-- to have the same versions of all haskell libraries installed. -- to have the same versions of all haskell libraries installed.
armelCompanionContainer :: (System -> Docker.Image) -> Host armelCompanionContainer :: (System -> Docker.Image) -> Docker.Container
armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion" armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion"
(dockerImage $ System (Debian Unstable) "amd64") (dockerImage $ System (Debian Unstable) "amd64")
& os (System (Debian Testing) "amd64") & os (System (Debian Testing) "amd64")
@ -156,7 +156,7 @@ armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-
& Ssh.authorizedKeys builduser (Context "armel-git-annex-builder") & Ssh.authorizedKeys builduser (Context "armel-git-annex-builder")
& Docker.tweaked & Docker.tweaked
armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container
armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder" armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder"
(dockerImage $ System (Debian Unstable) "armel") (dockerImage $ System (Debian Unstable) "armel")
& os (System (Debian Testing) "armel") & os (System (Debian Testing) "armel")

2
src/Propellor/Property/SiteSpecific/JoeySites.hs
View File

@ -1,4 +1,4 @@
-- | Specific configuation for Joey Hess's sites. Probably not useful to -- | Specific configuration for Joey Hess's sites. Probably not useful to
-- others except as an example. -- others except as an example.
module Propellor.Property.SiteSpecific.JoeySites where module Propellor.Property.SiteSpecific.JoeySites where

4
src/Propellor/Protocol.hs
View File

@ -2,6 +2,10 @@
-- a local and remote propellor. It's sent over a ssh channel, and lines of -- a local and remote propellor. It's sent over a ssh channel, and lines of
-- the protocol can be interspersed with other, non-protocol lines -- the protocol can be interspersed with other, non-protocol lines
-- that should be passed through to be displayed. -- that should be passed through to be displayed.
--
-- Avoid making backwards-incompatible changes to this protocol,
-- since propellor needs to use this protocol to update itself to new
-- versions speaking newer versions of the protocol.
module Propellor.Protocol where module Propellor.Protocol where

139
src/Propellor/Server.hs Normal file
View File

@ -0,0 +1,139 @@
module Propellor.Server (
update,
updateServer,
gitPushHelper
) where
import Data.List
import System.Exit
import System.PosixCompat
import System.Posix.IO
import Control.Concurrent.Async
import qualified Data.ByteString as B
import Propellor
import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Git
import Propellor.Ssh
import Utility.FileMode
import Utility.SafeCommand
-- Update the privdata, repo url, and git repo over the ssh
-- connection, talking to the user's local propellor instance which is
-- running the updateServer
update :: IO ()
update = do
req NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
req NeedPrivData privDataMarker $
writeFileProtected privDataLocal
req NeedGitPush gitPushMarker $ \_ -> do
hin <- dup stdInput
hout <- dup stdOutput
hClose stdin
hClose stdout
unlessM (boolSystem "git" (pullparams hin hout)) $
errorMessage "git pull from client failed"
where
pullparams hin hout =
[ Param "pull"
, Param "--progress"
, Param "--upload-pack"
, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
, Param "."
]
-- The connect action should ssh to the remote host and run the provided
-- calback action.
updateServer :: HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO ()
updateServer hn hst connect = connect go
where
go (toh, fromh) = do
let loop = go (toh, fromh)
v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
case v of
(Just NeedRepoUrl) -> do
sendRepoUrl toh
loop
(Just NeedPrivData) -> do
sendPrivData hn hst toh
loop
(Just NeedGitPush) -> do
sendGitUpdate hn fromh toh
-- no more protocol possible after git push
hClose fromh
hClose toh
(Just NeedGitClone) -> do
hClose toh
hClose fromh
sendGitClone hn
updateServer hn hst connect
Nothing -> return ()
sendRepoUrl :: Handle -> IO ()
sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
sendPrivData :: HostName -> Host -> Handle -> IO ()
sendPrivData hn hst toh = do
privdata <- show . filterPrivData hst <$> decryptPrivData
void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
sendMarked toh privDataMarker privdata
return True
sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
sendGitUpdate hn fromh toh =
void $ actionMessage ("Sending git update to " ++ hn) $ do
sendMarked toh gitPushMarker ""
(Nothing, Nothing, Nothing, h) <- createProcess p
(==) ExitSuccess <$> waitForProcess h
where
p = (proc "git" ["upload-pack", "."])
{ std_in = UseHandle fromh
, std_out = UseHandle toh
}
-- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> IO ()
sendGitClone hn = void $ actionMessage ("Clone 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
]
-- Shim for git push over the propellor ssh channel.
-- Reads from stdin and sends it to hout;
-- reads from hin and sends it to stdout.
gitPushHelper :: Fd -> Fd -> IO ()
gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
where
fromstdin = do
h <- fdToHandle hout
connect stdin h
tostdout = do
h <- fdToHandle hin
connect h stdout
connect fromh toh = do
hSetBinaryMode fromh True
hSetBinaryMode toh True
b <- B.hGetSome fromh 40960
if B.null b
then do
hClose fromh
hClose toh
else do
B.hPut toh b
hFlush toh
connect fromh toh

101
src/Propellor/SimpleSh.hs
View File

@ -1,101 +0,0 @@
-- | 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

75
src/Propellor/Types.hs
View File

@ -3,7 +3,7 @@
module Propellor.Types module Propellor.Types
( Host(..) ( Host(..)
, Info , Info(..)
, getInfo , getInfo
, Propellor(..) , Propellor(..)
, Property(..) , Property(..)
@ -21,6 +21,10 @@ module Propellor.Types
, Context(..) , Context(..)
, anyContext , anyContext
, SshKeyType(..) , SshKeyType(..)
, Val(..)
, fromVal
, DockerInfo(..)
, DockerRunParam(..)
, module Propellor.Types.OS , module Propellor.Types.OS
, module Propellor.Types.Dns , module Propellor.Types.Dns
) where ) where
@ -31,8 +35,10 @@ import System.Console.ANSI
import System.Posix.Types import System.Posix.Types
import "mtl" Control.Monad.Reader import "mtl" Control.Monad.Reader
import "MonadCatchIO-transformers" Control.Monad.CatchIO import "MonadCatchIO-transformers" Control.Monad.CatchIO
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Propellor.Types.Dns as Dns
import Propellor.Types.Info
import Propellor.Types.OS import Propellor.Types.OS
import Propellor.Types.Dns import Propellor.Types.Dns
import Propellor.Types.PrivData import Propellor.Types.PrivData
@ -145,8 +151,69 @@ data CmdLine
| ListFields | ListFields
| AddKey String | AddKey String
| Continue CmdLine | Continue CmdLine
| Chain HostName Bool
| Update HostName | Update HostName
| Docker HostName | DockerInit HostName
| DockerChain HostName String
| GitPush Fd Fd | GitPush Fd Fd
deriving (Read, Show, Eq) deriving (Read, Show, Eq)
-- | Information about a host.
data Info = Info
{ _os :: Val System
, _privDataFields :: S.Set (PrivDataField, Context)
, _sshPubKey :: Val String
, _aliases :: S.Set HostName
, _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 mempty
mappend old new = Info
{ _os = _os old <> _os new
, _privDataFields = _privDataFields old <> _privDataFields new
, _sshPubKey = _sshPubKey old <> _sshPubKey new
, _aliases = _aliases old <> _aliases 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
{ _dockerRunParams :: [DockerRunParam]
, _dockerContainers :: M.Map String Host
}
deriving (Show)
instance Monoid DockerInfo where
mempty = DockerInfo mempty mempty
mappend old new = DockerInfo
{ _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
, _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new)
}
instance Eq DockerInfo where
x == y = and
[ let simpl v = map (\(DockerRunParam a) -> a "") (_dockerRunParams v)
in simpl x == simpl y
]
newtype DockerRunParam = DockerRunParam (HostName -> String)
instance Show DockerRunParam where
show (DockerRunParam a) = a ""

70
src/Propellor/Types/Info.hs
View File

@ -1,70 +0,0 @@
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
, _aliases :: S.Set HostName
, _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 mempty
mappend old new = Info
{ _os = _os old <> _os new
, _privDataFields = _privDataFields old <> _privDataFields new
, _sshPubKey = _sshPubKey old <> _sshPubKey new
, _aliases = _aliases old <> _aliases 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))
]

16
src/Utility/Process.hs
View File

@ -10,9 +10,10 @@
module Utility.Process ( module Utility.Process (
module X, module X,
CreateProcess, CreateProcess(..),
StdHandle(..), StdHandle(..),
readProcess, readProcess,
readProcess',
readProcessEnv, readProcessEnv,
writeReadProcessEnv, writeReadProcessEnv,
forceSuccessProcess, forceSuccessProcess,
@ -31,6 +32,7 @@ module Utility.Process (
stdinHandle, stdinHandle,
stdoutHandle, stdoutHandle,
stderrHandle, stderrHandle,
bothHandles,
processHandle, processHandle,
devNull, devNull,
) where ) where
@ -65,17 +67,19 @@ readProcess :: FilePath -> [String] -> IO String
readProcess cmd args = readProcessEnv cmd args Nothing readProcess cmd args = readProcessEnv cmd args Nothing
readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
readProcessEnv cmd args environ = readProcessEnv cmd args environ = readProcess' p
withHandle StdoutHandle createProcessSuccess p $ \h -> do
output <- hGetContentsStrict h
hClose h
return output
where where
p = (proc cmd args) p = (proc cmd args)
{ std_out = CreatePipe { std_out = CreatePipe
, env = environ , env = environ
} }
readProcess' :: CreateProcess -> IO String
readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
output <- hGetContentsStrict h
hClose h
return output
{- Runs an action to write to a process on its stdin, {- Runs an action to write to a process on its stdin,
- returns its output, and also allows specifying the environment. - returns its output, and also allows specifying the environment.
-} -}

1
src/Utility/SafeCommand.hs
View File

@ -9,7 +9,6 @@ module Utility.SafeCommand where
import System.Exit import System.Exit
import Utility.Process import Utility.Process
import System.Process (env)
import Data.String.Utils import Data.String.Utils
import Control.Applicative import Control.Applicative
import System.FilePath import System.FilePath