From fd3335e40e3c938f1fbf53287e37aaf76b8c69df Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 12:57:07 -0400 Subject: --via implemented --- src/Propellor/CmdLine.hs | 40 ++++++++++++++++++++++++++-------------- src/Propellor/PrivData/Paths.hs | 3 +++ src/Propellor/Server.hs | 22 +++++++++++++++------- src/Propellor/Types.hs | 4 ++-- 4 files changed, 46 insertions(+), 23 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index ec2ca7ed..c681a08d 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -24,7 +24,7 @@ usage h = hPutStrLn h $ unlines [ "Usage:" , " propellor" , " propellor hostname" - , " propellor --spin hostname" + , " propellor --spin targethost [--via relayhost]" , " propellor --add-key keyid" , " propellor --set field context" , " propellor --dump field context" @@ -41,7 +41,8 @@ processCmdLine :: IO CmdLine processCmdLine = go =<< getArgs where go ("--run":h:[]) = return $ Run h - go ("--spin":h:[]) = return $ Spin h + go ("--spin":h:[]) = return $ Spin h Nothing + go ("--spin":h:"--via":r:[]) = return $ Spin h (Just r) go ("--add-key":k:[]) = return $ AddKey k go ("--set":f:c:[]) = withprivfield f c Set go ("--dump":f:c:[]) = withprivfield f c Dump @@ -50,8 +51,8 @@ processCmdLine = go =<< getArgs go ("--help":_) = do usage stdout exitFailure - go ("--update":h:[]) = return $ Update h - go ("--boot":h:[]) = return $ Update h -- for back-compat + go ("--update":_:[]) = return $ Update Nothing + go ("--boot":_:[]) = return $ Update Nothing -- for back-compat go ("--continue":s:[]) = case readish s of Just cmdline -> return $ Continue cmdline Nothing -> errorMessage $ "--continue serialization failure (" ++ s ++ ")" @@ -89,15 +90,16 @@ defaultMain hostlist = do 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 _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing)) + go _ (Update (Just h)) = forceConsole >> fetchFirst (update (Just h)) + 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 (Spin hn r) = withhost hn $ spin hn r go False cmdline@(SimpleRun hn) = buildFirst cmdline $ go False (Run hn) go False (Run hn) = ifM ((==) 0 <$> getRealUserID) ( onlyprocess $ withhost hn mainProperties - , go True (Spin hn) + , go True (Spin hn Nothing) ) withhost :: HostName -> (Host -> IO ()) -> IO () @@ -148,8 +150,8 @@ updateFirst' cmdline next = ifM fetchOrigin , next ) -spin :: HostName -> Host -> IO () -spin hn hst = do +spin :: HostName -> Maybe HostName -> Host -> IO () +spin target relay hst = do void $ actionMessage "Git commit" $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] -- Push to central origin repo first, if possible. @@ -160,15 +162,18 @@ spin hn hst = do boolSystem "git" [Param "push"] cacheparams <- toCommand <$> sshCachingParams hn + when (isJust relay) $ + void $ boolSystem "ssh-add" [] -- Install, or update the remote propellor. - updateServer hn hst $ withBothHandles createProcessSuccess + updateServer target relay 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" where + hn = fromMaybe target relay user = "root@"++hn mkcmd = shellWrap . intercalate " ; " @@ -183,10 +188,17 @@ spin hn hst = do , "else " ++ intercalate " && " [ "cd " ++ localdir , "if ! test -x ./propellor; then make deps build; fi" - , "./propellor --boot " ++ hn + , if isNothing relay + -- Still using --boot for back-compat... + then "./propellor --boot " ++ target + else "./propellor --continue " ++ + shellEscape (show (Update (Just target))) ] , "fi" ] - runcmd = mkcmd - [ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show (SimpleRun hn)) ] + runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor " ++ cmd ] + cmd = if isNothing relay + then "--continue " ++ shellEscape (show (SimpleRun target)) + else "--spin " ++ shellEscape target + diff --git a/src/Propellor/PrivData/Paths.hs b/src/Propellor/PrivData/Paths.hs index 1922a31e..9f791b76 100644 --- a/src/Propellor/PrivData/Paths.hs +++ b/src/Propellor/PrivData/Paths.hs @@ -10,3 +10,6 @@ privDataFile = privDataDir "privdata.gpg" privDataLocal :: FilePath privDataLocal = privDataDir "local" + +privDataRelay :: String -> FilePath +privDataRelay host = privDataDir "relay" host diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index 19a2c901..e2d6552f 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -29,13 +29,16 @@ 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 +update :: Maybe HostName -> IO () +update forhost = do whenM hasOrigin $ req NeedRepoUrl repoUrlMarker setRepoUrl + makePrivDataDir + createDirectoryIfMissing True (takeDirectory privfile) req NeedPrivData privDataMarker $ - writeFileProtected privDataLocal + writeFileProtected privfile + whenM hasOrigin $ req NeedGitPush gitPushMarker $ \_ -> do hin <- dup stdInput @@ -52,12 +55,17 @@ update = do , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout , Param "." ] + + -- When --spin --relay is run, get a privdata file + -- to be relayed to the target host. + privfile = maybe privDataLocal privDataRelay forhost -- 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 +updateServer :: HostName -> Maybe HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO () +updateServer target relay hst connect = connect go where + hn = fromMaybe target relay go (toh, fromh) = do let loop = go (toh, fromh) v <- (maybe Nothing readish <$> getMarked fromh statusMarker) @@ -77,12 +85,12 @@ updateServer hn hst connect = connect go hClose toh hClose fromh sendGitClone hn - updateServer hn hst connect + updateServer hn relay hst connect (Just NeedPrecompiled) -> do hClose toh hClose fromh sendPrecompiled hn - updateServer hn hst connect + updateServer hn relay hst connect Nothing -> return () sendRepoUrl :: Handle -> IO () diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index e7d63547..e4cbf981 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -142,7 +142,7 @@ instance ActionResult Result where data CmdLine = Run HostName - | Spin HostName + | Spin HostName (Maybe HostName) | SimpleRun HostName | Set PrivDataField Context | Dump PrivDataField Context @@ -150,7 +150,7 @@ data CmdLine | ListFields | AddKey String | Continue CmdLine - | Update HostName + | Update (Maybe HostName) | DockerInit HostName | DockerChain HostName String | ChrootChain HostName FilePath Bool Bool -- cgit v1.2.3 From 8e5551c925828fe1f5133c3c9e86d13722c09f89 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 13:44:25 -0400 Subject: avoid unncessary apt-get upgrade --- src/Propellor/CmdLine.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index c681a08d..aa294fb5 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -181,8 +181,7 @@ spin target relay hst = do updatecmd = mkcmd [ "if [ ! -d " ++ localdir ++ " ]" , "then (" ++ intercalate " && " - [ "apt-get update" - , "apt-get --no-install-recommends --no-upgrade -y install git make" + [ "if ! git --version || ! make --version; the apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi" , "echo " ++ toMarked statusMarker (show NeedGitClone) ] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled) , "else " ++ intercalate " && " -- cgit v1.2.3 From fdde4d91c7dda15dcc4eee5fc91859c0e1a45b9b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 13:48:16 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index aa294fb5..3e64f035 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -181,7 +181,7 @@ spin target relay hst = do updatecmd = mkcmd [ "if [ ! -d " ++ localdir ++ " ]" , "then (" ++ intercalate " && " - [ "if ! git --version || ! make --version; the apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi" + [ "if ! git --version || ! make --version; then apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi" , "echo " ++ toMarked statusMarker (show NeedGitClone) ] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled) , "else " ++ intercalate " && " -- cgit v1.2.3 From 0b9164e286911a2e1d594f0c4561737e2d5416af Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 15:01:08 -0400 Subject: propellor spin --- src/Propellor/Server.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index e2d6552f..05a8856d 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -74,7 +74,7 @@ updateServer target relay hst connect = connect go sendRepoUrl toh loop (Just NeedPrivData) -> do - sendPrivData hn hst toh + sendPrivData hn hst toh relay loop (Just NeedGitPush) -> do sendGitUpdate hn fromh toh @@ -96,12 +96,21 @@ updateServer target relay hst connect = connect go 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 +sendPrivData :: HostName -> Host -> Handle -> Maybe HostName -> IO () +sendPrivData hn hst toh target = do + privdata <- getdata void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do sendMarked toh privDataMarker privdata return True + where + getdata + | isNothing target = + show . filterPrivData hst <$> decryptPrivData + | otherwise = do + let f = privDataRelay hn + d <- readFileStrictAnyEncoding f + nukeFile f + return d sendGitUpdate :: HostName -> Handle -> Handle -> IO () sendGitUpdate hn fromh toh = -- cgit v1.2.3 From 151aadd4e20c49d18eedadb08272fccd114de7c8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 15:11:24 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 3e64f035..bb9b470e 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -170,7 +170,7 @@ spin target relay hst = do (proc "ssh" $ cacheparams ++ [user, updatecmd]) -- And now we can run it. - unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $ + unlessM (boolSystem "ssh" (map Param $ cacheparams ++ runparams)) $ error $ "remote propellor failed" where hn = fromMaybe target relay @@ -200,4 +200,9 @@ spin target relay hst = do cmd = if isNothing relay then "--continue " ++ shellEscape (show (SimpleRun target)) else "--spin " ++ shellEscape target - + runparams = catMaybes + [ if isJust relay then Just "-A" else Nothing + , Just "-t" + , Just user + , Just runcmd + ] -- cgit v1.2.3 From ef883cbbe809498800f22ea8fd68d9102f64c27d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 15:18:30 -0400 Subject: still do peer-to-peer git push when there are no git remotes --- src/Propellor/Git.hs | 3 +++ src/Propellor/Server.hs | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs index e5f464c0..ccf97b94 100644 --- a/src/Propellor/Git.hs +++ b/src/Propellor/Git.hs @@ -42,6 +42,9 @@ hasOrigin = catchDefaultIO False $ do rs <- lines <$> readProcess "git" ["remote"] return $ "origin" `elem` rs +hasGitRepo :: IO Bool +hasGitRepo = doesFileExist ".git/HEAD" + {- To verify origin branch commit's signature, have to convince gpg - to use our keyring. - While running git log. Which has no way to pass options to gpg. diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index 05a8856d..bf3ba3f9 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -31,7 +31,7 @@ import Utility.SafeCommand -- running the updateServer update :: Maybe HostName -> IO () update forhost = do - whenM hasOrigin $ + whenM hasGitRep $ req NeedRepoUrl repoUrlMarker setRepoUrl makePrivDataDir @@ -39,7 +39,7 @@ update forhost = do req NeedPrivData privDataMarker $ writeFileProtected privfile - whenM hasOrigin $ + whenM hasGitRepo $ req NeedGitPush gitPushMarker $ \_ -> do hin <- dup stdInput hout <- dup stdOutput -- cgit v1.2.3 From 615799dbcce1221ca48a2dc00a4ebc729c4c86c7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 15:19:20 -0400 Subject: propellor spin --- src/Propellor/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index bf3ba3f9..fe90a456 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -31,7 +31,7 @@ import Utility.SafeCommand -- running the updateServer update :: Maybe HostName -> IO () update forhost = do - whenM hasGitRep $ + whenM hasGitRepo $ req NeedRepoUrl repoUrlMarker setRepoUrl makePrivDataDir -- cgit v1.2.3 From 395f311e1e07e0da31b48dc1bd0c1f5882fc3627 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 15:48:17 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 6 +++--- src/Propellor/Server.hs | 31 +++++++++++++++++-------------- 2 files changed, 20 insertions(+), 17 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index bb9b470e..7a4fdd7c 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -196,10 +196,10 @@ spin target relay hst = do , "fi" ] - runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor " ++ cmd ] + runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show cmd) ] cmd = if isNothing relay - then "--continue " ++ shellEscape (show (SimpleRun target)) - else "--spin " ++ shellEscape target + then SimpleRun target + else Spin target relay runparams = catMaybes [ if isJust relay then Just "-A" else Nothing , Just "-t" diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index fe90a456..be2eb1d3 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -66,51 +66,54 @@ updateServer :: HostName -> Maybe HostName -> Host -> (((Handle, Handle) -> IO ( updateServer target relay hst connect = connect go where hn = fromMaybe target relay + relaying = relay == Just target + go (toh, fromh) = do let loop = go (toh, fromh) + let restart = updateServer hn relay hst connect + let done = return () v <- (maybe Nothing readish <$> getMarked fromh statusMarker) case v of (Just NeedRepoUrl) -> do sendRepoUrl toh loop (Just NeedPrivData) -> do - sendPrivData hn hst toh relay + sendPrivData hn hst toh relaying 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 relay hst connect + restart (Just NeedPrecompiled) -> do hClose toh hClose fromh sendPrecompiled hn - updateServer hn relay hst connect - Nothing -> return () + restart + (Just NeedGitPush) -> do + sendGitUpdate hn fromh toh + hClose fromh + hClose toh + done + Nothing -> done sendRepoUrl :: Handle -> IO () sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl) -sendPrivData :: HostName -> Host -> Handle -> Maybe HostName -> IO () -sendPrivData hn hst toh target = do +sendPrivData :: HostName -> Host -> Handle -> Bool -> IO () +sendPrivData hn hst toh relaying = do privdata <- getdata void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do sendMarked toh privDataMarker privdata return True where getdata - | isNothing target = - show . filterPrivData hst <$> decryptPrivData - | otherwise = do + | relaying = do let f = privDataRelay hn d <- readFileStrictAnyEncoding f nukeFile f return d + | otherwise = show . filterPrivData hst <$> decryptPrivData sendGitUpdate :: HostName -> Handle -> Handle -> IO () sendGitUpdate hn fromh toh = -- cgit v1.2.3 From 97931fe6700be054e6e5e26da9a9f47e88ba6a2a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 15:50:14 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 7a4fdd7c..2bd07614 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -199,7 +199,7 @@ spin target relay hst = do runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show cmd) ] cmd = if isNothing relay then SimpleRun target - else Spin target relay + else Spin target (Just target) runparams = catMaybes [ if isJust relay then Just "-A" else Nothing , Just "-t" -- cgit v1.2.3 From 40339a7fd830503a09b54138372a159c8bc342d7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 15:54:31 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 16 ++++++++++------ src/Propellor/Types.hs | 1 + 2 files changed, 11 insertions(+), 6 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 2bd07614..ea6cabff 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -53,9 +53,8 @@ processCmdLine = go =<< getArgs exitFailure go ("--update":_:[]) = return $ Update Nothing go ("--boot":_:[]) = return $ Update Nothing -- for back-compat - go ("--continue":s:[]) = case readish s of - Just cmdline -> return $ Continue cmdline - Nothing -> errorMessage $ "--continue serialization failure (" ++ s ++ ")" + go ("--serialized":s:[]) = serialized Serialized s + go ("--continue":s:[]) = serialized Continue s go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout) go (h:[]) | "--" `isPrefixOf` h = usageError [h] @@ -71,6 +70,10 @@ processCmdLine = go =<< getArgs Just pf -> return $ f pf (Context c) Nothing -> errorMessage $ "Unknown privdata field " ++ s + serialized mk s = case readish s of + Just cmdline -> return $ mk cmdline + Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")" + -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () defaultMain hostlist = do @@ -80,6 +83,7 @@ defaultMain hostlist = do debug ["command line: ", show cmdline] go True cmdline where + go _ (Serialized cmdline) = go True cmdline go _ (Continue cmdline) = go False cmdline go _ (Set field context) = setPrivData field context go _ (Dump field context) = dumpPrivData field context @@ -196,10 +200,10 @@ spin target relay hst = do , "fi" ] - runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show cmd) ] + runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor " ++ cmd ] cmd = if isNothing relay - then SimpleRun target - else Spin target (Just target) + then "--continue " ++ shellEscape (show (SimpleRun target)) + else "--serialized " ++ shellEscape (show (Spin target (Just target))) runparams = catMaybes [ if isJust relay then Just "-A" else Nothing , Just "-t" diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index e4cbf981..949ce4b7 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -149,6 +149,7 @@ data CmdLine | Edit PrivDataField Context | ListFields | AddKey String + | Serialized CmdLine | Continue CmdLine | Update (Maybe HostName) | DockerInit HostName -- cgit v1.2.3 From 6d13790afa236b958eec9e8a0ea1e75125d90351 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 15:58:09 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index ea6cabff..e719e149 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -156,14 +156,15 @@ updateFirst' cmdline next = ifM fetchOrigin spin :: HostName -> Maybe HostName -> Host -> IO () spin target relay hst = do - 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 - -- us needing to send stuff directly to the remote host. - whenM hasOrigin $ - void $ actionMessage "Push to central git repository" $ - boolSystem "git" [Param "push"] + unless relaying $ do + 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 + -- us needing to send stuff directly to the remote host. + whenM hasOrigin $ + void $ actionMessage "Push to central git repository" $ + boolSystem "git" [Param "push"] cacheparams <- toCommand <$> sshCachingParams hn when (isJust relay) $ @@ -179,6 +180,7 @@ spin target relay hst = do where hn = fromMaybe target relay user = "root@"++hn + relaying = relay == Just target mkcmd = shellWrap . intercalate " ; " -- cgit v1.2.3 From 392a0d3c1cc175161cd0c6d82b098e92d6adf9e6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 16:06:44 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 28 ++++++++++++---------------- src/Propellor/Server.hs | 4 ++-- src/Propellor/Ssh.hs | 12 +++++++----- 3 files changed, 21 insertions(+), 23 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index e719e149..b44cbc28 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -166,8 +166,8 @@ spin target relay hst = do void $ actionMessage "Push to central git repository" $ boolSystem "git" [Param "push"] - cacheparams <- toCommand <$> sshCachingParams hn - when (isJust relay) $ + cacheparams <- toCommand <$> sshCachingParams hn viarelay + when viarelay $ void $ boolSystem "ssh-add" [] -- Install, or update the remote propellor. @@ -175,12 +175,14 @@ spin target relay hst = do (proc "ssh" $ cacheparams ++ [user, updatecmd]) -- And now we can run it. - unlessM (boolSystem "ssh" (map Param $ cacheparams ++ runparams)) $ + unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $ error $ "remote propellor failed" where hn = fromMaybe target relay user = "root@"++hn + relaying = relay == Just target + viarelay = isJust relay && not relaying mkcmd = shellWrap . intercalate " ; " @@ -193,22 +195,16 @@ spin target relay hst = do , "else " ++ intercalate " && " [ "cd " ++ localdir , "if ! test -x ./propellor; then make deps build; fi" - , if isNothing relay - -- Still using --boot for back-compat... - then "./propellor --boot " ++ target - else "./propellor --continue " ++ + , if viarelay + then "./propellor --continue " ++ shellEscape (show (Update (Just target))) + -- Still using --boot for back-compat... + else "./propellor --boot " ++ target ] , "fi" ] runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor " ++ cmd ] - cmd = if isNothing relay - then "--continue " ++ shellEscape (show (SimpleRun target)) - else "--serialized " ++ shellEscape (show (Spin target (Just target))) - runparams = catMaybes - [ if isJust relay then Just "-A" else Nothing - , Just "-t" - , Just user - , Just runcmd - ] + cmd = if viarelay + then "--serialized " ++ shellEscape (show (Spin target (Just target))) + else "--continue " ++ shellEscape (show (SimpleRun target)) diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index be2eb1d3..38325003 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -131,7 +131,7 @@ sendGitUpdate hn fromh toh = sendGitClone :: HostName -> IO () sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do branch <- getCurrentBranch - cacheparams <- sshCachingParams hn + cacheparams <- sshCachingParams hn False 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)] @@ -156,7 +156,7 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor withTmpDir "propellor" go where go tmpdir = do - cacheparams <- sshCachingParams hn + cacheparams <- sshCachingParams hn False let shimdir = takeFileName localdir createDirectoryIfMissing True (tmpdir shimdir) changeWorkingDirectory (tmpdir shimdir) diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs index 969517a8..ecdb54d2 100644 --- a/src/Propellor/Ssh.hs +++ b/src/Propellor/Ssh.hs @@ -14,15 +14,17 @@ import Data.Time.Clock.POSIX -- minutes, and if so stop that ssh process, in order to not try to -- use an old stale connection. (atime would be nicer, but there's -- a good chance a laptop uses noatime) -sshCachingParams :: HostName -> IO [CommandParam] -sshCachingParams hn = do +sshCachingParams :: HostName -> Bool -> IO [CommandParam] +sshCachingParams hn viarelay = do home <- myHomeDir let cachedir = home ".ssh" "propellor" createDirectoryIfMissing False cachedir let socketfile = cachedir hn ++ ".sock" - let ps = - [ Param "-o", Param ("ControlPath=" ++ socketfile) - , Params "-o ControlMaster=auto -o ControlPersist=yes" + let ps = catMaybes + [ if viarelay then Just (Param "-A") else Nothing + , Just $ Param "-o" + , Just $ Param ("ControlPath=" ++ socketfile) + , Just $ Params "-o ControlMaster=auto -o ControlPersist=yes" ] maybe noop (expireold ps socketfile) -- cgit v1.2.3 From 6be56755eedc4a8c259c0be7f912a3fde1da245a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 16:10:46 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index b44cbc28..fb4b8eed 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -166,7 +166,9 @@ spin target relay hst = do void $ actionMessage "Push to central git repository" $ boolSystem "git" [Param "push"] - cacheparams <- toCommand <$> sshCachingParams hn viarelay + cacheparams <- if relaying + then pure [] + else toCommand <$> sshCachingParams hn viarelay when viarelay $ void $ boolSystem "ssh-add" [] -- cgit v1.2.3 From 7ed9f70504d902f48e88e7701f6398e769072bd7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 16:12:53 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index fb4b8eed..51ee592d 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -166,7 +166,7 @@ spin target relay hst = do void $ actionMessage "Push to central git repository" $ boolSystem "git" [Param "push"] - cacheparams <- if relaying + cacheparams <- if relaying || viarelay then pure [] else toCommand <$> sshCachingParams hn viarelay when viarelay $ -- cgit v1.2.3 From cb94e7484e5c0c966f3f9624e910ae2521b259a3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 16:14:20 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 51ee592d..5827409c 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -166,9 +166,11 @@ spin target relay hst = do void $ actionMessage "Push to central git repository" $ boolSystem "git" [Param "push"] - cacheparams <- if relaying || viarelay + cacheparams <- if relaying then pure [] - else toCommand <$> sshCachingParams hn viarelay + else if viarelay + then pure ["-A"] + else toCommand <$> sshCachingParams hn viarelay when viarelay $ void $ boolSystem "ssh-add" [] -- cgit v1.2.3 From 02e0fac6839572f8823369730b0f73f2374d5574 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 16:17:39 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 5827409c..7002a3f6 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -166,7 +166,7 @@ spin target relay hst = do void $ actionMessage "Push to central git repository" $ boolSystem "git" [Param "push"] - cacheparams <- if relaying + cacheparams <- if False then pure [] else if viarelay then pure ["-A"] -- cgit v1.2.3 From a4edc404f0d91db54e13dace7be265a2611de5d6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 16:20:02 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 8 +++----- src/Propellor/Server.hs | 4 ++-- src/Propellor/Ssh.hs | 13 ++++++------- 3 files changed, 11 insertions(+), 14 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 7002a3f6..11193ab3 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -166,11 +166,9 @@ spin target relay hst = do void $ actionMessage "Push to central git repository" $ boolSystem "git" [Param "push"] - cacheparams <- if False - then pure [] - else if viarelay - then pure ["-A"] - else toCommand <$> sshCachingParams hn viarelay + cacheparams <- if viarelay + then pure ["-A"] + else toCommand <$> sshCachingParams hn when viarelay $ void $ boolSystem "ssh-add" [] diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index 38325003..be2eb1d3 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -131,7 +131,7 @@ sendGitUpdate hn fromh toh = sendGitClone :: HostName -> IO () sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do branch <- getCurrentBranch - cacheparams <- sshCachingParams hn False + 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)] @@ -156,7 +156,7 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor withTmpDir "propellor" go where go tmpdir = do - cacheparams <- sshCachingParams hn False + cacheparams <- sshCachingParams hn let shimdir = takeFileName localdir createDirectoryIfMissing True (tmpdir shimdir) changeWorkingDirectory (tmpdir shimdir) diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs index ecdb54d2..97c3eb6d 100644 --- a/src/Propellor/Ssh.hs +++ b/src/Propellor/Ssh.hs @@ -14,17 +14,16 @@ import Data.Time.Clock.POSIX -- minutes, and if so stop that ssh process, in order to not try to -- use an old stale connection. (atime would be nicer, but there's -- a good chance a laptop uses noatime) -sshCachingParams :: HostName -> Bool -> IO [CommandParam] -sshCachingParams hn viarelay = do +sshCachingParams :: HostName -> IO [CommandParam] +sshCachingParams hn = do home <- myHomeDir let cachedir = home ".ssh" "propellor" createDirectoryIfMissing False cachedir let socketfile = cachedir hn ++ ".sock" - let ps = catMaybes - [ if viarelay then Just (Param "-A") else Nothing - , Just $ Param "-o" - , Just $ Param ("ControlPath=" ++ socketfile) - , Just $ Params "-o ControlMaster=auto -o ControlPersist=yes" + let ps = + [ Param "-o" + , Param ("ControlPath=" ++ socketfile) + , Params "-o ControlMaster=auto -o ControlPersist=yes" ] maybe noop (expireold ps socketfile) -- cgit v1.2.3 From aa986724a2fa56aba0b8584deb33536d24d7f66d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 17:16:25 -0400 Subject: propellor spin --- src/Propellor/Server.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index be2eb1d3..3fd34a51 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -161,7 +161,8 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor createDirectoryIfMissing True (tmpdir shimdir) changeWorkingDirectory (tmpdir shimdir) me <- readSymbolicLink "/proc/self/exe" - shim <- Shim.setup me "." + me' <- catchDefaultIO me (readSymbolicLink me) + shim <- Shim.setup me' "." when (shim /= "propellor") $ renameFile shim "propellor" changeWorkingDirectory tmpdir -- cgit v1.2.3 From 95f78a058660701cd7eb182f4d1989da27718c2a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 17:22:11 -0400 Subject: propellor spin --- src/Propellor/Server.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index 3fd34a51..77f72085 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -161,10 +161,10 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor createDirectoryIfMissing True (tmpdir shimdir) changeWorkingDirectory (tmpdir shimdir) me <- readSymbolicLink "/proc/self/exe" - me' <- catchDefaultIO me (readSymbolicLink me) - shim <- Shim.setup me' "." - when (shim /= "propellor") $ - renameFile shim "propellor" + createDirectoryIfMissing True "bin" + unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $ + errorMessage "failed copying in propellor" + void $ Shim.setup "bin/propellor" "." changeWorkingDirectory tmpdir withTmpFile "propellor.tar." $ \tarball _ -> allM id [ boolSystem "strip" [File me] -- cgit v1.2.3 From 9a8fcf80bb026c390ad56da9b70d153fd978d6cf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 19:58:35 -0400 Subject: Hostname parameters not containing dots are looked up in the DNS to find the full hostname. --- debian/changelog | 2 ++ src/Propellor/CmdLine.hs | 16 ++++++++++++---- src/Propellor/Types/OS.hs | 15 +++++++++++++-- 3 files changed, 27 insertions(+), 6 deletions(-) (limited to 'src/Propellor') diff --git a/debian/changelog b/debian/changelog index f82270e2..32b504fd 100644 --- a/debian/changelog +++ b/debian/changelog @@ -6,6 +6,8 @@ propellor (1.0.1) UNRELEASED; urgency=medium * --spin target --via relay causes propellor to bounce through an intermediate relay host, which handles any necessary uploads when provisioning the target host. + * Hostname parameters not containing dots are looked up in the DNS to + find the full hostname. -- Joey Hess Sat, 22 Nov 2014 00:12:35 -0400 diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 11193ab3..e808395b 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -7,6 +7,7 @@ import System.Environment (getArgs) import Data.List import System.Exit import System.PosixCompat +import qualified Network.BSD import Propellor import Propellor.Protocol @@ -40,9 +41,8 @@ usageError ps = do processCmdLine :: IO CmdLine processCmdLine = go =<< getArgs where - go ("--run":h:[]) = return $ Run h - go ("--spin":h:[]) = return $ Spin h Nothing - go ("--spin":h:"--via":r:[]) = return $ Spin h (Just r) + go ("--spin":h:[]) = Spin <$> hostname h <*> pure Nothing + go ("--spin":h:"--via":r:[]) = Spin <$> hostname h <*> pure (Just r) go ("--add-key":k:[]) = return $ AddKey k go ("--set":f:c:[]) = withprivfield f c Set go ("--dump":f:c:[]) = withprivfield f c Dump @@ -56,9 +56,10 @@ processCmdLine = go =<< getArgs go ("--serialized":s:[]) = serialized Serialized s go ("--continue":s:[]) = serialized Continue s go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout) + go ("--run":h:[]) = go [h] go (h:[]) | "--" `isPrefixOf` h = usageError [h] - | otherwise = return $ Run h + | otherwise = Run <$> hostname h go [] = do s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] if null s @@ -210,3 +211,10 @@ spin target relay hst = do cmd = if viarelay then "--serialized " ++ shellEscape (show (Spin target (Just target))) else "--continue " ++ shellEscape (show (SimpleRun target)) + +hostname :: String -> IO HostName +hostname s + | "." `isInfixOf` s = pure s + | otherwise = do + h <- Network.BSD.getHostByName s + return (Network.BSD.hostName h) diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs index 2529e7d8..72e3d764 100644 --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -1,6 +1,17 @@ -module Propellor.Types.OS where +module Propellor.Types.OS ( + HostName, + UserName, + GroupName, + System(..), + Distribution(..), + DebianSuite(..), + isStable, + Release, + Architecture, +) where + +import Network.BSD (HostName) -type HostName = String type UserName = String type GroupName = String -- cgit v1.2.3 From eb946f109bb895545dd41c7328d900648e2eb71a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 20:02:44 -0400 Subject: look for /usr/local/propellor/.git to know if it's fully deployed When propellor is deployed by uploading the binary, there's no git repo, so each spin needs to re-upload it to get any config changes. This should be rare since this is only intended to be used when taking over a host and getting it properly set up from source, but it still needs to be supported. --- src/Propellor/CmdLine.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index e808395b..5c051d1c 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -190,7 +190,7 @@ spin target relay hst = do mkcmd = shellWrap . intercalate " ; " updatecmd = mkcmd - [ "if [ ! -d " ++ localdir ++ " ]" + [ "if [ ! -d " ++ localdir ++ "/.git ]" , "then (" ++ intercalate " && " [ "if ! git --version || ! make --version; then apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi" , "echo " ++ toMarked statusMarker (show NeedGitClone) -- cgit v1.2.3 From 239581c75901c3305eaa9298cf41de28a57bd099 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 20:17:46 -0400 Subject: reorg --- propellor.cabal | 2 +- src/Propellor/CmdLine.hs | 61 +---------- src/Propellor/Server.hs | 207 ------------------------------------- src/Propellor/Spin.hs | 262 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 264 insertions(+), 268 deletions(-) delete mode 100644 src/Propellor/Server.hs create mode 100644 src/Propellor/Spin.hs (limited to 'src/Propellor') diff --git a/propellor.cabal b/propellor.cabal index 9fe7a26f..20aba22e 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -121,7 +121,7 @@ Library Other-Modules: Propellor.Git Propellor.Gpg - Propellor.Server + Propellor.Spin Propellor.Ssh Propellor.PrivData.Paths Propellor.Protocol diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 5c051d1c..f5cfc783 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -10,11 +10,9 @@ import System.PosixCompat import qualified Network.BSD import Propellor -import Propellor.Protocol import Propellor.Gpg import Propellor.Git -import Propellor.Ssh -import Propellor.Server +import Propellor.Spin import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim @@ -155,63 +153,6 @@ updateFirst' cmdline next = ifM fetchOrigin , next ) -spin :: HostName -> Maybe HostName -> Host -> IO () -spin target relay hst = do - unless relaying $ do - 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 - -- us needing to send stuff directly to the remote host. - whenM hasOrigin $ - void $ actionMessage "Push to central git repository" $ - boolSystem "git" [Param "push"] - - cacheparams <- if viarelay - then pure ["-A"] - else toCommand <$> sshCachingParams hn - when viarelay $ - void $ boolSystem "ssh-add" [] - - -- Install, or update the remote propellor. - updateServer target relay 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" - where - hn = fromMaybe target relay - user = "root@"++hn - - relaying = relay == Just target - viarelay = isJust relay && not relaying - - mkcmd = shellWrap . intercalate " ; " - - updatecmd = mkcmd - [ "if [ ! -d " ++ localdir ++ "/.git ]" - , "then (" ++ intercalate " && " - [ "if ! git --version || ! make --version; then apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi" - , "echo " ++ toMarked statusMarker (show NeedGitClone) - ] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled) - , "else " ++ intercalate " && " - [ "cd " ++ localdir - , "if ! test -x ./propellor; then make deps build; fi" - , if viarelay - then "./propellor --continue " ++ - shellEscape (show (Update (Just target))) - -- Still using --boot for back-compat... - else "./propellor --boot " ++ target - ] - , "fi" - ] - - runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor " ++ cmd ] - cmd = if viarelay - then "--serialized " ++ shellEscape (show (Spin target (Just target))) - else "--continue " ++ shellEscape (show (SimpleRun target)) - hostname :: String -> IO HostName hostname s | "." `isInfixOf` s = pure s diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs deleted file mode 100644 index 77f72085..00000000 --- a/src/Propellor/Server.hs +++ /dev/null @@ -1,207 +0,0 @@ --- When propellor --spin is running, the local host acts as a server, --- which connects to the remote host's propellor and responds to its --- requests. - -module Propellor.Server ( - update, - updateServer, - gitPushHelper -) where - -import Data.List -import System.Exit -import System.PosixCompat -import System.Posix.IO -import System.Posix.Directory -import Control.Concurrent.Async -import Control.Exception (bracket) -import qualified Data.ByteString as B - -import Propellor -import Propellor.Protocol -import Propellor.PrivData.Paths -import Propellor.Git -import Propellor.Ssh -import qualified Propellor.Shim as Shim -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 :: Maybe HostName -> IO () -update forhost = do - whenM hasGitRepo $ - req NeedRepoUrl repoUrlMarker setRepoUrl - - makePrivDataDir - createDirectoryIfMissing True (takeDirectory privfile) - req NeedPrivData privDataMarker $ - writeFileProtected privfile - - whenM hasGitRepo $ - 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 "." - ] - - -- When --spin --relay is run, get a privdata file - -- to be relayed to the target host. - privfile = maybe privDataLocal privDataRelay forhost - --- The connect action should ssh to the remote host and run the provided --- calback action. -updateServer :: HostName -> Maybe HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO () -updateServer target relay hst connect = connect go - where - hn = fromMaybe target relay - relaying = relay == Just target - - go (toh, fromh) = do - let loop = go (toh, fromh) - let restart = updateServer hn relay hst connect - let done = return () - v <- (maybe Nothing readish <$> getMarked fromh statusMarker) - case v of - (Just NeedRepoUrl) -> do - sendRepoUrl toh - loop - (Just NeedPrivData) -> do - sendPrivData hn hst toh relaying - loop - (Just NeedGitClone) -> do - hClose toh - hClose fromh - sendGitClone hn - restart - (Just NeedPrecompiled) -> do - hClose toh - hClose fromh - sendPrecompiled hn - restart - (Just NeedGitPush) -> do - sendGitUpdate hn fromh toh - hClose fromh - hClose toh - done - Nothing -> done - -sendRepoUrl :: Handle -> IO () -sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl) - -sendPrivData :: HostName -> Host -> Handle -> Bool -> IO () -sendPrivData hn hst toh relaying = do - privdata <- getdata - void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do - sendMarked toh privDataMarker privdata - return True - where - getdata - | relaying = do - let f = privDataRelay hn - d <- readFileStrictAnyEncoding f - nukeFile f - return d - | otherwise = show . filterPrivData hst <$> decryptPrivData - -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 - ] - --- Send a tarball containing the precompiled propellor, and libraries. --- This should be reasonably portable, as long as the remote host has the --- same architecture as the build host. -sendPrecompiled :: HostName -> IO () -sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor as a last resort") $ do - bracket getWorkingDirectory changeWorkingDirectory $ \_ -> - withTmpDir "propellor" go - where - go tmpdir = do - cacheparams <- sshCachingParams hn - let shimdir = takeFileName localdir - createDirectoryIfMissing True (tmpdir shimdir) - changeWorkingDirectory (tmpdir shimdir) - me <- readSymbolicLink "/proc/self/exe" - createDirectoryIfMissing True "bin" - unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $ - errorMessage "failed copying in propellor" - void $ Shim.setup "bin/propellor" "." - changeWorkingDirectory tmpdir - withTmpFile "propellor.tar." $ \tarball _ -> allM id - [ boolSystem "strip" [File me] - , boolSystem "tar" [Param "czf", File tarball, File shimdir] - , boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)] - , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd] - ] - - remotetarball = "/usr/local/propellor.tar" - - unpackcmd = shellWrap $ intercalate " && " - [ "cd " ++ takeDirectory remotetarball - , "tar xzf " ++ remotetarball - , "rm -f " ++ remotetarball - ] - --- 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/Spin.hs b/src/Propellor/Spin.hs new file mode 100644 index 00000000..8baf4fd9 --- /dev/null +++ b/src/Propellor/Spin.hs @@ -0,0 +1,262 @@ +module Propellor.Spin ( + spin, + update, + gitPushHelper +) where + +import Data.List +import System.Exit +import System.PosixCompat +import System.Posix.IO +import System.Posix.Directory +import Control.Concurrent.Async +import Control.Exception (bracket) +import qualified Data.ByteString as B + +import Propellor +import Propellor.Protocol +import Propellor.PrivData.Paths +import Propellor.Git +import Propellor.Ssh +import Propellor.Gpg +import qualified Propellor.Shim as Shim +import Utility.FileMode +import Utility.SafeCommand + +spin :: HostName -> Maybe HostName -> Host -> IO () +spin target relay hst = do + unless relaying $ do + 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 + -- us needing to send stuff directly to the remote host. + whenM hasOrigin $ + void $ actionMessage "Push to central git repository" $ + boolSystem "git" [Param "push"] + + cacheparams <- if viarelay + then pure ["-A"] + else toCommand <$> sshCachingParams hn + when viarelay $ + void $ boolSystem "ssh-add" [] + + -- Install, or update the remote propellor. + updateServer target relay 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" + where + hn = fromMaybe target relay + user = "root@"++hn + + relaying = relay == Just target + viarelay = isJust relay && not relaying + + mkcmd = shellWrap . intercalate " ; " + + updatecmd = mkcmd + [ "if [ ! -d " ++ localdir ++ "/.git ]" + , "then (" ++ intercalate " && " + [ "if ! git --version || ! make --version; then apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi" + , "echo " ++ toMarked statusMarker (show NeedGitClone) + ] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled) + , "else " ++ intercalate " && " + [ "cd " ++ localdir + , "if ! test -x ./propellor; then make deps build; fi" + , if viarelay + then "./propellor --continue " ++ + shellEscape (show (Update (Just target))) + -- Still using --boot for back-compat... + else "./propellor --boot " ++ target + ] + , "fi" + ] + + runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor " ++ cmd ] + cmd = if viarelay + then "--serialized " ++ shellEscape (show (Spin target (Just target))) + else "--continue " ++ shellEscape (show (SimpleRun target)) + +-- 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 :: Maybe HostName -> IO () +update forhost = do + whenM hasGitRepo $ + req NeedRepoUrl repoUrlMarker setRepoUrl + + makePrivDataDir + createDirectoryIfMissing True (takeDirectory privfile) + req NeedPrivData privDataMarker $ + writeFileProtected privfile + + whenM hasGitRepo $ + 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 "." + ] + + -- When --spin --relay is run, get a privdata file + -- to be relayed to the target host. + privfile = maybe privDataLocal privDataRelay forhost + +-- The connect action should ssh to the remote host and run the provided +-- calback action. +updateServer :: HostName -> Maybe HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO () +updateServer target relay hst connect = connect go + where + hn = fromMaybe target relay + relaying = relay == Just target + + go (toh, fromh) = do + let loop = go (toh, fromh) + let restart = updateServer hn relay hst connect + let done = return () + v <- (maybe Nothing readish <$> getMarked fromh statusMarker) + case v of + (Just NeedRepoUrl) -> do + sendRepoUrl toh + loop + (Just NeedPrivData) -> do + sendPrivData hn hst toh relaying + loop + (Just NeedGitClone) -> do + hClose toh + hClose fromh + sendGitClone hn + restart + (Just NeedPrecompiled) -> do + hClose toh + hClose fromh + sendPrecompiled hn + restart + (Just NeedGitPush) -> do + sendGitUpdate hn fromh toh + hClose fromh + hClose toh + done + Nothing -> done + +sendRepoUrl :: Handle -> IO () +sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl) + +sendPrivData :: HostName -> Host -> Handle -> Bool -> IO () +sendPrivData hn hst toh relaying = do + privdata <- getdata + void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do + sendMarked toh privDataMarker privdata + return True + where + getdata + | relaying = do + let f = privDataRelay hn + d <- readFileStrictAnyEncoding f + nukeFile f + return d + | otherwise = show . filterPrivData hst <$> decryptPrivData + +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 + ] + +-- Send a tarball containing the precompiled propellor, and libraries. +-- This should be reasonably portable, as long as the remote host has the +-- same architecture as the build host. +sendPrecompiled :: HostName -> IO () +sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor as a last resort") $ do + bracket getWorkingDirectory changeWorkingDirectory $ \_ -> + withTmpDir "propellor" go + where + go tmpdir = do + cacheparams <- sshCachingParams hn + let shimdir = takeFileName localdir + createDirectoryIfMissing True (tmpdir shimdir) + changeWorkingDirectory (tmpdir shimdir) + me <- readSymbolicLink "/proc/self/exe" + createDirectoryIfMissing True "bin" + unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $ + errorMessage "failed copying in propellor" + void $ Shim.setup "bin/propellor" "." + changeWorkingDirectory tmpdir + withTmpFile "propellor.tar." $ \tarball _ -> allM id + [ boolSystem "strip" [File me] + , boolSystem "tar" [Param "czf", File tarball, File shimdir] + , boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)] + , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd] + ] + + remotetarball = "/usr/local/propellor.tar" + + unpackcmd = shellWrap $ intercalate " && " + [ "cd " ++ takeDirectory remotetarball + , "rm -rf " ++ localdir + , "tar xzf " ++ remotetarball + , "rm -f " ++ remotetarball + ] + +-- 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 -- cgit v1.2.3 From 868d7cdcb5c80d38f4d96efff121b5940c667b2e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 20:29:27 -0400 Subject: avoid loop after uploading precompiled tarball The localdir still has no .git repo, so it looped. --- src/Propellor/Spin.hs | 50 ++++++++++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 22 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 8baf4fd9..cffa7610 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -42,11 +42,12 @@ spin target relay hst = do void $ boolSystem "ssh-add" [] -- Install, or update the remote propellor. - updateServer target relay hst $ withBothHandles createProcessSuccess - (proc "ssh" $ cacheparams ++ [user, updatecmd]) + updateServer target relay hst + (proc "ssh" $ cacheparams ++ [user, shellWrap probecmd]) + (proc "ssh" $ cacheparams ++ [user, shellWrap updatecmd]) -- And now we can run it. - unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $ + unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, shellWrap runcmd])) $ error $ "remote propellor failed" where hn = fromMaybe target relay @@ -55,27 +56,27 @@ spin target relay hst = do relaying = relay == Just target viarelay = isJust relay && not relaying - mkcmd = shellWrap . intercalate " ; " - - updatecmd = mkcmd + probecmd = intercalate " ; " [ "if [ ! -d " ++ localdir ++ "/.git ]" , "then (" ++ intercalate " && " [ "if ! git --version || ! make --version; then apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi" , "echo " ++ toMarked statusMarker (show NeedGitClone) ] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled) - , "else " ++ intercalate " && " - [ "cd " ++ localdir - , "if ! test -x ./propellor; then make deps build; fi" - , if viarelay - then "./propellor --continue " ++ - shellEscape (show (Update (Just target))) - -- Still using --boot for back-compat... - else "./propellor --boot " ++ target - ] + , "else " ++ updatecmd , "fi" ] + + updatecmd = intercalate " && " + [ "cd " ++ localdir + , "if ! test -x ./propellor; then make deps build; fi" + , if viarelay + then "./propellor --continue " ++ + shellEscape (show (Update (Just target))) + -- Still using --boot for back-compat... + else "./propellor --boot " ++ target + ] - runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor " ++ cmd ] + runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd cmd = if viarelay then "--serialized " ++ shellEscape (show (Spin target (Just target))) else "--continue " ++ shellEscape (show (SimpleRun target)) @@ -114,17 +115,22 @@ update forhost = do -- to be relayed to the target host. privfile = maybe privDataLocal privDataRelay forhost --- The connect action should ssh to the remote host and run the provided --- calback action. -updateServer :: HostName -> Maybe HostName -> Host -> (((Handle, Handle) -> IO ()) -> IO ()) -> IO () -updateServer target relay hst connect = connect go +updateServer + :: HostName + -> Maybe HostName + -> Host + -> CreateProcess + -> CreateProcess + -> IO () +updateServer target relay hst connect haveprecompiled = + withBothHandles createProcessSuccess connect go where hn = fromMaybe target relay relaying = relay == Just target go (toh, fromh) = do let loop = go (toh, fromh) - let restart = updateServer hn relay hst connect + let restart = updateServer hn relay hst connect haveprecompiled let done = return () v <- (maybe Nothing readish <$> getMarked fromh statusMarker) case v of @@ -143,7 +149,7 @@ updateServer target relay hst connect = connect go hClose toh hClose fromh sendPrecompiled hn - restart + updateServer hn relay hst haveprecompiled (error "loop") (Just NeedGitPush) -> do sendGitUpdate hn fromh toh hClose fromh -- cgit v1.2.3 From 40bec41f569a73a8e95d9acf91f0ae7465b0f8c0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 20:35:46 -0400 Subject: avoid removing whole localdir every time the precompiled tarball is uploaded There's some state in there.. Moved it to a shim subdir, which can be deleted and the tarball unpacked to recreate it. --- src/Propellor/Spin.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index cffa7610..1688bcaf 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -217,7 +217,7 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor where go tmpdir = do cacheparams <- sshCachingParams hn - let shimdir = takeFileName localdir + let shimdir = takeFileName localdir "shim" createDirectoryIfMissing True (tmpdir shimdir) changeWorkingDirectory (tmpdir shimdir) me <- readSymbolicLink "/proc/self/exe" @@ -237,9 +237,10 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor unpackcmd = shellWrap $ intercalate " && " [ "cd " ++ takeDirectory remotetarball - , "rm -rf " ++ localdir + , "rm -rf " ++ localdir "shim" , "tar xzf " ++ remotetarball , "rm -f " ++ remotetarball + , "ln -sf shim/propellor propellor/propellor" ] -- Shim for git push over the propellor ssh channel. -- cgit v1.2.3 From 58b5de78020f65ec54ba3ddb20741d9bf9906ad6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 20:42:20 -0400 Subject: Revert "avoid removing whole localdir every time the precompiled tarball is uploaded" This reverts commit 40bec41f569a73a8e95d9acf91f0ae7465b0f8c0. --- src/Propellor/Spin.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 1688bcaf..cffa7610 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -217,7 +217,7 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor where go tmpdir = do cacheparams <- sshCachingParams hn - let shimdir = takeFileName localdir "shim" + let shimdir = takeFileName localdir createDirectoryIfMissing True (tmpdir shimdir) changeWorkingDirectory (tmpdir shimdir) me <- readSymbolicLink "/proc/self/exe" @@ -237,10 +237,9 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor unpackcmd = shellWrap $ intercalate " && " [ "cd " ++ takeDirectory remotetarball - , "rm -rf " ++ localdir "shim" + , "rm -rf " ++ localdir , "tar xzf " ++ remotetarball , "rm -f " ++ remotetarball - , "ln -sf shim/propellor propellor/propellor" ] -- Shim for git push over the propellor ssh channel. -- cgit v1.2.3 From 1338f4effda3293356e493a375e912d3821b6069 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 20:42:31 -0400 Subject: don't remove old localdir before tarball unpack it may get messy if old stuff is left, but there is state in there --- src/Propellor/Spin.hs | 1 - 1 file changed, 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index cffa7610..6add4f9f 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -237,7 +237,6 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor unpackcmd = shellWrap $ intercalate " && " [ "cd " ++ takeDirectory remotetarball - , "rm -rf " ++ localdir , "tar xzf " ++ remotetarball , "rm -f " ++ remotetarball ] -- cgit v1.2.3 From 50b6e377906785a711371856e796ea14f295a76d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 21:10:35 -0400 Subject: propellor spin --- src/Propellor/Property/Debootstrap.hs | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 0611e735..fe87cc27 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -141,8 +141,26 @@ installed = RevertableProperty install remove aptremove = Apt.removed ["debootstrap"] sourceInstall :: Property -sourceInstall = property "debootstrap installed from source" - (liftIO sourceInstall') +sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall') + `requires` perlInstalled + `requires` arInstalled + +perlInstalled :: Property +perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ do + v <- liftIO $ firstM id + [ yumInstall "perl" + ] + if isJust v then return MadeChange else return FailedChange + +arInstalled :: Property +arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ do + v <- liftIO $ firstM id + [ yumInstall "binutils" + ] + if isJust v then return MadeChange else return FailedChange + +yumInstall :: String -> IO Bool +yumInstall p = boolSystem "yum" [Param "-y", Param "install", Param p] sourceInstall' :: IO Result sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do -- cgit v1.2.3 From 1d5d911aa09297c2f9d4e6db1f9437ff8c014a74 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 21:30:50 -0400 Subject: propellor spin --- src/Propellor/Property/Debootstrap.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index fe87cc27..2ba9faac 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -78,7 +78,8 @@ built target system@(System _ arch) config = , Param target ] cmd <- fromMaybe "debootstrap" <$> programPath - ifM (boolSystem cmd params) + de <- debootstrapEnv + ifM (boolSystemEnv cmd params (Just de)) ( do fixForeignDev target return MadeChange @@ -107,6 +108,15 @@ built target system@(System _ arch) config = , return False ) +-- workaround for http://bugs.debian.org/770658 +debootstrapEnv :: IO [(String, String)] +debootstrapEnv = do + path <- getEnvDefault "/bin" "PATH" + addEntry "PATH" (path ++ debianPath) + <$> getEnvironment + where + debianPath = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" + mountPoints :: IO [FilePath] mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] -- cgit v1.2.3 From cc8babccc8992f0f169c5613d583ae5d82373272 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 21:37:39 -0400 Subject: propellor spin --- src/Propellor/Property/Debootstrap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 2ba9faac..b04bda71 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -111,7 +111,7 @@ built target system@(System _ arch) config = -- workaround for http://bugs.debian.org/770658 debootstrapEnv :: IO [(String, String)] debootstrapEnv = do - path <- getEnvDefault "/bin" "PATH" + path <- getEnvDefault "PATH" "/bin" addEntry "PATH" (path ++ debianPath) <$> getEnvironment where -- cgit v1.2.3 From 5360e466d35d01f83f782496ee672206530a85cd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 21:50:49 -0400 Subject: reorg --- src/Propellor/Property/Debootstrap.hs | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index b04bda71..a8c80348 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -108,15 +108,6 @@ built target system@(System _ arch) config = , return False ) --- workaround for http://bugs.debian.org/770658 -debootstrapEnv :: IO [(String, String)] -debootstrapEnv = do - path <- getEnvDefault "PATH" "/bin" - addEntry "PATH" (path ++ debianPath) - <$> getEnvironment - where - debianPath = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" - mountPoints :: IO [FilePath] mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] @@ -243,6 +234,15 @@ makeWrapperScript dir = do ] modifyFileMode wrapperScript (addModes $ readModes ++ executeModes) +-- workaround for http://bugs.debian.org/770658 +debootstrapEnv :: IO [(String, String)] +debootstrapEnv = do + path <- getEnvDefault "PATH" "/bin" + addEntry "PATH" (path ++ debianPath) + <$> getEnvironment + where + debianPath = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" + -- Work around for http://bugs.debian.org/770217 makeDevicesTarball :: IO () makeDevicesTarball = do @@ -256,8 +256,9 @@ makeDevicesTarball = do tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz" fixForeignDev :: FilePath -> IO () -fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ - void $ boolSystem "chroot" +fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ do + de <- debootstrapEnv + void $ boolSystemEnv "chroot" [ File target , Param "sh" , Param "-c" @@ -268,6 +269,7 @@ fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ , "/sbin/MAKEDEV std ptmx fd consoleonly" ] ] + (Just de) foreignDevFlag :: FilePath foreignDevFlag = "/dev/.propellor-foreign-dev" -- cgit v1.2.3 From 7c5188b202977d341bdfae504c987e8ee0451157 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 22:01:19 -0400 Subject: propellor spin --- src/Propellor/Shim.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs index 1bfbb0ca..6262ea5c 100644 --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -11,14 +11,18 @@ import Utility.LinuxMkLibs import Utility.SafeCommand import Utility.Path import Utility.FileMode +import Utility.FileSystemEncoding import Data.List import System.Posix.Files -- | Sets up a shimmed version of the program, in a directory, and -- returns its path. +-- +-- Propellor may be running from an existing shim, in which case it's +-- simply reused. setup :: FilePath -> FilePath -> IO FilePath -setup propellorbin dest = do +setup propellorbin dest = checkAlreadyShimmed propellorbin $ do createDirectoryIfMissing True dest libs <- parseLdd <$> readProcess "ldd" [propellorbin] @@ -36,7 +40,7 @@ setup propellorbin dest = do let linkerparams = ["--library-path", intercalate ":" libdirs ] let shim = file propellorbin dest writeFile shim $ unlines - [ "#!/bin/sh" + [ shebang , "GCONV_PATH=" ++ shellEscape gconvdir , "export GCONV_PATH" , "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ @@ -45,6 +49,17 @@ setup propellorbin dest = do modifyFileMode shim (addModes executeModes) return shim +shebang :: String +shebang = "#!/bin/sh" + +checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath +checkAlreadyShimmed f nope = withFile f ReadMode $ \h -> do + fileEncoding h + s <- hGetLine h + if s == shebang + then return f + else nope + -- Called when the shimmed propellor is running, so that commands it runs -- don't see it. cleanEnv :: IO () -- cgit v1.2.3 From 96ecbaad25076901802dd7a311161d46a1212d68 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 22:10:53 -0400 Subject: pute full path to bin/propellor inside shim --- src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/Debootstrap.hs | 3 ++- src/Propellor/Property/Docker.hs | 2 +- src/Propellor/Shim.hs | 6 +++--- src/Propellor/Spin.hs | 2 +- 5 files changed, 8 insertions(+), 7 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index c3b14a8e..f45e2fc1 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -88,7 +88,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c " let me = localdir "propellor" shim <- liftIO $ ifM (doesDirectoryExist d) ( pure (Shim.file me d) - , Shim.setup me d + , Shim.setup me Nothing d ) ifM (liftIO $ bindmount shim) ( chainprovision shim diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index a8c80348..f85eb2e6 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -263,7 +263,8 @@ fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ do , Param "sh" , Param "-c" , Param $ intercalate " && " - [ "rm -rf /dev" + [ "apt-get -y install makedev" + , "rm -rf /dev" , "mkdir /dev" , "cd /dev" , "/sbin/MAKEDEV std ptmx fd consoleonly" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 460bc3ec..586ebc2e 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -377,7 +377,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope liftIO $ do clearProvisionedFlag cid createDirectoryIfMissing True (takeDirectory $ identFile cid) - shim <- liftIO $ Shim.setup (localdir "propellor") (localdir shimdir cid) + shim <- liftIO $ Shim.setup (localdir "propellor") Nothing (localdir shimdir cid) liftIO $ writeFile (identFile cid) (show ident) ensureProperty $ boolProperty "run" $ runContainer img (runps ++ ["-i", "-d", "-t"]) diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs index 6262ea5c..a97bf5c8 100644 --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -21,8 +21,8 @@ import System.Posix.Files -- -- Propellor may be running from an existing shim, in which case it's -- simply reused. -setup :: FilePath -> FilePath -> IO FilePath -setup propellorbin dest = checkAlreadyShimmed propellorbin $ do +setup :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath +setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do createDirectoryIfMissing True dest libs <- parseLdd <$> readProcess "ldd" [propellorbin] @@ -44,7 +44,7 @@ setup propellorbin dest = checkAlreadyShimmed propellorbin $ do , "GCONV_PATH=" ++ shellEscape gconvdir , "export GCONV_PATH" , "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ - " " ++ shellEscape propellorbin ++ " \"$@\"" + " " ++ shellEscape (fromMaybe propellorbin propellorbinpath) ++ " \"$@\"" ] modifyFileMode shim (addModes executeModes) return shim diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 6add4f9f..228c4027 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -224,7 +224,7 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor createDirectoryIfMissing True "bin" unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $ errorMessage "failed copying in propellor" - void $ Shim.setup "bin/propellor" "." + void $ Shim.setup "bin/propellor" (localdir "bin/propellor") "." changeWorkingDirectory tmpdir withTmpFile "propellor.tar." $ \tarball _ -> allM id [ boolSystem "strip" [File me] -- cgit v1.2.3 From 81e52f1e14d92a455a873afc183aa9d4333876b4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 22:11:36 -0400 Subject: update --- .gitignore | 1 + src/Propellor/Spin.hs | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/.gitignore b/.gitignore index e9925509..a2d84e4e 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ Setup Setup.hi Setup.o docker +propellor.1 diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 228c4027..06bac330 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -224,7 +224,9 @@ sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor createDirectoryIfMissing True "bin" unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $ errorMessage "failed copying in propellor" - void $ Shim.setup "bin/propellor" (localdir "bin/propellor") "." + let bin = "bin/propellor" + let binpath = Just $ localdir bin + void $ Shim.setup bin binpath "." changeWorkingDirectory tmpdir withTmpFile "propellor.tar." $ \tarball _ -> allM id [ boolSystem "strip" [File me] -- cgit v1.2.3 From ca09087caf5298b01f05bae4a4601fce47966c4f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 22:24:09 -0400 Subject: propellor spin --- src/Propellor/Engine.hs | 3 +++ src/Propellor/Property/Debootstrap.hs | 4 +++- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index b551ca05..0b65fb7e 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -11,6 +11,8 @@ import "mtl" Control.Monad.Reader import Control.Exception (bracket) import System.PosixCompat import System.Posix.IO +import System.FilePath +import System.Directory import Propellor.Types import Propellor.Message @@ -60,6 +62,7 @@ onlyProcess :: FilePath -> IO a -> IO a onlyProcess lockfile a = bracket lock unlock (const a) where lock = do + createDirectoryIfMissing True (takeDirectory lockfile) l <- createFile lockfile stdFileMode setLock l (WriteLock, AbsoluteSeek, 0, 0) `catchIO` const alreadyrunning diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index f85eb2e6..32e892bb 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -263,10 +263,12 @@ fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ do , Param "sh" , Param "-c" , Param $ intercalate " && " - [ "apt-get -y install makedev" + [ "apt-get update" + , "apt-get -y install makedev" , "rm -rf /dev" , "mkdir /dev" , "cd /dev" + , "mount -t proc proc /proc" , "/sbin/MAKEDEV std ptmx fd consoleonly" ] ] -- cgit v1.2.3 From 5fefb161c388f72fa598c238295ce1f051cc0029 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 22 Nov 2014 22:37:25 -0400 Subject: propellor spin --- propellor.cabal | 1 + src/Propellor/Property/Chroot.hs | 5 ++++- src/Propellor/Property/Chroot/Util.hs | 15 +++++++++++++++ src/Propellor/Property/Debootstrap.hs | 14 +++----------- 4 files changed, 23 insertions(+), 12 deletions(-) create mode 100644 src/Propellor/Property/Chroot/Util.hs (limited to 'src/Propellor') diff --git a/propellor.cabal b/propellor.cabal index 20aba22e..a09a80d1 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -126,6 +126,7 @@ Library Propellor.PrivData.Paths Propellor.Protocol Propellor.Shim + Propellor.Property.Chroot.Util Utility.Applicative Utility.Data Utility.Directory diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index f45e2fc1..3da8b0d6 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -11,6 +11,7 @@ module Propellor.Property.Chroot ( import Propellor import Propellor.Types.Chroot +import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd import qualified Propellor.Shim as Shim @@ -109,12 +110,14 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c " chainprovision shim = do parenthost <- asks hostName cmd <- liftIO $ toChain parenthost c systemdonly + pe <- liftIO standardPathEnv let p = mkproc [ shim , "--continue" , show cmd ] - liftIO $ withHandle StdoutHandle createProcessSuccess p + let p' = p { env = Just pe } + liftIO $ withHandle StdoutHandle createProcessSuccess p' processChainOutput toChain :: HostName -> Chroot -> Bool -> IO CmdLine diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs new file mode 100644 index 00000000..feb71d01 --- /dev/null +++ b/src/Propellor/Property/Chroot/Util.hs @@ -0,0 +1,15 @@ +module Propellor.Property.Chroot.Util where + +import Utility.Env +import Control.Applicative + +-- When chrooting, it's useful to ensure that PATH has all the standard +-- directories in it. This adds those directories to whatever PATH is +-- already set. +standardPathEnv :: IO [(String, String)] +standardPathEnv = do + path <- getEnvDefault "PATH" "/bin" + addEntry "PATH" (path ++ std) + <$> getEnvironment + where + std = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 32e892bb..ab5bddf4 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -8,6 +8,7 @@ module Propellor.Property.Debootstrap ( import Propellor import qualified Propellor.Property.Apt as Apt +import Propellor.Property.Chroot.Util import Utility.Path import Utility.SafeCommand import Utility.FileMode @@ -78,7 +79,7 @@ built target system@(System _ arch) config = , Param target ] cmd <- fromMaybe "debootstrap" <$> programPath - de <- debootstrapEnv + de <- standardPathEnv ifM (boolSystemEnv cmd params (Just de)) ( do fixForeignDev target @@ -234,15 +235,6 @@ makeWrapperScript dir = do ] modifyFileMode wrapperScript (addModes $ readModes ++ executeModes) --- workaround for http://bugs.debian.org/770658 -debootstrapEnv :: IO [(String, String)] -debootstrapEnv = do - path <- getEnvDefault "PATH" "/bin" - addEntry "PATH" (path ++ debianPath) - <$> getEnvironment - where - debianPath = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" - -- Work around for http://bugs.debian.org/770217 makeDevicesTarball :: IO () makeDevicesTarball = do @@ -257,7 +249,7 @@ makeDevicesTarball = do fixForeignDev :: FilePath -> IO () fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ do - de <- debootstrapEnv + de <- standardPathEnv void $ boolSystemEnv "chroot" [ File target , Param "sh" -- cgit v1.2.3 From f4e06ae77818f32c16c5051b4fe40a7bc993b624 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Sun, 23 Nov 2014 18:25:39 +0100 Subject: User: hasGroup Signed-off-by: Félix Sipma --- src/Propellor/Property/User.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index f9c400a8..b7bd5e93 100644 --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -30,7 +30,7 @@ hasSomePassword user context = check ((/= HasPassword) <$> getPasswordStatus use hasPassword :: UserName -> Context -> Property hasPassword user context = withPrivData (Password user) context $ \getpassword -> - property (user ++ " has password") $ + property (user ++ " has password") $ getpassword $ \password -> makeChange $ withHandle StdinHandle createProcessSuccess (proc "chpasswd" []) $ \h -> do @@ -60,3 +60,12 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user homedir :: UserName -> IO FilePath homedir user = homeDirectory <$> getUserEntryForName user + +hasGroup :: UserName -> GroupName -> Property +hasGroup user group' = check test $ cmdProperty "adduser" + [ user + , group' + ] + `describe` unwords ["user", user, "in group", group'] + where + test = not <$> elem group' <$> words <$> readProcess "groups" [user] -- cgit v1.2.3 From 69eace8e9a9d4fb2c6193e9e44ea836bd0bf8ba4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 23 Nov 2014 14:37:37 -0400 Subject: preferred style --- src/Propellor/Property/User.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index b7bd5e93..6a51703a 100644 --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -68,4 +68,4 @@ hasGroup user group' = check test $ cmdProperty "adduser" ] `describe` unwords ["user", user, "in group", group'] where - test = not <$> elem group' <$> words <$> readProcess "groups" [user] + test = not . elem group' . words <$> readProcess "groups" [user] -- cgit v1.2.3 From 6aa21366d57679f82fbaf96a90f93d2d1ac7f223 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Sun, 23 Nov 2014 18:33:26 +0100 Subject: Group properties Signed-off-by: Félix Sipma --- propellor.cabal | 1 + src/Propellor/Property/Group.hs | 14 ++++++++++++++ 2 files changed, 15 insertions(+) create mode 100644 src/Propellor/Property/Group.hs (limited to 'src/Propellor') diff --git a/propellor.cabal b/propellor.cabal index a09a80d1..cd34d4bf 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -83,6 +83,7 @@ Library Propellor.Property.Firewall Propellor.Property.Git Propellor.Property.Gpg + Propellor.Property.Group Propellor.Property.Grub Propellor.Property.Network Propellor.Property.Nginx diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs new file mode 100644 index 00000000..f03510cf --- /dev/null +++ b/src/Propellor/Property/Group.hs @@ -0,0 +1,14 @@ +module Propellor.Property.Group where + +import Propellor + +type GID = Int + +exists :: GroupName -> Maybe GID -> Property +exists group' mgid = check test (cmdProperty "addgroup" $ args mgid) + `describe` unwords ["group", group'] + where + groupFile = "/etc/group" + test = not <$> elem group' <$> words <$> readProcess "cut" ["-d:", "-f1", groupFile] + args Nothing = [group'] + args (Just gid) = ["--gid", show gid, group'] -- cgit v1.2.3 From 226981cda4597f6564b9e31d826efc84a2ce61a5 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Sun, 23 Nov 2014 18:42:36 +0100 Subject: Git: bareRepo Signed-off-by: Félix Sipma --- src/Propellor/Property/Git.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index 8d49cbd0..a2bec5ef 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -94,3 +94,23 @@ cloned owner url dir mbranch = check originurl (property desc checkout) isGitDir :: FilePath -> IO Bool isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", dir]) + +data GitShared = Shared GroupName | SharedAll | NotShared + +bareRepo :: FilePath -> UserName -> GitShared -> Property +bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ + dirExists repo : case gitshared of + NotShared -> + [ ownerGroup repo user user + , userScriptProperty user ["git", "init", "--bare", "--shared=false", repo] + ] + SharedAll -> + [ ownerGroup repo user user + , userScriptProperty user ["git", "init", "--bare", "--shared=all", repo] + ] + Shared group' -> + [ ownerGroup repo user group' + , userScriptProperty user ["git", "init", "--bare", "--shared=group", repo] + ] + where + isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo']) -- cgit v1.2.3 From 3c952a0de9d228eafe6e208007be7d2e018d68b8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 23 Nov 2014 14:40:28 -0400 Subject: comment --- src/Propellor/Property/Git.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index a2bec5ef..eb7801c1 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -57,8 +57,9 @@ type Branch = String -- | Specified git repository is cloned to the specified directory. -- --- If the firectory exists with some other content, it will be recursively --- deleted. +-- If the directory exists with some other content (either a non-git +-- repository, or a git repository cloned from some other location), +-- it will be recursively deleted first. -- -- A branch can be specified, to check out. cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property -- cgit v1.2.3