From 380c1b0fd6c25dec3c924b82f1d721aa91a001da Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 30 Mar 2014 23:37:54 -0400 Subject: prepare for hackage --- CmdLine.hs | 107 -------------------------------- Common.hs | 22 ------- PrivData.hs | 85 -------------------------- Propellor.hs | 77 ----------------------- Propellor/CmdLine.hs | 107 ++++++++++++++++++++++++++++++++ Propellor/Common.hs | 22 +++++++ Propellor/PrivData.hs | 85 ++++++++++++++++++++++++++ Propellor/Property.hs | 123 +++++++++++++++++++++++++++++++++++++ Propellor/Property/Apt.hs | 132 ++++++++++++++++++++++++++++++++++++++++ Propellor/Property/Cmd.hs | 35 +++++++++++ Propellor/Property/Docker.hs | 16 +++++ Propellor/Property/File.hs | 40 ++++++++++++ Propellor/Property/GitHome.hs | 30 +++++++++ Propellor/Property/Hostname.hs | 9 +++ Propellor/Property/JoeySites.hs | 23 +++++++ Propellor/Property/Network.hs | 27 ++++++++ Propellor/Property/Reboot.hs | 7 +++ Propellor/Property/Ssh.hs | 53 ++++++++++++++++ Propellor/Property/Sudo.hs | 34 +++++++++++ Propellor/Property/Tor.hs | 19 ++++++ Propellor/Property/User.hs | 61 +++++++++++++++++++ Propellor/Types.hs | 22 +++++++ Property.hs | 123 ------------------------------------- Property/Apt.hs | 132 ---------------------------------------- Property/Cmd.hs | 35 ----------- Property/Docker.hs | 16 ----- Property/File.hs | 40 ------------ Property/GitHome.hs | 30 --------- Property/Hostname.hs | 9 --- Property/JoeySites.hs | 23 ------- Property/Network.hs | 27 -------- Property/Reboot.hs | 7 --- Property/Ssh.hs | 53 ---------------- Property/Sudo.hs | 34 ----------- Property/Tor.hs | 19 ------ Property/User.hs | 61 ------------------- README | 4 +- Types.hs | 22 ------- propellor.cabal | 56 ++++++++++++++++- propellor.hs | 80 ++++++++++++++++++++++++ 40 files changed, 981 insertions(+), 926 deletions(-) delete mode 100644 CmdLine.hs delete mode 100644 Common.hs delete mode 100644 PrivData.hs delete mode 100644 Propellor.hs create mode 100644 Propellor/CmdLine.hs create mode 100644 Propellor/Common.hs create mode 100644 Propellor/PrivData.hs create mode 100644 Propellor/Property.hs create mode 100644 Propellor/Property/Apt.hs create mode 100644 Propellor/Property/Cmd.hs create mode 100644 Propellor/Property/Docker.hs create mode 100644 Propellor/Property/File.hs create mode 100644 Propellor/Property/GitHome.hs create mode 100644 Propellor/Property/Hostname.hs create mode 100644 Propellor/Property/JoeySites.hs create mode 100644 Propellor/Property/Network.hs create mode 100644 Propellor/Property/Reboot.hs create mode 100644 Propellor/Property/Ssh.hs create mode 100644 Propellor/Property/Sudo.hs create mode 100644 Propellor/Property/Tor.hs create mode 100644 Propellor/Property/User.hs create mode 100644 Propellor/Types.hs delete mode 100644 Property.hs delete mode 100644 Property/Apt.hs delete mode 100644 Property/Cmd.hs delete mode 100644 Property/Docker.hs delete mode 100644 Property/File.hs delete mode 100644 Property/GitHome.hs delete mode 100644 Property/Hostname.hs delete mode 100644 Property/JoeySites.hs delete mode 100644 Property/Network.hs delete mode 100644 Property/Reboot.hs delete mode 100644 Property/Ssh.hs delete mode 100644 Property/Sudo.hs delete mode 100644 Property/Tor.hs delete mode 100644 Property/User.hs delete mode 100644 Types.hs create mode 100644 propellor.hs diff --git a/CmdLine.hs b/CmdLine.hs deleted file mode 100644 index c93d69ad..00000000 --- a/CmdLine.hs +++ /dev/null @@ -1,107 +0,0 @@ -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 - -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:[]) = case readish f of - Just pf -> return $ Set h pf - 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" - ] - exitFailure - -defaultMain :: (HostName -> Maybe [Property]) -> IO () -defaultMain getprops = go =<< processCmdLine - 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 - -unknownhost :: HostName -> IO a -unknownhost h = error $ unwords - [ "Unknown host:", h - , "(perhaps you should specify the real hostname on the command line?)" - ] - -spin :: HostName -> IO () -spin host = do - url <- getUrl - void $ boolSystem "git" [Param "commit", 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 - 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 - makePrivDataDir - 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 diff --git a/Common.hs b/Common.hs deleted file mode 100644 index 93704ce6..00000000 --- a/Common.hs +++ /dev/null @@ -1,22 +0,0 @@ -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 -import System.Directory as X -import System.IO as X -import Utility.Exception as X -import Utility.Env as X -import Utility.Directory as X -import Utility.Tmp as X -import System.FilePath as X -import Data.Maybe as X -import Data.Either as X -import Utility.Monad as X -import Utility.Misc as X diff --git a/PrivData.hs b/PrivData.hs deleted file mode 100644 index d1e75c88..00000000 --- a/PrivData.hs +++ /dev/null @@ -1,85 +0,0 @@ -module PrivData where - -import qualified Data.Map as M -import Control.Applicative -import System.FilePath -import System.IO -import System.Directory -import Data.Maybe -import Control.Monad - -import Types -import Property -import Utility.Monad -import Utility.PartialPrelude -import Utility.Exception -import Utility.Process -import Utility.Tmp -import Utility.SafeCommand -import Utility.Misc - -{- Note that removing or changing field names will break the - - serialized privdata files, so don't do that! - - It's fine to add new fields. -} -data PrivDataField - = DockerAuthentication - | SshPrivKey UserName - | Password UserName - deriving (Read, Show, Ord, Eq) - -withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result -withPrivData field a = maybe missing a =<< getPrivData field - where - missing = do - warningMessage $ "Missing privdata " ++ show field - return FailedChange - -getPrivData :: PrivDataField -> IO (Maybe String) -getPrivData field = do - m <- catchDefaultIO Nothing $ readish <$> readFile privDataLocal - return $ maybe Nothing (M.lookup field) m - -setPrivData :: HostName -> PrivDataField -> IO () -setPrivData host field = do - putStrLn "Enter private data on stdin; ctrl-D when done:" - value <- hGetContentsStrict stdin - makePrivDataDir - let f = privDataFile host - m <- fromMaybe M.empty . readish <$> gpgDecrypt f - let m' = M.insert field value m - gpgEncrypt f (show m') - putStrLn "Private data set." - void $ boolSystem "git" [Param "add", File f] - -makePrivDataDir :: IO () -makePrivDataDir = createDirectoryIfMissing False privDataDir - -privDataDir :: FilePath -privDataDir = "privdata" - -privDataFile :: HostName -> FilePath -privDataFile host = privDataDir host ++ ".gpg" - -privDataLocal :: FilePath -privDataLocal = privDataDir "local" - -privDataMarker :: String -privDataMarker = "PRIVDATA " - -gpgDecrypt :: FilePath -> IO String -gpgDecrypt f = ifM (doesFileExist f) - ( readProcess "gpg" ["--decrypt", f] - , return "" - ) - -gpgEncrypt :: FilePath -> String -> IO () -gpgEncrypt f s = do - encrypted <- writeReadProcessEnv "gpg" - [ "--default-recipient-self" - , "--armor" - , "--encrypt" - ] - Nothing - (Just $ flip hPutStr s) - Nothing - viaTmp writeFile f encrypted diff --git a/Propellor.hs b/Propellor.hs deleted file mode 100644 index 58d8289d..00000000 --- a/Propellor.hs +++ /dev/null @@ -1,77 +0,0 @@ -import Common -import CmdLine -import qualified Property.File as File -import qualified Property.Apt as Apt -import qualified Property.Network as Network -import qualified Property.Ssh as Ssh -import qualified Property.Sudo as Sudo -import qualified Property.User as User -import qualified Property.Hostname as Hostname -import qualified Property.Reboot as Reboot -import qualified Property.Tor as Tor -import qualified Property.Docker as Docker -import qualified Property.GitHome as GitHome -import qualified Property.JoeySites as JoeySites - -main :: IO () -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 - - Properties for that system. -} -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 - -- Should come last as it reboots. - , Apt.installed ["systemd-sysv"] `onChange` Reboot.now - ] --- add more hosts here... ---getProperties "foo" = -getProperties _ = Nothing - --- This is my standard system setup -standardSystem :: Apt.Suite -> Property -standardSystem suite = propertyList "standard system" - [ Apt.stdSourcesList suite `onChange` Apt.upgrade - , Apt.installed ["etckeeper"] - , Apt.installed ["ssh"] - , GitHome.installedFor "root" - , User.hasSomePassword "root" - -- Harden the system, but only once root's authorized_keys - -- is safely in place. - , check (Ssh.hasAuthorizedKeys "root") $ - Ssh.passwordAuthentication False - , User.sshAccountFor "joey" - , User.hasSomePassword "joey" - , Sudo.enabledFor "joey" - , GitHome.installedFor "joey" - , Apt.installed ["vim", "screen"] - -- I use postfix, or no MTA. - , Apt.removed ["exim4"] `onChange` Apt.autoRemove - ] - --- Clean up a system as installed by cloudatcost.com -cleanCloudAtCost :: HostName -> Property -cleanCloudAtCost hostname = propertyList "cloudatcost cleanup" - [ Hostname.set hostname - , Ssh.uniqueHostKeys - , "worked around grub/lvm boot bug #743126" ==> - "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" - `onChange` cmdProperty "update-grub" [] - `onChange` cmdProperty "update-initramfs" [Param "-u"] - , "nuked cloudatcost cruft" ==> combineProperties - [ File.notPresent "/etc/rc.local" - , File.notPresent "/etc/init.d/S97-setup.sh" - , User.nuked "user" User.YesReallyDeleteHome - ] - ] diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs new file mode 100644 index 00000000..b60b916e --- /dev/null +++ b/Propellor/CmdLine.hs @@ -0,0 +1,107 @@ +module Propellor.CmdLine where + +import System.Environment +import Data.List +import System.Exit + +import Propellor.Common +import Utility.FileMode + +data CmdLine + = Run HostName + | Spin HostName + | Boot HostName + | Set HostName PrivDataField + +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:[]) = case readish f of + Just pf -> return $ Set h pf + 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" + ] + exitFailure + +defaultMain :: (HostName -> Maybe [Property]) -> IO () +defaultMain getprops = go =<< processCmdLine + 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 + +unknownhost :: HostName -> IO a +unknownhost h = error $ unwords + [ "Unknown host:", h + , "(perhaps you should specify the real hostname on the command line?)" + ] + +spin :: HostName -> IO () +spin host = do + url <- getUrl + void $ boolSystem "git" [Param "commit", 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 + 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 + makePrivDataDir + 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 diff --git a/Propellor/Common.hs b/Propellor/Common.hs new file mode 100644 index 00000000..3a085540 --- /dev/null +++ b/Propellor/Common.hs @@ -0,0 +1,22 @@ +module Propellor.Common (module X) where + +import Propellor.Types as X +import Propellor.Property as X +import Propellor.Property.Cmd as X +import Propellor.PrivData as X + +import Utility.PartialPrelude as X +import Control.Applicative as X +import Control.Monad as X +import Utility.Process as X +import System.Directory as X +import System.IO as X +import Utility.Exception as X +import Utility.Env as X +import Utility.Directory as X +import Utility.Tmp as X +import System.FilePath as X +import Data.Maybe as X +import Data.Either as X +import Utility.Monad as X +import Utility.Misc as X diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs new file mode 100644 index 00000000..cf4840b9 --- /dev/null +++ b/Propellor/PrivData.hs @@ -0,0 +1,85 @@ +module Propellor.PrivData where + +import qualified Data.Map as M +import Control.Applicative +import System.FilePath +import System.IO +import System.Directory +import Data.Maybe +import Control.Monad + +import Propellor.Types +import Propellor.Property +import Utility.Monad +import Utility.PartialPrelude +import Utility.Exception +import Utility.Process +import Utility.Tmp +import Utility.SafeCommand +import Utility.Misc + +{- | Note that removing or changing field names will break the + - serialized privdata files, so don't do that! + - It's fine to add new fields. -} +data PrivDataField + = DockerAuthentication + | SshPrivKey UserName + | Password UserName + deriving (Read, Show, Ord, Eq) + +withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result +withPrivData field a = maybe missing a =<< getPrivData field + where + missing = do + warningMessage $ "Missing privdata " ++ show field + return FailedChange + +getPrivData :: PrivDataField -> IO (Maybe String) +getPrivData field = do + m <- catchDefaultIO Nothing $ readish <$> readFile privDataLocal + return $ maybe Nothing (M.lookup field) m + +setPrivData :: HostName -> PrivDataField -> IO () +setPrivData host field = do + putStrLn "Enter private data on stdin; ctrl-D when done:" + value <- hGetContentsStrict stdin + makePrivDataDir + let f = privDataFile host + m <- fromMaybe M.empty . readish <$> gpgDecrypt f + let m' = M.insert field value m + gpgEncrypt f (show m') + putStrLn "Private data set." + void $ boolSystem "git" [Param "add", File f] + +makePrivDataDir :: IO () +makePrivDataDir = createDirectoryIfMissing False privDataDir + +privDataDir :: FilePath +privDataDir = "privdata" + +privDataFile :: HostName -> FilePath +privDataFile host = privDataDir host ++ ".gpg" + +privDataLocal :: FilePath +privDataLocal = privDataDir "local" + +privDataMarker :: String +privDataMarker = "PRIVDATA " + +gpgDecrypt :: FilePath -> IO String +gpgDecrypt f = ifM (doesFileExist f) + ( readProcess "gpg" ["--decrypt", f] + , return "" + ) + +gpgEncrypt :: FilePath -> String -> IO () +gpgEncrypt f s = do + encrypted <- writeReadProcessEnv "gpg" + [ "--default-recipient-self" + , "--armor" + , "--encrypt" + ] + Nothing + (Just $ flip hPutStr s) + Nothing + viaTmp writeFile f encrypted diff --git a/Propellor/Property.hs b/Propellor/Property.hs new file mode 100644 index 00000000..727fe25e --- /dev/null +++ b/Propellor/Property.hs @@ -0,0 +1,123 @@ +module Propellor.Property where + +import System.Directory +import Control.Monad +import System.Console.ANSI +import System.Exit +import System.IO + +import Propellor.Types +import Utility.Monad +import Utility.Exception + +makeChange :: IO () -> IO Result +makeChange a = a >> return MadeChange + +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. + -} +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 + 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)" + +{- | 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 + where + go True = return NoChange + go False = do + r <- ensureProperty property + when (r == MadeChange) $ + 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. -} +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 + +{- | 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. -} +check :: IO Bool -> Property -> Property +check c property = Property (propertyDesc property) $ ifM c + ( ensureProperty property + , return NoChange + ) + +ensureProperty :: Property -> IO Result +ensureProperty = catchDefaultIO FailedChange . propertySatisfy + +ensureProperties :: [Property] -> IO () +ensureProperties ps = do + r <- ensureProperties' [propertyList "overall" ps] + case r of + FailedChange -> exitWith (ExitFailure 1) + _ -> exitWith ExitSuccess + +ensureProperties' :: [Property] -> IO Result +ensureProperties' ps = ensure ps NoChange + 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 diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs new file mode 100644 index 00000000..a7d50408 --- /dev/null +++ b/Propellor/Property/Apt.hs @@ -0,0 +1,132 @@ +module Propellor.Property.Apt where + +import Data.Maybe +import Control.Applicative +import Data.List +import System.IO +import Control.Monad + +import Propellor.Common +import qualified Propellor.Property.File as File +import Propellor.Property.File (Line) + +sourcesList :: FilePath +sourcesList = "/etc/apt/sources.list" + +type Url = String +type Section = String + +data Suite = Stable | Testing | Unstable | Experimental + deriving Show + +showSuite :: Suite -> String +showSuite Stable = "stable" +showSuite Testing = "testing" +showSuite Unstable = "unstable" +showSuite Experimental = "experimental" + +debLine :: Suite -> Url -> [Section] -> Line +debLine suite mirror sections = unwords $ + ["deb", mirror, showSuite suite] ++ sections + +srcLine :: Line -> Line +srcLine l = case words l of + ("deb":rest) -> unwords $ "deb-src" : rest + _ -> "" + +stdSections :: [Section] +stdSections = ["main", "contrib", "non-free"] + +debCdn :: Suite -> [Line] +debCdn suite = [l, srcLine l] + where + l = debLine suite "http://cdn.debian.net/debian" stdSections + +{- | Makes sources.list have a standard content using the mirror CDN, + - with a particular Suite. -} +stdSourcesList :: Suite -> Property +stdSourcesList suite = setSourcesList (debCdn suite) + `describe` ("standard sources.list for " ++ show suite) + +setSourcesList :: [Line] -> Property +setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update + +runApt :: [CommandParam] -> Property +runApt ps = cmdProperty' "apt-get" ps env + where + env = + [ ("DEBIAN_FRONTEND", "noninteractive") + , ("APT_LISTCHANGES_FRONTEND", "none") + ] + +update :: Property +update = runApt [Param "update"] + `describe` "apt update" + +upgrade :: Property +upgrade = runApt [Params "-y dist-upgrade"] + `describe` "apt dist-upgrade" + +type Package = String + +installed :: [Package] -> Property +installed ps = check (isInstallable ps) go + `describe` (unwords $ "apt installed":ps) + where + go = runApt $ [Param "-y", Param "install"] ++ map Param ps + +removed :: [Package] -> Property +removed ps = check (or <$> isInstalled' ps) go + `describe` (unwords $ "apt removed":ps) + where + go = runApt $ [Param "-y", Param "remove"] ++ map Param ps + +isInstallable :: [Package] -> IO Bool +isInstallable ps = do + l <- isInstalled' ps + return $ any (== False) l && not (null l) + +isInstalled :: Package -> IO Bool +isInstalled p = (== [True]) <$> isInstalled' [p] + +{- | Note that the order of the returned list will not always + - correspond to the order of the input list. The number of items may + - even vary. If apt does not know about a package at all, it will not + - be included in the result list. -} +isInstalled' :: [Package] -> IO [Bool] +isInstalled' ps = catMaybes . map parse . lines + <$> readProcess "apt-cache" ("policy":ps) + where + parse l + | "Installed: (none)" `isInfixOf` l = Just False + | "Installed: " `isInfixOf` l = Just True + | otherwise = Nothing + +autoRemove :: Property +autoRemove = runApt [Param "-y", Param "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) + where + v + | enabled = "true" + | otherwise = "false" + +{- | Preseeds debconf values and reconfigures the package so it takes + - effect. -} +reConfigure :: Package -> [(String, String, String)] -> Property +reConfigure package vals = reconfigure `requires` setselections + `describe` ("reconfigure " ++ package) + where + setselections = Property "preseed" $ makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "debconf-set-selections" []) $ \h -> do + forM_ vals $ \(template, tmpltype, value) -> + hPutStrLn h $ unwords [package, template, tmpltype, value] + hClose h + reconfigure = cmdProperty "dpkg-reconfigure" [Param "-fnone", Param package] diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs new file mode 100644 index 00000000..6e23955c --- /dev/null +++ b/Propellor/Property/Cmd.hs @@ -0,0 +1,35 @@ +module Propellor.Property.Cmd ( + cmdProperty, + cmdProperty', + scriptProperty, + module Utility.SafeCommand +) where + +import Control.Applicative +import Data.List + +import Propellor.Types +import Utility.Monad +import Utility.SafeCommand +import Utility.Env + +cmdProperty :: String -> [CommandParam] -> Property +cmdProperty cmd params = cmdProperty' cmd params [] + +cmdProperty' :: String -> [CommandParam] -> [(String, String)] -> Property +cmdProperty' cmd params env = Property desc $ do + env' <- addEntries env <$> getEnvironment + ifM (boolSystemEnv cmd params (Just env')) + ( return MadeChange + , return FailedChange + ) + where + desc = unwords $ cmd : map showp params + showp (Params s) = s + showp (Param s) = s + showp (File s) = s + +scriptProperty :: [String] -> Property +scriptProperty script = cmdProperty "sh" [Param "-c", Param shellcmd] + where + shellcmd = intercalate " ; " ("set -e" : script) diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs new file mode 100644 index 00000000..744feb42 --- /dev/null +++ b/Propellor/Property/Docker.hs @@ -0,0 +1,16 @@ +module Propellor.Property.Docker where + +import Propellor.Common +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +{- | Configures docker with an authentication file, so that images can be + - pushed to index.docker.io. -} +configured :: Property +configured = Property "docker configured" go `requires` installed + where + go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ + "/root/.dockercfg" `File.hasContent` (lines cfg) + +installed :: Property +installed = Apt.installed ["docker.io"] diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs new file mode 100644 index 00000000..082542e9 --- /dev/null +++ b/Propellor/Property/File.hs @@ -0,0 +1,40 @@ +module Propellor.Property.File where + +import Propellor.Common + +type Line = String + +{- | Replaces all the content of a file. -} +hasContent :: FilePath -> [Line] -> Property +f `hasContent` newcontent = fileProperty ("replace " ++ f) + (\_oldcontent -> newcontent) f + +{- | Ensures that a line is present in a file, adding it to the end if not. -} +containsLine :: FilePath -> Line -> Property +f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f + where + go ls + | l `elem` ls = ls + | otherwise = ls++[l] + +{- | Ensures that a line is not present in a file. + - Note that the file is ensured to exist, so if it doesn't, an empty + - file will be written. -} +lacksLine :: FilePath -> Line -> Property +f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f + +{- | Removes a file. Does not remove symlinks or non-plain-files. -} +notPresent :: FilePath -> Property +notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $ + makeChange $ nukeFile f + +fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty desc a f = Property desc $ go =<< doesFileExist f + where + go True = do + ls <- lines <$> catchDefaultIO [] (readFile f) + let ls' = a ls + if ls' == ls + then noChange + else makeChange $ viaTmp writeFile f (unlines ls') + go False = makeChange $ writeFile f (unlines $ a []) diff --git a/Propellor/Property/GitHome.hs b/Propellor/Property/GitHome.hs new file mode 100644 index 00000000..400586e2 --- /dev/null +++ b/Propellor/Property/GitHome.hs @@ -0,0 +1,30 @@ +module Propellor.Property.GitHome where + +import Propellor.Common +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.User + +{- | 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") diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs new file mode 100644 index 00000000..8daf6bb2 --- /dev/null +++ b/Propellor/Property/Hostname.hs @@ -0,0 +1,9 @@ +module Propellor.Property.Hostname where + +import Propellor.Common +import qualified Propellor.Property.File as File + +set :: HostName -> Property +set hostname = "/etc/hostname" `File.hasContent` [hostname] + `onChange` cmdProperty "hostname" [Param hostname] + `describe` ("hostname " ++ hostname) diff --git a/Propellor/Property/JoeySites.hs b/Propellor/Property/JoeySites.hs new file mode 100644 index 00000000..e862916d --- /dev/null +++ b/Propellor/Property/JoeySites.hs @@ -0,0 +1,23 @@ +-- | Specific configuation for Joey Hess's sites. Probably not useful to +-- others except as an example. + +module Propellor.Property.JoeySites where + +import Propellor.Common +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" + ] diff --git a/Propellor/Property/Network.hs b/Propellor/Property/Network.hs new file mode 100644 index 00000000..704455b0 --- /dev/null +++ b/Propellor/Property/Network.hs @@ -0,0 +1,27 @@ +module Propellor.Property.Network where + +import Propellor.Common +import Propellor.Property.File + +interfaces :: FilePath +interfaces = "/etc/network/interfaces" + +-- | 6to4 ipv6 connection, should work anywhere +ipv6to4 :: Property +ipv6to4 = fileProperty "ipv6to4" go interfaces + `onChange` ifUp "sit0" + where + go ls + | all (`elem` ls) stanza = ls + | otherwise = ls ++ stanza + stanza = + [ "# Automatically added by propeller" + , "iface sit0 inet6 static" + , "\taddress 2002:5044:5531::1" + , "\tnetmask 64" + , "\tgateway ::192.88.99.1" + , "# End automatically added by propeller" + ] + +ifUp :: String -> Property +ifUp iface = cmdProperty "ifup" [Param iface] diff --git a/Propellor/Property/Reboot.hs b/Propellor/Property/Reboot.hs new file mode 100644 index 00000000..1a419d60 --- /dev/null +++ b/Propellor/Property/Reboot.hs @@ -0,0 +1,7 @@ +module Propellor.Property.Reboot where + +import Propellor.Common + +now :: Property +now = cmdProperty "reboot" [] + `describe` "reboot now" diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs new file mode 100644 index 00000000..39e02689 --- /dev/null +++ b/Propellor/Property/Ssh.hs @@ -0,0 +1,53 @@ +module Propellor.Property.Ssh where + +import Propellor.Common +import qualified Propellor.Property.File as File +import Propellor.Property.User + +sshBool :: Bool -> String +sshBool True = "yes" +sshBool False = "no" + +sshdConfig :: FilePath +sshdConfig = "/etc/ssh/sshd_config" + +setSshdConfig :: String -> Bool -> Property +setSshdConfig setting allowed = combineProperties + [ sshdConfig `File.lacksLine` (sshline $ not allowed) + , sshdConfig `File.containsLine` (sshline allowed) + ] + `onChange` restartSshd + `describe` unwords [ "ssh config:", setting, sshBool allowed ] + where + sshline v = setting ++ " " ++ sshBool v + +permitRootLogin :: Bool -> Property +permitRootLogin = setSshdConfig "PermitRootLogin" + +passwordAuthentication :: Bool -> Property +passwordAuthentication = setSshdConfig "PasswordAuthentication" + +hasAuthorizedKeys :: UserName -> IO Bool +hasAuthorizedKeys = go <=< homedir + where + go Nothing = return False + go (Just home) = not . null <$> catchDefaultIO "" + (readFile $ home ".ssh" "authorized_keys") + +restartSshd :: Property +restartSshd = cmdProperty "service" [Param "ssh", Param "restart"] + +{- | Blow away existing host keys and make new ones. Use a flag + - file to prevent doing this more than once. -} +uniqueHostKeys :: Property +uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" + `onChange` restartSshd + where + prop = Property "ssh unique host keys" $ do + void $ boolSystem "sh" + [ Param "-c" + , Param "rm -f /etc/ssh/ssh_host_*" + ] + ensureProperty $ + cmdProperty "/var/lib/dpkg/info/openssh-server.postinst" + [Param "configure"] diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs new file mode 100644 index 00000000..05484411 --- /dev/null +++ b/Propellor/Property/Sudo.hs @@ -0,0 +1,34 @@ +module Propellor.Property.Sudo where + +import Data.List + +import Propellor.Common +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.User + +{- | Allows a user to sudo. If the user has a password, sudo is configured + - to require it. If not, NOPASSWORD is enabled for the user. + - + - TOOD: Full sudoers file format parse.. + -} +enabledFor :: UserName -> Property +enabledFor user = Property desc go `requires` Apt.installed ["sudo"] + where + go = do + locked <- isLockedPassword user + ensureProperty $ + fileProperty desc + (modify locked . filter (wanted locked)) + "/etc/sudoers" + desc = user ++ " is sudoer" + sudobaseline = user ++ " ALL=(ALL:ALL)" + sudoline True = sudobaseline ++ " NOPASSWD:ALL" + sudoline False = sudobaseline ++ " ALL" + wanted locked l + | not (sudobaseline `isPrefixOf` l) = True + | "NOPASSWD" `isInfixOf` l = locked + | otherwise = True + modify locked ls + | sudoline locked `elem` ls = ls + | otherwise = ls ++ [sudoline locked] diff --git a/Propellor/Property/Tor.hs b/Propellor/Property/Tor.hs new file mode 100644 index 00000000..aa5d29e4 --- /dev/null +++ b/Propellor/Property/Tor.hs @@ -0,0 +1,19 @@ +module Propellor.Property.Tor where + +import Propellor.Common +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +isBridge :: Property +isBridge = setup `requires` Apt.installed ["tor"] + `describe` "tor bridge" + where + setup = "/etc/tor/torrc" `File.hasContent` + [ "SocksPort 0" + , "ORPort 443" + , "BridgeRelay 1" + , "Exitpolicy reject *:*" + ] `onChange` restartTor + +restartTor :: Property +restartTor = cmdProperty "service" [Param "tor", Param "restart"] diff --git a/Propellor/Property/User.hs b/Propellor/Property/User.hs new file mode 100644 index 00000000..2d2118cc --- /dev/null +++ b/Propellor/Property/User.hs @@ -0,0 +1,61 @@ +module Propellor.Property.User where + +import System.Posix + +import Propellor.Common + +data Eep = YesReallyDeleteHome + +sshAccountFor :: UserName -> Property +sshAccountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser" + [ Param "--disabled-password" + , Param "--gecos", Param "" + , Param user + ] + `describe` ("ssh account " ++ user) + +{- | Removes user home directory!! Use with caution. -} +nuked :: UserName -> Eep -> Property +nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel" + [ Param "-r" + , Param user + ] + `describe` ("nuked user " ++ user) + +{- | 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 + +hasPassword :: UserName -> Property +hasPassword user = Property (user ++ " has password") $ + 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" + , Param user + ] + `describe` ("locked " ++ user ++ " password") + +data PasswordStatus = NoPassword | LockedPassword | HasPassword + deriving (Eq) + +getPasswordStatus :: UserName -> IO PasswordStatus +getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user] + where + parse (_:"L":_) = LockedPassword + parse (_:"NP":_) = NoPassword + parse (_:"P":_) = HasPassword + parse _ = NoPassword + +isLockedPassword :: UserName -> IO Bool +isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user + +homedir :: UserName -> IO (Maybe FilePath) +homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user diff --git a/Propellor/Types.hs b/Propellor/Types.hs new file mode 100644 index 00000000..70ad8f9b --- /dev/null +++ b/Propellor/Types.hs @@ -0,0 +1,22 @@ +module Propellor.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 diff --git a/Property.hs b/Property.hs deleted file mode 100644 index c37af3dc..00000000 --- a/Property.hs +++ /dev/null @@ -1,123 +0,0 @@ -module Property where - -import System.Directory -import Control.Monad -import System.Console.ANSI -import System.Exit -import System.IO - -import Types -import Utility.Monad -import Utility.Exception - -makeChange :: IO () -> IO Result -makeChange a = a >> return MadeChange - -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. - -} -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 - 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)" - -{- 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 - where - go True = return NoChange - go False = do - r <- ensureProperty property - when (r == MadeChange) $ - 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. -} -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 - -{- 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. -} -check :: IO Bool -> Property -> Property -check c property = Property (propertyDesc property) $ ifM c - ( ensureProperty property - , return NoChange - ) - -ensureProperty :: Property -> IO Result -ensureProperty = catchDefaultIO FailedChange . propertySatisfy - -ensureProperties :: [Property] -> IO () -ensureProperties ps = do - r <- ensureProperties' [propertyList "overall" ps] - case r of - FailedChange -> exitWith (ExitFailure 1) - _ -> exitWith ExitSuccess - -ensureProperties' :: [Property] -> IO Result -ensureProperties' ps = ensure ps NoChange - 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 diff --git a/Property/Apt.hs b/Property/Apt.hs deleted file mode 100644 index b89fb30b..00000000 --- a/Property/Apt.hs +++ /dev/null @@ -1,132 +0,0 @@ -module Property.Apt where - -import Data.Maybe -import Control.Applicative -import Data.List -import System.IO -import Control.Monad - -import Common -import qualified Property.File as File -import Property.File (Line) - -sourcesList :: FilePath -sourcesList = "/etc/apt/sources.list" - -type Url = String -type Section = String - -data Suite = Stable | Testing | Unstable | Experimental - deriving Show - -showSuite :: Suite -> String -showSuite Stable = "stable" -showSuite Testing = "testing" -showSuite Unstable = "unstable" -showSuite Experimental = "experimental" - -debLine :: Suite -> Url -> [Section] -> Line -debLine suite mirror sections = unwords $ - ["deb", mirror, showSuite suite] ++ sections - -srcLine :: Line -> Line -srcLine l = case words l of - ("deb":rest) -> unwords $ "deb-src" : rest - _ -> "" - -stdSections :: [Section] -stdSections = ["main", "contrib", "non-free"] - -debCdn :: Suite -> [Line] -debCdn suite = [l, srcLine l] - where - l = debLine suite "http://cdn.debian.net/debian" stdSections - -{- Makes sources.list have a standard content using the mirror CDN, - - with a particular Suite. -} -stdSourcesList :: Suite -> Property -stdSourcesList suite = setSourcesList (debCdn suite) - `describe` ("standard sources.list for " ++ show suite) - -setSourcesList :: [Line] -> Property -setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update - -runApt :: [CommandParam] -> Property -runApt ps = cmdProperty' "apt-get" ps env - where - env = - [ ("DEBIAN_FRONTEND", "noninteractive") - , ("APT_LISTCHANGES_FRONTEND", "none") - ] - -update :: Property -update = runApt [Param "update"] - `describe` "apt update" - -upgrade :: Property -upgrade = runApt [Params "-y dist-upgrade"] - `describe` "apt dist-upgrade" - -type Package = String - -installed :: [Package] -> Property -installed ps = check (isInstallable ps) go - `describe` (unwords $ "apt installed":ps) - where - go = runApt $ [Param "-y", Param "install"] ++ map Param ps - -removed :: [Package] -> Property -removed ps = check (or <$> isInstalled' ps) go - `describe` (unwords $ "apt removed":ps) - where - go = runApt $ [Param "-y", Param "remove"] ++ map Param ps - -isInstallable :: [Package] -> IO Bool -isInstallable ps = do - l <- isInstalled' ps - return $ any (== False) l && not (null l) - -isInstalled :: Package -> IO Bool -isInstalled p = (== [True]) <$> isInstalled' [p] - -{- Note that the order of the returned list will not always - - correspond to the order of the input list. The number of items may - - even vary. If apt does not know about a package at all, it will not - - be included in the result list. -} -isInstalled' :: [Package] -> IO [Bool] -isInstalled' ps = catMaybes . map parse . lines - <$> readProcess "apt-cache" ("policy":ps) - where - parse l - | "Installed: (none)" `isInfixOf` l = Just False - | "Installed: " `isInfixOf` l = Just True - | otherwise = Nothing - -autoRemove :: Property -autoRemove = runApt [Param "-y", Param "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) - where - v - | enabled = "true" - | otherwise = "false" - -{- Preseeds debconf values and reconfigures the package so it takes - - effect. -} -reConfigure :: Package -> [(String, String, String)] -> Property -reConfigure package vals = reconfigure `requires` setselections - `describe` ("reconfigure " ++ package) - where - setselections = Property "preseed" $ makeChange $ - withHandle StdinHandle createProcessSuccess - (proc "debconf-set-selections" []) $ \h -> do - forM_ vals $ \(template, tmpltype, value) -> - hPutStrLn h $ unwords [package, template, tmpltype, value] - hClose h - reconfigure = cmdProperty "dpkg-reconfigure" [Param "-fnone", Param package] diff --git a/Property/Cmd.hs b/Property/Cmd.hs deleted file mode 100644 index 278d2fb0..00000000 --- a/Property/Cmd.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Property.Cmd ( - cmdProperty, - cmdProperty', - scriptProperty, - module Utility.SafeCommand -) where - -import Control.Applicative -import Data.List - -import Types -import Utility.Monad -import Utility.SafeCommand -import Utility.Env - -cmdProperty :: String -> [CommandParam] -> Property -cmdProperty cmd params = cmdProperty' cmd params [] - -cmdProperty' :: String -> [CommandParam] -> [(String, String)] -> Property -cmdProperty' cmd params env = Property desc $ do - env' <- addEntries env <$> getEnvironment - ifM (boolSystemEnv cmd params (Just env')) - ( return MadeChange - , return FailedChange - ) - where - desc = unwords $ cmd : map showp params - showp (Params s) = s - showp (Param s) = s - showp (File s) = s - -scriptProperty :: [String] -> Property -scriptProperty script = cmdProperty "sh" [Param "-c", Param shellcmd] - where - shellcmd = intercalate " ; " ("set -e" : script) diff --git a/Property/Docker.hs b/Property/Docker.hs deleted file mode 100644 index ebb3d3a4..00000000 --- a/Property/Docker.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Property.Docker where - -import Common -import qualified Property.File as File -import qualified Property.Apt as Apt - -{- Configures docker with an authentication file, so that images can be - - pushed to index.docker.io. -} -configured :: Property -configured = Property "docker configured" go `requires` installed - where - go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ - "/root/.dockercfg" `File.hasContent` (lines cfg) - -installed :: Property -installed = Apt.installed ["docker.io"] diff --git a/Property/File.hs b/Property/File.hs deleted file mode 100644 index 55ca4fec..00000000 --- a/Property/File.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Property.File where - -import Common - -type Line = String - -{- Replaces all the content of a file. -} -hasContent :: FilePath -> [Line] -> Property -f `hasContent` newcontent = fileProperty ("replace " ++ f) - (\_oldcontent -> newcontent) f - -{- Ensures that a line is present in a file, adding it to the end if not. -} -containsLine :: FilePath -> Line -> Property -f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f - where - go ls - | l `elem` ls = ls - | otherwise = ls++[l] - -{- Ensures that a line is not present in a file. - - Note that the file is ensured to exist, so if it doesn't, an empty - - file will be written. -} -lacksLine :: FilePath -> Line -> Property -f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f - -{- Note: Does not remove symlinks or non-plain-files. -} -notPresent :: FilePath -> Property -notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $ - makeChange $ nukeFile f - -fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property -fileProperty desc a f = Property desc $ go =<< doesFileExist f - where - go True = do - ls <- lines <$> catchDefaultIO [] (readFile f) - let ls' = a ls - if ls' == ls - then noChange - else makeChange $ viaTmp writeFile f (unlines ls') - go False = makeChange $ writeFile f (unlines $ a []) diff --git a/Property/GitHome.hs b/Property/GitHome.hs deleted file mode 100644 index 99402b8e..00000000 --- a/Property/GitHome.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Property.GitHome where - -import Common -import qualified Property.Apt as Apt -import Property.User - -{- 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") diff --git a/Property/Hostname.hs b/Property/Hostname.hs deleted file mode 100644 index 204ff5d4..00000000 --- a/Property/Hostname.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Property.Hostname where - -import Common -import qualified Property.File as File - -set :: HostName -> Property -set hostname = "/etc/hostname" `File.hasContent` [hostname] - `onChange` cmdProperty "hostname" [Param hostname] - `describe` ("hostname " ++ hostname) diff --git a/Property/JoeySites.hs b/Property/JoeySites.hs deleted file mode 100644 index 92279aeb..00000000 --- a/Property/JoeySites.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- Specific configuation for Joey Hess's sites. Probably not useful to - - others except as an example. -} - -module Property.JoeySites where - -import Common -import qualified 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" - ] diff --git a/Property/Network.hs b/Property/Network.hs deleted file mode 100644 index cd98100d..00000000 --- a/Property/Network.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Property.Network where - -import Common -import Property.File - -interfaces :: FilePath -interfaces = "/etc/network/interfaces" - --- 6to4 ipv6 connection, should work anywhere -ipv6to4 :: Property -ipv6to4 = fileProperty "ipv6to4" go interfaces - `onChange` ifUp "sit0" - where - go ls - | all (`elem` ls) stanza = ls - | otherwise = ls ++ stanza - stanza = - [ "# Automatically added by propeller" - , "iface sit0 inet6 static" - , "\taddress 2002:5044:5531::1" - , "\tnetmask 64" - , "\tgateway ::192.88.99.1" - , "# End automatically added by propeller" - ] - -ifUp :: String -> Property -ifUp iface = cmdProperty "ifup" [Param iface] diff --git a/Property/Reboot.hs b/Property/Reboot.hs deleted file mode 100644 index 9b06f07c..00000000 --- a/Property/Reboot.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Property.Reboot where - -import Common - -now :: Property -now = cmdProperty "reboot" [] - `describe` "reboot now" diff --git a/Property/Ssh.hs b/Property/Ssh.hs deleted file mode 100644 index c726bedd..00000000 --- a/Property/Ssh.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Property.Ssh where - -import Common -import qualified Property.File as File -import Property.User - -sshBool :: Bool -> String -sshBool True = "yes" -sshBool False = "no" - -sshdConfig :: FilePath -sshdConfig = "/etc/ssh/sshd_config" - -setSshdConfig :: String -> Bool -> Property -setSshdConfig setting allowed = combineProperties - [ sshdConfig `File.lacksLine` (sshline $ not allowed) - , sshdConfig `File.containsLine` (sshline allowed) - ] - `onChange` restartSshd - `describe` unwords [ "ssh config:", setting, sshBool allowed ] - where - sshline v = setting ++ " " ++ sshBool v - -permitRootLogin :: Bool -> Property -permitRootLogin = setSshdConfig "PermitRootLogin" - -passwordAuthentication :: Bool -> Property -passwordAuthentication = setSshdConfig "PasswordAuthentication" - -hasAuthorizedKeys :: UserName -> IO Bool -hasAuthorizedKeys = go <=< homedir - where - go Nothing = return False - go (Just home) = not . null <$> catchDefaultIO "" - (readFile $ home ".ssh" "authorized_keys") - -restartSshd :: Property -restartSshd = cmdProperty "service" [Param "ssh", Param "restart"] - -{- Blow away existing host keys and make new ones. Use a flag - - file to prevent doing this more than once. -} -uniqueHostKeys :: Property -uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" - `onChange` restartSshd - where - prop = Property "ssh unique host keys" $ do - void $ boolSystem "sh" - [ Param "-c" - , Param "rm -f /etc/ssh/ssh_host_*" - ] - ensureProperty $ - cmdProperty "/var/lib/dpkg/info/openssh-server.postinst" - [Param "configure"] diff --git a/Property/Sudo.hs b/Property/Sudo.hs deleted file mode 100644 index f341a3eb..00000000 --- a/Property/Sudo.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Property.Sudo where - -import Data.List - -import Common -import Property.File -import qualified Property.Apt as Apt -import Property.User - -{- Allows a user to sudo. If the user has a password, sudo is configured - - to require it. If not, NOPASSWORD is enabled for the user. - - - - TOOD: Full sudoers file format parse.. - -} -enabledFor :: UserName -> Property -enabledFor user = Property desc go `requires` Apt.installed ["sudo"] - where - go = do - locked <- isLockedPassword user - ensureProperty $ - fileProperty desc - (modify locked . filter (wanted locked)) - "/etc/sudoers" - desc = user ++ " is sudoer" - sudobaseline = user ++ " ALL=(ALL:ALL)" - sudoline True = sudobaseline ++ " NOPASSWD:ALL" - sudoline False = sudobaseline ++ " ALL" - wanted locked l - | not (sudobaseline `isPrefixOf` l) = True - | "NOPASSWD" `isInfixOf` l = locked - | otherwise = True - modify locked ls - | sudoline locked `elem` ls = ls - | otherwise = ls ++ [sudoline locked] diff --git a/Property/Tor.hs b/Property/Tor.hs deleted file mode 100644 index f7182120..00000000 --- a/Property/Tor.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Property.Tor where - -import Common -import qualified Property.File as File -import qualified Property.Apt as Apt - -isBridge :: Property -isBridge = setup `requires` Apt.installed ["tor"] - `describe` "tor bridge" - where - setup = "/etc/tor/torrc" `File.hasContent` - [ "SocksPort 0" - , "ORPort 443" - , "BridgeRelay 1" - , "Exitpolicy reject *:*" - ] `onChange` restartTor - -restartTor :: Property -restartTor = cmdProperty "service" [Param "tor", Param "restart"] diff --git a/Property/User.hs b/Property/User.hs deleted file mode 100644 index 6bdff2ea..00000000 --- a/Property/User.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Property.User where - -import System.Posix - -import Common - -data Eep = YesReallyDeleteHome - -sshAccountFor :: UserName -> Property -sshAccountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser" - [ Param "--disabled-password" - , Param "--gecos", Param "" - , Param user - ] - `describe` ("ssh account " ++ user) - -{- Removes user home directory!! Use with caution. -} -nuked :: UserName -> Eep -> Property -nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel" - [ Param "-r" - , Param user - ] - `describe` ("nuked user " ++ user) - -{- 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 - -hasPassword :: UserName -> Property -hasPassword user = Property (user ++ " has password") $ - 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" - , Param user - ] - `describe` ("locked " ++ user ++ " password") - -data PasswordStatus = NoPassword | LockedPassword | HasPassword - deriving (Eq) - -getPasswordStatus :: UserName -> IO PasswordStatus -getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user] - where - parse (_:"L":_) = LockedPassword - parse (_:"NP":_) = NoPassword - parse (_:"P":_) = HasPassword - parse _ = NoPassword - -isLockedPassword :: UserName -> IO Bool -isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user - -homedir :: UserName -> IO (Maybe FilePath) -homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user diff --git a/README b/README index 84c4b81f..a85e34a8 100644 --- a/README +++ b/README @@ -11,9 +11,9 @@ 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 Propellor.hs +Properties are defined using Haskell. Edit propellor.hs to get started. -There is no special language as used in puppet, chef, ansible, etc, just +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. diff --git a/Types.hs b/Types.hs deleted file mode 100644 index d22bd171..00000000 --- a/Types.hs +++ /dev/null @@ -1,22 +0,0 @@ -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 diff --git a/propellor.cabal b/propellor.cabal index eebb4f04..f78874bf 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 0 +Version: 0.1 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess @@ -10,13 +10,21 @@ License-File: GPL Build-Type: Simple Homepage: http://joeyh.name/code/propellor/ Category: Utility +Extra-Source-Files: + README + TODO + Makefile Synopsis: property-based host configuration management in haskell Description: 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. + . + While Propellor can be installed from hackage, to customize and use it + you should fork its git repository and modify it from there: + git clone git://git.kitenet.net/propellor Executable propellor - Main-Is: Propellor.hs + 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, @@ -25,6 +33,50 @@ Executable propellor if (! os(windows)) Build-Depends: unix +Library + GHC-Options: -Wall + Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, + IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, + containers + + if (! os(windows)) + Build-Depends: unix + + Exposed-Modules: + Propellor.Property + Propellor.Property.Apt + Propellor.Property.Cmd + 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.CmdLine + Propellor.Common + Propellor.PrivData + Propellor.Types + Other-Modules: + Utility.Applicative + Utility.Data + Utility.Directory + Utility.Env + Utility.Exception + Utility.FileMode + Utility.FileSystemEncoding + Utility.Misc + Utility.Monad + Utility.PartialPrelude + Utility.PosixFiles + Utility.Process + Utility.SafeCommand + Utility.Tmp + source-repository head type: git location: git://git.kitenet.net/propellor.git diff --git a/propellor.hs b/propellor.hs new file mode 100644 index 00000000..695fdf82 --- /dev/null +++ b/propellor.hs @@ -0,0 +1,80 @@ +import Propellor.Common +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.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 + +main :: IO () +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 + - 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 + -- Should come last as it reboots. + , Apt.installed ["systemd-sysv"] `onChange` Reboot.now + ] +-- add more hosts here... +--getProperties "foo" = +getProperties _ = Nothing + +-- This is my standard system setup +standardSystem :: Apt.Suite -> Property +standardSystem suite = propertyList "standard system" + [ Apt.stdSourcesList suite `onChange` Apt.upgrade + , Apt.installed ["etckeeper"] + , Apt.installed ["ssh"] + , GitHome.installedFor "root" + , User.hasSomePassword "root" + -- Harden the system, but only once root's authorized_keys + -- is safely in place. + , check (Ssh.hasAuthorizedKeys "root") $ + Ssh.passwordAuthentication False + , User.sshAccountFor "joey" + , User.hasSomePassword "joey" + , Sudo.enabledFor "joey" + , GitHome.installedFor "joey" + , Apt.installed ["vim", "screen"] + -- I use postfix, or no MTA. + , Apt.removed ["exim4"] `onChange` Apt.autoRemove + ] + +-- Clean up a system as installed by cloudatcost.com +cleanCloudAtCost :: HostName -> Property +cleanCloudAtCost hostname = propertyList "cloudatcost cleanup" + [ Hostname.set hostname + , Ssh.uniqueHostKeys + , "worked around grub/lvm boot bug #743126" ==> + "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" + `onChange` cmdProperty "update-grub" [] + `onChange` cmdProperty "update-initramfs" [Param "-u"] + , "nuked cloudatcost cruft" ==> combineProperties + [ File.notPresent "/etc/rc.local" + , File.notPresent "/etc/init.d/S97-setup.sh" + , User.nuked "user" User.YesReallyDeleteHome + ] + ] -- cgit v1.3-2-g0d8e