summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/CmdLine.hs212
-rw-r--r--src/Propellor/Engine.hs15
-rw-r--r--src/Propellor/Git.hs23
-rw-r--r--src/Propellor/Info.hs1
-rw-r--r--src/Propellor/Message.hs9
-rw-r--r--src/Propellor/PrivData.hs1
-rw-r--r--src/Propellor/Property.hs44
-rw-r--r--src/Propellor/Property/Debootstrap.hs253
-rw-r--r--src/Propellor/Property/Dns.hs1
-rw-r--r--src/Propellor/Property/Docker.hs202
-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
-rw-r--r--src/Propellor/Protocol.hs4
-rw-r--r--src/Propellor/Server.hs139
-rw-r--r--src/Propellor/SimpleSh.hs101
-rw-r--r--src/Propellor/Types.hs75
-rw-r--r--src/Propellor/Types/Info.hs70
18 files changed, 688 insertions, 484 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index ee563012..061c9700 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -1,24 +1,21 @@
-module Propellor.CmdLine where
+module Propellor.CmdLine (
+ defaultMain,
+ processCmdLine,
+) where
import System.Environment (getArgs)
import Data.List
import System.Exit
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.Protocol
-import Propellor.PrivData.Paths
import Propellor.Gpg
import Propellor.Git
import Propellor.Ssh
+import Propellor.Server
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Docker.Shim as DockerShim
-import Utility.FileMode
import Utility.SafeCommand
usage :: Handle -> IO ()
@@ -72,6 +69,7 @@ processCmdLine = go =<< getArgs
Just pf -> return $ f pf (Context c)
Nothing -> errorMessage $ "Unknown privdata field " ++ s
+-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO ()
defaultMain hostlist = do
DockerShim.cleanEnv
@@ -86,39 +84,24 @@ defaultMain hostlist = do
go _ (Edit field context) = editPrivData field context
go _ ListFields = listPrivDataFields hostlist
go _ (AddKey keyid) = addKey keyid
- go _ (Chain hn isconsole) = withhost hn $ \h -> do
- when isconsole forceConsole
- r <- runPropellor h $ ensureProperties $ hostProperties h
- putStrLn $ "\n" ++ show r
- go _ (Docker hn) = Docker.chain hn
- go _ (GitPush fin fout) = gitPush fin fout
+ go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
+ go _ (DockerInit hn) = Docker.init hn
+ go _ (GitPush fin fout) = gitPushHelper fin fout
+ go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin hn) = withhost hn $ spin hn
go False cmdline@(SimpleRun hn) = buildFirst cmdline $
go False (Run hn)
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
- ( onlyProcess $ withhost hn mainProperties
+ ( onlyprocess $ withhost hn mainProperties
, go True (Spin hn)
)
- go False (Update _) = do
- forceConsole
- onlyProcess update
withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
-
-onlyProcess :: IO a -> IO a
-onlyProcess a = bracket lock unlock (const a)
- where
- lock = do
- l <- createFile lockfile stdFileMode
- setLock l (WriteLock, AbsoluteSeek, 0, 0)
- `catchIO` const alreadyrunning
- return l
- unlock = closeFd
- alreadyrunning = error "Propellor is already running on this host!"
- lockfile = localdir </> ".lock"
+
+ onlyprocess = onlyProcess (localdir </> ".lock")
unknownhost :: HostName -> [Host] -> IO a
unknownhost h hosts = errorMessage $ unlines
@@ -142,42 +125,27 @@ buildFirst cmdline next = do
where
getmtime = catchMaybeIO $ getModificationTime "propellor"
+fetchFirst :: IO () -> IO ()
+fetchFirst next = do
+ whenM hasOrigin $
+ void fetchOrigin
+ next
+
updateFirst :: CmdLine -> IO () -> IO ()
updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
updateFirst' :: CmdLine -> IO () -> IO ()
-updateFirst' cmdline next = do
- branchref <- getCurrentBranch
- let originbranch = "origin" </> branchref
-
- void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
-
- oldsha <- getCurrentGitSha1 branchref
-
- whenM (doesFileExist keyring) $
- 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)]
+updateFirst' cmdline next = ifM fetchOrigin
+ ( ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
+ ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
, 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 hn hst = do
- void $ actionMessage "Git commit (signed)" $
+ void $ actionMessage "Git commit" $
gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
-- Push to central origin repo first, if possible.
-- The remote propellor will pull from there, which avoids
@@ -187,16 +155,20 @@ spin hn hst = do
boolSystem "git" [Param "push"]
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])) $
- error $ "remote propellor failed (running: " ++ runcmd ++")"
+ error $ "remote propellor failed"
where
user = "root@"++hn
mkcmd = shellWrap . intercalate " ; "
- bootstrapcmd = mkcmd
+ updatecmd = mkcmd
[ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && "
[ "apt-get update"
@@ -213,119 +185,3 @@ spin hn hst = do
runcmd = mkcmd
[ "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
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index a3fc0f30..3fa9ffc0 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -8,11 +8,15 @@ import Data.Monoid
import Control.Applicative
import System.Console.ANSI
import "mtl" Control.Monad.Reader
+import Control.Exception (bracket)
+import System.PosixCompat
+import System.Posix.IO
import Propellor.Types
import Propellor.Message
import Propellor.Exception
import Propellor.Info
+import Utility.Exception
runPropellor :: Host -> Propellor a -> IO a
runPropellor host a = runReaderT (runWithHost a) host
@@ -47,3 +51,14 @@ fromHost l hn getter = case findHost l hn of
Nothing -> return Nothing
Just h -> liftIO $ Just <$>
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!"
diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs
index 51ed3df2..73de1def 100644
--- a/src/Propellor/Git.hs
+++ b/src/Propellor/Git.hs
@@ -62,3 +62,26 @@ verifyOriginBranch originbranch = do
nukeFile $ privDataDir </> "pubring.gpg"
nukeFile $ privDataDir </> "gpg.conf"
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
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index f44d1de3..a91f69c8 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -3,7 +3,6 @@
module Propellor.Info where
import Propellor.Types
-import Propellor.Types.Info
import "mtl" Control.Monad.Reader
import qualified Data.Set as S
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index a1e510ab..09a92538 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -21,10 +21,11 @@ data MessageHandle
| TextMessageHandle
mkMessageHandle :: IO MessageHandle
-mkMessageHandle = ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))
- ( return ConsoleMessageHandle
- , return TextMessageHandle
- )
+mkMessageHandle = do
+ ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))
+ ( return ConsoleMessageHandle
+ , return TextMessageHandle
+ )
forceConsole :: IO ()
forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index a5150432..c5f489e5 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -15,7 +15,6 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Propellor.Types
-import Propellor.Types.Info
import Propellor.Message
import Propellor.Info
import Propellor.Gpg
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 4b957317..bf69ff60 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -89,6 +89,15 @@ check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
, 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
-- NoChange.
--
@@ -122,6 +131,10 @@ boolProperty desc a = property desc $ ifM (liftIO a)
revert :: RevertableProperty -> RevertableProperty
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.
--
-- > host "example.com"
@@ -131,27 +144,28 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
host :: HostName -> Host
host hn = Host hn [] mempty
--- | Adds a property to a Host
---
--- Can add Properties and RevertableProperties
-(&) :: IsProp p => Host -> p -> Host
-(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
+class Hostlike h where
+ -- | Adds a property to a Host
+ --
+ -- Can add Properties and RevertableProperties
+ (&) :: 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.
-(!) :: Host -> RevertableProperty -> Host
+(!) :: Hostlike h => h -> RevertableProperty -> h
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 !
-- Changes the action that is performed to satisfy a property.
adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
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
+ info = dockerInfo mempty
-cn2hn :: ContainerName -> HostName
-cn2hn cn = cn ++ ".docker"
-
--- | Ensures that a docker container is set up and running, finding
--- its configuration in the passed list of hosts.
+-- | 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
+ 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)
- ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
+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
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index f8b706cc..68c2443b 100644
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@@ -2,6 +2,10 @@
-- 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
-- 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
diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs
new file mode 100644
index 00000000..513a81f4
--- /dev/null
+++ b/src/Propellor/Server.hs
@@ -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
diff --git a/src/Propellor/SimpleSh.hs b/src/Propellor/SimpleSh.hs
deleted file mode 100644
index cc5c62cd..00000000
--- a/src/Propellor/SimpleSh.hs
+++ /dev/null
@@ -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
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index a1d25b4f..90c08e64 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -3,7 +3,7 @@
module Propellor.Types
( Host(..)
- , Info
+ , Info(..)
, getInfo
, Propellor(..)
, Property(..)
@@ -21,6 +21,10 @@ module Propellor.Types
, Context(..)
, anyContext
, SshKeyType(..)
+ , Val(..)
+ , fromVal
+ , DockerInfo(..)
+ , DockerRunParam(..)
, module Propellor.Types.OS
, module Propellor.Types.Dns
) where
@@ -31,8 +35,10 @@ import System.Console.ANSI
import System.Posix.Types
import "mtl" Control.Monad.Reader
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.Dns
import Propellor.Types.PrivData
@@ -145,8 +151,69 @@ data CmdLine
| ListFields
| AddKey String
| Continue CmdLine
- | Chain HostName Bool
| Update HostName
- | Docker HostName
+ | DockerInit HostName
+ | DockerChain HostName String
| GitPush Fd Fd
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 ""
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
deleted file mode 100644
index de072aa0..00000000
--- a/src/Propellor/Types/Info.hs
+++ /dev/null
@@ -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))
- ]
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-06-14 15:41:17 +0000