better method of starting propellor simplesh inside docker

This commit is contained in:
Joey Hess 2014-04-01 13:51:58 -04:00
parent 2c328ad142
commit 79cbdf35b1
11 changed files with 532 additions and 65 deletions

View File

@ -32,6 +32,7 @@ module Propellor (
, module Propellor.PrivData
, module Propellor.Engine
, module Propellor.Message
, localdir
, module X
) where
@ -61,3 +62,7 @@ import Control.Applicative as X
import Control.Monad as X
import Data.Monoid as X
import Control.Monad.IfElse as X
-- | This is where propellor installs itself when deploying a host.
localdir :: FilePath
localdir = "/usr/local/propellor"

View File

@ -9,21 +9,10 @@ import System.Log.Handler (setFormatter, LogHandler)
import System.Log.Handler.Simple
import Propellor
import Propellor.SimpleSh
import qualified Propellor.Property.Docker as Docker
import Utility.FileMode
import Utility.SafeCommand
data CmdLine
= Run HostName
| Spin HostName
| Boot HostName
| Set HostName PrivDataField
| AddKey String
| Continue CmdLine
| SimpleSh FilePath
| Chain HostName
deriving (Read, Show, Eq)
usage :: IO a
usage = do
putStrLn $ unlines
@ -49,7 +38,6 @@ processCmdLine = go =<< getArgs
go ("--continue":s:[]) = case readish s of
Just cmdline -> return $ Continue cmdline
Nothing -> errorMessage "--continue serialization failure"
go ("--simplesh":f:[]) = return $ SimpleSh f
go ("--chain":h:[]) = return $ Chain h
go (h:[])
| "--" `isPrefixOf` h = usage
@ -71,8 +59,8 @@ defaultMain getprops = do
go _ (Continue cmdline) = go False cmdline
go _ (Set host field) = setPrivData host field
go _ (AddKey keyid) = addKey keyid
go _ (SimpleSh f) = simpleSh f
go _ (Chain host) = withprops host $ print <=< ensureProperties'
go _ (ChainDocker host) = Docker.chain host
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin host) = withprops host $ const $ spin host
@ -296,9 +284,6 @@ keyring = privDataDir </> "keyring.gpg"
gpgopts :: [String]
gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring]
localdir :: FilePath
localdir = "/usr/local/propellor"
getUrl :: IO String
getUrl = maybe nourl return =<< getM get urls
where

View File

@ -18,15 +18,6 @@ import Utility.Tmp
import Utility.SafeCommand
import Utility.Misc
-- | Note that removing or changing field names will break the
-- serialized privdata files, so don't do that!
-- It's fine to add new fields.
data PrivDataField
= DockerAuthentication
| SshPrivKey UserName
| Password UserName
deriving (Read, Show, Ord, Eq)
withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result
withPrivData field a = maybe missing a =<< getPrivData field
where

View File

@ -3,7 +3,6 @@ module Propellor.Property.Cron where
import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Propellor.CmdLine
type CronTimes = String

View File

