summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Debootstrap.hs253
-rw-r--r--src/Propellor/Property/Dns.hs1
-rw-r--r--src/Propellor/Property/Docker.hs204
-rw-r--r--src/Propellor/Property/Hostname.hs10
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs10
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs2
6 files changed, 369 insertions, 111 deletions
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
new file mode 100644
index 00000000..4e7bc740
--- /dev/null
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -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
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 135c765d..f351804c 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -15,7 +15,6 @@ module Propellor.Property.Dns (
import Propellor
import Propellor.Types.Dns
import Propellor.Property.File
-import Propellor.Types.Info
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Utility.Applicative
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 491955dd..676d323a 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -16,6 +16,7 @@ module Propellor.Property.Docker (
tweaked,
Image,
ContainerName,
+ Container,
-- * Container configuration
dns,
hostname,
@@ -33,24 +34,26 @@ module Propellor.Property.Docker (
restartOnFailure,
restartNever,
-- * Internal use
+ init,
chain,
) where
-import Propellor
-import Propellor.SimpleSh
-import Propellor.Types.Info
+import Propellor hiding (init)
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Docker.Shim as Shim
import Utility.SafeCommand
import Utility.Path
+import Utility.ThreadScheduler
import Control.Concurrent.Async hiding (link)
import System.Posix.Directory
import System.Posix.Process
-import Data.List
+import Prelude hiding (init)
+import Data.List hiding (init)
import Data.List.Utils
import qualified Data.Set as S
+import qualified Data.Map as M
installed :: Property
installed = Apt.installed ["docker.io"]
@@ -69,55 +72,56 @@ configured = prop `requires` installed
-- only [a-zA-Z0-9_-] are allowed
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"
-- > & publish "80:80"
-- > & Apt.installed {"apache2"]
-- > & ...
-container :: ContainerName -> Image -> Host
-container cn image = Host hn [] info
+container :: ContainerName -> Image -> Container
+container cn image = Container image (Host cn [] info)
where
- info = dockerInfo $ mempty { _dockerImage = Val image }
- hn = cn2hn cn
-
-cn2hn :: ContainerName -> HostName
-cn2hn cn = cn ++ ".docker"
+ info = dockerInfo mempty
--- | Ensures that a docker container is set up and running, finding
--- its configuration in the passed list of hosts.
+-- | Ensures that a docker container is set up and running.
--
-- The container has its own Properties which are handled by running
-- propellor inside the container.
--
-- When the container's Properties include DNS info, such as a CNAME,
--- that is propigated to the Info of the host(s) it's docked in.
+-- that is propigated to the Info of the Host it's docked in.
--
-- Reverting this property ensures that the container is stopped and
-- removed.
docked
- :: [Host]
- -> ContainerName
+ :: Container
-> RevertableProperty
-docked hosts cn = RevertableProperty
- ((maybe id propigateInfo mhost) (go "docked" setup))
+docked ctr@(Container _ h) = RevertableProperty
+ (propigateInfo ctr (go "docked" setup))
(go "undocked" teardown)
where
+ cn = hostName h
+
go desc a = property (desc ++ " " ++ cn) $ do
hn <- asks hostName
let cid = ContainerId hn cn
- ensureProperties [findContainer mhost cid cn $ a cid]
-
- mhost = findHostNoAlias hosts (cn2hn cn)
+ ensureProperties [a cid (mkContainerInfo cid ctr)]
- setup cid (Container image runparams) =
+ setup cid (ContainerInfo image runparams) =
provisionContainer cid
`requires`
runningContainer cid image runparams
`requires`
installed
- teardown cid (Container image _runparams) =
+ teardown cid (ContainerInfo image _runparams) =
combineProperties ("undocked " ++ fromContainerId cid)
[ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $
@@ -127,33 +131,21 @@ docked hosts cn = RevertableProperty
]
]
-propigateInfo :: Host -> Property -> Property
-propigateInfo (Host _ _ containerinfo) p =
- combineProperties (propertyDesc p) $ p : dnsprops ++ privprops
+propigateInfo :: Container -> Property -> Property
+propigateInfo (Container _ h@(Host hn _ containerinfo)) p =
+ combineProperties (propertyDesc p) $ p' : dnsprops ++ privprops
where
+ p' = p { propertyInfo = propertyInfo p <> dockerinfo }
+ dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton hn h }
dnsprops = map addDNS (S.toList $ _dns containerinfo)
privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo)
-findContainer
- :: Maybe Host
- -> ContainerId
- -> ContainerName
- -> (Container -> Property)
- -> Property
-findContainer mhost cid cn mk = case mhost of
- Nothing -> cantfind
- Just h -> maybe cantfind mk (mkContainer cid h)
- where
- cantfind = containerDesc cid $ property "" $ do
- liftIO $ warningMessage $
- "missing definition for docker container \"" ++ cn2hn cn
- return FailedChange
-
-mkContainer :: ContainerId -> Host -> Maybe Container
-mkContainer cid@(ContainerId hn _cn) h = Container
- <$> fromVal (_dockerImage info)
- <*> pure (map (\mkparam -> mkparam hn) (_dockerRunParams info))
+mkContainerInfo :: ContainerId -> Container -> ContainerInfo
+mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
+ ContainerInfo img runparams
where
+ runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
+ (_dockerRunParams info)
info = _dockerinfo $ hostInfo h'
h' = h
-- 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"
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.
type RunParam = String
@@ -301,7 +293,10 @@ restartNever = runProp "restart" "no"
-- | A container is identified by its name, and the host
-- on which it's deployed.
-data ContainerId = ContainerId HostName ContainerName
+data ContainerId = ContainerId
+ { containerHostName :: HostName
+ , containerName :: ContainerName
+ }
deriving (Eq, Read, Show)
-- | Two containers with the same ContainerIdent were started from
@@ -324,22 +319,19 @@ toContainerId s
fromContainerId :: ContainerId -> String
fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
-containerHostName :: ContainerId -> HostName
-containerHostName (ContainerId _ cn) = cn2hn cn
-
myContainerSuffix :: String
myContainerSuffix = ".propellor"
containerDesc :: ContainerId -> Property -> Property
containerDesc cid p = p `describe` desc
where
- desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
+ desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
runningContainer :: ContainerId -> Image -> [RunParam] -> Property
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers
if cid `elem` l
- then checkident =<< liftIO (getrunningident simpleShClient)
+ then checkident =<< liftIO getrunningident
else ifM (liftIO $ elem cid <$> listContainers AllContainers)
( do
-- The container exists, but is not
@@ -348,9 +340,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
-- starting it up first.
void $ liftIO $ startContainer cid
-- It can take a while for the container to
- -- start up enough to get its ident, so
- -- retry for up to 60 seconds.
- checkident =<< liftIO (getrunningident (simpleShClientRetry 60))
+ -- start up enough for its ident file to be
+ -- written, so retry for up to 60 seconds.
+ checkident =<< liftIO (retry 60 $ getrunningident)
, go image
)
where
@@ -370,12 +362,18 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
void $ liftIO $ removeContainer cid
go oldimage
- getrunningident shclient = shclient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
- let !v = extractident rs
- return v
+ getrunningident = readish
+ <$> readProcess' (inContainerProcess cid [] ["cat", propellorIdent])
- extractident :: [Resp] -> Maybe ContainerIdent
- extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
+ retry :: Int -> IO (Maybe a) -> IO (Maybe a)
+ 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
liftIO $ do
@@ -385,7 +383,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
liftIO $ writeFile (identFile cid) (show ident)
ensureProperty $ boolProperty "run" $ runContainer img
(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.
-- 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.
-- It even needs to wait on zombie processes!
--
--- Fork a thread to run the SimpleSh server in the background.
-- In the foreground, run an interactive bash (or sh) shell,
-- so that the user can interact with it when attached to the container.
--
@@ -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
-- to provision the container then. However, if the container is already
-- being provisioned by the calling propellor, it would be redundant and
--- problimatic to also provisoon it here.
+-- problimatic to also provisoon it here, when not booting up.
--
-- The solution is a flag file. If the flag file exists, then the container
-- was already provisioned. So, it must be a reboot, and time to provision
-- again. If the flag file doesn't exist, don't provision here.
-chain :: String -> IO ()
-chain s = case toContainerId s of
+init :: String -> IO ()
+init s = case toContainerId s of
Nothing -> error $ "Invalid ContainerId: " ++ s
Just cid -> do
changeWorkingDirectory localdir
writeFile propellorIdent . show =<< readIdentFile cid
- -- Run boot provisioning before starting simpleSh,
- -- to avoid ever provisioning twice at the same time.
whenM (checkProvisionedFlag cid) $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
- unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain (containerHostName cid) False]) $
+ unlessM (boolSystem shim [Param "--continue", Param $ show $ toChain cid]) $
warningMessage "Boot provision failed!"
void $ async $ job reapzombies
- void $ async $ job $ simpleSh $ namedPipe cid
job $ do
void $ tryIO $ ifM (inPath "bash")
( boolSystem "bash" [Param "-l"]
@@ -432,36 +426,47 @@ chain s = case toContainerId s of
-- | Once a container is running, propellor can be run inside
-- it to provision it.
---
--- Note that there is a race here, between the simplesh
--- server starting up in the container, and this property
--- being run. So, retry connections to the client for up to
--- 1 minute.
provisionContainer :: ContainerId -> Property
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
+ let params = ["--continue", show $ toChain cid]
msgh <- mkMessageHandle
- let params = ["--continue", show $ Chain (containerHostName cid) (isConsole msgh)]
- r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
+ let p = inContainerProcess cid
+ [ if isConsole msgh then "-it" else "-i" ]
+ (shim : params)
+ r <- withHandle StdoutHandle createProcessSuccess p $
+ processoutput Nothing
when (r /= FailedChange) $
setProvisionedFlag cid
return r
where
- go lastline (v:rest) = case v of
- StdoutLine s -> do
- maybe noop putStrLn lastline
- hFlush stdout
- go (Just s) rest
- StderrLine s -> do
- maybe noop putStrLn lastline
- hFlush stdout
- hPutStrLn stderr s
- hFlush stderr
- go Nothing rest
- Done -> ret lastline
- go lastline [] = ret lastline
-
- ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
+ processoutput lastline h = do
+ v <- catchMaybeIO (hGetLine h)
+ case v of
+ Nothing -> pure $ fromMaybe FailedChange $
+ readish =<< lastline
+ Just s -> do
+ maybe noop putStrLn lastline
+ hFlush stdout
+ processoutput (Just s) h
+
+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 cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
@@ -479,7 +484,6 @@ stoppedContainer cid = containerDesc cid $ property desc $
where
desc = "stopped"
cleanup = do
- nukeFile $ namedPipe cid
nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid
clearProvisionedFlag cid
@@ -496,6 +500,9 @@ runContainer :: Image -> [RunParam] -> [String] -> IO Bool
runContainer image ps cmd = boolSystem dockercmd $ map Param $
"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 cid = catchMaybeIO $
takeWhile (/= '\n')
@@ -521,13 +528,13 @@ listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Property
runProp field val = pureInfoProperty (param) $ dockerInfo $
- mempty { _dockerRunParams = [\_ -> "--"++param] }
+ mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
param = field++"="++val
genProp :: String -> (HostName -> RunParam) -> Property
genProp field mkval = pureInfoProperty field $ dockerInfo $
- mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] }
+ mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
dockerInfo :: DockerInfo -> Info
dockerInfo i = mempty { _dockerinfo = i }
@@ -538,10 +545,6 @@ dockerInfo i = mempty { _dockerinfo = i }
propellorIdent :: FilePath
propellorIdent = "/.propellor-ident"
--- | Named pipe used for communication with the container.
-namedPipe :: ContainerId -> FilePath
-namedPipe cid = "docker" </> fromContainerId cid
-
provisionedFlag :: ContainerId -> FilePath
provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
@@ -556,6 +559,9 @@ setProvisionedFlag cid = do
checkProvisionedFlag :: ContainerId -> IO Bool
checkProvisionedFlag = doesFileExist . provisionedFlag
+provisioningLock :: ContainerId -> FilePath
+provisioningLock cid = "docker" </> fromContainerId cid ++ ".lock"
+
shimdir :: ContainerId -> FilePath
shimdir cid = "docker" </> fromContainerId cid ++ ".shim"
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index c489e2fb..4a5e77d3 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -7,14 +7,14 @@ import Data.List
-- | 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.
--
--- 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
-- messages from eg, apache.
sane :: Property
@@ -44,7 +44,7 @@ setTo hn = combineProperties desc go
(ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls
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.
searchDomain :: Property
searchDomain = property desc (ensureProperty . go =<< asks hostName)
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 901eba2e..0208dea6 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -88,7 +88,7 @@ cabalDeps = flagFile go cabalupdated
go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"]
cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
-standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host
+standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Docker.Container
standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder")
(dockerImage $ 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
& Docker.tweaked
-androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host
+androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Docker.Container
androidAutoBuilderContainer dockerImage crontimes timeout =
androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir
& Apt.unattendedUpgrades
& autobuilder "android" crontimes timeout
-- Android is cross-built in a Debian i386 container, using the Android NDK.
-androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host
+androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container
androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
(dockerImage osver)
& os osver
@@ -137,7 +137,7 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe
-- armel builder has a companion container using amd64 that
-- runs the build first to get TH splices. They need
-- to have the same versions of all haskell libraries installed.
-armelCompanionContainer :: (System -> Docker.Image) -> Host
+armelCompanionContainer :: (System -> Docker.Image) -> Docker.Container
armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion"
(dockerImage $ System (Debian Unstable) "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")
& 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"
(dockerImage $ System (Debian Unstable) "armel")
& os (System (Debian Testing) "armel")
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 4a95067f..ad1c661a 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -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.
module Propellor.Property.SiteSpecific.JoeySites where