propellor 0.1.2 → 0.2.0
raw patch · 34 files changed
+1896/−307 lines, 34 filesdep +asyncdep +network
Dependencies added: async, network
Files
- CHANGELOG +16/−0
- Makefile +4/−7
- Propellor.hs +10/−1
- Propellor/CmdLine.hs +259/−54
- Propellor/Engine.hs +7/−24
- Propellor/Message.hs +42/−0
- Propellor/PrivData.hs +6/−14
- Propellor/Property.hs +31/−28
- Propellor/Property/Apt.hs +46/−21
- Propellor/Property/Cmd.hs +23/−1
- Propellor/Property/Cron.hs +33/−0
- Propellor/Property/Docker.hs +409/−1
- Propellor/Property/File.hs +5/−0
- Propellor/Property/GitHome.hs +0/−31
- Propellor/Property/JoeySites.hs +0/−23
- Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +51/−0
- Propellor/Property/SiteSpecific/GitHome.hs +36/−0
- Propellor/Property/SiteSpecific/JoeySites.hs +23/−0
- Propellor/Property/Ssh.hs +1/−1
- Propellor/Property/User.hs +6/−6
- Propellor/SimpleSh.hs +96/−0
- Propellor/Types.hs +90/−7
- README +0/−42
- README.md +97/−0
- TODO +13/−0
- Utility/FileMode.hs +7/−5
- Utility/Path.hs +293/−0
- Utility/ThreadScheduler.hs +73/−0
- Utility/UserInfo.hs +55/−0
- config.hs +75/−32
- debian/README +1/−0
- debian/changelog +16/−0
- propellor.cabal +20/−9
- simple-config.hs +52/−0
+ CHANGELOG view
@@ -0,0 +1,16 @@+propellor (0.2) unstable; urgency=low++ * Added support for provisioning Docker containers.+ * Bootstrap deployment now pushes the git repo to the remote host+ over ssh, securely.+ * propellor --add-key configures a gpg key, and makes propellor refuse+ to pull commits from git repositories not signed with that key.+ This allows propellor to be securely used with public, non-encrypted+ git repositories without the possibility of MITM.+ * Added support for type-safe reversions. Only some properties can be+ reverted; the type checker will tell you if you try something that won't+ work.+ * New syntactic sugar for building a list of properties, including+ revertable properties.++ -- Joey Hess <joeyh@debian.org> Wed, 02 Apr 2014 13:57:42 -0400
Makefile view
@@ -1,17 +1,14 @@-run: pull build+run: build ./propellor -devel: build tags--pull:- git pull+dev: build tags build: deps dist/setup-config- cabal build || (cabal configure; cabal build)+ if ! cabal build; then cabal configure; cabal build; fi ln -sf dist/build/propellor/propellor deps:- @if [ $$(whoami) = root ]; then apt-get install ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev; fi || true+ @if [ $$(whoami) = root ]; then apt-get -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-async-dev; fi || true dist/setup-config: propellor.cabal cabal configure
Propellor.hs view
@@ -17,7 +17,7 @@ -- > getProperties "example.com" = Just -- > [ Apt.installed ["mydaemon"] -- > , "/etc/mydaemon.conf" `File.containsLine` "secure=1"--- > `onChange` cmdProperty "service" ["mydaemon", "restart"]]+-- > `onChange` cmdProperty "service" ["mydaemon", "restart"] -- > ] -- > getProperties _ = Nothing --@@ -31,6 +31,8 @@ , module Propellor.Property.Cmd , module Propellor.PrivData , module Propellor.Engine+ , module Propellor.Message+ , localdir , module X ) where@@ -40,6 +42,7 @@ import Propellor.Engine import Propellor.Property.Cmd import Propellor.PrivData+import Propellor.Message import Utility.PartialPrelude as X import Utility.Process as X@@ -57,3 +60,9 @@ import Data.Either as X import Control.Applicative as X import Control.Monad as X+import Data.Monoid as X+import Control.Monad.IfElse as X++-- | This is where propellor installs itself when deploying a host.+localdir :: FilePath+localdir = "/usr/local/propellor"
Propellor/CmdLine.hs view
@@ -1,18 +1,29 @@ module Propellor.CmdLine where -import System.Environment+import System.Environment (getArgs) import Data.List import System.Exit+import System.Log.Logger+import System.Log.Formatter+import System.Log.Handler (setFormatter, LogHandler)+import System.Log.Handler.Simple import Propellor+import qualified Propellor.Property.Docker as Docker import Utility.FileMode import Utility.SafeCommand -data CmdLine- = Run HostName- | Spin HostName- | Boot HostName- | Set HostName PrivDataField+usage :: IO a+usage = do+ putStrLn $ unlines + [ "Usage:"+ , " propellor"+ , " propellor hostname"+ , " propellor --spin hostname"+ , " propellor --set hostname field"+ , " propellor --add-key keyid"+ ]+ exitFailure processCmdLine :: IO CmdLine processCmdLine = go =<< getArgs@@ -20,85 +31,267 @@ go ("--help":_) = usage go ("--spin":h:[]) = return $ Spin h go ("--boot":h:[]) = return $ Boot h+ go ("--add-key":k:[]) = return $ AddKey k go ("--set":h:f:[]) = case readish f of Just pf -> return $ Set h pf- Nothing -> error $ "Unknown privdata field " ++ f- go (h:[]) = return $ Run h+ Nothing -> errorMessage $ "Unknown privdata field " ++ f+ go ("--continue":s:[]) = case readish s of+ Just cmdline -> return $ Continue cmdline+ Nothing -> errorMessage "--continue serialization failure"+ go ("--chain":h:[]) = return $ Chain h+ go ("--docker":h:[]) = return $ Docker h+ go (h:[])+ | "--" `isPrefixOf` h = usage+ | otherwise = 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."+ then errorMessage "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"- ]- exitFailure -defaultMain :: (HostName -> Maybe [Property]) -> IO ()-defaultMain getprops = go =<< processCmdLine+defaultMain :: [HostName -> Maybe [Property]] -> IO ()+defaultMain getprops = do+ checkDebugMode+ cmdline <- processCmdLine+ debug ["command line: ", show cmdline]+ go True cmdline where- go (Run host) = maybe (unknownhost host) ensureProperties (getprops host)- go (Spin host) = spin host- go (Boot host) = maybe (unknownhost host) boot (getprops host)- go (Set host field) = setPrivData host field+ go _ (Continue cmdline) = go False cmdline+ go _ (Set host field) = setPrivData host field+ go _ (AddKey keyid) = addKey keyid+ go _ (Chain host) = withprops host $ \ps -> do+ r <- ensureProperties' ps+ putStrLn $ "\n" ++ show r+ go _ (Docker host) = Docker.chain host+ go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline+ go True cmdline = updateFirst cmdline $ go False cmdline+ go False (Spin host) = withprops host $ const $ spin host+ go False (Run host) = withprops host $ ensureProperties+ go False (Boot host) = withprops host $ boot + withprops host a = maybe (unknownhost host) a $+ headMaybe $ catMaybes $ map (\get -> get host) getprops+ unknownhost :: HostName -> IO a-unknownhost h = error $ unwords+unknownhost h = errorMessage $ unwords [ "Unknown host:", h , "(perhaps you should specify the real hostname on the command line?)" ] +buildFirst :: CmdLine -> IO () -> IO ()+buildFirst cmdline next = do+ oldtime <- getmtime+ ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])+ ( do+ newtime <- getmtime+ if newtime == oldtime+ then next+ else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]+ , errorMessage "Propellor build failed!" + )+ where+ getmtime = catchMaybeIO $ getModificationTime "propellor"++updateFirst :: CmdLine -> IO () -> IO ()+updateFirst cmdline next = do+ branchref <- takeWhile (/= '\n') + <$> readProcess "git" ["symbolic-ref", "HEAD"]+ let originbranch = "origin" </> takeFileName branchref++ void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]+ + whenM (doesFileExist keyring) $ do+ {- To verify origin/master commit's signature, have to+ - convince gpg to use our keyring. While running git log.+ - Which has no way to pass options to gpg.+ - Argh! -}+ let gpgconf = privDataDir </> "gpg.conf"+ writeFile gpgconf $ unlines+ [ " keyring " ++ keyring+ , "no-auto-check-trustdb"+ ]+ -- gpg is picky about perms+ modifyFileMode privDataDir (removeModes otherGroupModes)+ s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]+ (Just [("GNUPGHOME", privDataDir)])+ nukeFile $ privDataDir </> "trustring.gpg"+ nukeFile $ privDataDir </> "gpg.conf"+ if s == "U\n" || s == "G\n"+ then do+ putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"+ hFlush stdout+ else errorMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"+ + oldsha <- getCurrentGitSha1 branchref+ void $ boolSystem "git" [Param "merge", Param originbranch]+ newsha <- getCurrentGitSha1 branchref++ if oldsha == newsha+ then next+ else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])+ ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]+ , errorMessage "Propellor build failed!" + )++getCurrentGitSha1 :: String -> IO String+getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]+ spin :: HostName -> IO () spin host = do url <- getUrl- void $ boolSystem "git" [Param "commit", Param "-a", Param "-m", Param "propellor spin"]+ void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] void $ boolSystem "git" [Param "push"]- privdata <- gpgDecrypt (privDataFile host)- withHandle StdinHandle createProcessSuccess- (proc "ssh" ["root@"++host, bootstrap url]) $ \h -> do- hPutStr h $ unlines $ map (privDataMarker ++) $ lines privdata- hClose h+ go url =<< gpgDecrypt (privDataFile host) where- bootstrap url = shellWrap $ intercalate " && "- [ intercalate " ; "- [ "if [ ! -d " ++ localdir ++ " ]"- , "then " ++ intercalate " && "- [ "apt-get -y install git"- , "git clone " ++ url ++ " " ++ localdir- ]- , "fi"+ go url privdata = withBothHandles createProcessSuccess (proc "ssh" [user, bootstrapcmd]) $ \(toh, fromh) -> do+ let finish = do+ senddata toh (privDataFile host) privDataMarker privdata+ hClose toh+ + -- Display remaining output.+ void $ tryIO $ forever $+ showremote =<< hGetLine fromh+ hClose fromh+ status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")+ case status of+ Ready -> finish+ NeedGitClone -> do+ hClose toh+ hClose fromh+ sendGitClone host url+ go url privdata+ + user = "root@"++host++ bootstrapcmd = shellWrap $ intercalate " ; "+ [ "if [ ! -d " ++ localdir ++ " ]"+ , "then " ++ intercalate " && "+ [ "apt-get -y install git"+ , "echo " ++ toMarked statusMarker (show NeedGitClone) ]+ , "else " ++ intercalate " && "+ [ "cd " ++ localdir+ , "if ! test -x ./propellor; then make build; fi"+ , "./propellor --boot " ++ host+ ]+ , "fi"+ ]++ getstatus :: Handle -> IO BootStrapStatus+ getstatus h = do+ l <- hGetLine h+ case readish =<< fromMarked statusMarker l of+ Nothing -> do+ showremote l+ getstatus h+ Just status -> return status+ + showremote s = putStrLn s+ senddata toh f marker s = void $+ actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do+ sendMarked toh marker s+ return True++sendGitClone :: HostName -> String -> IO ()+sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $+ withTmpFile "propellor.git." $ \tmp _ -> allM id+ -- TODO: ssh connection caching, or better push method+ -- with less connections.+ [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]+ , boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)]+ , boolSystem "ssh" [Param ("root@"++host), Param unpackcmd]+ ]+ where+ remotebundle = "/usr/local/propellor.git"+ unpackcmd = shellWrap $ intercalate " && "+ [ "git clone " ++ remotebundle ++ " " ++ localdir , "cd " ++ localdir- , "make pull build"- , "./propellor --boot " ++ host+ , "git checkout -b master"+ , "git remote rm origin"+ , "git remote add origin " ++ url+ , "rm -f " ++ remotebundle ] +data BootStrapStatus = Ready | NeedGitClone+ deriving (Read, Show, Eq)++type Marker = String+type Marked = String++statusMarker :: Marker+statusMarker = "STATUS"++privDataMarker :: String+privDataMarker = "PRIVDATA "++toMarked :: Marker -> String -> String+toMarked marker = intercalate "\n" . map (marker ++) . lines++sendMarked :: Handle -> Marker -> String -> IO ()+sendMarked h marker s = do+ -- Prefix string with newline because sometimes a+ -- incomplete line is output.+ hPutStrLn h ("\n" ++ toMarked marker s)+ hFlush h++fromMarked :: Marker -> Marked -> Maybe String+fromMarked marker s+ | null matches = Nothing+ | otherwise = Just $ intercalate "\n" $+ map (drop len) matches+ where+ len = length marker+ matches = filter (marker `isPrefixOf`) $ lines s+ boot :: [Property] -> IO ()-boot props = do- privdata <- map (drop $ length privDataMarker ) - . filter (privDataMarker `isPrefixOf`) - . lines - <$> getContents+boot ps = do+ sendMarked stdout statusMarker $ show Ready+ reply <- hGetContentsStrict stdin+ makePrivDataDir- writeFileProtected privDataLocal (unlines privdata)- ensureProperties props+ maybe noop (writeFileProtected privDataLocal) $+ fromMarked privDataMarker reply+ ensureProperties ps -localdir :: FilePath-localdir = "/usr/local/propellor"+addKey :: String -> IO ()+addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]+ where+ gpg = boolSystem "sh"+ [ Param "-c"+ , Param $ "gpg --export " ++ keyid ++ " | gpg " +++ unwords (gpgopts ++ ["--import"])+ ]+ gitadd = boolSystem "git"+ [ Param "add"+ , File keyring+ ]+ gitcommit = gitCommit+ [ File keyring+ , Param "-m"+ , Param "propellor addkey"+ ] +{- Automatically sign the commit if there'a a keyring. -}+gitCommit :: [CommandParam] -> IO Bool+gitCommit ps = do+ k <- doesFileExist keyring+ boolSystem "git" $ catMaybes $+ [ Just (Param "commit")+ , if k then Just (Param "--gpg-sign") else Nothing+ ] ++ map Just ps++keyring :: FilePath+keyring = privDataDir </> "keyring.gpg"++gpgopts :: [String]+gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring]+ getUrl :: IO String-getUrl = fromMaybe nourl <$> getM get urls+getUrl = maybe nourl return =<< getM get urls where urls = ["remote.deploy.url", "remote.origin.url"]- nourl = error $ "Cannot find deploy url in " ++ show urls+ nourl = errorMessage $ "Cannot find deploy url in " ++ show urls get u = do v <- catchMaybeIO $ takeWhile (/= '\n') @@ -106,3 +299,15 @@ return $ case v of Just url | not (null url) -> Just url _ -> Nothing++checkDebugMode :: IO ()+checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"+ where+ go (Just s)+ | s == "1" = do+ f <- setFormatter+ <$> streamHandler stderr DEBUG+ <*> pure (simpleLogFormatter "[$time] $msg")+ updateGlobalLogger rootLoggerName $ + setLevel DEBUG . setHandlers [f]+ go _ = noop
Propellor/Engine.hs view
@@ -1,10 +1,12 @@ module Propellor.Engine where -import System.Console.ANSI import System.Exit import System.IO+import Data.Monoid+import System.Console.ANSI import Propellor.Types+import Propellor.Message import Utility.Exception ensureProperty :: Property -> IO Result@@ -13,6 +15,8 @@ ensureProperties :: [Property] -> IO () ensureProperties ps = do r <- ensureProperties' [Property "overall" $ ensureProperties' ps]+ setTitle "propellor: done"+ hFlush stdout case r of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess@@ -22,26 +26,5 @@ where ensure [] rs = return rs ensure (l:ls) rs = do- r <- ensureProperty l- clearFromCursorToLineBeginning- setCursorColumn 0- putStr $ propertyDesc l ++ "... "- case r of- FailedChange -> do- setSGR [SetColor Foreground Vivid Red]- putStrLn "failed"- NoChange -> do- setSGR [SetColor Foreground Dull Green]- putStrLn "unchanged"- MadeChange -> do- setSGR [SetColor Foreground Vivid Green]- putStrLn "done"- setSGR []- ensure ls (combineResult r rs)--warningMessage :: String -> IO ()-warningMessage s = do- setSGR [SetColor Foreground Vivid Red]- putStrLn $ "** warning: " ++ s- setSGR []- hFlush stdout+ r <- actionMessage (propertyDesc l) (ensureProperty l)+ ensure ls (r <> rs)
+ Propellor/Message.hs view
@@ -0,0 +1,42 @@+module Propellor.Message where++import System.Console.ANSI+import System.IO+import System.Log.Logger++import Propellor.Types++-- | Shows a message while performing an action, with a colored status+-- display.+actionMessage :: ActionResult r => Desc -> IO r -> IO r+actionMessage desc a = do+ setTitle $ "propellor: " ++ desc+ hFlush stdout++ r <- a++ let (msg, intensity, color) = getActionResult r+ putStr $ desc ++ " ... "+ setSGR [SetColor Foreground intensity color]+ putStrLn msg+ setSGR []+ setTitle "propellor: running"+ hFlush stdout++ return r++warningMessage :: String -> IO ()+warningMessage s = do+ setSGR [SetColor Foreground Vivid Red]+ putStrLn $ "** warning: " ++ s+ setSGR []+ hFlush stdout++errorMessage :: String -> IO a+errorMessage s = do+ warningMessage s+ error "Propellor failed!"++-- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1+debug :: [String] -> IO ()+debug = debugM "propellor" . unwords
Propellor/PrivData.hs view
@@ -9,7 +9,7 @@ import Control.Monad import Propellor.Types-import Propellor.Engine+import Propellor.Message import Utility.Monad import Utility.PartialPrelude import Utility.Exception@@ -18,15 +18,6 @@ import Utility.SafeCommand import Utility.Misc --- | Note that removing or changing field names will break the--- serialized privdata files, so don't do that!--- It's fine to add new fields.-data PrivDataField- = DockerAuthentication- | SshPrivKey UserName- | Password UserName- deriving (Read, Show, Ord, Eq)- withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result withPrivData field a = maybe missing a =<< getPrivData field where@@ -42,7 +33,7 @@ setPrivData :: HostName -> PrivDataField -> IO () setPrivData host field = do putStrLn "Enter private data on stdin; ctrl-D when done:"- value <- hGetContentsStrict stdin+ value <- chomp <$> hGetContentsStrict stdin makePrivDataDir let f = privDataFile host m <- fromMaybe M.empty . readish <$> gpgDecrypt f@@ -50,6 +41,10 @@ gpgEncrypt f (show m') putStrLn "Private data set." void $ boolSystem "git" [Param "add", File f]+ where+ chomp s+ | end s == "\n" = chomp (beginning s)+ | otherwise = s makePrivDataDir :: IO () makePrivDataDir = createDirectoryIfMissing False privDataDir@@ -62,9 +57,6 @@ privDataLocal :: FilePath privDataLocal = privDataDir </> "local"--privDataMarker :: String-privDataMarker = "PRIVDATA " gpgDecrypt :: FilePath -> IO String gpgDecrypt f = ifM (doesFileExist f)
Propellor/Property.hs view
@@ -2,6 +2,7 @@ import System.Directory import Control.Monad+import Data.Monoid import Propellor.Types import Propellor.Engine@@ -13,32 +14,28 @@ noChange :: IO Result noChange = return NoChange -{- | Combines a list of properties, resulting in a single property- - that when run will run each property in the list in turn,- - and print out the description of each as it's run. Does not stop- - on failure; does propigate overall success/failure.- -}+-- | Combines a list of properties, resulting in a single property+-- that when run will run each property in the list in turn,+-- and print out the description of each as it's run. Does not stop+-- on failure; does propigate overall success/failure. propertyList :: Desc -> [Property] -> Property propertyList desc ps = Property desc $ ensureProperties' ps -{- | Combines a list of properties, resulting in one property that- - ensures each in turn, stopping on failure. -}-combineProperties :: [Property] -> Property-combineProperties ps = Property desc $ go ps NoChange+-- | Combines a list of properties, resulting in one property that+-- ensures each in turn, stopping on failure.+combineProperties :: Desc -> [Property] -> Property+combineProperties desc ps = Property desc $ go ps NoChange where go [] rs = return rs go (l:ls) rs = do r <- ensureProperty l case r of FailedChange -> return FailedChange- _ -> go ls (combineResult r rs)- desc = case ps of- (p:_) -> propertyDesc p- _ -> "(empty)"+ _ -> go ls (r <> rs) -{- | Makes a perhaps non-idempotent Property be idempotent by using a flag- - file to indicate whether it has run before.- - Use with caution. -}+-- | Makes a perhaps non-idempotent Property be idempotent by using a flag+-- file to indicate whether it has run before.+-- Use with caution. flagFile :: Property -> FilePath -> Property flagFile property flagfile = Property (propertyDesc property) $ go =<< doesFileExist flagfile@@ -50,32 +47,38 @@ writeFile flagfile "" return r -{- | Whenever a change has to be made for a Property, causes a hook- - Property to also be run, but not otherwise. -}+--- | Whenever a change has to be made for a Property, causes a hook+-- Property to also be run, but not otherwise. onChange :: Property -> Property -> Property property `onChange` hook = Property (propertyDesc property) $ do r <- ensureProperty property case r of MadeChange -> do r' <- ensureProperty hook- return $ combineResult r r'+ return $ r <> r' _ -> return r -{- | Indicates that the first property can only be satisfied once- - the second is. -} -requires :: Property -> Property -> Property-x `requires` y = combineProperties [y, x] `describe` propertyDesc x--describe :: Property -> Desc -> Property-describe p d = p { propertyDesc = d }- (==>) :: Desc -> Property -> Property (==>) = flip describe infixl 1 ==> -{- | Makes a Property only be performed when a test succeeds. -}+-- | Makes a Property only be performed when a test succeeds. check :: IO Bool -> Property -> Property check c property = Property (propertyDesc property) $ ifM c ( ensureProperty property , return NoChange )++-- | Undoes the effect of a property.+revert :: RevertableProperty -> RevertableProperty+revert (RevertableProperty p1 p2) = RevertableProperty p2 p1++-- | Starts a list of Properties+props :: [Property]+props = []++-- | Adds a property to the list.+-- Can add both Properties and RevertableProperties.+(&) :: IsProp p => [Property] -> p -> [Property]+ps & p = ps ++ [toProp p]+infixl 1 &
Propellor/Property/Apt.hs view
@@ -16,16 +16,14 @@ type Url = String type Section = String -data Suite = Stable | Testing | Unstable | Experimental- deriving Show--showSuite :: Suite -> String+showSuite :: DebianSuite -> String showSuite Stable = "stable" showSuite Testing = "testing" showSuite Unstable = "unstable" showSuite Experimental = "experimental"+showSuite (DebianRelease r) = r -debLine :: Suite -> Url -> [Section] -> Line+debLine :: DebianSuite -> Url -> [Section] -> Line debLine suite mirror sections = unwords $ ["deb", mirror, showSuite suite] ++ sections @@ -37,15 +35,25 @@ stdSections :: [Section] stdSections = ["main", "contrib", "non-free"] -debCdn :: Suite -> [Line]-debCdn suite = [l, srcLine l]+binandsrc :: String -> DebianSuite -> [Line]+binandsrc url suite = [l, srcLine l] where- l = debLine suite "http://cdn.debian.net/debian" stdSections+ l = debLine suite url stdSections +debCdn :: DebianSuite -> [Line]+debCdn = binandsrc "http://cdn.debian.net/debian"++kernelOrg :: DebianSuite -> [Line]+kernelOrg = binandsrc "http://mirrors.kernel.org/debian"+ {- | Makes sources.list have a standard content using the mirror CDN,- - with a particular Suite. -}-stdSourcesList :: Suite -> Property-stdSourcesList suite = setSourcesList (debCdn suite)+ - with a particular DebianSuite.+ -+ - Since the CDN is sometimes unreliable, also adds backup lines using+ - kernel.org.+ -}+stdSourcesList :: DebianSuite -> Property+stdSourcesList suite = setSourcesList (debCdn suite ++ kernelOrg suite) `describe` ("standard sources.list for " ++ show suite) setSourcesList :: [Line] -> Property@@ -70,7 +78,7 @@ type Package = String installed :: [Package] -> Property-installed ps = check (isInstallable ps) go+installed ps = robustly $ check (isInstallable ps) go `describe` (unwords $ "apt installed":ps) where go = runApt $ ["-y", "install"] ++ ps@@ -81,6 +89,21 @@ where go = runApt $ ["-y", "remove"] ++ ps +buildDep :: [Package] -> Property+buildDep ps = robustly go+ `describe` (unwords $ "apt build-dep":ps)+ where+ go = runApt $ ["-y", "build-dep"] ++ ps++{- Package installation may fail becuse the archive has changed.+ - Run an update in that case and retry. -}+robustly :: Property -> Property+robustly p = Property (propertyDesc p) $ do+ r <- ensureProperty p+ if r == FailedChange+ then ensureProperty $ p `requires` update+ else return r+ isInstallable :: [Package] -> IO Bool isInstallable ps = do l <- isInstalled' ps@@ -106,16 +129,18 @@ autoRemove = runApt ["-y", "autoremove"] `describe` "apt autoremove" -unattendedUpgrades :: Bool -> Property-unattendedUpgrades enabled =- (if enabled then installed else removed) ["unattended-upgrades"]- `onChange` reConfigure "unattended-upgrades"- [("unattended-upgrades/enable_auto_updates" , "boolean", v)]- `describe` ("unattended upgrades " ++ v)+-- | Enables unattended upgrades. Revert to disable.+unattendedUpgrades :: RevertableProperty+unattendedUpgrades = RevertableProperty (go True) (go False) where- v- | enabled = "true"- | otherwise = "false"+ go enabled = (if enabled then installed else removed) ["unattended-upgrades"]+ `onChange` reConfigure "unattended-upgrades"+ [("unattended-upgrades/enable_auto_updates" , "boolean", v)]+ `describe` ("unattended upgrades " ++ v)+ where+ v+ | enabled = "true"+ | otherwise = "false" -- | Preseeds debconf values and reconfigures the package so it takes -- effect.
Propellor/Property/Cmd.hs view
@@ -1,13 +1,17 @@ module Propellor.Property.Cmd ( cmdProperty, cmdProperty',- scriptProperty+ scriptProperty,+ userScriptProperty,+ serviceRunning, ) where +import Control.Monad import Control.Applicative import Data.List import Propellor.Types+import Propellor.Engine import Utility.Monad import Utility.SafeCommand import Utility.Env@@ -35,3 +39,21 @@ scriptProperty script = cmdProperty "sh" ["-c", shellcmd] where shellcmd = intercalate " ; " ("set -e" : script)++-- | A property that can satisfied by running a series of shell commands,+-- as user (staring in their home directory).+userScriptProperty :: UserName -> [String] -> Property+userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]+ where+ shellcmd = intercalate " ; " ("set -e" : "cd" : script)++-- | Ensures that a service is running.+--+-- Note that due to the general poor state of init scripts, the best+-- we can do is try to start the service, and if it fails, assume+-- this means it's already running.+serviceRunning :: String -> Property+serviceRunning svc = Property ("running " ++ svc) $ do+ void $ ensureProperty $+ scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]+ return NoChange
+ Propellor/Property/Cron.hs view
@@ -0,0 +1,33 @@+module Propellor.Property.Cron where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt++type CronTimes = String++-- | Installs a cron job, run as a specificed user, in a particular+--directory. Note that the Desc must be unique, as it is used for the +--cron.d/ filename.+job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property+job desc times user cddir command = ("/etc/cron.d/" ++ desc) `File.hasContent`+ [ "# Generated by propellor"+ , ""+ , "SHELL=/bin/sh"+ , "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin"+ , ""+ , times ++ "\t" ++ user ++ "\t" ++ "cd " ++ cddir ++ " && " ++ command+ ]+ `requires` Apt.installed ["cron"]+ `requires` serviceRunning "cron"+ `describe` ("cronned " ++ desc)++-- | Installs a cron job, and runs it niced and ioniced.+niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property+niceJob desc times user cddir command = job desc times user cddir+ ("nice ionice -c 3 " ++ command)+ `requires` Apt.installed ["util-linux", "moreutils"]++-- | Installs a cron job to run propellor.+runPropellor :: CronTimes -> Property+runPropellor times = niceJob "propellor" times "root" localdir "chronic make"
Propellor/Property/Docker.hs view
@@ -1,9 +1,30 @@+{-# LANGUAGE RankNTypes #-}++-- | Docker support for propellor+--+-- The existance of a docker container is just another Property of a system,+-- which propellor can set up. See config.hs for an example.+--+-- Note that propellor provisions a container by running itself, inside the+-- container. Currently, to avoid the overhead of building propellor+-- inside the container, the binary from outside is reused inside. +-- So, the libraries that propellor is linked against need to be available+-- in the container with compatable versions. This can cause a problem+-- if eg, mixing Debian stable and unstable.+ module Propellor.Property.Docker where import Propellor+import Propellor.SimpleSh import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt+import Utility.SafeCommand+import Utility.Path +import Control.Concurrent.Async+import System.Posix.Directory+import Data.List+ -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. configured :: Property@@ -11,6 +32,393 @@ where go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ "/root/.dockercfg" `File.hasContent` (lines cfg)- + installed :: Property installed = Apt.installed ["docker.io"]++-- | Ensures that a docker container is set up and running. The container+-- has its own Properties which are handled by running propellor+-- inside the container.+--+-- Reverting this property ensures that the container is stopped and+-- removed.+docked+ :: (HostName -> ContainerName -> Maybe (Container))+ -> HostName+ -> ContainerName+ -> RevertableProperty+docked findc hn cn = findContainer findc hn cn $+ \(Container image containerprops) ->+ let setup = provisionContainer cid+ `requires`+ runningContainer cid image containerprops+ teardown = + Property ("undocked " ++ fromContainerId cid) $+ report <$> mapM id+ [ stopContainerIfRunning cid+ , removeContainer cid+ , removeImage image+ ]+ in RevertableProperty setup teardown+ where+ cid = ContainerId hn cn++findContainer+ :: (HostName -> ContainerName -> Maybe (Container))+ -> HostName+ -> ContainerName+ -> (Container -> RevertableProperty)+ -> RevertableProperty+findContainer findc hn cn mk = case findc hn cn of+ Nothing -> RevertableProperty cantfind cantfind+ Just container -> mk container+ where+ cid = ContainerId hn cn+ cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do+ warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid+ return FailedChange++-- | Causes *any* docker images that are not in use by running containers to+-- be deleted. And deletes any containers that propellor has set up+-- before that are not currently running. Does not delete any containers+-- that were not set up using propellor.+--+-- Generally, should come after the properties for the desired containers.+garbageCollected :: Property+garbageCollected = propertyList "docker garbage collected"+ [ gccontainers+ , gcimages+ ]+ where+ gccontainers = Property "docker containers garbage collected" $+ report <$> (mapM removeContainer =<< listContainers AllContainers)+ gcimages = Property "docker images garbage collected" $ do+ report <$> (mapM removeImage =<< listImages)++-- | Pass to defaultMain to add docker containers.+-- You need to provide the function mapping from+-- HostName and ContainerName to the Container to use.+containerProperties+ :: (HostName -> ContainerName -> Maybe (Container))+ -> (HostName -> Maybe [Property])+containerProperties findcontainer = \h -> case toContainerId h of+ Nothing -> Nothing+ Just cid@(ContainerId hn cn) ->+ case findcontainer hn cn of+ Nothing -> Nothing+ Just (Container _ cprops) -> + Just $ map (containerDesc cid) $+ fromContainerized cprops++-- | This type is used to configure a docker container.+-- It has an image, and a list of Properties, but these+-- properties are Containerized; they can specify+-- things about the container's configuration, in+-- addition to properties of the system inside the+-- container.+data Container = Container Image [Containerized Property]++data Containerized a = Containerized [RunParam] a++-- | Parameters to pass to `docker run` when creating a container.+type RunParam = String++-- | A docker image, that can be used to run a container.+type Image = String++-- | A short descriptive name for a container.+-- Should not contain whitespace or other unusual characters,+-- only [a-zA-Z0-9_.-] are allowed+type ContainerName = String++-- | Lift a Property to apply inside a container.+inside1 :: Property -> Containerized Property+inside1 = Containerized []++inside :: [Property] -> Containerized Property+inside = Containerized [] . combineProperties "provision"++-- | Set custom dns server for container.+dns :: String -> Containerized Property+dns = runProp "dns"++-- | Set container host name.+hostname :: String -> Containerized Property+hostname = runProp "hostname"++-- | Set name for container. (Normally done automatically.)+name :: String -> Containerized Property+name = runProp "name"++-- | Publish a container's port to the host+-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)+publish :: String -> Containerized Property+publish = runProp "publish"++-- | Username or UID for container.+user :: String -> Containerized Property+user = runProp "user"++-- | Bind mount a volume+volume :: String -> Containerized Property+volume = runProp "volume"++-- | Work dir inside the container. +workdir :: String -> Containerized Property+workdir = runProp "workdir"++-- | Memory limit for container.+--Format: <number><optional unit>, where unit = b, k, m or g+memory :: String -> Containerized Property+memory = runProp "memory"++-- | A container is identified by its name, and the host+-- on which it's deployed.+data ContainerId = ContainerId HostName ContainerName+ deriving (Eq, Read, Show)++-- | Two containers with the same ContainerIdent were started from+-- the same base image (possibly a different version though), and+-- with the same RunParams.+data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]+ deriving (Read, Show, Eq)++getRunParams :: [Containerized a] -> [RunParam]+getRunParams l = concatMap get l+ where+ get (Containerized ps _) = ps++fromContainerized :: forall a. [Containerized a] -> [a]+fromContainerized l = map get l+ where+ get (Containerized _ a) = a++ident2id :: ContainerIdent -> ContainerId+ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn++toContainerId :: String -> Maybe ContainerId+toContainerId s+ | myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of+ (cn, hn)+ | null hn || null cn -> Nothing+ | otherwise -> Just $ ContainerId hn cn+ | otherwise = Nothing+ where+ desuffix = reverse . drop len . reverse+ len = length myContainerSuffix++fromContainerId :: ContainerId -> String+fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix++myContainerSuffix :: String+myContainerSuffix = ".propellor"++containerFrom :: Image -> [Containerized Property] -> Container+containerFrom = Container++containerDesc :: ContainerId -> Property -> Property+containerDesc cid p = p `describe` desc+ where+ desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p++runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property+runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do+ l <- listContainers RunningContainers+ if cid `elem` l+ then do+ runningident <- getrunningident+ if (ident2id <$> runningident) == Just (ident2id ident)+ then return NoChange+ else do+ void $ stopContainer cid+ oldimage <- fromMaybe image <$> commitContainer cid+ void $ removeContainer cid+ go oldimage+ else do+ whenM (elem cid <$> listContainers AllContainers) $ do+ void $ removeContainer cid+ go image+ where+ ident = ContainerIdent image hn cn runps++ getrunningident = catchDefaultIO Nothing $+ simpleShClient (namedPipe cid) "cat" [propellorIdent] $+ pure . headMaybe . catMaybes . map readish . catMaybes . map getStdout++ runps = getRunParams $ containerprops +++ -- expose propellor directory inside the container+ [ volume (localdir++":"++localdir)+ -- name the container in a predictable way so we+ -- and the user can easily find it later+ , name (fromContainerId cid)+ ]+ + chaincmd = [localdir </> "propellor", "--docker", fromContainerId cid]++ go img = do+ clearProvisionedFlag cid+ createDirectoryIfMissing True (takeDirectory $ identFile cid)+ writeFile (identFile cid) (show ident)+ ifM (runContainer img (runps ++ ["-i", "-d", "-t"]) chaincmd)+ ( return MadeChange+ , return FailedChange+ )++-- | Called when propellor is running inside a docker container.+-- The string should be the container's ContainerId.+--+-- Fork a thread to run the SimpleSh server in the background.+-- In the foreground, run an interactive bash (or sh) shell,+-- so that the user can interact with it when attached to the container.+--+-- When the system reboots, docker restarts the container, and this is run+-- again. So, to make the necessary services get started on boot, this needs+-- to provision the container then. However, if the container is already+-- being provisioned by the calling propellor, it would be redundant and+-- problimatic to also provisoon it here.+--+-- The solution is a flag file. If the flag file exists, then the container+-- was already provisioned. So, it must be a reboot, and time to provision+-- again. If the flag file doesn't exist, don't provision here.+chain :: String -> IO ()+chain s = case toContainerId s of+ Nothing -> error $ "Invalid ContainerId: " ++ s+ Just cid -> do+ changeWorkingDirectory localdir+ writeFile propellorIdent . show =<< readIdentFile cid+ -- Run boot provisioning before starting simpleSh,+ -- to avoid ever provisioning twice at the same time.+ whenM (checkProvisionedFlag cid) $+ unlessM (boolSystem "./propellor" [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $+ warningMessage "Boot provision failed!"+ void $ async $ simpleSh $ namedPipe cid+ forever $ do+ void $ ifM (inPath "bash")+ ( boolSystem "bash" [Param "-l"]+ , boolSystem "/bin/sh" []+ )+ putStrLn "Container is still running. Press ^P^Q to detach."++-- | Once a container is running, propellor can be run inside+-- it to provision it.+--+-- Note that there is a race here, between the simplesh+-- server starting up in the container, and this property+-- being run. So, retry connections to the client for up to+-- 1 minute.+provisionContainer :: ContainerId -> Property+provisionContainer cid = containerDesc cid $ Property "provision" $ do+ r <- simpleShClientRetry 60 (namedPipe cid) "./propellor" params (go Nothing)+ when (r /= FailedChange) $+ setProvisionedFlag cid + return r+ where+ params = ["--continue", show $ Chain $ fromContainerId cid]++ go lastline (v:rest) = case v of+ StdoutLine s -> do+ debug ["stdout: ", show s]+ maybe noop putStrLn lastline+ hFlush stdout+ go (Just s) rest+ StderrLine s -> do+ debug ["stderr: ", show s]+ maybe noop putStrLn lastline+ hFlush stdout+ hPutStrLn stderr s+ hFlush stderr+ go Nothing rest+ Done _ -> ret lastline+ go lastline [] = ret lastline++ ret lastline = return $ fromMaybe FailedChange $+ readish =<< lastline++stopContainer :: ContainerId -> IO Bool+stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]++stopContainerIfRunning :: ContainerId -> IO Bool+stopContainerIfRunning cid = ifM (elem cid <$> listContainers RunningContainers)+ ( stopContainer cid+ , return True+ )++removeContainer :: ContainerId -> IO Bool+removeContainer cid = catchBoolIO $+ snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing++removeImage :: Image -> IO Bool+removeImage image = catchBoolIO $+ snd <$> processTranscript dockercmd ["rmi", image ] Nothing++runContainer :: Image -> [RunParam] -> [String] -> IO Bool+runContainer image ps cmd = boolSystem dockercmd $ map Param $+ "run" : (ps ++ image : cmd)++commitContainer :: ContainerId -> IO (Maybe Image)+commitContainer cid = catchMaybeIO $+ takeWhile (/= '\n') + <$> readProcess dockercmd ["commit", fromContainerId cid]++data ContainerFilter = RunningContainers | AllContainers+ deriving (Eq)++-- | Only lists propellor managed containers.+listContainers :: ContainerFilter -> IO [ContainerId]+listContainers status = + catMaybes . map toContainerId . catMaybes . map (lastMaybe . words) . lines+ <$> readProcess dockercmd ps+ where+ ps+ | status == AllContainers = baseps ++ ["--all"]+ | otherwise = baseps+ baseps = ["ps", "--no-trunc"]++listImages :: IO [Image]+listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]++runProp :: String -> RunParam -> Containerized Property+runProp field val = + Containerized ["--" ++ param] (Property (param) (return NoChange))+ where+ param = field++"="++val++-- | The ContainerIdent of a container is written to+-- /.propellor-ident inside it. This can be checked to see if+-- the container has the same ident later.+propellorIdent :: FilePath+propellorIdent = "/.propellor-ident"++-- | Named pipe used for communication with the container.+namedPipe :: ContainerId -> FilePath+namedPipe cid = "docker/" ++ fromContainerId cid++provisionedFlag :: ContainerId -> FilePath+provisionedFlag cid = "docker/" ++ fromContainerId cid ++ ".provisioned"++clearProvisionedFlag :: ContainerId -> IO ()+clearProvisionedFlag = nukeFile . provisionedFlag++setProvisionedFlag :: ContainerId -> IO ()+setProvisionedFlag cid = do+ createDirectoryIfMissing True (takeDirectory (provisionedFlag cid))+ writeFile (provisionedFlag cid) "1"++checkProvisionedFlag :: ContainerId -> IO Bool+checkProvisionedFlag = doesFileExist . provisionedFlag++identFile :: ContainerId -> FilePath+identFile cid = "docker/" ++ fromContainerId cid ++ ".ident"++readIdentFile :: ContainerId -> IO ContainerIdent+readIdentFile cid = fromMaybe (error "bad ident in identFile")+ . readish <$> readFile (identFile cid)++dockercmd :: String+dockercmd = "docker.io"++report :: [Bool] -> Result+report rmed+ | or rmed = MadeChange+ | otherwise = NoChange+
Propellor/Property/File.hs view
@@ -38,3 +38,8 @@ then noChange else makeChange $ viaTmp writeFile f (unlines ls') go False = makeChange $ writeFile f (unlines $ a [])++-- | Ensures a directory exists.+dirExists :: FilePath -> Property+dirExists d = check (not <$> doesDirectoryExist d) $ Property (d ++ " exists") $+ makeChange $ createDirectoryIfMissing True d
− Propellor/Property/GitHome.hs
@@ -1,31 +0,0 @@-module Propellor.Property.GitHome where--import Propellor-import qualified Propellor.Property.Apt as Apt-import Propellor.Property.User-import Utility.SafeCommand--{- | Clones Joey Hess's git home directory, and runs its fixups script. -}-installedFor :: UserName -> Property-installedFor user = check (not <$> hasGitDir user) $ - Property ("githome " ++ user) (go =<< homedir user)- `requires` Apt.installed ["git", "myrepos"]- where- go Nothing = noChange- go (Just home) = do- let tmpdir = home </> "githome"- ok <- boolSystem "git" [Param "clone", Param url, Param tmpdir]- <&&> (and <$> moveout tmpdir home)- <&&> (catchBoolIO $ removeDirectory tmpdir >> return True)- <&&> boolSystem "su" [Param "-c", Param "cd; rm -rf .aptitude/ .bashrc .profile; mr checkout; bin/fixups", Param user]- return $ if ok then MadeChange else FailedChange- moveout tmpdir home = do- fs <- dirContents tmpdir- forM fs $ \f -> boolSystem "mv" [File f, File home]- url = "git://git.kitenet.net/joey/home"--hasGitDir :: UserName -> IO Bool-hasGitDir user = go =<< homedir user- where- go Nothing = return False- go (Just home) = doesDirectoryExist (home </> ".git")
− Propellor/Property/JoeySites.hs
@@ -1,23 +0,0 @@--- | Specific configuation for Joey Hess's sites. Probably not useful to--- others except as an example.--module Propellor.Property.JoeySites where--import Propellor-import qualified Propellor.Property.Apt as Apt--oldUseNetshellBox :: Property-oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $- propertyList ("olduse.net shellbox")- [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")- `describe` "olduse.net build deps"- , scriptProperty- [ "rm -rf /root/tmp/oldusenet" -- idenpotency- , "git clone git://olduse.net/ /root/tmp/oldusenet/source"- , "cd /root/tmp/oldusenet/source/"- , "dpkg-buildpackage -us -uc"- , "dpkg -i ../oldusenet*.deb || true"- , "apt-get -fy install" -- dependencies- , "rm -rf /root/tmp/oldusenet"- ] `describe` "olduse.net built"- ]
+ Propellor/Property/SiteSpecific/GitAnnexBuilder.hs view
@@ -0,0 +1,51 @@+module Propellor.Property.SiteSpecific.GitAnnexBuilder where++import Propellor+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.User as User+import qualified Propellor.Property.Cron as Cron+import Propellor.Property.Cron (CronTimes)++builduser :: UserName+builduser = "builder"++builddir :: FilePath+builddir = "gitbuilder"++builder :: Architecture -> CronTimes -> Property+builder arch crontimes = combineProperties "gitannexbuilder"+ [ Apt.stdSourcesList Unstable+ , Apt.buildDep ["git-annex"]+ , Apt.installed ["git", "rsync", "moreutils", "ca-certificates",+ "liblockfile-simple-perl", "cabal-install", "vim", "less",+ "libghc-fdo-notify-dev"]+ , serviceRunning "cron" `requires` Apt.installed ["cron"]+ , User.accountFor builduser+ , check (lacksdir builddir) $ userScriptProperty builduser+ [ "git clone git://git.kitenet.net/gitannexbuilder " ++ builddir+ , "cd " ++ builddir+ , "git checkout " ++ arch+ ]+ `describe` "gitbuilder setup"+ , check (lacksdir $ builddir </> "build") $ userScriptProperty builduser+ [ "cd " ++ builddir+ , "git clone git://git-annex.branchable.com/ build"+ ]+ , Cron.niceJob "gitannexbuilder" crontimes builduser ("~/" ++ builddir) "git pull ; ./autobuild"+ -- The builduser account does not have a password set,+ -- instead use the password privdata to hold the rsync server+ -- password used to upload the built image.+ , Property "rsync password" $ do+ d <- homedir+ let f = d </> "rsyncpassword"+ withPrivData (Password builduser) $ \p -> do+ oldp <- catchDefaultIO "" $ readFileStrict f+ if p /= oldp+ then makeChange $ writeFile f p+ else noChange+ ]+ where+ homedir = fromMaybe ("/home/" ++ builduser) <$> User.homedir builduser+ lacksdir d = do+ h <- homedir+ not <$> doesDirectoryExist (h </> d)
+ Propellor/Property/SiteSpecific/GitHome.hs view
@@ -0,0 +1,36 @@+module Propellor.Property.SiteSpecific.GitHome where++import Propellor+import qualified Propellor.Property.Apt as Apt+import Propellor.Property.User+import Utility.SafeCommand++-- | Clones Joey Hess's git home directory, and runs its fixups script.+installedFor :: UserName -> Property+installedFor user = check (not <$> hasGitDir user) $ + Property ("githome " ++ user) (go =<< homedir user)+ `requires` Apt.installed ["git", "myrepos"]+ where+ go Nothing = noChange+ go (Just home) = do+ let tmpdir = home </> "githome"+ ensureProperty $ combineProperties "githome setup"+ [ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]+ , Property "moveout" $ makeChange $ void $+ moveout tmpdir home+ , Property "rmdir" $ makeChange $ void $+ catchMaybeIO $ removeDirectory tmpdir+ , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; mr checkout; bin/fixups"]+ ]+ moveout tmpdir home = do+ fs <- dirContents tmpdir+ forM fs $ \f -> boolSystem "mv" [File f, File home]++url :: String+url = "git://git.kitenet.net/joey/home"++hasGitDir :: UserName -> IO Bool+hasGitDir user = go =<< homedir user+ where+ go Nothing = return False+ go (Just home) = doesDirectoryExist (home </> ".git")
+ Propellor/Property/SiteSpecific/JoeySites.hs view
@@ -0,0 +1,23 @@+-- | Specific configuation for Joey Hess's sites. Probably not useful to+-- others except as an example.++module Propellor.Property.SiteSpecific.JoeySites where++import Propellor+import qualified Propellor.Property.Apt as Apt++oldUseNetshellBox :: Property+oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $+ propertyList ("olduse.net shellbox")+ [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")+ `describe` "olduse.net build deps"+ , scriptProperty+ [ "rm -rf /root/tmp/oldusenet" -- idenpotency+ , "git clone git://olduse.net/ /root/tmp/oldusenet/source"+ , "cd /root/tmp/oldusenet/source/"+ , "dpkg-buildpackage -us -uc"+ , "dpkg -i ../oldusenet*.deb || true"+ , "apt-get -fy install" -- dependencies+ , "rm -rf /root/tmp/oldusenet"+ ] `describe` "olduse.net built"+ ]
Propellor/Property/Ssh.hs view
@@ -13,7 +13,7 @@ sshdConfig = "/etc/ssh/sshd_config" setSshdConfig :: String -> Bool -> Property-setSshdConfig setting allowed = combineProperties+setSshdConfig setting allowed = combineProperties "sshd config" [ sshdConfig `File.lacksLine` (sshline $ not allowed) , sshdConfig `File.containsLine` (sshline allowed) ]
Propellor/Property/User.hs view
@@ -6,15 +6,15 @@ data Eep = YesReallyDeleteHome -sshAccountFor :: UserName -> Property-sshAccountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser"+accountFor :: UserName -> Property+accountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser" [ "--disabled-password" , "--gecos", "" , user ]- `describe` ("ssh account " ++ user)+ `describe` ("account for " ++ user) -{- | Removes user home directory!! Use with caution. -}+-- | Removes user home directory!! Use with caution. nuked :: UserName -> Eep -> Property nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel" [ "-r"@@ -22,8 +22,8 @@ ] `describe` ("nuked user " ++ user) -{- | Only ensures that the user has some password set. It may or may- - not be the password from the PrivData. -}+-- | Only ensures that the user has some password set. It may or may+-- not be the password from the PrivData. hasSomePassword :: UserName -> Property hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $ hasPassword user
+ Propellor/SimpleSh.hs view
@@ -0,0 +1,96 @@+-- | Simple server, using a named pipe. Client connects, sends a command,+-- and gets back all the output from the command, in a stream.+--+-- This is useful for eg, docker.++module Propellor.SimpleSh where++import Network.Socket+import Control.Concurrent.Chan+import Control.Concurrent.Async+import System.Process (std_in, std_out, std_err)+import System.Exit++import Propellor+import Utility.FileMode+import Utility.ThreadScheduler++data Cmd = Cmd String [String]+ deriving (Read, Show)++data Resp = StdoutLine String | StderrLine String | Done ExitCode+ deriving (Read, Show)++simpleSh :: FilePath -> IO ()+simpleSh namedpipe = do+ nukeFile namedpipe+ let dir = takeDirectory namedpipe+ createDirectoryIfMissing True dir+ modifyFileMode dir (removeModes otherGroupModes)+ s <- socket AF_UNIX Stream defaultProtocol+ bind s (SockAddrUnix namedpipe)+ listen s 2+ forever $ do+ (client, _addr) <- accept s+ h <- socketToHandle client ReadWriteMode+ hSetBuffering h LineBuffering+ maybe noop (run h) . readish =<< hGetLine h+ where+ run h (Cmd cmd params) = do+ let p = (proc cmd params)+ { std_in = Inherit+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ (Nothing, Just outh, Just errh, pid) <- createProcess p+ chan <- newChan++ let runwriter = do+ v <- readChan chan+ hPutStrLn h (show v)+ case v of+ Done _ -> noop+ _ -> runwriter+ writer <- async runwriter++ let mkreader t from = maybe noop (const $ mkreader t from) + =<< catchMaybeIO (writeChan chan . t =<< hGetLine from)+ void $ concurrently+ (mkreader StdoutLine outh)+ (mkreader StderrLine errh)++ writeChan chan . Done =<< waitForProcess pid++ wait writer++ hClose outh+ hClose errh+ hClose h++simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a+simpleShClient namedpipe cmd params handler = do+ s <- socket AF_UNIX Stream defaultProtocol+ connect s (SockAddrUnix namedpipe)+ h <- socketToHandle s ReadWriteMode+ hSetBuffering h LineBuffering+ hPutStrLn h $ show $ Cmd cmd params+ resps <- catMaybes . map readish . lines <$> hGetContents h+ hClose h `after` handler resps++simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a+simpleShClientRetry retries namedpipe cmd params handler = go retries+ where+ run = simpleShClient namedpipe cmd params handler+ go n+ | n < 1 = run+ | otherwise = do+ v <- tryIO run+ case v of+ Right r -> return r+ Left _ -> do+ threadDelaySeconds (Seconds 1)+ go (n - 1)++getStdout :: Resp -> Maybe String+getStdout (StdoutLine s) = Just s+getStdout _ = Nothing
Propellor/Types.hs view
@@ -1,5 +1,8 @@ module Propellor.Types where +import Data.Monoid+import System.Console.ANSI+ type HostName = String type UserName = String @@ -9,14 +12,94 @@ , propertySatisfy :: IO Result } +data RevertableProperty = RevertableProperty Property Property++class IsProp p where+ -- | Sets description.+ describe :: p -> Desc -> p+ toProp :: p -> Property+ -- | Indicates that the first property can only be satisfied+ -- once the second one is.+ requires :: p -> Property -> p++instance IsProp Property where+ describe p d = p { propertyDesc = d }+ toProp p = p+ x `requires` y = Property (propertyDesc x) $ do+ r <- propertySatisfy y+ case r of+ FailedChange -> return FailedChange+ _ -> propertySatisfy x++instance IsProp RevertableProperty where+ -- | Sets the description of both sides.+ describe (RevertableProperty p1 p2) d = + RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))+ toProp (RevertableProperty p1 _) = p1+ (RevertableProperty p1 p2) `requires` y =+ RevertableProperty (p1 `requires` y) p2+ type Desc = String data Result = NoChange | MadeChange | FailedChange- deriving (Show, Eq)+ deriving (Read, Show, Eq) -combineResult :: Result -> Result -> Result-combineResult FailedChange _ = FailedChange-combineResult _ FailedChange = FailedChange-combineResult MadeChange _ = MadeChange-combineResult _ MadeChange = MadeChange-combineResult NoChange NoChange = NoChange+instance Monoid Result where+ mempty = NoChange++ mappend FailedChange _ = FailedChange+ mappend _ FailedChange = FailedChange+ mappend MadeChange _ = MadeChange+ mappend _ MadeChange = MadeChange+ mappend NoChange NoChange = NoChange++-- | High level descritption of a operating system.+data System = System Distribution Architecture+ deriving (Show)++data Distribution+ = Debian DebianSuite+ | Ubuntu Release+ deriving (Show)++data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release+ deriving (Show)++type Release = String++type Architecture = String++-- | Results of actions, with color.+class ActionResult a where+ getActionResult :: a -> (String, ColorIntensity, Color)++instance ActionResult Bool where+ getActionResult False = ("failed", Vivid, Red)+ getActionResult True = ("done", Dull, Green)++instance ActionResult Result where+ getActionResult NoChange = ("ok", Dull, Green)+ getActionResult MadeChange = ("done", Vivid, Green)+ getActionResult FailedChange = ("failed", Vivid, Red)++data CmdLine+ = Run HostName+ | Spin HostName+ | Boot HostName+ | Set HostName PrivDataField+ | AddKey String+ | Continue CmdLine+ | Chain HostName+ | Docker HostName+ deriving (Read, Show, Eq)++-- | Note that removing or changing field names will break the+-- serialized privdata files, so don't do that!+-- It's fine to add new fields.+data PrivDataField+ = DockerAuthentication+ | SshPrivKey UserName+ | Password UserName+ deriving (Read, Show, Ord, Eq)++
− README
@@ -1,42 +0,0 @@-This is a work in progress configuration management system using Haskell-and Git.--Propellor enures that the system it's run in satisfies a list of-properties, taking action as necessary when a property is not yet met.--The design is intentionally very minimal.--Propellor lives in a git repository, and so to set it up it's cloned-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.--Properties are defined using Haskell. Edit config.hs to get started.--There is no special language as used in puppet, chef, ansible, etc.. just-the full power of Haskell. Hopefully that power can be put to good use in-making declarative properties that are powerful, nicely idempotent, and-easy to adapt to a system's special needs.--Also avoided is any form of node classification. Ie, which hosts are part-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-The field name will be something like 'Password "root"'; see PrivData.hs-for available fields.--[1] http://reclass.pantsfullofunix.net/
+ README.md view
@@ -0,0 +1,97 @@+This is a work in progress configuration management system using Haskell+and Git.++Propellor enures that the system it's run in satisfies a list of+properties, taking action as necessary when a property is not yet met.++The design is intentionally very minimal.++Propellor lives in a git repository. You'll typically want to have+the repository checked out on a laptop, in order to make changes and push+them out to hosts. Each host will also have a clone of the repository,+and in that clone "make" can be used to build and run propellor.+This can be done by a cron job (which propellor can set up),+or a remote host can be triggered to update by running propellor+on your laptop: propellor --spin $host++Properties are defined using Haskell. Edit config.hs to get started.++There is no special language as used in puppet, chef, ansible, etc.. just+the full power of Haskell. Hopefully that power can be put to good use in+making declarative properties that are powerful, nicely idempotent, and+easy to adapt to a system's special needs.++Also avoided is any form of node classification. Ie, which hosts are part+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.++## quick start++1. Clone propellor's git repository to your laptop (or whatever).+ git clone git://git.kitenet.net/propellor+ or joeyh/propellor on github+2. Run: sudo make deps # installs build dependencies+3. Run: make build+4. If you don't have a gpg private key, generate one: gpg --gen-key+5. Run: ./propellor --add-key $KEYID+7. Pick a host and run: ./propellor --spin $HOST+8. Now you have a simple propellor deployment, but it doesn't do anything+ to the host yet, besides installing propellor.++ So, edit config.hs to configure the host (maybe start with a few simple+ properties), and re-run step 7. Repeat until happy and move on to the+ next host. :)+9. To move beyond manually running propellor --spin against hosts+ when you change configuration, add a property to your hosts+ like: Cron.runPropellor "30 * * * *"+ + Now they'll automatically update every 30 minutes, and you can+ `git commit -S` and `git push` changes that affect any number of+ hosts.+10. Write some neat new properties and send patches to propellor@joeyh.name!++## security++Propellor's security model is that the hosts it's used to deploy are+untrusted, and that the central git repository server is untrusted.++The only trusted machine is the laptop where you run propellor --spin+to connect to a remote host. And that one only because you have a ssh key+or login password to the host.++Since the hosts propellor deploys are not trusted by the central git+repository, they have to use git:// or http:// to pull from the central+git repository, rather than ssh://. ++So, to avoid a MITM attack, propellor checks that any commit it fetched+from origin is gpg signed by a trusted gpg key, and refuses to deploy it+otherwise.++That is only done when privdata/keyring.gpg exists. To set it up:++gpg --gen-key # only if you don't already have a gpg key+propellor --add-key $MYKEYID++In order to be secure from the beginning, when propellor --spin is used+to bootstrap propellor on a new host, it transfers the local git repositry+to the remote host over ssh. After that, the remote host knows the+gpg key, and will use it to verify git fetches.++Since the propoellor git repository is public, you can't store+in cleartext private data such as passwords, ssh private keys, etc.++Instead, propellor --spin $host looks for a privdata/$host.gpg file and+if found decrypts it and sends it to the remote host using ssh. This lets+a remote host know its own private data, without seeing all the rest.++To securely store private data, use: propellor --set $host $field+The field name will be something like 'Password "root"'; see PrivData.hs+for available fields.++## debugging++Set PROPELLOR_DEBUG=1 to make propellor print out all the commands it runs+and any other debug messages Properties choose to emit.++[1] http://reclass.pantsfullofunix.net/
TODO view
@@ -3,3 +3,16 @@ but only once despite many config changes being made to satisfy properties. onChange is a poor substitute. * I often seem to want to be able to combine Properties monadically.+* --spin needs 4 ssh connections when bootstrapping a new host+ that does not have the git repo yet. Should be possible to get that+ down to 1.+* Currently only Debian and derivatives are supported by most Properties.+ One way to improve that would be to parameterize Properties with a+ Distribution witness.+* Display of docker container properties is a bit wonky. It always+ says they are unchanged even when they changed and triggered a+ reprovision.+* Nothing brings up docker containers on boot. Although the next time+ propellor runs it will notice if a container is done, and fix it.+ Should propellor be run on boot? Or should provisioning a container+ install a systemd service file to start it?
Utility/FileMode.hs view
@@ -58,6 +58,12 @@ executeModes :: [FileMode] executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode] +otherGroupModes :: [FileMode]+otherGroupModes = + [ groupReadMode, otherReadMode+ , groupWriteMode, otherWriteMode+ ]+ {- Removes the write bits from a file. -} preventWrite :: FilePath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes@@ -147,9 +153,5 @@ writeFileProtected :: FilePath -> String -> IO () writeFileProtected file content = withUmask 0o0077 $ withFile file WriteMode $ \h -> do- void $ tryIO $ modifyFileMode file $- removeModes- [ groupReadMode, otherReadMode- , groupWriteMode, otherWriteMode- ]+ void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes hPutStr h content
+ Utility/Path.hs view
@@ -0,0 +1,293 @@+{- path manipulation+ -+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE PackageImports, CPP #-}++module Utility.Path where++import Data.String.Utils+import System.FilePath+import System.Directory+import Data.List+import Data.Maybe+import Data.Char+import Control.Applicative++#ifdef mingw32_HOST_OS+import qualified System.FilePath.Posix as Posix+#else+import System.Posix.Files+#endif++import qualified "MissingH" System.Path as MissingH+import Utility.Monad+import Utility.UserInfo++{- Simplifies a path, removing any ".." or ".", and removing the trailing+ - path separator.+ -+ - On Windows, preserves whichever style of path separator might be used in+ - the input FilePaths. This is done because some programs in Windows+ - demand a particular path separator -- and which one actually varies!+ -+ - This does not guarantee that two paths that refer to the same location,+ - and are both relative to the same location (or both absolute) will+ - yeild the same result. Run both through normalise from System.FilePath+ - to ensure that.+ -}+simplifyPath :: FilePath -> FilePath+simplifyPath path = dropTrailingPathSeparator $ + joinDrive drive $ joinPath $ norm [] $ splitPath path'+ where+ (drive, path') = splitDrive path++ norm c [] = reverse c+ norm c (p:ps)+ | p' == ".." = norm (drop 1 c) ps+ | p' == "." = norm c ps+ | otherwise = norm (p:c) ps+ where+ p' = dropTrailingPathSeparator p++{- Makes a path absolute.+ -+ - The first parameter is a base directory (ie, the cwd) to use if the path+ - is not already absolute.+ -+ - Does not attempt to deal with edge cases or ensure security with+ - untrusted inputs.+ -}+absPathFrom :: FilePath -> FilePath -> FilePath+absPathFrom dir path = simplifyPath (combine dir path)++{- On Windows, this converts the paths to unix-style, in order to run+ - MissingH's absNormPath on them. Resulting path will use / separators. -}+absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath+#ifndef mingw32_HOST_OS+absNormPathUnix dir path = MissingH.absNormPath dir path+#else+absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)+ where+ fromdos = replace "\\" "/"+ todos = replace "/" "\\"+#endif++{- Returns the parent directory of a path.+ -+ - To allow this to be easily used in loops, which terminate upon reaching the+ - top, the parent of / is "" -}+parentDir :: FilePath -> FilePath+parentDir dir+ | null dirs = ""+ | otherwise = joinDrive drive (join s $ init dirs)+ where+ -- on Unix, the drive will be "/" when the dir is absolute, otherwise ""+ (drive, path) = splitDrive dir+ dirs = filter (not . null) $ split s path+ s = [pathSeparator]++prop_parentDir_basics :: FilePath -> Bool+prop_parentDir_basics dir+ | null dir = True+ | dir == "/" = parentDir dir == ""+ | otherwise = p /= dir+ where+ p = parentDir dir++{- Checks if the first FilePath is, or could be said to contain the second.+ - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc+ - are all equivilant.+ -}+dirContains :: FilePath -> FilePath -> Bool+dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'+ where+ a' = norm a+ b' = norm b+ norm = normalise . simplifyPath++{- Converts a filename into an absolute path.+ -+ - Unlike Directory.canonicalizePath, this does not require the path+ - already exists. -}+absPath :: FilePath -> IO FilePath+absPath file = do+ cwd <- getCurrentDirectory+ return $ absPathFrom cwd file++{- Constructs a relative path from the CWD to a file.+ -+ - For example, assuming CWD is /tmp/foo/bar:+ - relPathCwdToFile "/tmp/foo" == ".."+ - relPathCwdToFile "/tmp/foo/bar" == "" + -}+relPathCwdToFile :: FilePath -> IO FilePath+relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f++{- Constructs a relative path from a directory to a file.+ -+ - Both must be absolute, and cannot contain .. etc. (eg use absPath first).+ -}+relPathDirToFile :: FilePath -> FilePath -> FilePath+relPathDirToFile from to = join s $ dotdots ++ uncommon+ where+ s = [pathSeparator]+ pfrom = split s from+ pto = split s to+ common = map fst $ takeWhile same $ zip pfrom pto+ same (c,d) = c == d+ uncommon = drop numcommon pto+ dotdots = replicate (length pfrom - numcommon) ".."+ numcommon = length common++prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool+prop_relPathDirToFile_basics from to+ | from == to = null r+ | otherwise = not (null r)+ where+ r = relPathDirToFile from to ++prop_relPathDirToFile_regressionTest :: Bool+prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference+ where+ {- Two paths have the same directory component at the same+ - location, but it's not really the same directory.+ - Code used to get this wrong. -}+ same_dir_shortcurcuits_at_difference =+ relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])+ (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])+ == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]++{- Given an original list of paths, and an expanded list derived from it,+ - generates a list of lists, where each sublist corresponds to one of the+ - original paths. When the original path is a directory, any items+ - in the expanded list that are contained in that directory will appear in+ - its segment.+ -}+segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]+segmentPaths [] new = [new]+segmentPaths [_] new = [new] -- optimisation+segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest+ where+ (found, rest)=partition (l `dirContains`) new++{- This assumes that it's cheaper to call segmentPaths on the result,+ - than it would be to run the action separately with each path. In+ - the case of git file list commands, that assumption tends to hold.+ -}+runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]+runSegmentPaths a paths = segmentPaths paths <$> a paths++{- Converts paths in the home directory to use ~/ -}+relHome :: FilePath -> IO String+relHome path = do+ home <- myHomeDir+ return $ if dirContains home path+ then "~/" ++ relPathDirToFile home path+ else path++{- Checks if a command is available in PATH.+ -+ - The command may be fully-qualified, in which case, this succeeds as+ - long as it exists. -}+inPath :: String -> IO Bool+inPath command = isJust <$> searchPath command++{- Finds a command in PATH and returns the full path to it.+ -+ - The command may be fully qualified already, in which case it will+ - be returned if it exists.+ -}+searchPath :: String -> IO (Maybe FilePath)+searchPath command+ | isAbsolute command = check command+ | otherwise = getSearchPath >>= getM indir+ where+ indir d = check $ d </> command+ check f = firstM doesFileExist+#ifdef mingw32_HOST_OS+ [f, f ++ ".exe"]+#else+ [f]+#endif++{- Checks if a filename is a unix dotfile. All files inside dotdirs+ - count as dotfiles. -}+dotfile :: FilePath -> Bool+dotfile file+ | f == "." = False+ | f == ".." = False+ | f == "" = False+ | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)+ where+ f = takeFileName file++{- Converts a DOS style path to a Cygwin style path. Only on Windows.+ - Any trailing '\' is preserved as a trailing '/' -}+toCygPath :: FilePath -> FilePath+#ifndef mingw32_HOST_OS+toCygPath = id+#else+toCygPath p+ | null drive = recombine parts+ | otherwise = recombine $ "/cygdrive" : driveletter drive : parts+ where+ (drive, p') = splitDrive p+ parts = splitDirectories p'+ driveletter = map toLower . takeWhile (/= ':')+ recombine = fixtrailing . Posix.joinPath+ fixtrailing s+ | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s+ | otherwise = s+#endif++{- Maximum size to use for a file in a specified directory.+ -+ - Many systems have a 255 byte limit to the name of a file, + - so that's taken as the max if the system has a larger limit, or has no+ - limit.+ -}+fileNameLengthLimit :: FilePath -> IO Int+#ifdef mingw32_HOST_OS+fileNameLengthLimit _ = return 255+#else+fileNameLengthLimit dir = do+ l <- fromIntegral <$> getPathVar dir FileNameLimit+ if l <= 0+ then return 255+ else return $ minimum [l, 255]+ where+#endif++{- Given a string that we'd like to use as the basis for FilePath, but that+ - was provided by a third party and is not to be trusted, returns the closest+ - sane FilePath.+ -+ - All spaces and punctuation and other wacky stuff are replaced+ - with '_', except for '.' "../" will thus turn into ".._", which is safe.+ -}+sanitizeFilePath :: String -> FilePath+sanitizeFilePath = map sanitize+ where+ sanitize c+ | c == '.' = c+ | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'+ | otherwise = c++{- Similar to splitExtensions, but knows that some things in FilePaths+ - after a dot are too long to be extensions. -}+splitShortExtensions :: FilePath -> (FilePath, [String])+splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"+splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])+splitShortExtensions' maxextension = go []+ where+ go c f+ | len > 0 && len <= maxextension && not (null base) = + go (ext:c) base+ | otherwise = (f, c)+ where+ (base, ext) = splitExtension f+ len = length ext
+ Utility/ThreadScheduler.hs view
@@ -0,0 +1,73 @@+{- thread scheduling+ -+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Bas van Dijk & Roel van Dijk+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.ThreadScheduler where++import Control.Monad+import Control.Monad.IfElse+import System.Posix.IO+import Control.Concurrent+#ifndef mingw32_HOST_OS+import System.Posix.Signals+#ifndef __ANDROID__+import System.Posix.Terminal+#endif+#endif++newtype Seconds = Seconds { fromSeconds :: Int }+ deriving (Eq, Ord, Show)++type Microseconds = Integer++{- Runs an action repeatedly forever, sleeping at least the specified number+ - of seconds in between. -}+runEvery :: Seconds -> IO a -> IO a+runEvery n a = forever $ do+ threadDelaySeconds n+ a++threadDelaySeconds :: Seconds -> IO ()+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)++{- Like threadDelay, but not bounded by an Int.+ -+ - There is no guarantee that the thread will be rescheduled promptly when the+ - delay has expired, but the thread will never continue to run earlier than+ - specified.+ - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines+ - of code.+ -}+unboundDelay :: Microseconds -> IO ()+unboundDelay time = do+ let maxWait = min time $ toInteger (maxBound :: Int)+ threadDelay $ fromInteger maxWait+ when (maxWait /= time) $ unboundDelay (time - maxWait)++{- Pauses the main thread, letting children run until program termination. -}+waitForTermination :: IO ()+waitForTermination = do+#ifdef mingw32_HOST_OS+ runEvery (Seconds 600) $+ void getLine+#else+ lock <- newEmptyMVar+ let check sig = void $+ installHandler sig (CatchOnce $ putMVar lock ()) Nothing+ check softwareTermination+#ifndef __ANDROID__+ whenM (queryTerminal stdInput) $+ check keyboardSignal+#endif+ takeMVar lock+#endif++oneSecond :: Microseconds+oneSecond = 1000000
+ Utility/UserInfo.hs view
@@ -0,0 +1,55 @@+{- user info+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.UserInfo (+ myHomeDir,+ myUserName,+ myUserGecos,+) where++import Control.Applicative+import System.PosixCompat++import Utility.Env++{- Current user's home directory.+ -+ - getpwent will fail on LDAP or NIS, so use HOME if set. -}+myHomeDir :: IO FilePath+myHomeDir = myVal env homeDirectory+ where+#ifndef mingw32_HOST_OS+ env = ["HOME"]+#else+ env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin+#endif++{- Current user's user name. -}+myUserName :: IO String+myUserName = myVal env userName+ where+#ifndef mingw32_HOST_OS+ env = ["USER", "LOGNAME"]+#else+ env = ["USERNAME", "USER", "LOGNAME"]+#endif++myUserGecos :: IO String+#ifdef __ANDROID__+myUserGecos = return "" -- userGecos crashes on Android+#else+myUserGecos = myVal [] userGecos+#endif++myVal :: [String] -> (UserEntry -> String) -> IO String+myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars+ where+ check [] = return Nothing+ check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v+ getpwent = getUserEntryForID =<< getEffectiveUserID
config.hs view
@@ -1,5 +1,8 @@-{- This is the main configuration file for Propellor, and is used to build- - the propellor program. -}+-- | This is the main configuration file for Propellor, and is used to build+-- the propellor program.+--+-- This is the live config file used by propellor's author.+-- For a simpler starting point, see simple-config.hs import Propellor import Propellor.CmdLine@@ -7,46 +10,85 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network import qualified Propellor.Property.Ssh as Ssh+import qualified Propellor.Property.Cron as Cron import qualified Propellor.Property.Sudo as Sudo import qualified Propellor.Property.User as User import qualified Propellor.Property.Hostname as Hostname import qualified Propellor.Property.Reboot as Reboot import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Docker as Docker-import qualified Propellor.Property.GitHome as GitHome-import qualified Propellor.Property.JoeySites as JoeySites+import qualified Propellor.Property.SiteSpecific.GitHome as GitHome+import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder+import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites+import Data.List main :: IO ()-main = defaultMain getProperties+main = defaultMain [host, Docker.containerProperties container] -{- | 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- - Properties for that system.- -- - Edit this to configure propellor!- -}-getProperties :: HostName -> Maybe [Property]-getProperties hostname@"clam.kitenet.net" = Just- [ cleanCloudAtCost hostname- , standardSystem Apt.Unstable- , Network.ipv6to4- -- Clam is a tor bridge, and an olduse.net shellbox.- , Tor.isBridge- , JoeySites.oldUseNetshellBox- -- I play with docker on clam.- , Docker.configured- -- This is not an important system so I don't want to need to - -- manually upgrade it.- , Apt.unattendedUpgrades True+-- | 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+-- Properties for that system.+--+-- Edit this to configure propellor!+host :: HostName -> Maybe [Property]+host hostname@"clam.kitenet.net" = Just $ props+ & cleanCloudAtCost hostname+ & standardSystem Unstable+ & Apt.unattendedUpgrades+ & Network.ipv6to4+ & Apt.installed ["git-annex", "mtr"]+ -- Clam is a tor bridge, and an olduse.net shellbox and other+ -- fun stuff.+ & Tor.isBridge+ & JoeySites.oldUseNetshellBox+ & Docker.configured+ & File.dirExists "/var/www"+ & revert (Docker.docked container hostname "webserver")+ & revert (Docker.docked container hostname "amd64-git-annex-builder")+ & Docker.garbageCollected -- Should come last as it reboots.- , Apt.installed ["systemd-sysv"] `onChange` Reboot.now- ]+ & Apt.installed ["systemd-sysv"] `onChange` Reboot.now+host hostname@"orca.kitenet.net" = Just $ props+ & Hostname.set hostname+ & standardSystem Unstable+ & Apt.unattendedUpgrades+ & Docker.configured+ & Docker.docked container hostname "amd64-git-annex-builder"+ & revert (Docker.docked container hostname "i386-git-annex-builder")+ & Docker.garbageCollected -- add more hosts here...---getProperties "foo" =-getProperties _ = Nothing+--host "foo.example.com" =+host _ = Nothing +-- | This is where Docker containers are set up. A container+-- can vary by hostname where it's used, or be the same everywhere.+container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)+container _host name+ | name == "webserver" = Just $ Docker.containerFrom+ (image $ System (Debian Unstable) "amd64")+ [ Docker.publish "8080:80"+ , Docker.volume "/var/www:/var/www"+ , Docker.inside $ props+ & serviceRunning "apache2"+ `requires` Apt.installed ["apache2"]+ ]+ | "-git-annex-builder" `isSuffixOf` name =+ let arch = takeWhile (/= '-') name+ in Just $ Docker.containerFrom+ (image $ System (Debian Unstable) arch)+ [ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" ]+ | otherwise = Nothing++-- | Docker images I prefer to use.+-- Edit as suites you, or delete this function and just put the image names+-- above.+image :: System -> Docker.Image+image (System (Debian Unstable) "amd64") = "joeyh/debian-unstable"+image (System (Debian Unstable) "i386") = "joeyh/debian-unstable-i386"+image _ = "debian"+ -- This is my standard system setup-standardSystem :: Apt.Suite -> Property+standardSystem :: DebianSuite -> Property standardSystem suite = propertyList "standard system" [ Apt.stdSourcesList suite `onChange` Apt.upgrade , Apt.installed ["etckeeper"]@@ -57,11 +99,12 @@ -- is safely in place. , check (Ssh.hasAuthorizedKeys "root") $ Ssh.passwordAuthentication False- , User.sshAccountFor "joey"+ , User.accountFor "joey" , User.hasSomePassword "joey" , Sudo.enabledFor "joey" , GitHome.installedFor "joey"- , Apt.installed ["vim", "screen"]+ , Apt.installed ["vim", "screen", "less"]+ , Cron.runPropellor "30 * * * *" -- I use postfix, or no MTA. , Apt.removed ["exim4"] `onChange` Apt.autoRemove ]@@ -75,7 +118,7 @@ "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" `onChange` cmdProperty "update-grub" [] `onChange` cmdProperty "update-initramfs" ["-u"]- , "nuked cloudatcost cruft" ==> combineProperties+ , combineProperties "nuked cloudatcost cruft" [ File.notPresent "/etc/rc.local" , File.notPresent "/etc/init.d/S97-setup.sh" , User.nuked "user" User.YesReallyDeleteHome
+ debian/README view
@@ -0,0 +1,1 @@+I don't know a good way to Debianize propellor! Help appreciated. -- Joey
+ debian/changelog view
@@ -0,0 +1,16 @@+propellor (0.2) unstable; urgency=low++ * Added support for provisioning Docker containers.+ * Bootstrap deployment now pushes the git repo to the remote host+ over ssh, securely.+ * propellor --add-key configures a gpg key, and makes propellor refuse+ to pull commits from git repositories not signed with that key.+ This allows propellor to be securely used with public, non-encrypted+ git repositories without the possibility of MITM.+ * Added support for type-safe reversions. Only some properties can be+ reverted; the type checker will tell you if you try something that won't+ work.+ * New syntactic sugar for building a list of properties, including+ revertable properties.++ -- Joey Hess <joeyh@debian.org> Wed, 02 Apr 2014 13:57:42 -0400
propellor.cabal view
@@ -1,5 +1,5 @@ Name: propellor-Version: 0.1.2+Version: 0.2.0 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -11,9 +11,13 @@ Homepage: http://joeyh.name/code/propellor/ Category: Utility Extra-Source-Files:- README+ README.md TODO+ CHANGELOG Makefile+ debian/changelog+ debian/README+ simple-config.hs Synopsis: property-based host configuration management in haskell Description: Propellor enures that the system it's run in satisfies a list of@@ -25,19 +29,19 @@ Executable propellor Main-Is: config.hs- GHC-Options: -Wall+ GHC-Options: -Wall -threaded Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,- containers+ containers, network, async if (! os(windows)) Build-Depends: unix Library- GHC-Options: -Wall+ GHC-Options: -Wall -threaded Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,- containers+ containers, network, async if (! os(windows)) Build-Depends: unix@@ -47,20 +51,24 @@ Propellor.Property Propellor.Property.Apt Propellor.Property.Cmd+ Propellor.Property.Hostname+ Propellor.Property.Cron Propellor.Property.Docker Propellor.Property.File- Propellor.Property.GitHome- Propellor.Property.Hostname- Propellor.Property.JoeySites Propellor.Property.Network Propellor.Property.Reboot Propellor.Property.Ssh Propellor.Property.Sudo Propellor.Property.Tor Propellor.Property.User+ Propellor.Property.SiteSpecific.GitHome+ Propellor.Property.SiteSpecific.JoeySites+ Propellor.Property.SiteSpecific.GitAnnexBuilder Propellor.CmdLine+ Propellor.Message Propellor.PrivData Propellor.Engine+ Propellor.SimpleSh Propellor.Types Other-Modules: Utility.Applicative@@ -72,11 +80,14 @@ Utility.FileSystemEncoding Utility.Misc Utility.Monad+ Utility.Path Utility.PartialPrelude Utility.PosixFiles Utility.Process Utility.SafeCommand+ Utility.ThreadScheduler Utility.Tmp+ Utility.UserInfo source-repository head type: git
+ simple-config.hs view
@@ -0,0 +1,52 @@+-- | This is the main configuration file for Propellor, and is used to build+-- the propellor program.++import Propellor+import Propellor.CmdLine+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Network as Network+import qualified Propellor.Property.Ssh as Ssh+import qualified Propellor.Property.Cron as Cron+import qualified Propellor.Property.Sudo as Sudo+import qualified Propellor.Property.User as User+import qualified Propellor.Property.Hostname as Hostname+import qualified Propellor.Property.Reboot as Reboot+import qualified Propellor.Property.Docker as Docker++main :: IO ()+main = defaultMain [host, Docker.containerProperties container]++-- | 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+-- Properties for that system.+--+-- Edit this to configure propellor!+host :: HostName -> Maybe [Property]+host hostname@"mybox.example.com" = Just $ props+ & Apt.stdSourcesList Unstable+ `onChange` Apt.upgrade+ & Apt.unattendedUpgrades+ & Apt.installed ["etckeeper"]+ & Apt.installed ["ssh"]+ & User.hasSomePassword "root"+ & Network.ipv6to4+ & Docker.docked container hostname "webserver"+ `requires` File.dirExists "/var/www"+ & Docker.garbageCollected+ & Cron.runPropellor "30 * * * *"+-- add more hosts here...+--host "foo.example.com" =+host _ = Nothing++-- | This is where Docker containers are set up. A container+-- can vary by hostname where it's used, or be the same everywhere.+container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)+container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"+ [ Docker.publish "80:80"+ , Docker.volume "/var/www:/var/www"+ , Docker.inside $ props+ & serviceRunning "apache2"+ `requires` Apt.installed ["apache2"]+ ]+container _ _ = Nothing