@ -3,11 +3,13 @@
module Propellor.Property.Docker where
import Propellor
import Propellor.CmdLine
import Propellor.SimpleSh
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Utility.SafeCommand
import Utility.Path
import Control.Concurrent.Async
dockercmd :: String
dockercmd = "docker.io"
@ -76,6 +78,9 @@ containerProperties findcontainer = \h -> case toContainerId h of
Just (Container _ cprops) ->
Just $ fromContainerized cprops
containerDesc :: ContainerId -> Desc -> Desc
containerDesc cid d = "docker container " ++ fromContainerId cid ++ " " ++ d
-- | 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.
@ -86,20 +91,18 @@ hasContainer
-> Property
hasContainer hn cn findcontainer =
case findcontainer hn cn of
Nothing -> Property desc $ do
Nothing -> Property (containerDesc cid "") $ do
warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid
return FailedChange
Just (Container image containerprops) ->
Property desc (provisionContainer cid)
provisionContainer cid
`requires`
Property desc (ensureContainer cid image containerprops)
runningContainer cid image containerprops
where
cid = ContainerId hn cn
desc = "docker container " ++ fromContainerId cid
ensureContainer :: ContainerId -> Image -> [Containerized Property] -> IO Result
ensureContainer cid@(ContainerId hn cn) image containerprops = do
runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property
runningContainer cid@(ContainerId hn cn) image containerprops = Property (containerDesc cid "running") $ do
l <- listContainers RunningContainers
if cid `elem` l
then do
@ -123,11 +126,9 @@ ensureContainer cid@(ContainerId hn cn) image containerprops = do
-- is also started, so the user can attach and use it if desired.
startsimplesh = ["sh", "-c", "./propellor --simplesh " ++ namedPipe cid ++ " & bash -l"]
getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $
getrunningident = catchDefaultIO Nothing $
simpleShClient (namedPipe cid) "cat" [propellorIdent] $
pure . headMaybe . catMaybes . map readish . catMaybes . map getStdout
setrunningident = simpleShClient (namedPipe cid) "sh"
["-c", "echo '" ++ show ident ++ "' > " ++ propellorIdent]
(const noop)
runps = getRunParams $ containerprops ++
-- expose propellor directory inside the container
@ -140,15 +141,55 @@ ensureContainer cid@(ContainerId hn cn) image containerprops = do
]
go img = ifM (runContainer img (runps ++ ["-i", "-d", "-t"]) startsimplesh)
( do
setrunningident
return MadeChange
( return MadeChange
, return FailedChange
)
provisionContainer :: ContainerId -> IO Result
provisionContainer cid = do
simpleShClient (namedPipe cid) "./propellor" [show params] (go Nothing)
-- | Two containers with the same ContainerIdent were started from
-- the same base image (possibly a different version though), and
-- with the same RunParams.
data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
deriving (Read, Show, Eq)
-- | The ContainerIdent of a container is written to
-- /.propellor-ident inside it. This can be checked to see if
-- the container has the same ident later.
propellorIdent :: FilePath
propellorIdent = "/.propellor-ident"
-- | Named pipe used for communication with the container.
namedPipe :: ContainerId -> FilePath
namedPipe cid = "docker/" ++ fromContainerId cid
-- | Called when propellor is running inside a docker container.
-- The string should be the container's ContainerIdent.
--
-- 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.
chain :: String -> IO ()
chain s = case readish s of
Nothing -> error $ "Invalid ContainerId: " ++ s
Just ident@(ContainerIdent _image hn cn _rp) -> do
let cid = ContainerId hn cn
writeFile propellorIdent (show ident)
t <- async $ simpleSh $ namedPipe cid
void $ ifM (inPath "bash")
( boolSystem "bash" [Param "-l"]
, boolSystem "/bin/sh" []
)
wait t
-- | 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 = Property (containerDesc cid "provision") $
simpleShClientRetry 60 (namedPipe cid) "./propellor" [show params] (go Nothing)
where
params = Chain $ fromContainerId cid
@ -169,22 +210,6 @@ provisionContainer cid = do
ret lastline = return $ fromMaybe FailedChange $
readish =<< lastline
-- | Two containers with the same ContainerIdent were started from
-- the same base image (possibly a different version though), and
-- with the same RunParams.
data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
deriving (Read, Show, Eq)
-- | The ContainerIdent of a container is written to
-- /.propellor-ident inside it. This can be checked to see if
-- the container has the same ident later.
propellorIdent :: FilePath
propellorIdent = "/.propellor-ident"
-- | Named pipe used for communication with the container.
namedPipe :: ContainerId -> FilePath
namedPipe cid = "docker/" ++ fromContainerId cid
stopContainer :: ContainerId -> IO Bool
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]

View File

