propellor spin

CmdLine.hs

@@ -0,0 +1,100 @@
+module CmdLine where
+
+import System.Environment
+import Data.List
+import System.Exit
+
+import Common
+import Utility.FileMode
+
+data CmdLine
+	= Run HostName
+	| Spin HostName
+	| Boot HostName
+	| Set HostName PrivDataField String
+
+processCmdLine :: IO CmdLine
+processCmdLine = go =<< getArgs
+  where
+  	go ("--help":_) = usage
+  	go ("--spin":h:[]) = return $ Spin h
+  	go ("--boot":h:[]) = return $ Boot h
+	go ("--set":h:f:v:[]) = case readish f of
+		Just pf -> return $ Set h pf v
+		Nothing -> error $ "Unknown privdata field " ++ f
+	go (h:[]) = return $ Run h
+	go [] = do
+		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
+		if null s
+			then error "Cannot determine hostname! Pass it on the command line."
+			else return $ Run s
+	go _ = usage
+	
+usage :: IO a
+usage = do
+	putStrLn $ unlines 
+		[ "Usage:"
+		, "  propellor"
+		, "  propellor hostname"
+		, "  propellor --spin hostname"
+		, "  propellor --set hostname field value"
+		]
+	exitFailure
+
+defaultMain :: (HostName -> [Property]) -> IO ()
+defaultMain getprops = go =<< processCmdLine
+  where
+	go (Run host) = ensureProperties (getprops host)
+	go (Spin host) = spin host
+	go (Boot host) = boot (getprops host)
+	go (Set host field val) = setPrivData host field val
+
+spin :: HostName -> IO ()
+spin host = do
+	url <- getUrl
+	privdata <- gpgDecrypt (privDataFile host)
+	void $ boolSystem "git" [Param "commit", Param "-a", Param "-m", Param "propellor spin"]
+	withHandle StdinHandle createProcessSuccess
+		(proc "ssh" ["root@"++host, bootstrap url]) $ \h -> do
+			hPutStr h $ unlines $ map (privDataMarker ++) $ lines privdata
+			hClose h
+  where
+	bootstrap url = shellWrap $ intercalate " && "
+		[ intercalate " ; "
+			[ "if [ ! -d " ++ localdir ++ " ]"
+			, "then"
+			, intercalate " && "
+				[ "apt-get -y install git"
+				, "git clone " ++ url ++ " " ++ localdir
+				]
+			, "fi"
+			]
+		, "cd " ++ localdir
+		, "make pull build"
+		, "./propellor --boot " ++ host
+		]
+
+boot :: [Property] -> IO ()
+boot props = do
+	privdata <- map (drop $ length privDataMarker ) 
+		. filter (privDataMarker `isPrefixOf`) 
+		. lines 
+		<$> getContents
+	writeFileProtected privDataLocal (unlines privdata)
+	ensureProperties props
+
+localdir :: FilePath
+localdir = "/usr/local/propellor"
+
+getUrl :: IO String
+getUrl = fromMaybe nourl <$> getM get urls
+  where
+	urls = ["remote.deploy.url", "remote.origin.url"]
+	nourl = error $ "Cannot find deploy url in " ++ show urls
+	get u = do
+		v <- catchMaybeIO $ 
+			takeWhile (/= '\n') 
+				<$> readProcess "git" ["config", u]
+		return $ case v of
+			Just url | not (null url) -> Just url
+			_ -> Nothing

Common.hs

@@ -1,8 +1,11 @@
 module Common (module X) where
 
+import Types as X
 import Property as X
 import Property.Cmd as X
+import PrivData as X
 
+import Utility.PartialPrelude as X
 import Control.Applicative as X
 import Control.Monad as X
 import Utility.Process as X

HostName.hs

@@ -1,18 +0,0 @@
-module HostName where
-
-import Control.Applicative
-import System.Environment
-
-import Utility.Process
-
-type HostName = String
-
-getHostName :: IO HostName
-getHostName = go =<< getArgs
-  where
-	go (h:_) = return h
-	go [] = do
-		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
-		if null s
-			then error "Cannot determine hostname! Pass it on the command line."
-			else return s

Propellor.hs

@@ -1,5 +1,5 @@
 import Common
-import HostName
+import CmdLine
 import qualified Property.File as File
 import qualified Property.Apt as Apt
 import qualified Property.Ssh as Ssh
@@ -10,7 +10,7 @@ import qualified Property.Tor as Tor
 import qualified Property.GitHome as GitHome
 
 main :: IO ()
