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 --- 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 +++++++ 18 files changed, 845 insertions(+) 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 (limited to 'Propellor') 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 -- cgit v1.2.3