@ -12,6 +12,8 @@ import System.Process (std_in, std_out, std_err)
import System.Exit
import Propellor
import Utility.FileMode
import Utility.ThreadScheduler
data Cmd = Cmd String [String]
deriving (Read, Show)
@ -22,7 +24,9 @@ data Resp = StdoutLine String | StderrLine String | Done ExitCode
simpleSh :: FilePath -> IO ()
simpleSh namedpipe = do
nukeFile namedpipe
createDirectoryIfMissing True (takeDirectory namedpipe)
let dir = takeDirectory namedpipe
createDirectoryIfMissing True dir
modifyFileMode dir (removeModes otherGroupModes)
s <- socket AF_UNIX Stream defaultProtocol
bind s (SockAddrUnix namedpipe)
listen s 2
@ -73,6 +77,20 @@ simpleShClient namedpipe cmd params handler = do
resps <- catMaybes . map readish . lines <$> hGetContents h
hClose h `after` handler resps
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 _ -> do
threadDelaySeconds (Seconds 1)
go (n - 1)
getStdout :: Resp -> Maybe String
getStdout (StdoutLine s) = Just s
getStdout _ = Nothing

View File

@ -37,3 +37,23 @@ instance ActionResult Result where
getActionResult NoChange = ("unchanged", Dull, Green)
getActionResult MadeChange = ("done", Vivid, Green)
getActionResult FailedChange = ("failed", Vivid, Red)
data CmdLine
= Run HostName
| Spin HostName
| Boot HostName
| Set HostName PrivDataField
| AddKey String
| Continue CmdLine
| Chain HostName
| ChainDocker HostName
deriving (Read, Show, Eq)
-- | Note that removing or changing field names will break the
-- serialized privdata files, so don't do that!
-- It's fine to add new fields.
data PrivDataField
= DockerAuthentication
| SshPrivKey UserName
| Password UserName
deriving (Read, Show, Ord, Eq)

293
Utility/Path.hs Normal file
View File

