Merge branch 'joeyconfig'

Conflicts:
	config.hs
This commit is contained in:
Joey Hess 2014-04-04 01:12:44 -04:00
commit 8bb175d107
13 changed files with 216 additions and 44 deletions

1
.gitignore vendored
View File

@ -6,3 +6,4 @@ privdata/keyring.gpg~
Setup
Setup.hi
Setup.o
docker

View File

@ -10,13 +10,15 @@ 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.Reboot as Reboot
import qualified Propellor.Property.Tor as Tor
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
import Data.List
-- Only imported to make sure it continues to build.
import qualified ConfigSimple as Simple
main :: IO ()
main = defaultMain [host, Docker.containerProperties container]
@ -45,7 +47,7 @@ host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
& Docker.configured
& Apt.buildDep ["git-annex"]
& Docker.docked container hostname "amd64-git-annex-builder"
! Docker.docked container hostname "i386-git-annex-builder"
& Docker.docked container hostname "i386-git-annex-builder"
& Docker.garbageCollected
-- My laptop
host _hostname@"darkstar.kitenet.net" = Just $ props
@ -75,17 +77,14 @@ container _host name
| otherwise = Nothing
-- | Docker images I prefer to use.
-- Edit as suites you, or delete this function and just put the image names
-- above.
image :: System -> Docker.Image
image (System (Debian Unstable) "amd64") = "joeyh/debian-unstable"
image (System (Debian Unstable) "i386") = "joeyh/debian-unstable-i386"
image _ = "debian"
image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
image _ = "debian-stable-official" -- does not currently exist!
-- This is my standard system setup
standardSystem :: DebianSuite -> [Property] -> Maybe [Property]
standardSystem suite customprops = Just $
standardprops : customprops ++ [endprops]
standardprops : customprops ++ endprops
where
standardprops = propertyList "standard system" $ props
& Apt.stdSourcesList suite `onChange` Apt.upgrade
@ -104,9 +103,11 @@ standardSystem suite customprops = Just $
& Apt.installed ["vim", "screen", "less"]
& Cron.runPropellor "30 * * * *"
-- I use postfix, or no MTA.
& Apt.removed ["exim4"] `onChange` Apt.autoRemove
-- May reboot, so comes last.
endprops = Apt.installed ["systemd-sysv"] `onChange` Reboot.now
& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
`onChange` Apt.autoRemove
-- May reboot, so comes last
-- Currently not enable due to #726375
endprops = [] -- [Apt.installed ["systemd-sysv"] `onChange` Reboot.now]
-- Clean up a system as installed by cloudatcost.com
cleanCloudAtCost :: HostName -> Property

View File

@ -15,21 +15,25 @@ actionMessage desc a = do
r <- a
setTitle "propellor: running"
let (msg, intensity, color) = getActionResult r
putStr $ desc ++ " ... "
setSGR [SetColor Foreground intensity color]
putStrLn msg
setSGR []
setTitle "propellor: running"
colorLine intensity color msg
hFlush stdout
return r
warningMessage :: String -> IO ()
warningMessage s = do
setSGR [SetColor Foreground Vivid Red]
putStrLn $ "** warning: " ++ s
warningMessage s = colorLine Vivid Red $ "** 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

View File