-main = ensureProperties . getProperties =<< getHostName
+main = defaultMain getProperties
 
 {- This is where the system's HostName, either as returned by uname
  - or one specified on the command line, is converted into a list of
@@ -21,6 +21,7 @@ getProperties hostname@"clam.kitenet.net" =
 	, standardSystem Apt.Unstable
 	-- Clam is a tor bridge.
 	, Tor.isBridge
+	, Apt.installed ["docker.io"]
 	-- This is not an important system so I don't want to need to 
 	-- manually upgrade it.
 	, Apt.unattendedUpgrades True

Property.hs

@@ -6,27 +6,10 @@ import System.Console.ANSI
 import System.Exit
 import System.IO
 
+import Types
 import Utility.Monad
 import Utility.Exception
 
-data Property = Property
-	{ propertyDesc :: Desc
-	-- must be idempotent; may run repeatedly
-	, propertySatisfy :: IO Result
-	}
-
-type Desc = String
-
-data Result = NoChange | MadeChange | FailedChange
-	deriving (Show, Eq)
-
-combineResult :: Result -> Result -> Result
-combineResult FailedChange _ = FailedChange
-combineResult _ FailedChange = FailedChange
-combineResult MadeChange _ = MadeChange
-combineResult _ MadeChange = MadeChange
-combineResult NoChange NoChange = NoChange
-
 makeChange :: IO () -> IO Result
 makeChange a = a >> return MadeChange
 

Property/Cmd.hs

@@ -6,7 +6,7 @@ module Property.Cmd (
 
 import Control.Applicative
 
-import Property
+import Types
 import Utility.Monad
 import Utility.SafeCommand
 import Utility.Env

Property/Hostname.hs

@@ -3,8 +3,6 @@ module Property.Hostname where
 import Common
 import qualified Property.File as File
 
-type HostName = String
-
 set :: HostName -> Property
 set hostname = "/etc/hostname" `File.hasContent` [hostname]
 	`onChange` cmdProperty "hostname" [Param hostname]

Property/User.hs

@@ -4,8 +4,6 @@ import System.Posix
 
 import Common
 
-type UserName = String
-
 data Eep = YesReallyDeleteHome
 
 sshAccountFor :: UserName -> Property
@@ -24,6 +22,14 @@ nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel"
 	]
 	`describe` ("nuked user " ++ user)
 
+setPassword :: UserName -> Property
+setPassword user = Property (user ++ " password set") $
+	withPrivData (Password user) $ \password -> makeChange $
+		withHandle StdinHandle createProcessSuccess
+			(proc "chpasswd" []) $ \h -> do
+				hPutStrLn h $ user ++ ":" ++ password
+				hClose h
+
 lockedPassword :: UserName -> Property
 lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd"
 	[ Param "--lock"

README

@@ -11,9 +11,6 @@ to a system, and "make" can be used to pull down any new changes,
 and compile and run propellor. This can be done by a cron job. Or something
 can ssh in and run it.
 
-For bootstrapping, propellor compiles to a single binary file,
-which can be transferred to a host and run.
-
 Properties are defined using Haskell. Edit Propellor.hs
 
 There is no special language as used in puppet, chef, ansible, etc, just
@@ -26,4 +23,20 @@ of which classes and share which configuration. It might be nice to use
 reclass[1], but then again a host is configured using simply haskell code,
 and so it's easy to factor out things like classes of hosts as desired.
 
+To bootstrap propellor on a new host, use: propellor --spin $host
+This looks up the git repository's remote.origin.url (or remote.deploy.url
+if available) and logs into the host, clones the url (if not already
+done), and sets up and runs propellor in /usr/local/propellor
+
+Private data such as passwords, ssh private keys, etc should not be checked
+into a propellor git repository in the clear, unless you want to restrict
+access to the repository. Which would probably involve a separate fork 
+for each host and be annoying. 
+
+Instead, propellor --spin $host looks for a privdata/$host.gpg file and
+if found decrypts it and sends it to the host using ssh. To set a field
+in such a file, use: propellor --set $host $field $value
+The field name is will be something like 'Password "root"'; see PrivData.hs
+for available fields.
+
 [1] http://reclass.pantsfullofunix.net/

Types.hs

@@ -0,0 +1,22 @@
+module Types where
+
+type HostName = String
+type UserName = String
+
+data Property = Property
+	{ propertyDesc :: Desc
+	-- must be idempotent; may run repeatedly
+	, propertySatisfy :: IO Result
+	}
+
+type Desc = String
+
+data Result = NoChange | MadeChange | FailedChange
+	deriving (Show, Eq)
+
+combineResult :: Result -> Result -> Result
+combineResult FailedChange _ = FailedChange
+combineResult _ FailedChange = FailedChange
+combineResult MadeChange _ = MadeChange
+combineResult _ MadeChange = MadeChange
+combineResult NoChange NoChange = NoChange

Utility/FileMode.hs

@@ -0,0 +1,155 @@
+{- File mode utilities.
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.FileMode where
+
+import System.IO
+import Control.Monad
+import Control.Exception (bracket)
+import System.PosixCompat.Types
+#ifndef mingw32_HOST_OS
+import System.Posix.Files
+#endif
+import Foreign (complement)
+
+import Utility.Exception
+
+{- Applies a conversion function to a file's mode. -}
+modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
+modifyFileMode f convert = void $ modifyFileMode' f convert
+modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' f convert = do
+	s <- getFileStatus f
+	let old = fileMode s
+	let new = convert old
+	when (new /= old) $
+		setFileMode f new
+	return old
+
+{- Adds the specified FileModes to the input mode, leaving the rest
+ - unchanged. -}
+addModes :: [FileMode] -> FileMode -> FileMode
+addModes ms m = combineModes (m:ms)
+
+{- Removes the specified FileModes from the input mode. -}
+removeModes :: [FileMode] -> FileMode -> FileMode
+removeModes ms m = m `intersectFileModes` complement (combineModes ms)
+
+{- Runs an action after changing a file's mode, then restores the old mode. -}
+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode file convert a = bracket setup cleanup go
+  where
+	setup = modifyFileMode' file convert
+	cleanup oldmode = modifyFileMode file (const oldmode)
+	go _ = a
+
+writeModes :: [FileMode]
+writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
+
+readModes :: [FileMode]
+readModes = [ownerReadMode, groupReadMode, otherReadMode]
+
+executeModes :: [FileMode]
+executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
+
+{- Removes the write bits from a file. -}
+preventWrite :: FilePath -> IO ()
+preventWrite f = modifyFileMode f $ removeModes writeModes
+
+{- Turns a file's owner write bit back on. -}
+allowWrite :: FilePath -> IO ()
+allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
+
+{- Turns a file's owner read bit back on. -}
+allowRead :: FilePath -> IO ()
+allowRead f = modifyFileMode f $ addModes [ownerReadMode]
+
+{- Allows owner and group to read and write to a file. -}
+groupSharedModes :: [FileMode]
+groupSharedModes =
+	[ ownerWriteMode, groupWriteMode
+	, ownerReadMode, groupReadMode
+	]
+
+groupWriteRead :: FilePath -> IO ()
+groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
+
+checkMode :: FileMode -> FileMode -> Bool
+checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor
+
+{- Checks if a file mode indicates it's a symlink. -}
+isSymLink :: FileMode -> Bool
+#ifdef mingw32_HOST_OS
+isSymLink _ = False
+#else
+isSymLink = checkMode symbolicLinkMode
+#endif
+
+{- Checks if a file has any executable bits set. -}
+isExecutable :: FileMode -> Bool
+isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
+
+{- Runs an action without that pesky umask influencing it, unless the
+ - passed FileMode is the standard one. -}
+noUmask :: FileMode -> IO a -> IO a
+#ifndef mingw32_HOST_OS
+noUmask mode a
+	| mode == stdFileMode = a
+	| otherwise = withUmask nullFileMode a
+#else
+noUmask _ a = a
+#endif
+
+withUmask :: FileMode -> IO a -> IO a
+#ifndef mingw32_HOST_OS
+withUmask umask a = bracket setup cleanup go
+  where
+	setup = setFileCreationMask umask
+	cleanup = setFileCreationMask
+	go _ = a
+#else
+withUmask _ a = a
+#endif
+
+combineModes :: [FileMode] -> FileMode
+combineModes [] = undefined
+combineModes [m] = m
+combineModes (m:ms) = foldl unionFileModes m ms
+
+isSticky :: FileMode -> Bool
+#ifdef mingw32_HOST_OS
+isSticky _ = False
+#else
+isSticky = checkMode stickyMode
+
+stickyMode :: FileMode
+stickyMode = 512
+
+setSticky :: FilePath -> IO ()
+setSticky f = modifyFileMode f $ addModes [stickyMode]
+#endif
+
+{- Writes a file, ensuring that its modes do not allow it to be read
+ - or written by anyone other than the current user,
+ - before any content is written.
+ -
+ - When possible, this is done using the umask.
+ -
+ - On a filesystem that does not support file permissions, this is the same
+ - as writeFile.
+ -}
+writeFileProtected :: FilePath -> String -> IO ()
+writeFileProtected file content = withUmask 0o0077 $
+	withFile file WriteMode $ \h -> do
+		void $ tryIO $ modifyFileMode file $
+			removeModes
+				[ groupReadMode, otherReadMode
+				, groupWriteMode, otherWriteMode
+				]
+		hPutStr h content

Utility/PartialPrelude.hs

@@ -0,0 +1,68 @@
+{- Parts of the Prelude are partial functions, which are a common source of
+ - bugs.
+ -
+ - This exports functions that conflict with the prelude, which avoids
+ - them being accidentially used.
+ -}
+
+module Utility.PartialPrelude where
+
+import qualified Data.Maybe
+
+{- read should be avoided, as it throws an error
+ - Instead, use: readish -}
+read :: Read a => String -> a
+read = Prelude.read
+
+{- head is a partial function; head [] is an error
+ - Instead, use: take 1 or headMaybe -}
+head :: [a] -> a
+head = Prelude.head
+
+{- tail is also partial
+ - Instead, use: drop 1 -}
+tail :: [a] -> [a]
+tail = Prelude.tail
+
+{- init too
+ - Instead, use: beginning -}
+init :: [a] -> [a]
+init = Prelude.init
+
+{- last too
+ - Instead, use: end or lastMaybe -}
+last :: [a] -> a
+last = Prelude.last
+
+{- Attempts to read a value from a String.
+ -
+ - Ignores leading/trailing whitespace, and throws away any trailing
+ - text after the part that can be read.
+ -
+ - readMaybe is available in Text.Read in new versions of GHC,
+ - but that one requires the entire string to be consumed.
+ -}
+readish :: Read a => String -> Maybe a
+readish s = case reads s of
+	((x,_):_) -> Just x
+	_ -> Nothing
+
+{- Like head but Nothing on empty list. -}
+headMaybe :: [a] -> Maybe a
+headMaybe = Data.Maybe.listToMaybe
+
+{- Like last but Nothing on empty list. -}
+lastMaybe :: [a] -> Maybe a
+lastMaybe [] = Nothing
+lastMaybe v = Just $ Prelude.last v
+
+{- All but the last element of a list.
+ - (Like init, but no error on an empty list.) -}
+beginning :: [a] -> [a]
+beginning [] = []
+beginning l = Prelude.init l
+
+{- Like last, but no error on an empty list. -}
+end :: [a] -> [a]
+end [] = []
+end l = [Prelude.last l]

privdata/clam.kitenet.net.gpg

@@ -0,0 +1,19 @@
+-----BEGIN PGP MESSAGE-----
+Version: GnuPG v1
+
+hQIMA7ODiaEXBlRZAQ//V77CfPgJXpqO0W3F41MaSV/sa1PIoB9B/JsLGog+2ZGW
+sbLevCdlQNoWwmzuBzDBsAdIDgsAQX3o5ldqOaJ6jZSc0AVUUE6QQQ6ggCz5kCre
+/JU/7YXTthmQv/9zu1tGeX7tjIaHQBkihq+3lS0TQjQqVBQmZJBJjgL+wZJ0fshF
+T+hrCBi5s9DS/YIGoghpuQVJ0yA16fU7aLaH5jaF0CEsRm8Q+Qvn4v+1YlEi+d7t
+Mk5AQ0YKE1kC2eIA8TjK1hIF/4NEEY/wnonJTcAhJ6op4gqjmhhQ/sXwaobg8UmQ
+vew4q3+wiYpLdTGbYMfI3pNV2FpltZXg8DLKjxZFH6H/0cL5xZDG7ZiDJh6hyHJN
+unpjgLm0UxvSLb/Jp4vycycP8SXz+XSo1ZhQDq8Qof1Sg5LBSXdzouM1xSX+kPqm
++0C9eabqNCG7deVDDQe9V25+CUIVMM70WavtRRICwNrUZCrChCO85gMZPzpYYYr2
++3z+ygPw8s41waCBPH6EH+9Qw5PmIyqBYoFbnPNY8g2hmu2oFlEcN7REzYduZL3D
+MNRahF/l40Ek4l3TYDI4OPyIqRb8sCifZTphyjhIULlTGlfuO4gwRiHIdssSpH7t
+TjhcgJfqBPSmyq4oIRUUxoBwMsaL9OunFi+7pHInbGksLY7Lfv07P3WpBdYjlwXS
+cgGqVY+WDTMvde+LYu459OkZW80VH+WgJb7NWpRiFqJyTyOtqeLIT+33/noO4f4y
+VYRb94zsB4n8u3tZfIFAGj2G6pbJPMhyEvST6ePkL0q63rC+BjwsQ0Q7wXVPLqMu
+mxr+K75/DTbP5ft8gmY80sDrHQ==
+=vDG9
+-----END PGP MESSAGE-----

propellor.cabal

@@ -19,7 +19,8 @@ Executable propellor
   Main-Is: Propellor.hs
   GHC-Options: -Wall
   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, 
-   IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal
+   IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
+   containers
 
   if (! os(windows))
     Build-Depends: unix