@ -0,0 +1,293 @@
{- path manipulation
-
- Copyright 2010-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE PackageImports, CPP #-}
module Utility.Path where
import Data.String.Utils
import System.FilePath
import System.Directory
import Data.List
import Data.Maybe
import Data.Char
import Control.Applicative
#ifdef mingw32_HOST_OS
import qualified System.FilePath.Posix as Posix
#else
import System.Posix.Files
#endif
import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo
{- Simplifies a path, removing any ".." or ".", and removing the trailing
- path separator.
-
- On Windows, preserves whichever style of path separator might be used in
- the input FilePaths. This is done because some programs in Windows
- demand a particular path separator -- and which one actually varies!
-
- This does not guarantee that two paths that refer to the same location,
- and are both relative to the same location (or both absolute) will
- yeild the same result. Run both through normalise from System.FilePath
- to ensure that.
-}
simplifyPath :: FilePath -> FilePath
simplifyPath path = dropTrailingPathSeparator $
joinDrive drive $ joinPath $ norm [] $ splitPath path'
where
(drive, path') = splitDrive path
norm c [] = reverse c
norm c (p:ps)
| p' == ".." = norm (drop 1 c) ps
| p' == "." = norm c ps
| otherwise = norm (p:c) ps
where
p' = dropTrailingPathSeparator p
{- Makes a path absolute.
-
- The first parameter is a base directory (ie, the cwd) to use if the path
- is not already absolute.
-
- Does not attempt to deal with edge cases or ensure security with
- untrusted inputs.
-}
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom dir path = simplifyPath (combine dir path)
{- On Windows, this converts the paths to unix-style, in order to run
- MissingH's absNormPath on them. Resulting path will use / separators. -}
absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
#ifndef mingw32_HOST_OS
absNormPathUnix dir path = MissingH.absNormPath dir path
#else
absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)
where
fromdos = replace "\\" "/"
todos = replace "/" "\\"
#endif
{- Returns the parent directory of a path.
-
- To allow this to be easily used in loops, which terminate upon reaching the
- top, the parent of / is "" -}
parentDir :: FilePath -> FilePath
parentDir dir
| null dirs = ""
| otherwise = joinDrive drive (join s $ init dirs)
where
-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
(drive, path) = splitDrive dir
dirs = filter (not . null) $ split s path
s = [pathSeparator]
prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir
| null dir = True
| dir == "/" = parentDir dir == ""
| otherwise = p /= dir
where
p = parentDir dir
{- Checks if the first FilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- are all equivilant.
-}
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
where
a' = norm a
b' = norm b
norm = normalise . simplifyPath
{- Converts a filename into an absolute path.
-
- Unlike Directory.canonicalizePath, this does not require the path
- already exists. -}
absPath :: FilePath -> IO FilePath
absPath file = do
cwd <- getCurrentDirectory
return $ absPathFrom cwd file
{- Constructs a relative path from the CWD to a file.
-
- For example, assuming CWD is /tmp/foo/bar:
- relPathCwdToFile "/tmp/foo" == ".."
- relPathCwdToFile "/tmp/foo/bar" == ""
-}
relPathCwdToFile :: FilePath -> IO FilePath
relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
{- Constructs a relative path from a directory to a file.
-
- Both must be absolute, and cannot contain .. etc. (eg use absPath first).
-}
relPathDirToFile :: FilePath -> FilePath -> FilePath
relPathDirToFile from to = join s $ dotdots ++ uncommon
where
s = [pathSeparator]
pfrom = split s from
pto = split s to
common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
| from == to = null r
| otherwise = not (null r)
where
r = relPathDirToFile from to
prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
where
{- Two paths have the same directory component at the same
- location, but it's not really the same directory.
- Code used to get this wrong. -}
same_dir_shortcurcuits_at_difference =
relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
{- Given an original list of paths, and an expanded list derived from it,
- generates a list of lists, where each sublist corresponds to one of the
- original paths. When the original path is a directory, any items
- in the expanded list that are contained in that directory will appear in
- its segment.
-}
segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest
where
(found, rest)=partition (l `dirContains`) new
{- This assumes that it's cheaper to call segmentPaths on the result,
- than it would be to run the action separately with each path. In
- the case of git file list commands, that assumption tends to hold.
-}
runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
runSegmentPaths a paths = segmentPaths paths <$> a paths
{- Converts paths in the home directory to use ~/ -}
relHome :: FilePath -> IO String
relHome path = do
home <- myHomeDir
return $ if dirContains home path
then "~/" ++ relPathDirToFile home path
else path
{- Checks if a command is available in PATH.
-
- The command may be fully-qualified, in which case, this succeeds as
- long as it exists. -}
inPath :: String -> IO Bool
inPath command = isJust <$> searchPath command
{- Finds a command in PATH and returns the full path to it.
-
- The command may be fully qualified already, in which case it will
- be returned if it exists.
-}
searchPath :: String -> IO (Maybe FilePath)
searchPath command
| isAbsolute command = check command
| otherwise = getSearchPath >>= getM indir
where
indir d = check $ d </> command
check f = firstM doesFileExist
#ifdef mingw32_HOST_OS
[f, f ++ ".exe"]
#else
[f]
#endif
{- Checks if a filename is a unix dotfile. All files inside dotdirs
- count as dotfiles. -}
dotfile :: FilePath -> Bool
dotfile file
| f == "." = False
| f == ".." = False
| f == "" = False
| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
where
f = takeFileName file
{- Converts a DOS style path to a Cygwin style path. Only on Windows.
- Any trailing '\' is preserved as a trailing '/' -}
toCygPath :: FilePath -> FilePath
#ifndef mingw32_HOST_OS
toCygPath = id
#else
toCygPath p
| null drive = recombine parts
| otherwise = recombine $ "/cygdrive" : driveletter drive : parts
where
(drive, p') = splitDrive p
parts = splitDirectories p'
driveletter = map toLower . takeWhile (/= ':')
recombine = fixtrailing . Posix.joinPath
fixtrailing s
| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
| otherwise = s
#endif
{- Maximum size to use for a file in a specified directory.
-
- Many systems have a 255 byte limit to the name of a file,
- so that's taken as the max if the system has a larger limit, or has no
- limit.
-}
fileNameLengthLimit :: FilePath -> IO Int
#ifdef mingw32_HOST_OS
fileNameLengthLimit _ = return 255
#else
fileNameLengthLimit dir = do
l <- fromIntegral <$> getPathVar dir FileNameLimit
if l <= 0
then return 255
else return $ minimum [l, 255]
where
#endif
{- Given a string that we'd like to use as the basis for FilePath, but that
- was provided by a third party and is not to be trusted, returns the closest
- sane FilePath.
-
- All spaces and punctuation and other wacky stuff are replaced
- with '_', except for '.' "../" will thus turn into ".._", which is safe.
-}
sanitizeFilePath :: String -> FilePath
sanitizeFilePath = map sanitize
where
sanitize c
| c == '.' = c
| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
| otherwise = c
{- Similar to splitExtensions, but knows that some things in FilePaths
- after a dot are too long to be extensions. -}
splitShortExtensions :: FilePath -> (FilePath, [String])
splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
splitShortExtensions' maxextension = go []
where
go c f
| len > 0 && len <= maxextension && not (null base) =
go (ext:c) base
| otherwise = (f, c)
where
(base, ext) = splitExtension f
len = length ext

View File

@ -0,0 +1,73 @@
{- thread scheduling
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
- Copyright 2011 Bas van Dijk & Roel van Dijk
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Utility.ThreadScheduler where
import Control.Monad
import Control.Monad.IfElse
import System.Posix.IO
import Control.Concurrent
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#ifndef __ANDROID__
import System.Posix.Terminal
#endif
#endif
newtype Seconds = Seconds { fromSeconds :: Int }
deriving (Eq, Ord, Show)
type Microseconds = Integer
{- Runs an action repeatedly forever, sleeping at least the specified number
- of seconds in between. -}
runEvery :: Seconds -> IO a -> IO a
runEvery n a = forever $ do
threadDelaySeconds n
a
threadDelaySeconds :: Seconds -> IO ()
threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
{- Like threadDelay, but not bounded by an Int.
-
- There is no guarantee that the thread will be rescheduled promptly when the
- delay has expired, but the thread will never continue to run earlier than
- specified.
-
- Taken from the unbounded-delay package to avoid a dependency for 4 lines
- of code.
-}
unboundDelay :: Microseconds -> IO ()
unboundDelay time = do
let maxWait = min time $ toInteger (maxBound :: Int)
threadDelay $ fromInteger maxWait
when (maxWait /= time) $ unboundDelay (time - maxWait)
{- Pauses the main thread, letting children run until program termination. -}
waitForTermination :: IO ()
waitForTermination = do
#ifdef mingw32_HOST_OS
runEvery (Seconds 600) $
void getLine
#else
lock <- newEmptyMVar
let check sig = void $
installHandler sig (CatchOnce $ putMVar lock ()) Nothing
check softwareTermination
#ifndef __ANDROID__
whenM (queryTerminal stdInput) $
check keyboardSignal
#endif
takeMVar lock
#endif
oneSecond :: Microseconds
oneSecond = 1000000

55
Utility/UserInfo.hs Normal file
View File

@ -0,0 +1,55 @@
{- user info
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Utility.UserInfo (
myHomeDir,
myUserName,
myUserGecos,
) where
import Control.Applicative
import System.PosixCompat
import Utility.Env
{- Current user's home directory.
-
- getpwent will fail on LDAP or NIS, so use HOME if set. -}
myHomeDir :: IO FilePath
myHomeDir = myVal env homeDirectory
where
#ifndef mingw32_HOST_OS
env = ["HOME"]
#else
env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin
#endif
{- Current user's user name. -}
myUserName :: IO String
myUserName = myVal env userName
where
#ifndef mingw32_HOST_OS
env = ["USER", "LOGNAME"]
#else
env = ["USERNAME", "USER", "LOGNAME"]
#endif
myUserGecos :: IO String
#ifdef __ANDROID__
myUserGecos = return "" -- userGecos crashes on Android
#else
myUserGecos = myVal [] userGecos
#endif
myVal :: [String] -> (UserEntry -> String) -> IO String
myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars
where
check [] = return Nothing
check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
getpwent = getUserEntryForID =<< getEffectiveUserID

View File

@ -75,11 +75,14 @@ Library
Utility.FileSystemEncoding
Utility.Misc
Utility.Monad
Utility.Path
Utility.PartialPrelude
Utility.PosixFiles
Utility.Process
Utility.SafeCommand
Utility.ThreadScheduler
Utility.Tmp
Utility.UserInfo
source-repository head
type: git