@ -4,13 +4,6 @@
--
-- The existance of a docker container is just another Property of a system,
-- which propellor can set up. See config.hs for an example.
--
-- Note that propellor provisions a container by running itself, inside the
-- container. Currently, to avoid the overhead of building propellor
-- inside the container, the binary from outside is reused inside.
-- So, the libraries that propellor is linked against need to be available
-- in the container with compatable versions. This can cause a problem
-- if eg, mixing Debian stable and unstable.
module Propellor.Property.Docker where
@ -18,6 +11,7 @@ import Propellor
import Propellor.SimpleSh
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
@ -256,15 +250,14 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
, name (fromContainerId cid)
]
chaincmd = [localdir </> "propellor", "--docker", fromContainerId cid]
go img = do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
shim <- Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
writeFile (identFile cid) (show ident)
ensureProperty $ boolProperty "run" $ runContainer img
(runps ++ ["-i", "-d", "-t"])
chaincmd
[shim, "--docker", fromContainerId cid]
-- | Called when propellor is running inside a docker container.
-- The string should be the container's ContainerId.
@ -290,8 +283,9 @@ chain s = case toContainerId s of
writeFile propellorIdent . show =<< readIdentFile cid
-- Run boot provisioning before starting simpleSh,
-- to avoid ever provisioning twice at the same time.
whenM (checkProvisionedFlag cid) $
unlessM (boolSystem "./propellor" [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $
whenM (checkProvisionedFlag cid) $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $
warningMessage "Boot provision failed!"
void $ async $ simpleSh $ namedPipe cid
forever $ do
@ -310,7 +304,8 @@ chain s = case toContainerId s of
-- 1 minute.
provisionContainer :: ContainerId -> Property
provisionContainer cid = containerDesc cid $ Property "provision" $ do
r <- simpleShClientRetry 60 (namedPipe cid) "./propellor" params (go Nothing)
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
@ -342,11 +337,17 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
stoppedContainer :: ContainerId -> Property
stoppedContainer cid = containerDesc cid $ Property desc $
ifM (elem cid <$> listContainers RunningContainers)
( ensureProperty $ boolProperty desc $ stopContainer cid
( 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 $
@ -396,10 +397,10 @@ propellorIdent = "/.propellor-ident"
-- | Named pipe used for communication with the container.
namedPipe :: ContainerId -> FilePath
namedPipe cid = "docker/" ++ fromContainerId cid
namedPipe cid = "docker" </> fromContainerId cid
provisionedFlag :: ContainerId -> FilePath
provisionedFlag cid = "docker/" ++ fromContainerId cid ++ ".provisioned"
provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
clearProvisionedFlag :: ContainerId -> IO ()
clearProvisionedFlag = nukeFile . provisionedFlag
@ -412,8 +413,11 @@ setProvisionedFlag cid = do
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"
identFile cid = "docker" </> fromContainerId cid ++ ".ident"
readIdentFile :: ContainerId -> IO ContainerIdent
readIdentFile cid = fromMaybe (error "bad ident in identFile")

View File

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

@ -2,6 +2,8 @@ module Propellor.Property.File where
import Propellor
import System.Posix.Files
type Line = String
-- | Replaces all the content of a file.
@ -32,13 +34,19 @@ fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
fileProperty desc a f = Property desc $ go =<< doesFileExist f
where
go True = do
ls <- lines <$> catchDefaultIO [] (readFile f)
ls <- lines <$> readFile f
let ls' = a ls
if ls' == ls
then noChange
else makeChange $ viaTmp writeFile f (unlines ls')
else makeChange $ viaTmp updatefile f (unlines ls')
go False = makeChange $ writeFile f (unlines $ a [])
-- viaTmp makes the temp file mode 600.
-- Replicate the original file mode before moving it into place.
updatefile f' content = do
writeFile f' content
getFileStatus f >>= setFileMode f' . fileMode
-- | Ensures a directory exists.
dirExists :: FilePath -> Property
dirExists d = check (not <$> doesDirectoryExist d) $ Property (d ++ " exists") $

View File

@ -3,7 +3,29 @@ module Propellor.Property.Hostname where
import Propellor
import qualified Propellor.Property.File as File
-- | Sets the hostname. Configures both /etc/hostname and the current
-- hostname.
--
-- When provided with a FQDN, also configures /etc/hosts,
-- with an entry for 127.0.1.1, which is standard at least on Debian
-- to set the FDQN (127.0.0.1 is localhost).
set :: HostName -> Property
set hostname = "/etc/hostname" `File.hasContent` [hostname]
`onChange` cmdProperty "hostname" [hostname]
`describe` ("hostname " ++ hostname)
set hostname = combineProperties desc go
`onChange` cmdProperty "hostname" [host]
where
desc = "hostname " ++ hostname
(host, domain) = separate (== '.') hostname
go = catMaybes
[ Just $ "/etc/hostname" `File.hasContent` [host]
, if null domain
then Nothing
else Just $ File.fileProperty desc
addhostline "/etc/hosts"
]
hostip = "127.0.1.1"
hostline = hostip ++ "\t" ++ hostname ++ " " ++ host
addhostline ls = hostline : filter (not . hashostip) ls
hashostip l = headMaybe (words l) == Just hostip

2
TODO
View File

@ -12,3 +12,5 @@
says they are unchanged even when they changed and triggered a
reprovision.
* Should properties be a tree rather than a list?
* Only make docker garbage collection run once a day or something
to avoid GC after a temp fail.

61
Utility/LinuxMkLibs.hs Normal file
View File

@ -0,0 +1,61 @@
{- Linux library copier and binary shimmer
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
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 = catMaybes . map (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'"]

View File

@ -1 +1 @@
config-simple.hs
Propellor/Config/Simple.hs

9
debian/changelog vendored
View File

@ -1,3 +1,12 @@
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.

View File

@ -1,5 +1,5 @@
Name: propellor
Version: 0.2.1
Version: 0.2.2
Cabal-Version: >= 1.6
License: GPL
Maintainer: Joey Hess <joey@kitenet.net>
@ -14,8 +14,6 @@ Extra-Source-Files:
README.md
TODO
CHANGELOG
config-simple.hs
config-joeyh.hs
Makefile
debian/changelog
debian/README.Debian
@ -64,6 +62,8 @@ Library
Exposed-Modules:
Propellor
Propellor.Config.Simple
Propellor.Config.Joey
Propellor.Property
Propellor.Property.Apt
Propellor.Property.Cmd
@ -87,6 +87,7 @@ Library
Other-Modules:
Propellor.CmdLine
Propellor.SimpleSh
Propellor.Property.Docker.Shim
Utility.Applicative
Utility.Data
Utility.Directory
@ -94,6 +95,7 @@ Library
Utility.Exception
Utility.FileMode
Utility.FileSystemEncoding
Utility.LinuxMkLibs
Utility.Misc
Utility.Monad
Utility.Path