diff options
Diffstat (limited to 'src')
150 files changed, 14933 insertions, 3070 deletions
diff --git a/src/Propellor.hs b/src/Propellor.hs index c0ef14f4..a371ea44 100644 --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -1,15 +1,12 @@ -{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | Pulls in lots of useful modules for building and using Properties. --- --- When propellor runs on a Host, it ensures that its list of Properties --- is satisfied, taking action as necessary when a Property is not +-- | When propellor runs on a Host, it ensures that its Properties +-- are satisfied, taking action as necessary when a Property is not -- currently satisfied. -- -- A simple propellor program example: -- -- > import Propellor --- > import Propellor.CmdLine -- > import qualified Propellor.Property.File as File -- > import qualified Propellor.Property.Apt as Apt -- > @@ -17,61 +14,63 @@ -- > main = defaultMain hosts -- > -- > hosts :: [Host] --- > hosts = --- > [ host "example.com" +-- > hosts = [example] +-- > +-- > example :: Host +-- > example = host "example.com" $ props -- > & Apt.installed ["mydaemon"] -- > & "/etc/mydaemon.conf" `File.containsLine` "secure=1" -- > `onChange` cmdProperty "service" ["mydaemon", "restart"] -- > ! Apt.installed ["unwantedpackage"] --- > ] -- -- See config.hs for a more complete example, and clone Propellor's -- git repository for a deployable system using Propellor: --- git clone <git://git.kitenet.net/propellor> +-- git clone <git://git.joeyh.name/propellor> module Propellor ( - module Propellor.Types + -- * Core data types + Host(..) + , Property + , RevertableProperty + , module Propellor.Types + -- * Config file + , defaultMain + , host + , (&) + , (!) + -- * Propertries + -- | Properties are often combined together in your propellor + -- configuration. For example: + -- + -- > "/etc/foo/config" `File.containsLine` "bar=1" + -- > `requires` File.dirExists "/etc/foo" + , requires + , before + , onChange + , describe , module Propellor.Property + -- | Everything you need to build your own properties, + -- and useful property combinators , module Propellor.Property.Cmd + -- | Properties to run shell commands , module Propellor.Info - , module Propellor.PrivData - , module Propellor.Engine - , module Propellor.Exception - , module Propellor.Message - , localdir + -- | Properties that set `Info` + , module Propellor.Property.List + -- | Combining a list of properties into a single property + , module Propellor.Types.PrivData + -- | Private data access for properties , module X ) where import Propellor.Types +import Propellor.CmdLine (defaultMain) import Propellor.Property -import Propellor.Engine +import Propellor.Property.List import Propellor.Property.Cmd -import Propellor.PrivData -import Propellor.Message -import Propellor.Exception +import Propellor.Types.PrivData import Propellor.Info +import Propellor.PropAccum -import Utility.PartialPrelude as X -import Utility.Process as X -import Utility.Exception as X -import Utility.Env as X -import Utility.Directory as X -import Utility.Tmp as X -import Utility.Monad as X -import Utility.Misc as X - -import System.Directory as X -import System.IO as X -import System.FilePath as X -import Data.Maybe as X -import Data.Either as X -import Control.Applicative as X -import Control.Monad as X import Data.Monoid as X -import Control.Monad.IfElse as X -import "mtl" Control.Monad.Reader as X - --- | This is where propellor installs itself when deploying a host. -localdir :: FilePath -localdir = "/usr/local/propellor" +import Data.String as X (fromString) diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs new file mode 100644 index 00000000..ae75589f --- /dev/null +++ b/src/Propellor/Base.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE PackageImports #-} + +-- | Pulls in lots of useful modules for building and using Properties. + +module Propellor.Base ( + -- * Propellor modules + module Propellor.Types + , module Propellor.Property + , module Propellor.Property.Cmd + , module Propellor.Property.List + , module Propellor.Types.PrivData + , module Propellor.PropAccum + , module Propellor.Info + , module Propellor.PrivData + , module Propellor.Engine + , module Propellor.Exception + , module Propellor.Message + , module Propellor.Debug + , module Propellor.Location + , module Propellor.Utilities + + -- * System modules + , module Utility.SystemDirectory + , module System.IO + , module System.FilePath + , module Data.Maybe + , module Data.Either + , module Control.Applicative + , module Control.Monad + , module Data.Monoid + , module Control.Monad.IfElse + , module Control.Monad.Reader +) where + +import Propellor.Types +import Propellor.Property +import Propellor.Engine +import Propellor.Property.List +import Propellor.Property.Cmd +import Propellor.PrivData +import Propellor.Types.PrivData +import Propellor.Message +import Propellor.Debug +import Propellor.Exception +import Propellor.Info +import Propellor.PropAccum +import Propellor.Location +import Propellor.Utilities + +import Utility.SystemDirectory +import System.IO +import System.FilePath +import Data.Maybe +import Data.Either +import Control.Applicative +import Control.Monad +import Data.Monoid +import Control.Monad.IfElse +import "mtl" Control.Monad.Reader diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs new file mode 100644 index 00000000..29175a67 --- /dev/null +++ b/src/Propellor/Bootstrap.hs @@ -0,0 +1,229 @@ +module Propellor.Bootstrap ( + bootstrapPropellorCommand, + checkBinaryCommand, + installGitCommand, + buildPropellor, +) where + +import Propellor.Base +import Propellor.Types.Info +import Propellor.Git.Config + +import System.Posix.Files +import Data.List + +type ShellCommand = String + +-- Shell command line to ensure propellor is bootstrapped and ready to run. +-- Should be run inside the propellor config dir, and will install +-- all necessary build dependencies and build propellor. +bootstrapPropellorCommand :: Maybe System -> ShellCommand +bootstrapPropellorCommand msys = checkDepsCommand msys ++ + "&& if ! test -x ./propellor; then " + ++ buildCommand ++ + "; fi;" ++ checkBinaryCommand + +-- Use propellor --check to detect if the local propellor binary has +-- stopped working (eg due to library changes), and must be rebuilt. +checkBinaryCommand :: ShellCommand +checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check; then " ++ go ++ "; fi" + where + go = intercalate " && " + [ "cabal clean" + , buildCommand + ] + +buildCommand :: ShellCommand +buildCommand = intercalate " && " + [ "cabal configure" + , "cabal build propellor-config" + , "ln -sf dist/build/propellor-config/propellor-config propellor" + ] + +-- Run cabal configure to check if all dependencies are installed; +-- if not, run the depsCommand. +checkDepsCommand :: Maybe System -> ShellCommand +checkDepsCommand sys = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand sys ++ "; fi" + +-- Install build dependencies of propellor. +-- +-- First, try to install ghc, cabal, gnupg, and all haskell libraries that +-- propellor uses from OS packages. +-- +-- Some packages may not be available in some versions of Debian +-- (eg, Debian wheezy lacks async), or propellor may need a newer version. +-- So, as a second step, cabal is used to install all dependencies. +-- +-- Note: May succeed and leave some deps not installed. +depsCommand :: Maybe System -> ShellCommand +depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true" + where + osinstall = case msys of + Just (System (FreeBSD _) _) -> map pkginstall fbsddeps + Just (System (Debian _) _) -> useapt + Just (System (Buntish _) _) -> useapt + -- assume a debian derived system when not specified + Nothing -> useapt + + useapt = "apt-get update" : map aptinstall debdeps + + cabalinstall = + [ "cabal update" + , "cabal install --only-dependencies" + ] + + aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p + pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p + + -- This is the same deps listed in debian/control. + debdeps = + [ "gnupg" + , "ghc" + , "cabal-install" + , "libghc-async-dev" + , "libghc-missingh-dev" + , "libghc-hslogger-dev" + , "libghc-unix-compat-dev" + , "libghc-ansi-terminal-dev" + , "libghc-ifelse-dev" + , "libghc-network-dev" + , "libghc-mtl-dev" + , "libghc-transformers-dev" + , "libghc-exceptions-dev" + , "libghc-stm-dev" + , "libghc-text-dev" + , "make" + ] + fbsddeps = + [ "gnupg" + , "ghc" + , "hs-cabal-install" + , "hs-async" + , "hs-MissingH" + , "hs-hslogger" + , "hs-unix-compat" + , "hs-ansi-terminal" + , "hs-IfElse" + , "hs-network" + , "hs-mtl" + , "hs-transformers-base" + , "hs-exceptions" + , "hs-stm" + , "hs-text" + , "gmake" + ] + +installGitCommand :: Maybe System -> ShellCommand +installGitCommand msys = case msys of + (Just (System (Debian _) _)) -> use apt + (Just (System (Buntish _) _)) -> use apt + (Just (System (FreeBSD _) _)) -> use + [ "ASSUME_ALWAYS_YES=yes pkg update" + , "ASSUME_ALWAYS_YES=yes pkg install git" + ] + -- assume a debian derived system when not specified + Nothing -> use apt + where + use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi" + apt = + [ "apt-get update" + , "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git" + ] + +buildPropellor :: Maybe Host -> IO () +buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $ + errorMessage "Propellor build failed!" + where + msys = case fmap (fromInfo . hostInfo) mh of + Just (InfoVal sys) -> Just sys + _ -> Nothing + +-- Build propellor using cabal or stack, and symlink propellor to the +-- built binary. +build :: Maybe System -> IO Bool +build msys = catchBoolIO $ do + bs <- getGitConfigValue "propellor.buildsystem" + case bs of + Just "stack" -> stackBuild msys + _ -> cabalBuild msys + +-- For speed, only runs cabal configure when it's not been run before. +-- If the build fails cabal may need to have configure re-run. +-- +-- If the cabal configure fails, and a System is provided, installs +-- dependencies and retries. +cabalBuild :: Maybe System -> IO Bool +cabalBuild msys = do + make "dist/setup-config" ["propellor.cabal"] cabal_configure + unlessM cabal_build $ + unlessM (cabal_configure <&&> cabal_build) $ + error "cabal build failed" + -- For safety against eg power loss in the middle of the build, + -- make a copy of the binary, and move it into place atomically. + -- This ensures that the propellor symlink only ever points at + -- a binary that is fully built. Also, avoid ever removing + -- or breaking the symlink. + -- + -- Need cp -a to make build timestamp checking work. + unlessM (boolSystem "cp" [Param "-af", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $ + error "cp of binary failed" + rename (tmpfor safetycopy) safetycopy + symlinkPropellorBin safetycopy + return True + where + cabalbuiltbin = "dist/build/propellor-config/propellor-config" + safetycopy = cabalbuiltbin ++ ".built" + cabal_configure = ifM (cabal ["configure"]) + ( return True + , case msys of + Nothing -> return False + Just sys -> + boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))] + <&&> cabal ["configure"] + ) + cabal_build = cabal ["build", "propellor-config"] + +stackBuild :: Maybe System -> IO Bool +stackBuild _msys = do + createDirectoryIfMissing True builddest + ifM (stack buildparams) + ( do + symlinkPropellorBin (builddest </> "propellor-config") + return True + , return False + ) + where + builddest = ".built" + buildparams = + [ "--local-bin-path", builddest + , "build" + , ":propellor-config" -- only build config program + , "--copy-bins" + ] + +-- Atomic symlink creation/update. +symlinkPropellorBin :: FilePath -> IO () +symlinkPropellorBin bin = do + createSymbolicLink bin (tmpfor dest) + rename (tmpfor dest) dest + where + dest = "propellor" + +tmpfor :: FilePath -> FilePath +tmpfor f = f ++ ".propellortmp" + +make :: FilePath -> [FilePath] -> IO Bool -> IO () +make dest srcs builder = do + dt <- getmtime dest + st <- mapM getmtime srcs + when (dt == Nothing || any (> dt) st) $ + unlessM builder $ + error $ "failed to make " ++ dest + where + getmtime = catchMaybeIO . getModificationTime + +cabal :: [String] -> IO Bool +cabal = boolSystem "cabal" . map Param + +stack :: [String] -> IO Bool +stack = boolSystem "stack" . map Param diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 415b8576..fc256109 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -1,110 +1,143 @@ -module Propellor.CmdLine where +module Propellor.CmdLine ( + defaultMain, + processCmdLine, +) where import System.Environment (getArgs) import Data.List import System.Exit -import System.Log.Logger -import System.Log.Formatter -import System.Log.Handler (setFormatter, LogHandler) -import System.Log.Handler.Simple import System.PosixCompat -import Control.Exception (bracket) -import System.Posix.IO -import Data.Time.Clock.POSIX - -import Propellor +import Network.Socket + +import Propellor.Base +import Propellor.Gpg +import Propellor.Git +import Propellor.Git.VerifiedBranch +import Propellor.Bootstrap +import Propellor.Spin +import Propellor.Types.CmdLine import qualified Propellor.Property.Docker as Docker -import qualified Propellor.Property.Docker.Shim as DockerShim -import Utility.FileMode -import Utility.SafeCommand -import Utility.UserInfo +import qualified Propellor.Property.Chroot as Chroot +import qualified Propellor.Shim as Shim + +usage :: Handle -> IO () +usage h = hPutStrLn h $ unlines + [ "Usage:" + , " propellor --init" + , " propellor" + , " propellor hostname" + , " propellor --spin targethost [--via relayhost]" + , " propellor --add-key keyid" + , " propellor --rm-key keyid" + , " propellor --list-fields" + , " propellor --dump field context" + , " propellor --edit field context" + , " propellor --set field context" + , " propellor --unset field context" + , " propellor --unset-unused" + , " propellor --merge" + , " propellor --build" + , " propellor --check" + ] -usage :: IO a -usage = do - putStrLn $ unlines - [ "Usage:" - , " propellor" - , " propellor hostname" - , " propellor --spin hostname" - , " propellor --add-key keyid" - , " propellor --set field context" - , " propellor --dump field context" - , " propellor --edit field context" - , " propellor --list-fields" - ] - exitFailure +usageError :: [String] -> IO a +usageError ps = do + usage stderr + error ("(Unexpected: " ++ show ps) processCmdLine :: IO CmdLine processCmdLine = go =<< getArgs where - go ("--help":_) = usage - go ("--spin":h:[]) = return $ Spin h - go ("--boot":h:[]) = return $ Boot h + go ("--check":_) = return Check + go ("--spin":ps) = case reverse ps of + (r:"--via":hs) -> Spin + <$> mapM hostname (reverse hs) + <*> pure (Just r) + _ -> Spin <$> mapM hostname ps <*> pure Nothing go ("--add-key":k:[]) = return $ AddKey k + go ("--rm-key":k:[]) = return $ RmKey k go ("--set":f:c:[]) = withprivfield f c Set + go ("--unset":f:c:[]) = withprivfield f c Unset + go ("--unset-unused":[]) = return UnsetUnused go ("--dump":f:c:[]) = withprivfield f c Dump go ("--edit":f:c:[]) = withprivfield f c Edit go ("--list-fields":[]) = return ListFields - go ("--continue":s:[]) = case readish s of - Just cmdline -> return $ Continue cmdline - Nothing -> errorMessage "--continue serialization failure" - go ("--chain":h:[]) = return $ Chain h - go ("--docker":h:[]) = return $ Docker h + go ("--merge":[]) = return Merge + go ("--help":_) = do + usage stdout + exitFailure + go ("--boot":_:[]) = return $ Update Nothing -- for back-compat + go ("--serialized":s:[]) = serialized Serialized s + go ("--continue":s:[]) = serialized Continue s + go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout) + go ("--run":h:[]) = go [h] go (h:[]) - | "--" `isPrefixOf` h = usage - | otherwise = return $ Run h + | "--" `isPrefixOf` h = usageError [h] + | otherwise = Run <$> hostname h go [] = do s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] if null s then errorMessage "Cannot determine hostname! Pass it on the command line." else return $ Run s - go _ = usage + go v = usageError v withprivfield s c f = case readish s of Just pf -> return $ f pf (Context c) Nothing -> errorMessage $ "Unknown privdata field " ++ s + serialized mk s = case readish s of + Just cmdline -> return $ mk cmdline + Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")" + +data CanRebuild = CanRebuild | NoRebuild + +-- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () -defaultMain hostlist = do - DockerShim.cleanEnv +defaultMain hostlist = withConcurrentOutput $ do + Shim.cleanEnv checkDebugMode cmdline <- processCmdLine debug ["command line: ", show cmdline] - go True cmdline + go CanRebuild cmdline where - go _ (Continue cmdline) = go False cmdline + go cr (Serialized cmdline) = go cr cmdline + go _ Check = return () go _ (Set field context) = setPrivData field context + go _ (Unset field context) = unsetPrivData field context + go _ (UnsetUnused) = unsetPrivDataUnused hostlist go _ (Dump field context) = dumpPrivData field context go _ (Edit field context) = editPrivData field context go _ ListFields = listPrivDataFields hostlist go _ (AddKey keyid) = addKey keyid - go _ (Chain hn) = withhost hn $ \h -> do - r <- runPropellor h $ ensureProperties $ hostProperties h - putStrLn $ "\n" ++ show r - go _ (Docker hn) = Docker.chain hn - go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline - go True cmdline = updateFirst cmdline $ go False cmdline - go False (Spin hn) = withhost hn $ spin hn - go False (Run hn) = ifM ((==) 0 <$> getRealUserID) - ( onlyProcess $ withhost hn mainProperties - , go True (Spin hn) + go _ (RmKey keyid) = rmKey keyid + go _ c@(ChrootChain _ _ _ _) = Chroot.chain hostlist c + go _ (DockerChain hn cid) = Docker.chain hostlist hn cid + go _ (DockerInit hn) = Docker.init hn + go _ (GitPush fin fout) = gitPushHelper fin fout + go cr (Relay h) = forceConsole >> + updateFirst Nothing cr (Update (Just h)) (update (Just h)) + go _ (Update Nothing) = forceConsole >> + fetchFirst (onlyprocess (update Nothing)) + go _ (Update (Just h)) = update (Just h) + go _ Merge = mergeSpin + go cr cmdline@(Spin hs mrelay) = buildFirst Nothing cr cmdline $ do + unless (isJust mrelay) commitSpin + forM_ hs $ \hn -> withhost hn $ spin mrelay hn + go cr cmdline@(Run hn) = ifM ((==) 0 <$> getRealUserID) + ( updateFirst (findHost hostlist hn) cr cmdline $ runhost hn + , fetchFirst $ go cr (Spin [hn] Nothing) ) - go False (Boot hn) = onlyProcess $ withhost hn boot + go cr cmdline@(SimpleRun hn) = forceConsole >> + fetchFirst (buildFirst (findHost hostlist hn) cr cmdline (runhost hn)) + -- When continuing after a rebuild, don't want to rebuild again. + go _ (Continue cmdline) = go NoRebuild cmdline withhost :: HostName -> (Host -> IO ()) -> IO () withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) -onlyProcess :: IO a -> IO a -onlyProcess a = bracket lock unlock (const a) - where - lock = do - l <- createFile lockfile stdFileMode - setLock l (WriteLock, AbsoluteSeek, 0, 0) - `catchIO` const alreadyrunning - return l - unlock = closeFd - alreadyrunning = error "Propellor is already running on this host!" - lockfile = localdir </> ".lock" + runhost hn = onlyprocess $ withhost hn mainProperties + + onlyprocess = onlyProcess (localdir </> ".lock") unknownhost :: HostName -> [Host] -> IO a unknownhost h hosts = errorMessage $ unlines @@ -114,293 +147,66 @@ unknownhost h hosts = errorMessage $ unlines , "Known hosts: " ++ unwords (map hostName hosts) ] -buildFirst :: CmdLine -> IO () -> IO () -buildFirst cmdline next = do +-- Builds propellor (when allowed) and if it looks like a new binary, +-- re-execs it to continue. +-- Otherwise, runs the IO action to continue. +-- +-- The Host should only be provided when dependencies should be installed +-- as needed to build propellor. +buildFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO () +buildFirst h CanRebuild cmdline next = do oldtime <- getmtime - ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"]) - ( do - newtime <- getmtime - if newtime == oldtime - then next - else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)] - , errorMessage "Propellor build failed!" - ) - where - getmtime = catchMaybeIO $ getModificationTime "propellor" - -getCurrentBranch :: IO String -getCurrentBranch = takeWhile (/= '\n') - <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"] - -updateFirst :: CmdLine -> IO () -> IO () -updateFirst cmdline next = do - branchref <- getCurrentBranch - let originbranch = "origin" </> branchref - - void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"] - - oldsha <- getCurrentGitSha1 branchref - - whenM (doesFileExist keyring) $ do - {- To verify origin branch commit's signature, have to - - convince gpg to use our keyring. While running git log. - - Which has no way to pass options to gpg. - - Argh! -} - let gpgconf = privDataDir </> "gpg.conf" - writeFile gpgconf $ unlines - [ " keyring " ++ keyring - , "no-auto-check-trustdb" - ] - -- gpg is picky about perms - modifyFileMode privDataDir (removeModes otherGroupModes) - s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch] - (Just [("GNUPGHOME", privDataDir)]) - nukeFile $ privDataDir </> "trustdb.gpg" - nukeFile $ privDataDir </> "pubring.gpg" - nukeFile $ privDataDir </> "gpg.conf" - if s == "U\n" || s == "G\n" - then do - putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging" - hFlush stdout - void $ boolSystem "git" [Param "merge", Param originbranch] - else warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)" - - newsha <- getCurrentGitSha1 branchref - - if oldsha == newsha + buildPropellor h + newtime <- getmtime + if newtime == oldtime then next - else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"]) - ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)] - , errorMessage "Propellor build failed!" - ) - -getCurrentGitSha1 :: String -> IO String -getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref] - -spin :: HostName -> Host -> IO () -spin hn hst = do - url <- getUrl - void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] - void $ boolSystem "git" [Param "push"] - cacheparams <- toCommand <$> sshCachingParams hn - go cacheparams url =<< hostprivdata + else continueAfterBuild cmdline where - hostprivdata = show . filterPrivData hst <$> decryptPrivData - - go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do - let finish = do - senddata toh "privdata" privDataMarker privdata - hClose toh - - -- Display remaining output. - void $ tryIO $ forever $ - showremote =<< hGetLine fromh - hClose fromh - status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)") - case status of - Ready -> finish - NeedGitClone -> do - hClose toh - hClose fromh - sendGitClone hn url - go cacheparams url privdata - - user = "root@"++hn - - bootstrapcmd = shellWrap $ intercalate " ; " - [ "if [ ! -d " ++ localdir ++ " ]" - , "then " ++ intercalate " && " - [ "apt-get update" - , "apt-get --no-install-recommends --no-upgrade -y install git make" - , "echo " ++ toMarked statusMarker (show NeedGitClone) - ] - , "else " ++ intercalate " && " - [ "cd " ++ localdir - , "if ! test -x ./propellor; then make deps build; fi" - , "./propellor --boot " ++ hn - ] - , "fi" - ] - - getstatus :: Handle -> IO BootStrapStatus - getstatus h = do - l <- hGetLine h - case readish =<< fromMarked statusMarker l of - Nothing -> do - showremote l - getstatus h - Just status -> return status - - showremote s = putStrLn s - senddata toh desc marker s = void $ - actionMessage ("Sending " ++ desc ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do - sendMarked toh marker s - return True - --- Initial git clone, used for bootstrapping. -sendGitClone :: HostName -> String -> IO () -sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do - branch <- getCurrentBranch - cacheparams <- sshCachingParams hn - withTmpFile "propellor.git" $ \tmp _ -> allM id - [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] - , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] - , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] - ] - where - remotebundle = "/usr/local/propellor.git" - unpackcmd branch = shellWrap $ intercalate " && " - [ "git clone " ++ remotebundle ++ " " ++ localdir - , "cd " ++ localdir - , "git checkout -b " ++ branch - , "git remote rm origin" - , "rm -f " ++ remotebundle - , "git remote add origin " ++ url - -- same as --set-upstream-to, except origin branch - -- has not been pulled yet - , "git config branch."++branch++".remote origin" - , "git config branch."++branch++".merge refs/heads/"++branch - ] - -data BootStrapStatus = Ready | NeedGitClone - deriving (Read, Show, Eq) - -type Marker = String -type Marked = String - -statusMarker :: Marker -statusMarker = "STATUS" - -privDataMarker :: String -privDataMarker = "PRIVDATA " - -toMarked :: Marker -> String -> String -toMarked marker = intercalate "\n" . map (marker ++) . lines - -sendMarked :: Handle -> Marker -> String -> IO () -sendMarked h marker s = do - -- Prefix string with newline because sometimes a - -- incomplete line is output. - hPutStrLn h ("\n" ++ toMarked marker s) - hFlush h - -fromMarked :: Marker -> Marked -> Maybe String -fromMarked marker s - | null matches = Nothing - | otherwise = Just $ intercalate "\n" $ - map (drop len) matches - where - len = length marker - matches = filter (marker `isPrefixOf`) $ lines s - -boot :: Host -> IO () -boot h = do - sendMarked stdout statusMarker $ show Ready - reply <- hGetContentsStrict stdin - - makePrivDataDir - maybe noop (writeFileProtected privDataLocal) $ - fromMarked privDataMarker reply - mainProperties h - -addKey :: String -> IO () -addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ] - where - gpg = do - createDirectoryIfMissing True privDataDir - boolSystem "sh" - [ Param "-c" - , Param $ "gpg --export " ++ keyid ++ " | gpg " ++ - unwords (gpgopts ++ ["--import"]) - ] - gitadd = boolSystem "git" - [ Param "add" - , File keyring - ] - - gitconfig = boolSystem "git" - [ Param "config" - , Param "user.signingkey" - , Param keyid - ] - - gitcommit = gitCommit - [ File keyring - , Param "-m" - , Param "propellor addkey" - ] - -{- Automatically sign the commit if there'a a keyring. -} -gitCommit :: [CommandParam] -> IO Bool -gitCommit ps = do - k <- doesFileExist keyring - boolSystem "git" $ catMaybes $ - [ Just (Param "commit") - , if k then Just (Param "--gpg-sign") else Nothing - ] ++ map Just ps - -keyring :: FilePath -keyring = privDataDir </> "keyring.gpg" - -gpgopts :: [String] -gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring] - -getUrl :: IO String -getUrl = maybe nourl return =<< getM get urls - where - urls = ["remote.deploy.url", "remote.origin.url"] - nourl = errorMessage $ "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 + getmtime = catchMaybeIO $ getModificationTime "propellor" +buildFirst _ NoRebuild _ next = next -checkDebugMode :: IO () -checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" +continueAfterBuild :: CmdLine -> IO a +continueAfterBuild cmdline = go =<< boolSystem "./propellor" + [ Param "--continue" + , Param (show cmdline) + ] where - go (Just s) - | s == "1" = do - f <- setFormatter - <$> streamHandler stderr DEBUG - <*> pure (simpleLogFormatter "[$time] $msg") - updateGlobalLogger rootLoggerName $ - setLevel DEBUG . setHandlers [f] - go _ = noop - --- Parameters can be passed to both ssh and scp, to enable a ssh connection --- caching socket. --- --- If the socket already exists, check if its mtime is older than 10 --- minutes, and if so stop that ssh process, in order to not try to --- use an old stale connection. (atime would be nicer, but there's --- a good chance a laptop uses noatime) -sshCachingParams :: HostName -> IO [CommandParam] -sshCachingParams hn = do - home <- myHomeDir - let cachedir = home </> ".ssh" </> "propellor" - createDirectoryIfMissing False cachedir - let socketfile = cachedir </> hn ++ ".sock" - let ps = - [ Param "-o", Param ("ControlPath=" ++ socketfile) - , Params "-o ControlMaster=auto -o ControlPersist=yes" - ] - - maybe noop (expireold ps socketfile) - =<< catchMaybeIO (getFileStatus socketfile) - - return ps - + go True = exitSuccess + go False = exitWith (ExitFailure 1) + +fetchFirst :: IO () -> IO () +fetchFirst next = do + whenM hasOrigin $ + void fetchOrigin + next + +updateFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO () +updateFirst h canrebuild cmdline next = ifM hasOrigin + ( updateFirst' h canrebuild cmdline next + , next + ) + +-- If changes can be fetched from origin, Builds propellor (when allowed) +-- and re-execs the updated propellor binary to continue. +-- Otherwise, runs the IO action to continue. +updateFirst' :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO () +updateFirst' h CanRebuild cmdline next = ifM fetchOrigin + ( do + buildPropellor h + continueAfterBuild cmdline + , next + ) +updateFirst' _ NoRebuild _ next = next + +-- Gets the fully qualified domain name, given a string that might be +-- a short name to look up in the DNS. +hostname :: String -> IO HostName +hostname s = go =<< catchDefaultIO [] dnslookup where - expireold ps f s = do - now <- truncate <$> getPOSIXTime :: IO Integer - if modificationTime s > fromIntegral now - tenminutes - then touchFile f - else do - void $ boolSystem "ssh" $ - [ Params "-O stop" ] ++ ps ++ - [ Param "localhost" ] - nukeFile f - tenminutes = 600 + dnslookup = getAddrInfo (Just canonname) (Just s) Nothing + canonname = defaultHints { addrFlags = [AI_CANONNAME] } + go (AddrInfo { addrCanonName = Just v } : _) = pure v + go _ + | "." `isInfixOf` s = pure s -- assume it's a fqdn + | otherwise = + error $ "cannot find host " ++ s ++ " in the DNS" diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs new file mode 100644 index 00000000..c4d6f864 --- /dev/null +++ b/src/Propellor/Container.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + +module Propellor.Container where + +import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes +import Propellor.Types.Info +import Propellor.Info +import Propellor.PrivData +import Propellor.PropAccum + +class IsContainer c where + containerProperties :: c -> [ChildProperty] + containerInfo :: c -> Info + setContainerProperties :: c -> [ChildProperty] -> c + +instance IsContainer Host where + containerProperties = hostProperties + containerInfo = hostInfo + setContainerProperties h ps = host (hostName h) (Props ps) + +-- | Note that the metatype of a container's properties is not retained, +-- so this defaults to UnixLike. So, using this with setContainerProps can +-- add properties to a container that conflict with properties already in it. +-- Use caution when using this; only add properties that do not have +-- restricted targets. +containerProps :: IsContainer c => c -> Props UnixLike +containerProps = Props . containerProperties + +setContainerProps :: IsContainer c => c -> Props metatypes -> c +setContainerProps c (Props ps) = setContainerProperties c ps + +-- | Adjust the provided Property, adding to its +-- propertyChidren the properties of the provided container. +-- +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propagated out to the Property. +-- +-- Any PrivInfo that uses HostContext is adjusted to use the name +-- of the container as its context. +propagateContainer + :: + -- Since the children being added probably have info, + -- require the Property's metatypes to have info. + ( IncludesInfo metatypes ~ 'True + , IsContainer c + ) + => String + -> c + -> Property metatypes + -> Property metatypes +propagateContainer containername c prop = prop + `addChildren` map convert (containerProperties c) + where + convert p = + let n = property (getDesc p) (getSatisfy p) :: Property UnixLike + n' = n + `setInfoProperty` mapInfo (forceHostContext containername) + (propagatableInfo (getInfo p)) + `addChildren` map convert (getChildren p) + in toChildProperty n' diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs new file mode 100644 index 00000000..5e729b23 --- /dev/null +++ b/src/Propellor/Debug.hs @@ -0,0 +1,37 @@ +module Propellor.Debug where + +import Control.Monad.IfElse +import System.IO +import System.Log.Logger +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple +import Control.Applicative +import Prelude + +import Utility.Monad +import Utility.Env +import Utility.Exception +import Utility.Process +import Utility.Directory + +debug :: [String] -> IO () +debug = debugM "propellor" . unwords + +checkDebugMode :: IO () +checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" + where + go (Just "1") = enableDebugMode + go (Just _) = noop + go Nothing = whenM (doesDirectoryExist ".git") $ + whenM (elem "1" . lines <$> getgitconfig) enableDebugMode + getgitconfig = catchDefaultIO "" $ + readProcess "git" ["config", "propellor.debug"] + +enableDebugMode :: IO () +enableDebugMode = do + f <- setFormatter + <$> streamHandler stderr DEBUG + <*> pure (simpleLogFormatter "[$time] $msg") + updateGlobalLogger rootLoggerName $ + setLevel DEBUG . setHandlers [f] diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs new file mode 100644 index 00000000..f32b52a4 --- /dev/null +++ b/src/Propellor/DotDir.hs @@ -0,0 +1,422 @@ +module Propellor.DotDir + ( distrepo + , dotPropellor + , interactiveInit + , checkRepoUpToDate + ) where + +import Propellor.Message +import Propellor.Bootstrap +import Propellor.Git +import Propellor.Gpg +import Propellor.Types.Result +import Utility.UserInfo +import Utility.Monad +import Utility.Process +import Utility.SafeCommand +import Utility.Exception +import Utility.Directory +import Utility.Path +-- This module is autogenerated by the build system. +import qualified Paths_propellor as Package + +import Data.Char +import Data.List +import Data.Version +import Control.Monad +import Control.Monad.IfElse +import System.FilePath +import System.Posix.Directory +import System.IO +import System.Console.Concurrent +import Control.Applicative +import Prelude + +distdir :: FilePath +distdir = "/usr/src/propellor" + +-- A distribution may include a bundle of propellor's git repository here. +-- If not, it will be pulled from the network when needed. +distrepo :: FilePath +distrepo = distdir </> "propellor.git" + +-- File containing the head rev of the distrepo. +disthead :: FilePath +disthead = distdir </> "head" + +upstreambranch :: String +upstreambranch = "upstream/master" + +-- Using the github mirror of the main propellor repo because +-- it is accessible over https for better security. +netrepo :: String +netrepo = "https://github.com/joeyh/propellor.git" + +dotPropellor :: IO FilePath +dotPropellor = do + home <- myHomeDir + return (home </> ".propellor") + +-- Detect if propellor was built using stack. This is somewhat of a hack. +buildSystem :: IO String +buildSystem = do + d <- Package.getLibDir + return $ if "stack-work" `isInfixOf` d then "stack" else "cabal" + +interactiveInit :: IO () +interactiveInit = ifM (doesDirectoryExist =<< dotPropellor) + ( error "~/.propellor/ already exists, not doing anything" + , do + welcomeBanner + setup + ) + +-- | Determine whether we need to create a cabal sandbox in ~/.propellor/, +-- which we do if the user has configured cabal to require a sandbox, and the +-- build system is cabal. +cabalSandboxRequired :: IO Bool +cabalSandboxRequired = ifM cabal + ( do + home <- myHomeDir + ls <- lines <$> catchDefaultIO [] + (readFile (home </> ".cabal" </> "config")) + -- For simplicity, we assume a sane ~/.cabal/config here: + return $ any ("True" `isInfixOf`) $ + filter ("require-sandbox:" `isPrefixOf`) ls + , return False + ) + where + cabal = buildSystem >>= \bSystem -> return (bSystem == "cabal") + +say :: String -> IO () +say = outputConcurrent + +sayLn :: String -> IO () +sayLn s = say (s ++ "\n") + +welcomeBanner :: IO () +welcomeBanner = say $ unlines $ map prettify + [ "" + , "" + , " _ ______`| ,-.__" + , " .--------------------------- / ~___-=O`/|O`/__| (____.'" + , " - Welcome to -- ~ / | / ) _.-'-._" + , " - Propellor! -- `/-==__ _/__|/__=-| ( ~_" + , " `--------------------------- * ~ | | '--------'" + , " (o) `" + , "" + , "" + ] + where + prettify = map (replace '~' '\\') + replace x y c + | c == x = y + | otherwise = c + +prompt :: String -> [(String, IO ())] -> IO () +prompt p cs = do + say (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ") + flushConcurrentOutput + hFlush stdout + r <- map toLower <$> getLine + if null r + then snd (head cs) -- default to first choice on return + else case filter (\(s, _) -> map toLower s == r) cs of + [(_, a)] -> a + _ -> do + sayLn "Not a valid choice, try again.. (Or ctrl-c to quit)" + prompt p cs + +section :: IO () +section = do + sayLn "" + sayLn "------------------------------------------------------------------------------" + sayLn "" + +setup :: IO () +setup = do + sayLn "Propellor's configuration file is ~/.propellor/config.hs" + sayLn "" + sayLn "Let's get you started with a simple config that you can adapt" + sayLn "to your needs. You can start with:" + sayLn " A: A clone of propellor's git repository (most flexible)" + sayLn " B: The bare minimum files to use propellor (most simple)" + prompt "Which would you prefer?" + [ ("A", void $ actionMessage "Cloning propellor's git repository" fullClone) + , ("B", void $ actionMessage "Creating minimal config" minimalConfig) + ] + changeWorkingDirectory =<< dotPropellor + + section + sayLn "Let's try building the propellor configuration, to make sure it will work..." + sayLn "" + b <- buildSystem + void $ boolSystem "git" + [ Param "config" + , Param "propellor.buildsystem" + , Param b + ] + ifM cabalSandboxRequired + ( void $ boolSystem "cabal" + [ Param "sandbox" + , Param "init" + ] + , return () + ) + buildPropellor Nothing + sayLn "" + sayLn "Great! Propellor is bootstrapped." + + section + sayLn "Propellor can use gpg to encrypt private data about the systems it manages," + sayLn "and to sign git commits." + gpg <- getGpgBin + ifM (inPath gpg) + ( setupGpgKey + , do + sayLn "You don't seem to have gpg installed, so skipping setting it up." + explainManualSetupGpgKey + ) + + section + sayLn "Everything is set up ..." + sayLn "Your next step is to edit ~/.propellor/config.hs" + sayLn "and run propellor again to try it out." + sayLn "" + sayLn "For docs, see https://propellor.branchable.com/" + sayLn "Enjoy propellor!" + +explainManualSetupGpgKey :: IO () +explainManualSetupGpgKey = do + sayLn "Propellor can still be used without gpg, but it won't be able to" + sayLn "manage private data. You can set this up later:" + sayLn " 1. gpg --gen-key" + sayLn " 2. propellor --add-key (pass it the key ID generated in step 1)" + +setupGpgKey :: IO () +setupGpgKey = do + ks <- listSecretKeys + sayLn "" + case ks of + [] -> makeGpgKey + [(k, d)] -> do + sayLn $ "You have one gpg key: " ++ desckey k d + prompt "Should propellor use that key?" + [ ("Y", propellorAddKey k) + , ("N", sayLn $ "Skipping gpg setup. If you change your mind, run: propellor --add-key " ++ k) + ] + _ -> do + let nks = zip ks (map show ([1..] :: [Integer])) + sayLn "I see you have several gpg keys:" + forM_ nks $ \((k, d), n) -> + sayLn $ " " ++ n ++ " " ++ desckey k d + prompt "Which of your gpg keys should propellor use?" + (map (\((k, _), n) -> (n, propellorAddKey k)) nks) + where + desckey k d = d ++ " (keyid " ++ k ++ ")" + +makeGpgKey :: IO () +makeGpgKey = do + sayLn "You seem to not have any gpg secret keys." + prompt "Would you like to create one now?" + [("Y", rungpg), ("N", nope)] + where + nope = do + sayLn "No problem." + explainManualSetupGpgKey + rungpg = do + sayLn "Running gpg --gen-key ..." + gpg <- getGpgBin + void $ boolSystem gpg [Param "--gen-key"] + ks <- listSecretKeys + case ks of + [] -> do + sayLn "Hmm, gpg seemed to not set up a secret key." + prompt "Want to try running gpg again?" + [("Y", rungpg), ("N", nope)] + ((k, _):_) -> propellorAddKey k + +propellorAddKey :: String -> IO () +propellorAddKey keyid = do + sayLn "" + sayLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid + d <- dotPropellor + unlessM (boolSystem (d </> "propellor") [Param "--add-key", Param keyid]) $ do + sayLn "Oops, that didn't work! You can retry the same command later." + sayLn "Continuing onward ..." + +minimalConfig :: IO Result +minimalConfig = do + d <- dotPropellor + createDirectoryIfMissing True d + changeWorkingDirectory d + void $ boolSystem "git" [Param "init"] + addfile "config.cabal" cabalcontent + addfile "config.hs" configcontent + addfile "stack.yaml" stackcontent + return MadeChange + where + addfile f content = do + writeFile f (unlines content) + void $ boolSystem "git" [Param "add" , File f] + cabalcontent = + [ "-- This is a cabal file to use to build your propellor configuration." + , "" + , "Name: config" + , "Cabal-Version: >= 1.6" + , "Build-Type: Simple" + , "Version: 0" + , "" + , "Executable propellor-config" + , " Main-Is: config.hs" + , " GHC-Options: -threaded -Wall -fno-warn-tabs -O0" + , " Extensions: TypeOperators" + , " Build-Depends: propellor >= 3.0, base >= 3" + ] + configcontent = + [ "-- This is the main configuration file for Propellor, and is used to build" + , "-- the propellor program. https://propellor.branchable.com/" + , "" + , "import Propellor" + , "import qualified Propellor.Property.File as File" + , "import qualified Propellor.Property.Apt as Apt" + , "import qualified Propellor.Property.Cron as Cron" + , "import qualified Propellor.Property.User as User" + , "" + , "main :: IO ()" + , "main = defaultMain hosts" + , "" + , "-- The hosts propellor knows about." + , "hosts :: [Host]" + , "hosts =" + , " [ mybox" + , " ]" + , "" + , "-- An example host." + , "mybox :: Host" + , "mybox = host \"mybox.example.com\" $ props" + , " & osDebian Unstable \"amd64\"" + , " & Apt.stdSourcesList" + , " & Apt.unattendedUpgrades" + , " & Apt.installed [\"etckeeper\"]" + , " & Apt.installed [\"ssh\"]" + , " & User.hasSomePassword (User \"root\")" + , " & File.dirExists \"/var/www\"" + , " & Cron.runPropellor (Cron.Times \"30 * * * *\")" + , "" + ] + stackcontent = + -- This should be the same resolver version in propellor's + -- own stack.yaml + [ "resolver: lts-5.10" + , "packages:" + , "- '.'" + , "extra-deps:" + , "- propellor-" ++ showVersion Package.version + ] + +fullClone :: IO Result +fullClone = do + d <- dotPropellor + let enterdotpropellor = changeWorkingDirectory d >> return True + ok <- ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo) + ( allM id + [ boolSystem "git" [Param "clone", File distrepo, File d] + , fetchUpstreamBranch distrepo + , enterdotpropellor + , boolSystem "git" [Param "remote", Param "rm", Param "origin"] + ] + , allM id + [ boolSystem "git" [Param "clone", Param netrepo, File d] + , enterdotpropellor + -- Rename origin to upstream and avoid + -- git push to that read-only repo. + , boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"] + , boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"] + ] + ) + return (toResult ok) + +fetchUpstreamBranch :: FilePath -> IO Bool +fetchUpstreamBranch repo = do + changeWorkingDirectory =<< dotPropellor + boolSystem "git" + [ Param "fetch" + , File repo + , Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch) + , Param "--quiet" + ] + +checkRepoUpToDate :: IO () +checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do + headrev <- takeWhile (/= '\n') <$> readFile disthead + changeWorkingDirectory =<< dotPropellor + headknown <- catchMaybeIO $ + withQuietOutput createProcessSuccess $ + proc "git" ["log", headrev] + if (headknown == Nothing) + then setupUpstreamMaster headrev + else do + theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef + when (theirhead /= headrev) $ do + merged <- not . null <$> + readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"] + unless merged $ + warnoutofdate True + where + gitbundleavail = doesFileExist disthead + dotpropellorpopulated = do + d <- dotPropellor + doesFileExist (d </> "propellor.cabal") + +-- Makes upstream/master in dotPropellor be a usefully mergeable branch. +-- +-- We cannot just use origin/master, because in the case of a distrepo, +-- it only contains 1 commit. So, trying to merge with it will result +-- in lots of merge conflicts, since git cannot find a common parent +-- commit. +-- +-- Instead, the upstream/master branch is created by taking the +-- upstream/master branch (which must be an old version of propellor, +-- as distributed), and diffing from it to the current origin/master, +-- and committing the result. This is done in a temporary clone of the +-- repository, giving it a new master branch. That new branch is fetched +-- into the user's repository, as if fetching from a upstream remote, +-- yielding a new upstream/master branch. +setupUpstreamMaster :: String -> IO () +setupUpstreamMaster newref = do + changeWorkingDirectory =<< dotPropellor + go =<< catchMaybeIO getoldrev + where + go Nothing = warnoutofdate False + go (Just oldref) = do + let tmprepo = ".git/propellordisttmp" + let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo + cleantmprepo + git ["clone", "--quiet", ".", tmprepo] + + changeWorkingDirectory tmprepo + git ["fetch", distrepo, "--quiet"] + git ["reset", "--hard", oldref, "--quiet"] + git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"] + + void $ fetchUpstreamBranch tmprepo + cleantmprepo + warnoutofdate True + + getoldrev = takeWhile (/= '\n') + <$> readProcess "git" ["show-ref", upstreambranch, "--hash"] + + git = run "git" + run cmd ps = unlessM (boolSystem cmd (map Param ps)) $ + error $ "Failed to run " ++ cmd ++ " " ++ show ps + +warnoutofdate :: Bool -> IO () +warnoutofdate havebranch = do + warningMessage ("** Your ~/.propellor/ is out of date..") + let also s = hPutStrLn stderr (" " ++ s) + also ("A newer upstream version is available in " ++ distrepo) + if havebranch + then also ("To merge it, run: git merge " ++ upstreambranch) + else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.") + also "" diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index a3fc0f30..8958da6b 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -1,49 +1,96 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE DataKinds #-} -module Propellor.Engine where +module Propellor.Engine ( + mainProperties, + runPropellor, + ensureChildProperties, + fromHost, + fromHost', + onlyProcess, +) where import System.Exit import System.IO import Data.Monoid +import "mtl" Control.Monad.RWS.Strict +import System.PosixCompat +import System.Posix.IO +import System.FilePath import Control.Applicative -import System.Console.ANSI -import "mtl" Control.Monad.Reader +import Prelude import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Message import Propellor.Exception import Propellor.Info +import Utility.Exception +import Utility.Directory -runPropellor :: Host -> Propellor a -> IO a -runPropellor host a = runReaderT (runWithHost a) host - +-- | Gets the Properties of a Host, and ensures them all, +-- with nice display of what's being done. mainProperties :: Host -> IO () mainProperties host = do - r <- runPropellor host $ - ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty] - setTitle "propellor: done" - hFlush stdout - case r of + ret <- runPropellor host $ ensureChildProperties [toChildProperty overall] + messagesDone + case ret of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess + where + overall :: Property (MetaTypes '[]) + overall = property "overall" $ + ensureChildProperties (hostProperties host) + +-- | Runs a Propellor action with the specified host. +-- +-- If the Result is not FailedChange, any EndActions +-- that were accumulated while running the action +-- are then also run. +runPropellor :: Host -> Propellor Result -> IO Result +runPropellor host a = do + (res, endactions) <- evalRWST (runWithHost a) host () + endres <- mapM (runEndAction host res) endactions + return $ mconcat (res:endres) + +runEndAction :: Host -> Result -> EndAction -> IO Result +runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc $ do + (ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host () + return ret -ensureProperties :: [Property] -> Propellor Result -ensureProperties ps = ensure ps NoChange +-- | Ensures the child properties, with a display of each as it runs. +ensureChildProperties :: [ChildProperty] -> Propellor Result +ensureChildProperties ps = ensure ps NoChange where ensure [] rs = return rs - ensure (l:ls) rs = do + ensure (p:ls) rs = do hn <- asks hostName - r <- actionMessageOn hn (propertyDesc l) (ensureProperty l) + r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p) ensure ls (r <> rs) -ensureProperty :: Property -> Propellor Result -ensureProperty = catchPropellor . propertySatisfy - --- | Lifts an action into a different host. +-- | Lifts an action into the context of a different host. -- --- For example, `fromHost hosts "otherhost" getSshPubKey` +-- > fromHost hosts "otherhost" Ssh.getHostPubKey fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) fromHost l hn getter = case findHost l hn of Nothing -> return Nothing - Just h -> liftIO $ Just <$> - runReaderT (runWithHost getter) h + Just h -> Just <$> fromHost' h getter + +fromHost' :: Host -> Propellor a -> Propellor a +fromHost' h getter = do + (ret, _s, runlog) <- liftIO $ runRWST (runWithHost getter) h () + tell runlog + return ret + +onlyProcess :: FilePath -> IO a -> IO a +onlyProcess lockfile a = bracket lock unlock (const a) + where + lock = do + createDirectoryIfMissing True (takeDirectory lockfile) + l <- createFile lockfile stdFileMode + setLock l (WriteLock, AbsoluteSeek, 0, 0) + `catchIO` const alreadyrunning + return l + unlock = closeFd + alreadyrunning = error "Propellor is already running on this host!" diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs new file mode 100644 index 00000000..c4666722 --- /dev/null +++ b/src/Propellor/EnsureProperty.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Propellor.EnsureProperty + ( ensureProperty + , property' + , OuterMetaTypesWitness(..) + ) where + +import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes +import Propellor.Exception + +import Data.Monoid +import Prelude + +-- | For when code running in the Propellor monad needs to ensure a +-- Property. +-- +-- Use `property'` to get the `OuterMetaTypesWithness`. For example: +-- +-- > foo = Property Debian +-- > foo = property' "my property" $ \w -> do +-- > ensureProperty w (aptInstall "foo") +-- +-- The type checker will prevent using ensureProperty with a property +-- that does not support the target OSes needed by the OuterMetaTypesWitness. +-- In the example above, aptInstall must support Debian, since foo +-- is supposed to support Debian. +-- +-- The type checker will also prevent using ensureProperty with a property +-- with HasInfo in its MetaTypes. Doing so would cause the `Info` associated +-- with the property to be lost. +ensureProperty + :: + ( Cannot_ensureProperty_WithInfo inner ~ 'True + , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine + ) + => OuterMetaTypesWitness outer + -> Property (MetaTypes inner) + -> Propellor Result +ensureProperty _ = catchPropellor . getSatisfy + +-- The name of this was chosen to make type errors a more understandable. +type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool +type instance Cannot_ensureProperty_WithInfo '[] = 'True +type instance Cannot_ensureProperty_WithInfo (t ': ts) = + Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts + +-- | Constructs a property, like `property`, but provides its +-- `OuterMetaTypesWitness`. +property' + :: SingI metatypes + => Desc + -> (OuterMetaTypesWitness metatypes -> Propellor Result) + -> Property (MetaTypes metatypes) +property' d a = + let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty + in p + +-- | Used to provide the metatypes of a Property to calls to +-- 'ensureProperty` within it. +newtype OuterMetaTypesWitness metatypes = OuterMetaTypesWitness (MetaTypes metatypes) + +outerMetaTypesWitness :: Property (MetaTypes l) -> OuterMetaTypesWitness l +outerMetaTypesWitness (Property metatypes _ _ _ _) = OuterMetaTypesWitness metatypes diff --git a/src/Propellor/Exception.hs b/src/Propellor/Exception.hs index f6fd15f1..2b38af0c 100644 --- a/src/Propellor/Exception.hs +++ b/src/Propellor/Exception.hs @@ -2,11 +2,11 @@ module Propellor.Exception where -import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M -import Control.Exception - import Propellor.Types import Propellor.Message +import Utility.Exception + +import Control.Exception (IOException) -- | Catches IO exceptions and returns FailedChange. catchPropellor :: Propellor Result -> Propellor Result @@ -15,4 +15,4 @@ catchPropellor a = either err return =<< tryPropellor a err e = warningMessage (show e) >> return FailedChange tryPropellor :: Propellor a -> Propellor (Either IOException a) -tryPropellor = M.try +tryPropellor = try diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs new file mode 100644 index 00000000..c3257b31 --- /dev/null +++ b/src/Propellor/Git.hs @@ -0,0 +1,28 @@ +module Propellor.Git where + +import Utility.Process +import Utility.Exception +import Utility.Directory + +import Control.Applicative +import Prelude + +getCurrentBranch :: IO String +getCurrentBranch = takeWhile (/= '\n') + <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"] + +getCurrentBranchRef :: IO String +getCurrentBranchRef = takeWhile (/= '\n') + <$> readProcess "git" ["symbolic-ref", "HEAD"] + +getCurrentGitSha1 :: String -> IO String +getCurrentGitSha1 branchref = takeWhile (/= '\n') + <$> readProcess "git" ["show-ref", "--hash", branchref] + +hasOrigin :: IO Bool +hasOrigin = catchDefaultIO False $ do + rs <- lines <$> readProcess "git" ["remote"] + return $ "origin" `elem` rs + +hasGitRepo :: IO Bool +hasGitRepo = doesFileExist ".git/HEAD" diff --git a/src/Propellor/Git/Config.hs b/src/Propellor/Git/Config.hs new file mode 100644 index 00000000..837fc0de --- /dev/null +++ b/src/Propellor/Git/Config.hs @@ -0,0 +1,49 @@ +module Propellor.Git.Config where + +import Propellor.Git +import Utility.Process +import Utility.Exception +import Utility.SafeCommand +import Utility.Monad + +import Control.Monad +import Control.Applicative +import Prelude + +getGitConfigValue :: String -> IO (Maybe String) +getGitConfigValue key = do + value <- catchMaybeIO $ + takeWhile (/= '\n') + <$> readProcess"git" ["config", key] + return $ case value of + Just v | not (null v) -> Just v + _ -> Nothing + +-- `git config --bool propellor.blah` outputs "false" if propellor.blah is unset +-- i.e. the git convention is that the default value of any git-config setting +-- is "false". So we don't need a Maybe Bool here. +getGitConfigBool :: String -> IO Bool +getGitConfigBool key = do + value <- catchMaybeIO $ + takeWhile (/= '\n') + <$> readProcess "git" ["config", "--bool", key] + return $ case value of + Just "true" -> True + _ -> False + +setRepoUrl :: String -> IO () +setRepoUrl "" = return () +setRepoUrl url = do + subcmd <- ifM hasOrigin (pure "set-url", pure "add") + void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url] + -- same as --set-upstream-to, except origin branch + -- may not have been pulled yet + branch <- getCurrentBranch + let branchval s = "branch." ++ branch ++ "." ++ s + void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"] + void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch] + +getRepoUrl :: IO (Maybe String) +getRepoUrl = getM getGitConfigValue urls + where + urls = ["remote.deploy.url", "remote.origin.url"] diff --git a/src/Propellor/Git/VerifiedBranch.hs b/src/Propellor/Git/VerifiedBranch.hs new file mode 100644 index 00000000..51fcb573 --- /dev/null +++ b/src/Propellor/Git/VerifiedBranch.hs @@ -0,0 +1,52 @@ +module Propellor.Git.VerifiedBranch where + +import Propellor.Base +import Propellor.Git +import Propellor.PrivData.Paths +import Utility.FileMode + +{- To verify origin branch commit's signature, have to convince gpg + - to use our keyring. + - While running git log. Which has no way to pass options to gpg. + - Argh! + -} +verifyOriginBranch :: String -> IO Bool +verifyOriginBranch originbranch = do + let gpgconf = privDataDir </> "gpg.conf" + keyring <- privDataKeyring + writeFile gpgconf $ unlines + [ " keyring " ++ keyring + , "no-auto-check-trustdb" + ] + -- gpg is picky about perms + modifyFileMode privDataDir (removeModes otherGroupModes) + s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch] + (Just [("GNUPGHOME", privDataDir)]) + nukeFile $ privDataDir </> "trustdb.gpg" + nukeFile $ privDataDir </> "pubring.gpg" + nukeFile $ privDataDir </> "gpg.conf" + return (s == "U\n" || s == "G\n") + +-- Returns True if HEAD is changed by fetching and merging from origin. +fetchOrigin :: IO Bool +fetchOrigin = do + branchref <- getCurrentBranch + let originbranch = "origin" </> branchref + + void $ actionMessage "Pull from central git repository" $ + boolSystem "git" [Param "fetch"] + + oldsha <- getCurrentGitSha1 branchref + + keyring <- privDataKeyring + whenM (doesFileExist keyring) $ + ifM (verifyOriginBranch originbranch) + ( do + putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging" + hFlush stdout + void $ boolSystem "git" [Param "merge", Param originbranch] + , warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)" + ) + + newsha <- getCurrentGitSha1 branchref + return $ oldsha /= newsha diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs new file mode 100644 index 00000000..b825d743 --- /dev/null +++ b/src/Propellor/Gpg.hs @@ -0,0 +1,185 @@ +module Propellor.Gpg where + +import System.IO +import Data.Maybe +import Data.List.Utils +import Control.Monad +import Control.Applicative +import Prelude + +import Propellor.PrivData.Paths +import Propellor.Message +import Propellor.Git.Config +import Utility.SafeCommand +import Utility.Process +import Utility.Process.NonConcurrent +import Utility.Monad +import Utility.Misc +import Utility.Tmp +import Utility.FileSystemEncoding +import Utility.Env +import Utility.Directory + +type KeyId = String + +getGpgBin :: IO String +getGpgBin = do + gitGpgBin <- getGitConfigValue "gpg.program" + case gitGpgBin of + Nothing -> getEnvDefault "GNUPGBIN" "gpg" + Just b -> return b + +-- Lists the keys in propellor's keyring. +listPubKeys :: IO [KeyId] +listPubKeys = do + keyring <- privDataKeyring + map fst <$> listKeys ("--list-public-keys" : useKeyringOpts keyring) + +listSecretKeys :: IO [(KeyId, String)] +listSecretKeys = listKeys ["--list-secret-keys"] + +listKeys :: [String] -> IO [(KeyId, String)] +listKeys ps = do + gpgbin <- getGpgBin + parse . lines <$> readProcess gpgbin listopts + where + listopts = ps ++ ["--with-colons"] + parse = mapMaybe (keyIdField . split ":") + keyIdField (t:_:_:_:f:_:_:_:_:n:_) + | t == "pub" || t == "sec" = Just (f, n) + keyIdField _ = Nothing + +useKeyringOpts :: FilePath -> [String] +useKeyringOpts keyring = + [ "--options" + , "/dev/null" + , "--no-default-keyring" + , "--keyring", keyring + ] + +addKey :: KeyId -> IO () +addKey keyid = do + gpgbin <- getGpgBin + keyring <- privDataKeyring + exitBool =<< allM (uncurry actionMessage) + [ ("adding key to propellor's keyring", addkeyring keyring gpgbin) + , ("staging propellor's keyring", gitAdd keyring) + , ("updating encryption of any privdata", reencryptPrivData) + , ("configuring git commit signing to use key", gitconfig gpgbin) + , ("committing changes", gitCommitKeyRing "add-key") + ] + where + addkeyring keyring' gpgbin' = do + createDirectoryIfMissing True privDataDir + boolSystem "sh" + [ Param "-c" + , Param $ gpgbin' ++ " --export " ++ keyid ++ " | gpg " ++ + unwords (useKeyringOpts keyring' ++ ["--import"]) + ] + + gitconfig gpgbin' = ifM (snd <$> processTranscript gpgbin' ["--list-secret-keys", keyid] Nothing) + ( boolSystem "git" + [ Param "config" + , Param "user.signingkey" + , Param keyid + ] + , do + warningMessage $ "Cannot find a secret key for key " ++ keyid ++ ", so not configuring git user.signingkey to use this key." + return True + ) + +rmKey :: KeyId -> IO () +rmKey keyid = do + gpgbin <- getGpgBin + keyring <- privDataKeyring + exitBool =<< allM (uncurry actionMessage) + [ ("removing key from propellor's keyring", rmkeyring keyring gpgbin) + , ("staging propellor's keyring", gitAdd keyring) + , ("updating encryption of any privdata", reencryptPrivData) + , ("configuring git commit signing to not use key", gitconfig) + , ("committing changes", gitCommitKeyRing "rm-key") + ] + where + rmkeyring keyring' gpgbin' = boolSystem gpgbin' $ + (map Param (useKeyringOpts keyring')) ++ + [ Param "--batch" + , Param "--yes" + , Param "--delete-key", Param keyid + ] + + gitconfig = ifM ((==) (keyid++"\n", True) <$> processTranscript "git" ["config", "user.signingkey"] Nothing) + ( boolSystem "git" + [ Param "config" + , Param "--unset" + , Param "user.signingkey" + ] + , return True + ) + +reencryptPrivData :: IO Bool +reencryptPrivData = do + f <- privDataFile + ifM (doesFileExist f) + ( do + gpgEncrypt f =<< gpgDecrypt f + gitAdd f + , return True + ) + +gitAdd :: FilePath -> IO Bool +gitAdd f = boolSystem "git" + [ Param "add" + , File f + ] + +gitCommitKeyRing :: String -> IO Bool +gitCommitKeyRing action = do + keyring <- privDataKeyring + privdata <- privDataFile + -- Commit explicitly the keyring and privdata files, as other + -- changes may be staged by the user and shouldn't be committed. + tocommit <- filterM doesFileExist [ privdata, keyring] + gitCommit (Just ("propellor " ++ action)) (map File tocommit) + +-- Adds --gpg-sign if there's a keyring. +gpgSignParams :: [CommandParam] -> IO [CommandParam] +gpgSignParams ps = do + keyring <- privDataKeyring + ifM (doesFileExist keyring) + ( return (ps ++ [Param "--gpg-sign"]) + , return ps + ) + +-- Automatically sign the commit if there'a a keyring. +gitCommit :: Maybe String -> [CommandParam] -> IO Bool +gitCommit msg ps = do + let ps' = Param "commit" : ps ++ + maybe [] (\m -> [Param "-m", Param m]) msg + ps'' <- gpgSignParams ps' + boolSystemNonConcurrent "git" ps'' + +gpgDecrypt :: FilePath -> IO String +gpgDecrypt f = do + gpgbin <- getGpgBin + ifM (doesFileExist f) + ( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing (Just fileEncoding) + , return "" + ) + +-- Encrypt file to all keys in propellor's keyring. +gpgEncrypt :: FilePath -> String -> IO () +gpgEncrypt f s = do + gpgbin <- getGpgBin + keyids <- listPubKeys + let opts = + [ "--default-recipient-self" + , "--armor" + , "--encrypt" + , "--trust-model", "always" + ] ++ concatMap (\k -> ["--recipient", k]) keyids + encrypted <- writeReadProcessEnv gpgbin opts Nothing (Just writer) Nothing + viaTmp writeFile f encrypted + where + writer h = do + fileEncoding h + hPutStr h s diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index f44d1de3..b87369c3 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -1,9 +1,30 @@ -{-# LANGUAGE PackageImports #-} - -module Propellor.Info where +{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} + +module Propellor.Info ( + osDebian, + osBuntish, + osFreeBSD, + setInfoProperty, + addInfoProperty, + pureInfoProperty, + pureInfoProperty', + askInfo, + getOS, + ipv4, + ipv6, + alias, + addDNS, + hostMap, + aliasMap, + findHost, + findHostNoAlias, + getAddresses, + hostAddresses, +) where import Propellor.Types import Propellor.Types.Info +import Propellor.Types.MetaTypes import "mtl" Control.Monad.Reader import qualified Data.Set as S @@ -11,29 +32,89 @@ import qualified Data.Map as M import Data.Maybe import Data.Monoid import Control.Applicative +import Prelude + +-- | Adds info to a Property. +-- +-- The new Property will include HasInfo in its metatypes. +setInfoProperty + :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + => Property metatypes + -> Info + -> Property (MetaTypes metatypes') +setInfoProperty (Property _ d a oldi c) newi = + Property sing d a (oldi <> newi) c + +-- | Adds more info to a Property that already HasInfo. +addInfoProperty + :: (IncludesInfo metatypes ~ 'True) + => Property metatypes + -> Info + -> Property metatypes +addInfoProperty (Property t d a oldi c) newi = + Property t d a (oldi <> newi) c + +-- | Makes a property that does nothing but set some `Info`. +pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike) +pureInfoProperty desc v = pureInfoProperty' desc (toInfo v) + +pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike) +pureInfoProperty' desc i = setInfoProperty p i + where + p :: Property UnixLike + p = property ("has " ++ desc) (return NoChange) + +-- | Gets a value from the host's Info. +askInfo :: (IsInfo v) => Propellor v +askInfo = asks (fromInfo . hostInfo) + +-- | Specifies that a host's operating system is Debian, +-- and further indicates the suite and architecture. +-- +-- This provides info for other Properties, so they can act +-- conditionally on the details of the OS. +-- +-- It also lets the type checker know that all the properties of the +-- host must support Debian. +-- +-- > & osDebian (Stable "jessie") "amd64" +osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian) +osDebian suite arch = tightenTargets $ os (System (Debian suite) arch) -pureInfoProperty :: Desc -> Info -> Property -pureInfoProperty desc = Property ("has " ++ desc) (return NoChange) +-- | Specifies that a host's operating system is a well-known Debian +-- derivative founded by a space tourist. +-- +-- (The actual name of this distribution is not used in Propellor per +-- <http://joeyh.name/blog/entry/trademark_nonsense/>) +osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish) +osBuntish release arch = tightenTargets $ os (System (Buntish release) arch) -askInfo :: (Info -> Val a) -> Propellor (Maybe a) -askInfo f = asks (fromVal . f . hostInfo) +-- | Specifies that a host's operating system is FreeBSD +-- and further indicates the release and architecture. +osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD) +osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch) -os :: System -> Property -os system = pureInfoProperty ("Operating " ++ show system) $ - mempty { _os = Val system } +os :: System -> Property (HasInfo + UnixLike) +os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system) +-- Gets the operating system of a host, if it has been specified. getOS :: Propellor (Maybe System) -getOS = askInfo _os +getOS = fromInfoVal <$> askInfo --- | Indidate that a host has an A record in the DNS. +-- | Indicate that a host has an A record in the DNS. +-- +-- When propellor is used to deploy a DNS server for a domain, +-- the hosts in the domain are found by looking for these +-- and similar properites. -- --- TODO check at run time if the host really has this address. --- (Can't change the host's address, but as a sanity check.) -ipv4 :: String -> Property +-- When propellor --spin is used to deploy a host, it checks +-- if the host's IP Property matches the DNS. If the DNS is missing or +-- out of date, the host will instead be contacted directly by IP address. +ipv4 :: String -> Property (HasInfo + UnixLike) ipv4 = addDNS . Address . IPv4 --- | Indidate that a host has an AAAA record in the DNS. -ipv6 :: String -> Property +-- | Indicate that a host has an AAAA record in the DNS. +ipv6 :: String -> Property (HasInfo + UnixLike) ipv6 = addDNS . Address . IPv6 -- | Indicates another name for the host in the DNS. @@ -42,16 +123,15 @@ ipv6 = addDNS . Address . IPv6 -- to use their address, rather than using a CNAME. This avoids various -- problems with CNAMEs, and also means that when multiple hosts have the -- same alias, a DNS round-robin is automatically set up. -alias :: Domain -> Property -alias d = pureInfoProperty ("alias " ++ d) $ mempty - { _aliases = S.singleton d +alias :: Domain -> Property (HasInfo + UnixLike) +alias d = pureInfoProperty' ("alias " ++ d) $ mempty + `addInfo` toAliasesInfo [d] -- A CNAME is added here, but the DNS setup code converts it to an -- IP address when that makes sense. - , _dns = S.singleton $ CNAME $ AbsDomain d - } + `addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d) -addDNS :: Record -> Property -addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r } +addDNS :: Record -> Property (HasInfo + UnixLike) +addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r)) where rdesc (CNAME d) = unwords ["alias", ddesc d] rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr] @@ -60,27 +140,23 @@ addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r } rdesc (NS d) = unwords ["NS", ddesc d] rdesc (TXT s) = unwords ["TXT", s] rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d] + rdesc (SSHFP x y s) = unwords ["SSHFP", show x, show y, s] + rdesc (INCLUDE f) = unwords ["$INCLUDE", f] + rdesc (PTR x) = unwords ["PTR", x] ddesc (AbsDomain domain) = domain ddesc (RelDomain domain) = domain ddesc RootDomain = "@" -sshPubKey :: String -> Property -sshPubKey k = pureInfoProperty ("ssh pubkey known") $ - mempty { _sshPubKey = Val k } - -getSshPubKey :: Propellor (Maybe String) -getSshPubKey = askInfo _sshPubKey - hostMap :: [Host] -> M.Map HostName Host -hostMap l = M.fromList $ zip (map hostName l) l +hostMap l = M.fromList $ zip (map hostName l) l aliasMap :: [Host] -> M.Map HostName Host aliasMap = M.fromList . concat . - map (\h -> map (\aka -> (aka, h)) $ S.toList $ _aliases $ hostInfo h) + map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h) findHost :: [Host] -> HostName -> Maybe Host -findHost l hn = maybe (findAlias l hn) Just (findHostNoAlias l hn) +findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn) findHostNoAlias :: [Host] -> HostName -> Maybe Host findHostNoAlias l hn = M.lookup hn (hostMap l) @@ -89,9 +165,7 @@ findAlias :: [Host] -> HostName -> Maybe Host findAlias l hn = M.lookup hn (aliasMap l) getAddresses :: Info -> [IPAddr] -getAddresses = mapMaybe getIPAddr . S.toList . _dns +getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo hostAddresses :: HostName -> [Host] -> [IPAddr] -hostAddresses hn hosts = case hostInfo <$> findHost hosts hn of - Nothing -> [] - Just info -> mapMaybe getIPAddr $ S.toList $ _dns info +hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn) diff --git a/src/Propellor/Location.hs b/src/Propellor/Location.hs new file mode 100644 index 00000000..3fc09538 --- /dev/null +++ b/src/Propellor/Location.hs @@ -0,0 +1,5 @@ +module Propellor.Location where + +-- | This is where propellor installs itself when deploying a host. +localdir :: FilePath +localdir = "/usr/local/propellor" diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index afbed1ca..32625e6a 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -1,66 +1,149 @@ -{-# LANGUAGE PackageImports #-} +-- | This module handles all display of output to the console when +-- propellor is ensuring Properties. +-- +-- When two threads both try to display a message concurrently, +-- the messages will be displayed sequentially. -module Propellor.Message where +module Propellor.Message ( + getMessageHandle, + isConsole, + forceConsole, + actionMessage, + actionMessageOn, + warningMessage, + infoMessage, + errorMessage, + processChainOutput, + messagesDone, + createProcessConcurrent, + withConcurrentOutput, +) where import System.Console.ANSI import System.IO -import System.Log.Logger -import "mtl" Control.Monad.Reader +import Control.Monad.IO.Class (liftIO, MonadIO) +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent +import System.Console.Concurrent +import Control.Applicative +import Prelude import Propellor.Types +import Utility.PartialPrelude +import Utility.Monad +import Utility.Exception + +data MessageHandle = MessageHandle + { isConsole :: Bool + } + +-- | A shared global variable for the MessageHandle. +{-# NOINLINE globalMessageHandle #-} +globalMessageHandle :: MVar MessageHandle +globalMessageHandle = unsafePerformIO $ + newMVar =<< MessageHandle + <$> catchDefaultIO False (hIsTerminalDevice stdout) + +-- | Gets the global MessageHandle. +getMessageHandle :: IO MessageHandle +getMessageHandle = readMVar globalMessageHandle + +-- | Force console output. This can be used when stdout is not directly +-- connected to a console, but is eventually going to be displayed at a +-- console. +forceConsole :: IO () +forceConsole = modifyMVar_ globalMessageHandle $ \mh -> + pure (mh { isConsole = True }) + +whenConsole :: String -> IO String +whenConsole s = ifM (isConsole <$> getMessageHandle) + ( pure s + , pure "" + ) -- | Shows a message while performing an action, with a colored status -- display. -actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r +actionMessage :: (MonadIO m, MonadMask m, ActionResult r) => Desc -> m r -> m r actionMessage = actionMessage' Nothing -- | Shows a message while performing an action on a specified host, -- with a colored status display. -actionMessageOn :: (MonadIO m, ActionResult r) => HostName -> Desc -> m r -> m r +actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r actionMessageOn = actionMessage' . Just -actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r +actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do - liftIO $ do - setTitle $ "propellor: " ++ desc - hFlush stdout + liftIO $ outputConcurrent + =<< whenConsole (setTitleCode $ "propellor: " ++ desc) r <- a - liftIO $ do - setTitle "propellor: running" - showhn mhn - putStr $ desc ++ " ... " - let (msg, intensity, color) = getActionResult r - colorLine intensity color msg - hFlush stdout + liftIO $ outputConcurrent . concat =<< sequence + [ whenConsole $ + setTitleCode "propellor: running" + , showhn mhn + , pure $ desc ++ " ... " + , let (msg, intensity, color) = getActionResult r + in colorLine intensity color msg + ] return r where - showhn Nothing = return () - showhn (Just hn) = do - setSGR [SetColor Foreground Dull Cyan] - putStr (hn ++ " ") - setSGR [] + showhn Nothing = return "" + showhn (Just hn) = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground Dull Cyan] + , pure (hn ++ " ") + , whenConsole $ + setSGRCode [] + ] warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s +warningMessage s = liftIO $ + outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) -colorLine :: ColorIntensity -> Color -> String -> IO () -colorLine intensity color msg = do - setSGR [SetColor Foreground intensity color] - putStr msg - setSGR [] +infoMessage :: MonadIO m => [String] -> m () +infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls + +errorMessage :: MonadIO m => String -> m a +errorMessage s = liftIO $ do + outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s) + error "Cannot continue!" + +colorLine :: ColorIntensity -> Color -> String -> IO String +colorLine intensity color msg = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground intensity color] + , pure msg + , whenConsole $ + setSGRCode [] -- Note this comes after the color is reset, so that -- the color set and reset happen in the same line. - putStrLn "" - hFlush stdout + , pure "\n" + ] -errorMessage :: String -> IO a -errorMessage s = do - liftIO $ colorLine Vivid Red $ "** error: " ++ s - error "Cannot continue!" +-- | Reads and displays each line from the Handle, except for the last line +-- which is a Result. +processChainOutput :: Handle -> IO Result +processChainOutput h = go Nothing + where + go lastline = do + v <- catchMaybeIO (hGetLine h) + case v of + Nothing -> case lastline of + Nothing -> do + return FailedChange + Just l -> case readish l of + Just r -> pure r + Nothing -> do + outputConcurrent (l ++ "\n") + return FailedChange + Just s -> do + outputConcurrent $ + maybe "" (\l -> if null l then "" else l ++ "\n") lastline + go (Just s) --- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1 -debug :: [String] -> IO () -debug = debugM "propellor" . unwords +-- | Called when all messages about properties have been printed. +messagesDone :: IO () +messagesDone = outputConcurrent + =<< whenConsole (setTitleCode "propellor: done") diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index f55ab74c..2e9cdbab 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -1,43 +1,73 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} -module Propellor.PrivData where +module Propellor.PrivData ( + withPrivData, + withSomePrivData, + addPrivData, + setPrivData, + unsetPrivData, + unsetPrivDataUnused, + dumpPrivData, + editPrivData, + filterPrivData, + listPrivDataFields, + makePrivDataDir, + decryptPrivData, + readPrivData, + readPrivDataFile, + PrivMap, + PrivInfo, + forceHostContext, +) where -import Control.Applicative -import System.FilePath import System.IO -import System.Directory import Data.Maybe -import Data.Monoid import Data.List +import Data.Typeable import Control.Monad import Control.Monad.IfElse import "mtl" Control.Monad.Reader import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.ByteString.Lazy as L +import Control.Applicative +import Data.Monoid +import Prelude import Propellor.Types +import Propellor.Types.PrivData +import Propellor.Types.MetaTypes import Propellor.Types.Info import Propellor.Message import Propellor.Info +import Propellor.Gpg +import Propellor.PrivData.Paths import Utility.Monad import Utility.PartialPrelude import Utility.Exception -import Utility.Process import Utility.Tmp import Utility.SafeCommand +import Utility.Process.NonConcurrent import Utility.Misc import Utility.FileMode import Utility.Env import Utility.Table +import Utility.FileSystemEncoding +import Utility.Directory -- | Allows a Property to access the value of a specific PrivDataField, --- for use in a specific Context. +-- for use in a specific Context or HostContext. -- -- Example use: -- -- > withPrivData (PrivFile pemfile) (Context "joeyh.name") $ \getdata -> -- > property "joeyh.name ssl cert" $ getdata $ \privdata -> --- > liftIO $ writeFile pemfile privdata +-- > liftIO $ writeFile pemfile (privDataVal privdata) -- > where pemfile = "/etc/ssl/certs/web.pem" -- -- Note that if the value is not available, the action is not run @@ -48,22 +78,73 @@ import Utility.Table -- being used, which is necessary to ensure that the privdata is sent to -- the remote host by propellor. withPrivData - :: PrivDataField - -> Context - -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property) - -> Property -withPrivData field context@(Context cname) mkprop = addinfo $ mkprop $ \a -> - maybe missing a =<< liftIO (getLocalPrivData field context) + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) + => s + -> c + -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes +withPrivData s = withPrivData' snd [s] + +-- Like withPrivData, but here any one of a list of PrivDataFields can be used. +withSomePrivData + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) + => [s] + -> c + -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes +withSomePrivData = withPrivData' id + +withPrivData' + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) + => ((PrivDataField, PrivData) -> v) + -> [s] + -> c + -> (((v -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes +withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> + maybe missing (a . feed) =<< getM get fieldlist where - missing = liftIO $ do - warningMessage $ "Missing privdata " ++ show field ++ " (for " ++ cname ++ ")" - putStrLn $ "Fix this by running: propellor --set '" ++ show field ++ "' '" ++ cname ++ "'" + get field = do + context <- mkHostContext hc <$> asks hostName + maybe Nothing (\privdata -> Just (field, privdata)) + <$> liftIO (getLocalPrivData field context) + missing = do + Context cname <- mkHostContext hc <$> asks hostName + warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")" + infoMessage $ + "Fix this by running:" : + showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) return FailedChange - addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = S.singleton (field, context) } } + addinfo p = p `addInfoProperty` (toInfo privset) + privset = PrivInfo $ S.fromList $ + map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist + fieldnames = map show fieldlist + fieldlist = map privDataField srclist + hc = asHostContext c + +showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> [String] +showSet = concatMap go + where + go (f, Context c, md) = catMaybes + [ Just $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\" + , maybe Nothing (\d -> Just $ " " ++ d) md + , Just "" + ] -addPrivDataField :: (PrivDataField, Context) -> Property -addPrivDataField v = pureInfoProperty (show v) $ - mempty { _privDataFields = S.singleton v } +addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property (HasInfo + UnixLike) +addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v)) {- Gets the requested field's value, in the specified context if it's - available, from the host's local privdata cache. -} @@ -73,103 +154,143 @@ getLocalPrivData field context = where localcache = catchDefaultIO Nothing $ readish <$> readFile privDataLocal -type PrivMap = M.Map (PrivDataField, Context) PrivData +type PrivMap = M.Map (PrivDataField, Context) String -{- Get only the set of PrivData that the Host's Info says it uses. -} +-- | Get only the set of PrivData that the Host's Info says it uses. filterPrivData :: Host -> PrivMap -> PrivMap filterPrivData host = M.filterWithKey (\k _v -> S.member k used) where - used = _privDataFields $ hostInfo host + used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $ + fromPrivInfo $ fromInfo $ hostInfo host getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData -getPrivData field context = M.lookup (field, context) +getPrivData field context m = do + s <- M.lookup (field, context) m + return (PrivData s) setPrivData :: PrivDataField -> Context -> IO () setPrivData field context = do putStrLn "Enter private data on stdin; ctrl-D when done:" - setPrivDataTo field context =<< hGetContentsStrict stdin + fileEncoding stdin + setPrivDataTo field context . PrivData =<< hGetContentsStrict stdin + +unsetPrivData :: PrivDataField -> Context -> IO () +unsetPrivData field context = do + modifyPrivData $ M.delete (field, context) + descUnset field context + +descUnset :: PrivDataField -> Context -> IO () +descUnset field context = + putStrLn $ "Private data unset: " ++ show field ++ " " ++ show context + +unsetPrivDataUnused :: [Host] -> IO () +unsetPrivDataUnused hosts = do + deleted <- modifyPrivData' $ \m -> + let (keep, del) = M.partitionWithKey (\k _ -> k `M.member` usedby) m + in (keep, M.keys del) + mapM_ (uncurry descUnset) deleted + where + usedby = mkUsedByMap hosts dumpPrivData :: PrivDataField -> Context -> IO () -dumpPrivData field context = - maybe (error "Requested privdata is not set.") putStrLn +dumpPrivData field context = do + maybe (error "Requested privdata is not set.") + (L.hPut stdout . privDataByteString) =<< (getPrivData field context <$> decryptPrivData) editPrivData :: PrivDataField -> Context -> IO () editPrivData field context = do v <- getPrivData field context <$> decryptPrivData - v' <- withTmpFile "propellorXXXX" $ \f h -> do - hClose h - maybe noop (writeFileProtected f) v + v' <- withTmpFile "propellorXXXX" $ \f th -> do + hClose th + maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v editor <- getEnvDefault "EDITOR" "vi" - unlessM (boolSystem editor [File f]) $ + unlessM (boolSystemNonConcurrent editor [File f]) $ error "Editor failed; aborting." - readFile f + PrivData <$> readFile f setPrivDataTo field context v' listPrivDataFields :: [Host] -> IO () listPrivDataFields hosts = do m <- decryptPrivData - showtable "Currently set data:" $ - map mkrow (M.keys m) - showtable "Data that would be used if set:" $ - map mkrow (M.keys $ M.difference wantedmap m) + + section "Currently set data:" + showtable $ map mkrow (M.keys m) + let missing = M.keys $ M.difference wantedmap m + + unless (null missing) $ do + section "Missing data that would be used if set:" + showtable $ map mkrow missing + + section "How to set missing data:" + mapM_ putStrLn $ showSet $ + map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing where header = ["Field", "Context", "Used by"] - mkrow k@(field, (Context context)) = + mkrow k@(field, Context context) = [ shellEscape $ show field , shellEscape context , intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby ] - mkhostmap host = M.fromList $ map (\k -> (k, [hostName host])) $ - S.toList $ _privDataFields $ hostInfo host - usedby = M.unionsWith (++) $ map mkhostmap hosts + usedby = mkUsedByMap hosts wantedmap = M.fromList $ zip (M.keys usedby) (repeat "") - showtable desc rows = do - putStrLn $ "\n" ++ desc + descmap = M.unions $ map (`mkPrivDataMap` id) hosts + section desc = putStrLn $ "\n" ++ desc + showtable rows = do putStr $ unlines $ formatTable $ tableWithHeader header rows +mkUsedByMap :: [Host] -> M.Map (PrivDataField, Context) [HostName] +mkUsedByMap = M.unionsWith (++) . map (\h -> mkPrivDataMap h $ const [hostName h]) + +mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a +mkPrivDataMap host mkv = M.fromList $ + map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) + (S.toList $ fromPrivInfo $ fromInfo $ hostInfo host) + setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () -setPrivDataTo field context value = do - makePrivDataDir - m <- decryptPrivData - let m' = M.insert (field, context) (chomp value) m - gpgEncrypt privDataFile (show m') +setPrivDataTo field context (PrivData value) = do + modifyPrivData set putStrLn "Private data set." - void $ boolSystem "git" [Param "add", File privDataFile] where - chomp s - | end s == "\n" = chomp (beginning s) - | otherwise = s + set = M.insert (field, context) value + +modifyPrivData :: (PrivMap -> PrivMap) -> IO () +modifyPrivData f = modifyPrivData' (\m -> (f m, ())) + +modifyPrivData' :: (PrivMap -> (PrivMap, a)) -> IO a +modifyPrivData' f = do + makePrivDataDir + m <- decryptPrivData + let (m', r) = f m + privdata <- privDataFile + gpgEncrypt privdata (show m') + void $ boolSystem "git" [Param "add", File privdata] + return r decryptPrivData :: IO PrivMap -decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile +decryptPrivData = readPrivData <$> (gpgDecrypt =<< privDataFile) -makePrivDataDir :: IO () -makePrivDataDir = createDirectoryIfMissing False privDataDir +readPrivData :: String -> PrivMap +readPrivData = fromMaybe M.empty . readish -privDataDir :: FilePath -privDataDir = "privdata" +readPrivDataFile :: FilePath -> IO PrivMap +readPrivDataFile f = readPrivData <$> readFileStrictAnyEncoding f -privDataFile :: FilePath -privDataFile = privDataDir </> "privdata.gpg" +makePrivDataDir :: IO () +makePrivDataDir = createDirectoryIfMissing False privDataDir -privDataLocal :: FilePath -privDataLocal = privDataDir </> "local" +newtype PrivInfo = PrivInfo + { fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) } + deriving (Eq, Ord, Show, Typeable, Monoid) -gpgDecrypt :: FilePath -> IO String -gpgDecrypt f = ifM (doesFileExist f) - ( readProcess "gpg" ["--decrypt", f] - , return "" - ) +-- PrivInfo is propagated out of containers, so that propellor can see which +-- hosts need it. +instance IsInfo PrivInfo where + propagateInfo _ = True -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 +-- | Sets the context of any privdata that uses HostContext to the +-- provided name. +forceHostContext :: String -> PrivInfo -> PrivInfo +forceHostContext name i = PrivInfo $ S.map go (fromPrivInfo i) + where + go (f, d, HostContext ctx) = (f, d, HostContext (const $ ctx name)) diff --git a/src/Propellor/PrivData/Paths.hs b/src/Propellor/PrivData/Paths.hs new file mode 100644 index 00000000..7410370b --- /dev/null +++ b/src/Propellor/PrivData/Paths.hs @@ -0,0 +1,31 @@ +module Propellor.PrivData.Paths where + +import Utility.Exception +import System.FilePath +import Control.Applicative +import Prelude + +privDataDir :: FilePath +privDataDir = "privdata" + +privDataFile :: IO FilePath +privDataFile = allowRelocate $ privDataDir </> "privdata.gpg" + +privDataKeyring :: IO FilePath +privDataKeyring = allowRelocate $ privDataDir </> "keyring.gpg" + +privDataLocal :: FilePath +privDataLocal = privDataDir </> "local" + +privDataRelay :: String -> FilePath +privDataRelay host = privDataDir </> "relay" </> host + +-- Allow relocating files in privdata, by checking for a file +-- privdata/relocate, which contains the path to a subdirectory that +-- contains the files. +allowRelocate :: FilePath -> IO FilePath +allowRelocate f = reloc . lines + <$> catchDefaultIO "" (readFile (privDataDir </> "relocate")) + where + reloc (p:_) | not (null p) = privDataDir </> p </> takeFileName f + reloc _ = f diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs new file mode 100644 index 00000000..fcac60bf --- /dev/null +++ b/src/Propellor/PropAccum.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} + +module Propellor.PropAccum + ( host + , Props(..) + , props + , (&) + , (&^) + , (!) + ) where + +import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core +import Propellor.Property + +import Data.Monoid +import Prelude + +-- | Defines a host and its properties. +-- +-- > host "example.com" $ props +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +host :: HostName -> Props metatypes -> Host +host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) + +-- | Start accumulating a list of properties. +-- +-- Properties can be added to it using `(&)` etc. +props :: Props UnixLike +props = Props [] + +infixl 1 & +infixl 1 &^ +infixl 1 ! + +type family GetMetaTypes x +type instance GetMetaTypes (Property (MetaTypes t)) = MetaTypes t +type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t + +-- | Adds a property to a Props. +-- +-- Can add Properties and RevertableProperties +(&) + :: + ( IsProp p + , MetaTypes y ~ GetMetaTypes p + , CheckCombinable x y ~ 'CanCombine + ) + => Props (MetaTypes x) + -> p + -> Props (MetaTypes (Combine x y)) +Props c & p = Props (c ++ [toChildProperty p]) + +-- | Adds a property before any other properties. +(&^) + :: + ( IsProp p + , MetaTypes y ~ GetMetaTypes p + , CheckCombinable x y ~ 'CanCombine + ) + => Props (MetaTypes x) + -> p + -> Props (MetaTypes (Combine x y)) +Props c &^ p = Props (toChildProperty p : c) + +-- | Adds a property in reverted form. +(!) + :: (CheckCombinable x z ~ 'CanCombine) + => Props (MetaTypes x) + -> RevertableProperty (MetaTypes y) (MetaTypes z) + -> Props (MetaTypes (Combine x z)) +Props c ! p = Props (c ++ [toChildProperty (revert p)]) diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 4b957317..af36ed58 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -1,58 +1,80 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} -module Propellor.Property where +module Propellor.Property ( + -- * Property combinators + requires + , before + , onChange + , onChangeFlagOnFail + , flagFile + , flagFile' + , check + , fallback + , revert + -- * Property descriptions + , describe + , (==>) + -- * Constructing properties + , Propellor + , property + , property' + , OuterMetaTypesWitness + , ensureProperty + , pickOS + , withOS + , unsupportedOS + , unsupportedOS' + , makeChange + , noChange + , doNothing + , endAction + -- * Property result checking + , UncheckedProperty + , unchecked + , changesFile + , changesFileContent + , isNewerThan + , checkResult + , Checkable + , assume +) where -import System.Directory +import System.FilePath import Control.Monad import Data.Monoid import Control.Monad.IfElse -import "mtl" Control.Monad.Reader +import "mtl" Control.Monad.RWS.Strict +import System.Posix.Files +import qualified Data.Hash.MD5 as MD5 +import Data.List +import Control.Applicative +import Prelude import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.ResultCheck +import Propellor.Types.MetaTypes +import Propellor.Types.Singletons import Propellor.Info -import Propellor.Engine +import Propellor.EnsureProperty +import Utility.Exception import Utility.Monad -import System.FilePath - --- Constructs a Property. -property :: Desc -> Propellor Result -> Property -property d s = Property d s mempty - --- | 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) (combineInfos ps) - --- | Combines a list of properties, resulting in one property that --- ensures each in turn. Does not stop on failure; does propigate --- overall success/failure. -combineProperties :: Desc -> [Property] -> Property -combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps) - where - go [] rs = return rs - go (l:ls) rs = do - r <- ensureProperty l - case r of - FailedChange -> return FailedChange - _ -> go ls (r <> rs) - --- | Combines together two properties, resulting in one property --- that ensures the first, and if the first succeeds, ensures the second. --- The property uses the description of the first property. -before :: Property -> Property -> Property -p1 `before` p2 = p2 `requires` p1 - `describe` (propertyDesc p1) +import Utility.Misc +import Utility.Directory -- | 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 i -> FilePath -> Property i flagFile p = flagFile' p . return -flagFile' :: Property -> IO FilePath -> Property -flagFile' p getflagfile = adjustProperty p $ \satisfy -> do +flagFile' :: Property i -> IO FilePath -> Property i +flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do flagfile <- liftIO getflagfile go satisfy flagfile =<< liftIO (doesFileExist flagfile) where @@ -65,107 +87,270 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do writeFile flagfile "" return r ---- | Whenever a change has to be made for a Property, causes a hook +-- | Indicates that the first property depends on the second, +-- so before the first is ensured, the second must be ensured. +-- +-- The combined property uses the description of the first property. +requires :: Combines x y => x -> y -> CombinedType x y +requires = combineWith + -- Run action of y, then x + (flip (<>)) + -- When reverting, run in reverse order. + (<>) + +-- | Combines together two properties, resulting in one property +-- that ensures the first, and if the first succeeds, ensures the second. +-- +-- The combined property uses the description of the first property. +before :: Combines x y => x -> y -> CombinedType x y +before = combineWith + -- Run action of x, then y + (<>) + -- When reverting, run in reverse order. + (flip (<>)) + +-- | 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 -p `onChange` hook = Property (propertyDesc p) satisfy (combineInfo p hook) +onChange + :: (Combines x y) + => x + -> y + -> CombinedType x y +onChange = combineWith combiner revertcombiner where - satisfy = do - r <- ensureProperty p + combiner p hook = do + r <- p case r of MadeChange -> do - r' <- ensureProperty hook + r' <- hook return $ r <> r' _ -> return r + revertcombiner = (<>) + +-- | Same as `onChange` except that if property y fails, a flag file +-- is generated. On next run, if the flag file is present, property y +-- is executed even if property x doesn't change. +-- +-- With `onChange`, if y fails, the property x `onChange` y returns +-- `FailedChange`. But if this property is applied again, it returns +-- `NoChange`. This behavior can cause trouble... +onChangeFlagOnFail + :: (Combines x y) + => FilePath + -> x + -> y + -> CombinedType x y +onChangeFlagOnFail flagfile = combineWith combiner revertcombiner + where + combiner s1 s2 = do + r1 <- s1 + case r1 of + MadeChange -> flagFailed s2 + _ -> ifM (liftIO $ doesFileExist flagfile) + (flagFailed s2 + , return r1 + ) + revertcombiner = (<>) + flagFailed s = do + r <- s + liftIO $ case r of + FailedChange -> createFlagFile + _ -> removeFlagFile + return r + createFlagFile = unlessM (doesFileExist flagfile) $ do + createDirectoryIfMissing True (takeDirectory flagfile) + writeFile flagfile "" + removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile -(==>) :: Desc -> Property -> Property +-- | Changes the description of a property. +describe :: IsProp p => p -> Desc -> p +describe = setDesc + +-- | Alias for @flip describe@ +(==>) :: IsProp (Property i) => Desc -> Property i -> Property i (==>) = flip describe infixl 1 ==> --- | Makes a Property only need to do anything when a test succeeds. -check :: IO Bool -> Property -> Property -check c p = adjustProperty p $ \satisfy -> ifM (liftIO c) - ( satisfy - , return NoChange - ) +-- | Tries the first property, but if it fails to work, instead uses +-- the second. +fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2 +fallback = combineWith combiner revertcombiner + where + combiner a1 a2 = do + r <- a1 + if r == FailedChange + then a2 + else return r + revertcombiner = (<>) --- | Marks a Property as trivial. It can only return FailedChange or --- NoChange. --- --- Useful when it's just as expensive to check if a change needs --- to be made as it is to just idempotently assure the property is --- satisfied. For example, chmodding a file. -trivial :: Property -> Property -trivial p = adjustProperty p $ \satisfy -> do - r <- satisfy - if r == MadeChange - then return NoChange - else return r - -doNothing :: Property -doNothing = property "noop property" noChange +-- | Indicates that a Property may change a particular file. When the file +-- is modified in any way (including changing its permissions or mtime), +-- the property will return MadeChange instead of NoChange. +changesFile :: Checkable p i => p i -> FilePath -> Property i +changesFile p f = checkResult getstat comparestat p + where + getstat = catchMaybeIO $ getSymbolicLinkStatus f + comparestat oldstat = do + newstat <- getstat + return $ if samestat oldstat newstat then NoChange else MadeChange + samestat Nothing Nothing = True + samestat (Just a) (Just b) = and + -- everything except for atime + [ deviceID a == deviceID b + , fileID a == fileID b + , fileMode a == fileMode b + , fileOwner a == fileOwner b + , fileGroup a == fileGroup b + , specialDeviceID a == specialDeviceID b + , fileSize a == fileSize b + , modificationTimeHiRes a == modificationTimeHiRes b + , isBlockDevice a == isBlockDevice b + , isCharacterDevice a == isCharacterDevice b + , isNamedPipe a == isNamedPipe b + , isRegularFile a == isRegularFile b + , isDirectory a == isDirectory b + , isSymbolicLink a == isSymbolicLink b + , isSocket a == isSocket b + ] + samestat _ _ = False --- | Makes a property that is satisfied differently depending on the host's --- operating system. --- --- Note that the operating system may not be declared for some hosts. -withOS :: Desc -> (Maybe System -> Propellor Result) -> Property -withOS desc a = property desc $ a =<< getOS - -boolProperty :: Desc -> IO Bool -> Property -boolProperty desc a = property desc $ ifM (liftIO a) - ( return MadeChange - , return FailedChange - ) - --- | Undoes the effect of a property. -revert :: RevertableProperty -> RevertableProperty -revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 +-- | Like `changesFile`, but compares the content of the file. +-- Changes to mtime etc that do not change file content are treated as +-- NoChange. +changesFileContent :: Checkable p i => p i -> FilePath -> Property i +changesFileContent p f = checkResult getmd5 comparemd5 p + where + getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f + comparemd5 oldmd5 = do + newmd5 <- getmd5 + return $ if oldmd5 == newmd5 then NoChange else MadeChange --- | Starts accumulating the properties of a Host. +-- | Determines if the first file is newer than the second file. -- --- > host "example.com" --- > & someproperty --- > ! oldproperty --- > & otherproperty -host :: HostName -> Host -host hn = Host hn [] mempty - --- | Adds a property to a Host +-- This can be used with `check` to only run a command when a file +-- has changed. -- --- Can add Properties and RevertableProperties -(&) :: IsProp p => Host -> p -> Host -(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) - -infixl 1 & - --- | Adds a property to the Host in reverted form. -(!) :: Host -> RevertableProperty -> Host -h ! p = h & revert p - -infixl 1 ! +-- > check ("/etc/aliases" `isNewerThan` "/etc/aliases.db") +-- > (cmdProperty "newaliases" [] `assume` MadeChange) -- updates aliases.db +-- +-- Or it can be used with `checkResult` to test if a command made a change. +-- +-- > checkResult (return ()) +-- > (\_ -> "/etc/aliases.db" `isNewerThan` "/etc/aliases") +-- > (cmdProperty "newaliases" []) +-- +-- (If one of the files does not exist, the file that does exist is +-- considered to be the newer of the two.) +isNewerThan :: FilePath -> FilePath -> IO Bool +isNewerThan x y = do + mx <- mtime x + my <- mtime y + return (mx > my) + where + mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f --- | Like (&), but adds the property as the first property of the host. --- Normally, property order should not matter, but this is useful --- when it does. -(&^) :: IsProp p => Host -> p -> Host -(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is) +-- | Picks one of the two input properties to use, +-- depending on the targeted OS. +-- +-- If both input properties support the targeted OS, then the +-- first will be used. +-- +-- The resulting property will use the description of the first property +-- no matter which property is used in the end. So, it's often a good +-- idea to change the description to something clearer. +-- +-- For example: +-- +-- > upgraded :: UnixLike +-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded) +-- > `describe` "OS upgraded" +-- +-- If neither input property supports the targeted OS, calls +-- `unsupportedOS`. Using the example above on a Fedora system would +-- fail that way. +pickOS + :: + ( SingKind ('KProxy :: KProxy ka) + , SingKind ('KProxy :: KProxy kb) + , DemoteRep ('KProxy :: KProxy ka) ~ [MetaType] + , DemoteRep ('KProxy :: KProxy kb) ~ [MetaType] + , SingI c + -- Would be nice to have this constraint, but + -- union will not generate metatypes lists with the same + -- order of OS's as is used everywhere else. So, + -- would need a type-level sort. + --, Union a b ~ c + ) + => Property (MetaTypes (a :: ka)) + -> Property (MetaTypes (b :: kb)) + -> Property (MetaTypes c) +pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] + where + -- This use of getSatisfy is safe, because both a and b + -- are added as children, so their info will propigate. + c = withOS (getDesc a) $ \_ o -> + if matching o a + then getSatisfy a + else if matching o b + then getSatisfy b + else unsupportedOS' + matching Nothing _ = False + matching (Just o) p = + Targeting (systemToTargetOS o) + `elem` + fromSing (proptype p) + proptype (Property t _ _ _ _) = t -infixl 1 &^ +-- | Makes a property that is satisfied differently depending on specifics +-- of the host's operating system. +-- +-- > myproperty :: Property Debian +-- > myproperty = withOS "foo installed" $ \w o -> case o of +-- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ... +-- > (Just (System (Debian suite) arch)) -> ensureProperty w ... +-- > _ -> unsupportedOS' +-- +-- Note that the operating system specifics may not be declared for all hosts, +-- which is where Nothing comes in. +withOS + :: (SingI metatypes) + => Desc + -> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result) + -> Property (MetaTypes metatypes) +withOS desc a = property desc $ a dummyoutermetatypes =<< getOS + where + -- Using this dummy value allows ensureProperty to be used + -- even though the inner property probably doesn't target everything + -- that the outer withOS property targets. + dummyoutermetatypes :: OuterMetaTypesWitness ('[]) + dummyoutermetatypes = OuterMetaTypesWitness sing --- Changes the action that is performed to satisfy a property. -adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property -adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } +-- | A property that always fails with an unsupported OS error. +unsupportedOS :: Property UnixLike +unsupportedOS = property "unsupportedOS" unsupportedOS' --- Combines the Info of two properties. -combineInfo :: (IsProp p, IsProp q) => p -> q -> Info -combineInfo p q = getInfo p <> getInfo q +-- | Throws an error, for use in `withOS` when a property is lacking +-- support for an OS. +unsupportedOS' :: Propellor Result +unsupportedOS' = go =<< getOS + where + go Nothing = error "Unknown host OS is not supported by this property." + go (Just o) = error $ "This property is not implemented for " ++ show o -combineInfos :: IsProp p => [p] -> Info -combineInfos = mconcat . map getInfo +-- | Undoes the effect of a RevertableProperty. +revert :: RevertableProperty setup undo -> RevertableProperty undo setup +revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 makeChange :: IO () -> Propellor Result makeChange a = liftIO a >> return MadeChange noChange :: Propellor Result noChange = return NoChange + +doNothing :: SingI t => Property (MetaTypes t) +doNothing = property "noop property" noChange + +-- | Registers an action that should be run at the very end, after +-- propellor has checks all the properties of a host. +endAction :: Desc -> (Result -> Propellor Result) -> Propellor () +endAction desc a = tell [EndAction desc a] diff --git a/src/Propellor/Property/Aiccu.hs b/src/Propellor/Property/Aiccu.hs new file mode 100644 index 00000000..1b28759c --- /dev/null +++ b/src/Propellor/Property/Aiccu.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Maintainer: Jelmer Vernooij <jelmer@samba.org> + +module Propellor.Property.Aiccu ( + installed, + restarted, + confPath, + UserName, + TunnelId, + hasConfig, +) where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.File as File + +installed :: Property DebianLike +installed = Apt.installed ["aiccu"] + +restarted :: Property DebianLike +restarted = Service.restarted "aiccu" + +confPath :: FilePath +confPath = "/etc/aiccu.conf" + +type TunnelId = String + +config :: UserName -> TunnelId -> PrivData -> [File.Line] +config u t p = + [ "protocol tic" + , "server tic.sixxs.net" + , "username " ++ u + , "password " ++ privDataVal p + , "ipv6_interface sixxs" + , "tunnel_id " ++ t + , "daemonize true" + , "automatic true" + , "requiretls true" + , "makebeats true" + ] + +-- | Configures an ipv6 tunnel using sixxs.net, with the given TunneId +-- and sixx.net UserName. +hasConfig :: TunnelId -> UserName -> Property (HasInfo + DebianLike) +hasConfig t u = prop `onChange` restarted + where + prop :: Property (HasInfo + UnixLike) + prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $ + property' "aiccu configured" . writeConfig + writeConfig getpassword w = getpassword $ ensureProperty w . go + go (Password u', p) = confPath `File.hasContentProtected` config u' t p + go (f, _) = error $ "Unexpected type of privdata: " ++ show f diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs index 1d9c35ce..f321143f 100644 --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -1,86 +1,109 @@ module Propellor.Property.Apache where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import Utility.SafeCommand +import qualified Propellor.Property.LetsEncrypt as LetsEncrypt -type ConfigFile = [String] +installed :: Property DebianLike +installed = Apt.installed ["apache2"] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty -siteEnabled hn cf = RevertableProperty enable disable - where - enable = check (not <$> isenabled) $ - cmdProperty "a2ensite" ["--quiet", hn] - `describe` ("apache site enabled " ++ hn) - `requires` siteAvailable hn cf +restarted :: Property DebianLike +restarted = Service.restarted "apache2" + +reloaded :: Property DebianLike +reloaded = Service.reloaded "apache2" + +type ConfigLine = String + +type ConfigFile = [ConfigLine] + +siteEnabled :: Domain -> ConfigFile -> RevertableProperty DebianLike DebianLike +siteEnabled domain cf = siteEnabled' domain cf <!> siteDisabled domain + +siteEnabled' :: Domain -> ConfigFile -> Property DebianLike +siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) $ props + & siteAvailable domain cf + `requires` installed + `onChange` reloaded + & check (not <$> isenabled) + (cmdProperty "a2ensite" ["--quiet", domain]) `requires` installed `onChange` reloaded - disable = combineProperties - ("apache site disabled " ++ hn) - (map File.notPresent (siteCfg hn)) - `onChange` cmdProperty "a2dissite" ["--quiet", hn] + where + isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param domain] + +siteDisabled :: Domain -> Property DebianLike +siteDisabled domain = combineProperties + ("apache site disabled " ++ domain) + (toProps $ map File.notPresent (siteCfg domain)) + `onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange) `requires` installed `onChange` reloaded - isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn] -siteAvailable :: HostName -> ConfigFile -> Property -siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $ - map (`File.hasContent` (comment:cf)) (siteCfg hn) +siteAvailable :: Domain -> ConfigFile -> Property DebianLike +siteAvailable domain cf = combineProperties ("apache site available " ++ domain) $ + toProps $ map tightenTargets $ + map (`File.hasContent` (comment:cf)) (siteCfg domain) where comment = "# deployed with propellor, do not modify" -modEnabled :: String -> RevertableProperty -modEnabled modname = RevertableProperty enable disable +modEnabled :: String -> RevertableProperty DebianLike DebianLike +modEnabled modname = enable <!> disable where - enable = check (not <$> isenabled) $ - cmdProperty "a2enmod" ["--quiet", modname] + enable = check (not <$> isenabled) + (cmdProperty "a2enmod" ["--quiet", modname]) `describe` ("apache module enabled " ++ modname) `requires` installed `onChange` reloaded - disable = check isenabled $ - cmdProperty "a2dismod" ["--quiet", modname] + disable = check isenabled + (cmdProperty "a2dismod" ["--quiet", modname]) `describe` ("apache module disabled " ++ modname) `requires` installed `onChange` reloaded isenabled = boolSystem "a2query" [Param "-q", Param "-m", Param modname] +-- | Make apache listen on the specified ports. +-- +-- Note that ports are also specified inside a site's config file, +-- so that also needs to be changed. +listenPorts :: [Port] -> Property DebianLike +listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps + `onChange` restarted + where + portline port = "Listen " ++ fromPort port + -- This is a list of config files because different versions of apache -- use different filenames. Propellor simply writes them all. -siteCfg :: HostName -> [FilePath] -siteCfg hn = +siteCfg :: Domain -> [FilePath] +siteCfg domain = -- Debian pre-2.4 - [ "/etc/apache2/sites-available/" ++ hn + [ "/etc/apache2/sites-available/" ++ domain -- Debian 2.4+ - , "/etc/apache2/sites-available/" ++ hn ++ ".conf" - ] - -installed :: Property -installed = Apt.installed ["apache2"] - -restarted :: Property -restarted = Service.restarted "apache2" - -reloaded :: Property -reloaded = Service.reloaded "apache2" + , "/etc/apache2/sites-available/" ++ domain ++ ".conf" + ] -- | Configure apache to use SNI to differentiate between -- https hosts. -multiSSL :: Property -multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent` - [ "NameVirtualHost *:443" - , "SSLStrictSNIVHostCheck off" - ] - `describe` "apache SNI enabled" - `onChange` reloaded +-- +-- This was off by default in apache 2.2.22. Newver versions enable +-- it by default. This property uses the filename used by the old version. +multiSSL :: Property DebianLike +multiSSL = check (doesDirectoryExist "/etc/apache2/conf.d") $ + "/etc/apache2/conf.d/ssl" `File.hasContent` + [ "NameVirtualHost *:443" + , "SSLStrictSNIVHostCheck off" + ] + `describe` "apache SNI enabled" + `onChange` reloaded -- | Config file fragment that can be inserted into a <Directory> -- stanza to allow global read access to the directory. -- -- Works with multiple versions of apache that have different ways to do -- it. -allowAll :: String +allowAll :: ConfigLine allowAll = unlines [ "<IfVersion < 2.4>" , "Order allow,deny" @@ -90,3 +113,102 @@ allowAll = unlines , "Require all granted" , "</IfVersion>" ] + +-- | Config file fragment that can be inserted into a <VirtualHost> +-- stanza to allow apache to display directory index icons. +iconDir :: ConfigLine +iconDir = unlines + [ "<Directory \"/usr/share/apache2/icons\">" + , "Options Indexes MultiViews" + , "AllowOverride None" + , allowAll + , " </Directory>" + ] + +type WebRoot = FilePath + +-- | A basic virtual host, publishing a directory, and logging to +-- the combined apache log file. Not https capable. +virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty DebianLike DebianLike +virtualHost domain port docroot = virtualHost' domain port docroot [] + +-- | Like `virtualHost` but with additional config lines added. +virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike +virtualHost' domain port docroot addedcfg = siteEnabled domain $ + [ "<VirtualHost *:" ++ fromPort port ++ ">" + , "ServerName " ++ domain ++ ":" ++ fromPort port + , "DocumentRoot " ++ docroot + , "ErrorLog /var/log/apache2/error.log" + , "LogLevel warn" + , "CustomLog /var/log/apache2/access.log combined" + , "ServerSignature On" + ] + ++ addedcfg ++ + [ "</VirtualHost>" + ] + +-- | A virtual host using https, with the certificate obtained +-- using `Propellor.Property.LetsEncrypt.letsEncrypt`. +-- +-- http connections are redirected to https. +-- +-- Example: +-- +-- > httpsVirtualHost "example.com" "/var/www" +-- > (LetsEncrypt.AgreeTOS (Just "me@my.domain")) +-- +-- Note that reverting this property does not remove the certificate from +-- letsencrypt's cert store. +httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty DebianLike DebianLike +httpsVirtualHost domain docroot letos = httpsVirtualHost' domain docroot letos [] + +-- | Like `httpsVirtualHost` but with additional config lines added. +httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty DebianLike DebianLike +httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown + where + setup = setuphttp + `requires` modEnabled "rewrite" + `requires` modEnabled "ssl" + `before` setuphttps + teardown = siteDisabled domain + setuphttp = siteEnabled' domain $ + -- The sslconffile is only created after letsencrypt gets + -- the cert. The "*" is needed to make apache not error + -- when the file doesn't exist. + ("IncludeOptional " ++ sslconffile "*") + : vhost (Port 80) + [ "RewriteEngine On" + -- Pass through .well-known directory on http for the + -- letsencrypt acme challenge. + , "RewriteRule ^/.well-known/(.*) - [L]" + -- Everything else redirects to https + , "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]" + ] + setuphttps = LetsEncrypt.letsEncrypt letos domain docroot + `onChange` postsetuphttps + postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props + & File.dirExists (takeDirectory cf) + & File.hasContent cf sslvhost + `onChange` reloaded + -- always reload since the cert has changed + & reloaded + where + cf = sslconffile "letsencrypt" + sslvhost = vhost (Port 443) + [ "SSLEngine on" + , "SSLCertificateFile " ++ LetsEncrypt.certFile domain + , "SSLCertificateKeyFile " ++ LetsEncrypt.privKeyFile domain + , "SSLCertificateChainFile " ++ LetsEncrypt.chainFile domain + ] + sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf" + vhost p ls = + [ "<VirtualHost *:" ++ fromPort p ++">" + , "ServerName " ++ domain ++ ":" ++ fromPort p + , "DocumentRoot " ++ docroot + , "ErrorLog /var/log/apache2/error.log" + , "LogLevel warn" + , "CustomLog /var/log/apache2/access.log combined" + , "ServerSignature On" + ] ++ ls ++ addedcfg ++ + [ "</VirtualHost>" + ] diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 7cf6c2b0..5e185a0e 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -1,12 +1,15 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Apt where import Data.Maybe -import Control.Applicative import Data.List import System.IO import Control.Monad +import Control.Applicative +import Prelude -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service import Propellor.Property.File (Line) @@ -29,6 +32,10 @@ backportSuite :: DebianSuite -> Maybe String backportSuite (Stable s) = Just (s ++ "-backports") backportSuite _ = Nothing +stableUpdatesSuite :: DebianSuite -> Maybe String +stableUpdatesSuite (Stable s) = Just (s ++ "-updates") +stableUpdatesSuite _ = Nothing + debLine :: String -> Url -> [Section] -> Line debLine suite mirror sections = unwords $ ["deb", mirror, suite] ++ sections @@ -55,7 +62,7 @@ binandsrc url suite = catMaybes return $ debLine bs url stdSections debCdn :: SourcesGenerator -debCdn = binandsrc "http://http.debian.net/debian" +debCdn = binandsrc "http://httpredir.debian.org/debian" kernelOrg :: SourcesGenerator kernelOrg = binandsrc "http://mirrors.kernel.org/debian" @@ -68,42 +75,41 @@ securityUpdates suite in [l, srcLine l] | otherwise = [] --- | Makes sources.list have a standard content using the mirror CDN, +-- | Makes sources.list have a standard content using the Debian mirror CDN, -- with the Debian suite configured by the os. -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. -stdSourcesList :: Property -stdSourcesList = withOS ("standard sources.list") $ \o -> - case o of - (Just (System (Debian suite) _)) -> - ensureProperty $ stdSourcesListFor suite - _ -> error "os is not declared to be Debian" - -stdSourcesListFor :: DebianSuite -> Property +stdSourcesList :: Property Debian +stdSourcesList = withOS "standard sources.list" $ \w o -> case o of + (Just (System (Debian suite) _)) -> + ensureProperty w $ stdSourcesListFor suite + _ -> unsupportedOS' + +stdSourcesListFor :: DebianSuite -> Property Debian stdSourcesListFor suite = stdSourcesList' suite [] -- | Adds additional sources.list generators. -- -- Note that if a Property needs to enable an apt source, it's better --- to do so via a separate file in /etc/apt/sources.list.d/ -stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property -stdSourcesList' suite more = setSourcesList +-- to do so via a separate file in </etc/apt/sources.list.d/> +stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian +stdSourcesList' suite more = tightenTargets $ setSourcesList (concatMap (\gen -> gen suite) generators) `describe` ("standard sources.list for " ++ show suite) where generators = [debCdn, kernelOrg, securityUpdates] ++ more -setSourcesList :: [Line] -> Property +setSourcesList :: [Line] -> Property DebianLike setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update -setSourcesListD :: [Line] -> FilePath -> Property +setSourcesListD :: [Line] -> FilePath -> Property DebianLike setSourcesListD ls basename = f `File.hasContent` ls `onChange` update where f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" -runApt :: [String] -> Property -runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv +runApt :: [String] -> UncheckedProperty DebianLike +runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv noninteractiveEnv :: [(String, String)] noninteractiveEnv = @@ -111,75 +117,93 @@ noninteractiveEnv = , ("APT_LISTCHANGES_FRONTEND", "none") ] -update :: Property -update = runApt ["update"] - `describe` "apt update" - -upgrade :: Property -upgrade = runApt ["-y", "dist-upgrade"] - `describe` "apt dist-upgrade" +-- | Have apt update its lists of packages, but without upgrading anything. +update :: Property DebianLike +update = combineProperties ("apt update") $ props + & pendingConfigured + & runApt ["update"] + `assume` MadeChange + +-- | Have apt upgrade packages, adding new packages and removing old as +-- necessary. Often used in combination with the `update` property. +upgrade :: Property DebianLike +upgrade = upgrade' "dist-upgrade" + +upgrade' :: String -> Property DebianLike +upgrade' p = combineProperties ("apt " ++ p) $ props + & pendingConfigured + & runApt ["-y", p] + `assume` MadeChange + +-- | Have apt upgrade packages, but never add new packages or remove +-- old packages. Not suitable for upgrading acrocess major versions +-- of the distribution. +safeUpgrade :: Property DebianLike +safeUpgrade = upgrade' "upgrade" + +-- | Have dpkg try to configure any packages that are not fully configured. +pendingConfigured :: Property DebianLike +pendingConfigured = tightenTargets $ + cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv + `assume` MadeChange + `describe` "dpkg configured pending" type Package = String -installed :: [Package] -> Property +installed :: [Package] -> Property DebianLike installed = installed' ["-y"] -installed' :: [String] -> [Package] -> Property +installed' :: [String] -> [Package] -> Property DebianLike installed' params ps = robustly $ check (isInstallable ps) go - `describe` (unwords $ "apt installed":ps) + `describe` unwords ("apt installed":ps) where - go = runApt $ params ++ ["install"] ++ ps + go = runApt (params ++ ["install"] ++ ps) -installedBackport :: [Package] -> Property -installedBackport ps = trivial $ withOS desc $ \o -> case o of - Nothing -> error "cannot install backports; os not declared" +installedBackport :: [Package] -> Property Debian +installedBackport ps = withOS desc $ \w o -> case o of (Just (System (Debian suite) _)) -> case backportSuite suite of - Nothing -> notsupported o - Just bs -> ensureProperty $ runApt $ - ["install", "-t", bs, "-y"] ++ ps - _ -> notsupported o + Nothing -> unsupportedOS' + Just bs -> ensureProperty w $ + runApt (["install", "-t", bs, "-y"] ++ ps) + `changesFile` dpkgStatus + _ -> unsupportedOS' where - desc = (unwords $ "apt installed backport":ps) - notsupported o = error $ "backports not supported on " ++ show o + desc = unwords ("apt installed backport":ps) -- | Minimal install of package, without recommends. -installedMin :: [Package] -> Property +installedMin :: [Package] -> Property DebianLike installedMin = installed' ["--no-install-recommends", "-y"] -removed :: [Package] -> Property -removed ps = check (or <$> isInstalled' ps) go - `describe` (unwords $ "apt removed":ps) - where - go = runApt $ ["-y", "remove"] ++ ps +removed :: [Package] -> Property DebianLike +removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps)) + `describe` unwords ("apt removed":ps) -buildDep :: [Package] -> Property -buildDep ps = robustly go - `describe` (unwords $ "apt build-dep":ps) +buildDep :: [Package] -> Property DebianLike +buildDep ps = robustly $ go + `changesFile` dpkgStatus + `describe` unwords ("apt build-dep":ps) where go = runApt $ ["-y", "build-dep"] ++ ps -- | Installs the build deps for the source package unpacked -- in the specifed directory, with a dummy package also -- installed so that autoRemove won't remove them. -buildDepIn :: FilePath -> Property -buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] +buildDepIn :: FilePath -> Property DebianLike +buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv + `changesFile` dpkgStatus + `requires` installedMin ["devscripts", "equivs"] where - go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"] - noninteractiveEnv + cmd = "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove" -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. -robustly :: Property -> Property -robustly p = adjustProperty p $ \satisfy -> do - r <- satisfy - if r == FailedChange - then ensureProperty $ p `requires` update - else return r +robustly :: Property DebianLike -> Property DebianLike +robustly p = p `fallback` (update `before` p) isInstallable :: [Package] -> IO Bool isInstallable ps = do l <- isInstalled' ps - return $ any (== False) l && not (null l) + return $ elem False l && not (null l) isInstalled :: Package -> IO Bool isInstalled p = (== [True]) <$> isInstalled' [p] @@ -189,25 +213,30 @@ isInstalled p = (== [True]) <$> isInstalled' [p] -- 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) +isInstalled' ps = (mapMaybe parse . lines) <$> policy where parse l | "Installed: (none)" `isInfixOf` l = Just False | "Installed: " `isInfixOf` l = Just True | otherwise = Nothing + policy = do + environ <- addEntry "LANG" "C" <$> getEnvironment + readProcessEnv "apt-cache" ("policy":ps) (Just environ) -autoRemove :: Property +autoRemove :: Property DebianLike autoRemove = runApt ["-y", "autoremove"] + `changesFile` dpkgStatus `describe` "apt autoremove" -- | Enables unattended upgrades. Revert to disable. -unattendedUpgrades :: RevertableProperty -unattendedUpgrades = RevertableProperty enable disable +unattendedUpgrades :: RevertableProperty DebianLike DebianLike +unattendedUpgrades = enable <!> disable where enable = setup True `before` Service.running "cron" `before` configure + -- work around http://bugs.debian.org/812380 + `before` File.notPresent "/etc/apt/apt.conf.d/50unattended-upgrades.ucf-dist" disable = setup False setup enabled = (if enabled then installed else removed) ["unattended-upgrades"] @@ -218,36 +247,64 @@ unattendedUpgrades = RevertableProperty enable disable v | enabled = "true" | otherwise = "false" - - configure = withOS "unattended upgrades configured" $ \o -> - case o of - -- the package defaults to only upgrading stable - (Just (System (Debian suite) _)) - | not (isStable suite) -> ensureProperty $ - "/etc/apt/apt.conf.d/50unattended-upgrades" - `File.containsLine` - ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") - _ -> noChange + + configure :: Property DebianLike + configure = propertyList "unattended upgrades configured" $ props + & enableupgrading + & unattendedconfig `File.containsLine` "Unattended-Upgrade::Mail \"root\";" + where + enableupgrading :: Property DebianLike + enableupgrading = withOS "unattended upgrades configured" $ \w o -> + case o of + -- the package defaults to only upgrading stable + (Just (System (Debian suite) _)) + | not (isStable suite) -> ensureProperty w $ + unattendedconfig + `File.containsLine` + ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") + _ -> noChange + unattendedconfig = "/etc/apt/apt.conf.d/50unattended-upgrades" + +-- | Enable periodic updates (but not upgrades), including download +-- of packages. +periodicUpdates :: Property DebianLike +periodicUpdates = tightenTargets $ "/etc/apt/apt.conf.d/02periodic" `File.hasContent` + [ "APT::Periodic::Enable \"1\";" + , "APT::Periodic::Update-Package-Lists \"1\";" + , "APT::Periodic::Download-Upgradeable-Packages \"1\";" + , "APT::Periodic::Verbose \"1\";" + ] + +type DebconfTemplate = String +type DebconfTemplateType = String +type DebconfTemplateValue = String -- | 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) +reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike +reConfigure package vals = tightenTargets $ + reconfigure + `requires` setselections + `describe` ("reconfigure " ++ package) where - setselections = property "preseed" $ makeChange $ - withHandle StdinHandle createProcessSuccess - (proc "debconf-set-selections" []) $ \h -> do - forM_ vals $ \(tmpl, tmpltype, value) -> - hPutStrLn h $ unwords [package, tmpl, tmpltype, value] - hClose h - reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv + setselections :: Property DebianLike + setselections = property "preseed" $ + if null vals + then noChange + else makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "debconf-set-selections" []) $ \h -> do + forM_ vals $ \(tmpl, tmpltype, value) -> + hPutStrLn h $ unwords [package, tmpl, tmpltype, value] + hClose h + reconfigure = cmdPropertyEnv "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv + `assume` MadeChange -- | Ensures that a service is installed and running. -- -- Assumes that there is a 1:1 mapping between service names and apt -- package names. -serviceInstalledRunning :: Package -> Property +serviceInstalledRunning :: Package -> Property DebianLike serviceInstalledRunning svc = Service.running svc `requires` installed [svc] data AptKey = AptKey @@ -255,21 +312,41 @@ data AptKey = AptKey , pubkey :: String } -trustsKey :: AptKey -> RevertableProperty -trustsKey k = RevertableProperty trust untrust +trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike +trustsKey k = trustsKey' k <!> untrustKey k + +trustsKey' :: AptKey -> Property DebianLike +trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do + withHandle StdinHandle createProcessSuccess + (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do + hPutStr h (pubkey k) + hClose h + nukeFile $ f ++ "~" -- gpg dropping where desc = "apt trusts key " ++ keyname k - f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg" - untrust = File.notPresent f - trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do - withHandle StdinHandle createProcessSuccess - (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do - hPutStr h (pubkey k) - hClose h - nukeFile $ f ++ "~" -- gpg dropping + f = aptKeyFile k + +untrustKey :: AptKey -> Property DebianLike +untrustKey = tightenTargets . File.notPresent . aptKeyFile + +aptKeyFile :: AptKey -> FilePath +aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg" -- | Cleans apt's cache of downloaded packages to avoid using up disk -- space. -cacheCleaned :: Property -cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"] - `describe` "apt cache cleaned" +cacheCleaned :: Property DebianLike +cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"] + `assume` NoChange + `describe` "apt cache cleaned" + +-- | Add a foreign architecture to dpkg and apt. +hasForeignArch :: String -> Property DebianLike +hasForeignArch arch = check notAdded (add `before` update) + `describe` ("dpkg has foreign architecture " ++ arch) + where + notAdded = (notElem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"] + add = cmdProperty "dpkg" ["--add-architecture", arch] + `assume` MadeChange + +dpkgStatus :: FilePath +dpkgStatus = "/var/lib/dpkg/status" diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs new file mode 100644 index 00000000..49fa9fa7 --- /dev/null +++ b/src/Propellor/Property/Apt/PPA.hs @@ -0,0 +1,115 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- Personal Package Archives +module Propellor.Property.Apt.PPA where + +import Data.List +import Control.Applicative +import Prelude +import Data.String.Utils +import Data.String (IsString(..)) +import Propellor.Base +import qualified Propellor.Property.Apt as Apt + +-- | Ensure software-properties-common is installed. +installed :: Property DebianLike +installed = Apt.installed ["software-properties-common"] + +-- | Personal Package Archives are people's individual package +-- contributions to the Buntish distro. There's a well-known format for +-- representing them, and this type represents that. It's also an instance +-- of 'Show' and 'IsString' so it can work with 'OverloadedStrings'. +-- More on PPAs can be found at <https://help.launchpad.net/Packaging/PPA> +data PPA = PPA + { ppaAccount :: String -- ^ The Launchpad account hosting this archive. + , ppaArchive :: String -- ^ The name of the archive. + } deriving (Eq, Ord) + +instance Show PPA where + show p = concat ["ppa:", ppaAccount p, "/", ppaArchive p] + +instance IsString PPA where + -- | Parse strings like "ppa:zfs-native/stable" into a PPA. + fromString s = + let + [_, ppa] = split "ppa:" s + [acct, arch] = split "/" ppa + in + PPA acct arch + +-- | Adds a PPA to the local system repositories. +addPpa :: PPA -> Property DebianLike +addPpa p = + cmdPropertyEnv "apt-add-repository" ["--yes", show p] Apt.noninteractiveEnv + `assume` MadeChange + `describe` ("Added PPA " ++ (show p)) + `requires` installed + +-- | A repository key ID to be downloaded with apt-key. +data AptKeyId = AptKeyId + { akiName :: String + , akiId :: String + , akiServer :: String + } deriving (Eq, Ord) + +instance Show AptKeyId where + show k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k] + +-- | Adds an 'AptKeyId' from the specified GPG server. +addKeyId :: AptKeyId -> Property DebianLike +addKeyId keyId = + check keyTrusted akcmd + `describe` (unwords ["Add third-party Apt key", show keyId]) + where + akcmd = + tightenTargets $ cmdProperty "apt-key" ["adv", "--keyserver", akiServer keyId, "--recv-keys", akiId keyId] + keyTrusted = + let + pks ls = concatMap (drop 1 . split "/") + $ concatMap (take 1 . drop 1 . words) + $ filter (\l -> "pub" `isPrefixOf` l) + $ lines ls + nkid = take 8 (akiId keyId) + in + (isInfixOf [nkid] . pks) <$> readProcess "apt-key" ["list"] + +-- | An Apt source line that apt-add-repository will just add to +-- sources.list. It's also an instance of both 'Show' and 'IsString' to make +-- using 'OverloadedStrings' in the configuration file easier. +-- +-- | FIXME there's apparently an optional "options" fragment that I've +-- definitely not parsed here. +data AptSource = AptSource + { asURL :: Apt.Url -- ^ The URL hosting the repository + , asSuite :: String -- ^ The operating system suite + , asComponents :: [String] -- ^ The list of components to install from this repository. + } deriving (Eq, Ord) + +instance Show AptSource where + show asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc] + +instance IsString AptSource where + fromString s = + let + url:suite:comps = drop 1 . words $ s + in + AptSource url suite comps + +-- | A repository for apt-add-source, either a PPA or a regular repository line. +data AptRepository = AptRepositoryPPA PPA | AptRepositorySource AptSource + +-- | Adds an 'AptRepository' using apt-add-source. +addRepository :: AptRepository -> Property DebianLike +addRepository (AptRepositoryPPA p) = addPpa p +addRepository (AptRepositorySource src) = + check repoExists addSrc + `describe` unwords ["Adding APT repository", show src] + `requires` installed + where + allSourceLines = + readProcess "/bin/sh" ["-c", "cat /etc/apt/sources.list /etc/apt/sources.list.d/*"] + activeSources = map (\s -> fromString s :: AptSource ) + . filter (not . isPrefixOf "#") + . filter (/= "") . lines <$> allSourceLines + repoExists = isInfixOf [src] <$> activeSources + addSrc = cmdProperty "apt-add-source" [show src] diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs new file mode 100644 index 00000000..4415f8c0 --- /dev/null +++ b/src/Propellor/Property/Attic.hs @@ -0,0 +1,149 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Support for the Attic backup tool <https://attic-backup.org/> + +module Propellor.Property.Attic + ( installed + , repoExists + , init + , restored + , backup + , KeepPolicy (..) + ) where + +import Propellor.Base hiding (init) +import Prelude hiding (init) +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import Data.List (intercalate) + +type AtticParam = String + +type AtticRepo = FilePath + +installed :: Property DebianLike +installed = Apt.installed ["attic"] + +repoExists :: AtticRepo -> IO Bool +repoExists repo = boolSystem "attic" [Param "list", File repo] + +-- | Inits a new attic repository +init :: AtticRepo -> Property DebianLike +init backupdir = check (not <$> repoExists backupdir) (cmdProperty "attic" initargs) + `requires` installed + where + initargs = + [ "init" + , backupdir + ] + +-- | Restores a directory from an attic backup. +-- +-- Only does anything if the directory does not exist, or exists, +-- but is completely empty. +-- +-- The restore is performed atomically; restoring to a temp directory +-- and then moving it to the directory. +restored :: FilePath -> AtticRepo -> Property DebianLike +restored dir backupdir = go `requires` installed + where + go :: Property DebianLike + go = property (dir ++ " restored by attic") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "attic-restore" $ \tmpdir -> do + ok <- boolSystem "attic" $ + [ Param "extract" + , Param backupdir + , Param tmpdir + ] + let restoreddir = tmpdir ++ "/" ++ dir + ifM (pure ok <&&> doesDirectoryExist restoreddir) + ( do + void $ tryIO $ removeDirectory dir + renameDirectory restoreddir dir + return MadeChange + , return FailedChange + ) + +-- | Installs a cron job that causes a given directory to be backed +-- up, by running attic with some parameters. +-- +-- If the directory does not exist, or exists but is completely empty, +-- this Property will immediately restore it from an existing backup. +-- +-- So, this property can be used to deploy a directory of content +-- to a host, while also ensuring any changes made to it get backed up. +-- For example: +-- +-- > & Attic.backup "/srv/git" "root@myserver:/mnt/backup/git.attic" Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Attic.KeepDays 7, Attic.KeepWeeks 4, Attic.KeepMonths 6, Attic.KeepYears 1] +-- +-- Note that this property does not make attic encrypt the backup +-- repository. +-- +-- Since attic uses a fair amount of system resources, only one attic +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike +backup dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp + `requires` restored dir backupdir + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike +backup' dir backupdir crontimes extraargs kp = cronjob + `describe` desc + `requires` installed + where + desc = backupdir ++ " attic backup" + cronjob = Cron.niceJob ("attic_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + lockfile = "/var/lock/propellor-attic.lock" + backupcmd = intercalate ";" $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "attic" + , "create" + , "--stats" + ] + ++ map shellEscape extraargs ++ + [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "attic" + , "prune" + , shellEscape backupdir + ] + ++ + map keepParam kp + +-- | Constructs an AtticParam that specifies which old backup generations to +-- keep. By default, all generations are kept. However, when this parameter is +-- passed to the `backup` property, they will run attic prune to clean out +-- generations not specified here. +keepParam :: KeepPolicy -> AtticParam +keepParam (KeepHours n) = "--keep-hourly=" ++ show n +keepParam (KeepDays n) = "--keep-daily=" ++ show n +keepParam (KeepWeeks n) = "--keep-daily=" ++ show n +keepParam (KeepMonths n) = "--keep-monthly=" ++ show n +keepParam (KeepYears n) = "--keep-yearly=" ++ show n + +-- | Policy for backup generations to keep. For example, KeepDays 30 will +-- keep the latest backup for each day when a backup was made, and keep the +-- last 30 such backups. When multiple KeepPolicies are combined together, +-- backups meeting any policy are kept. See attic's man page for details. +data KeepPolicy + = KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs new file mode 100644 index 00000000..f5842115 --- /dev/null +++ b/src/Propellor/Property/Borg.hs @@ -0,0 +1,155 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Support for the Borg backup tool <https://github.com/borgbackup> + +module Propellor.Property.Borg + ( installed + , repoExists + , init + , restored + , backup + , KeepPolicy (..) + ) where + +import Propellor.Base hiding (init) +import Prelude hiding (init) +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import Data.List (intercalate) + +type BorgParam = String + +type BorgRepo = FilePath + +installed :: Property DebianLike +installed = withOS desc $ \w o -> case o of + (Just (System (Debian (Stable "jessie")) _)) -> ensureProperty w $ + Apt.installedBackport ["borgbackup"] + _ -> ensureProperty w $ + Apt.installed ["borgbackup"] + where + desc = "installed borgbackup" + +repoExists :: BorgRepo -> IO Bool +repoExists repo = boolSystem "borg" [Param "list", File repo] + +-- | Inits a new borg repository +init :: BorgRepo -> Property DebianLike +init backupdir = check (not <$> repoExists backupdir) (cmdProperty "borg" initargs) + `requires` installed + where + initargs = + [ "init" + , backupdir + ] + +-- | Restores a directory from an borg backup. +-- +-- Only does anything if the directory does not exist, or exists, +-- but is completely empty. +-- +-- The restore is performed atomically; restoring to a temp directory +-- and then moving it to the directory. +restored :: FilePath -> BorgRepo -> Property DebianLike +restored dir backupdir = go `requires` installed + where + go :: Property DebianLike + go = property (dir ++ " restored by borg") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do + ok <- boolSystem "borg" $ + [ Param "extract" + , Param backupdir + , Param tmpdir + ] + let restoreddir = tmpdir ++ "/" ++ dir + ifM (pure ok <&&> doesDirectoryExist restoreddir) + ( do + void $ tryIO $ removeDirectory dir + renameDirectory restoreddir dir + return MadeChange + , return FailedChange + ) + +-- | Installs a cron job that causes a given directory to be backed +-- up, by running borg with some parameters. +-- +-- If the directory does not exist, or exists but is completely empty, +-- this Property will immediately restore it from an existing backup. +-- +-- So, this property can be used to deploy a directory of content +-- to a host, while also ensuring any changes made to it get backed up. +-- For example: +-- +-- > & Borg.backup "/srv/git" "root@myserver:/mnt/backup/git.borg" Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Borg.KeepDays 7, Borg.KeepWeeks 4, Borg.KeepMonths 6, Borg.KeepYears 1] +-- +-- Note that this property does not make borg encrypt the backup +-- repository. +-- +-- Since borg uses a fair amount of system resources, only one borg +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike +backup dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp + `requires` restored dir backupdir + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike +backup' dir backupdir crontimes extraargs kp = cronjob + `describe` desc + `requires` installed + where + desc = backupdir ++ " borg backup" + cronjob = Cron.niceJob ("borg_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + lockfile = "/var/lock/propellor-borg.lock" + backupcmd = intercalate ";" $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "borg" + , "create" + , "--stats" + ] + ++ map shellEscape extraargs ++ + [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "borg" + , "prune" + , shellEscape backupdir + ] + ++ + map keepParam kp + +-- | Constructs an BorgParam that specifies which old backup generations to +-- keep. By default, all generations are kept. However, when this parameter is +-- passed to the `backup` property, they will run borg prune to clean out +-- generations not specified here. +keepParam :: KeepPolicy -> BorgParam +keepParam (KeepHours n) = "--keep-hourly=" ++ show n +keepParam (KeepDays n) = "--keep-daily=" ++ show n +keepParam (KeepWeeks n) = "--keep-daily=" ++ show n +keepParam (KeepMonths n) = "--keep-monthly=" ++ show n +keepParam (KeepYears n) = "--keep-yearly=" ++ show n + +-- | Policy for backup generations to keep. For example, KeepDays 30 will +-- keep the latest backup for each day when a backup was made, and keep the +-- last 30 such backups. When multiple KeepPolicies are combined together, +-- backups meeting any policy are kept. See borg's man page for details. +data KeepPolicy + = KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/Ccache.hs b/src/Propellor/Property/Ccache.hs new file mode 100644 index 00000000..f2246fe1 --- /dev/null +++ b/src/Propellor/Property/Ccache.hs @@ -0,0 +1,110 @@ +-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name> + +module Propellor.Property.Ccache ( + hasCache, + hasLimits, + Limit(..), + DataSize, +) where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +import Utility.FileMode +import Utility.DataUnits +import System.Posix.Files + +-- | Limits on the size of a ccache +data Limit + -- | The maximum size of the cache, as a string such as "4G" + = MaxSize DataSize + -- | The maximum number of files in the cache + | MaxFiles Integer + -- | A cache with no limit specified + | NoLimit + | Limit :+ Limit + +instance Monoid Limit where + mempty = NoLimit + mappend = (:+) + +-- | A string that will be parsed to get a data size. +-- +-- Examples: "100 megabytes" or "0.5tb" +type DataSize = String + +maxSizeParam :: DataSize -> Maybe String +maxSizeParam s = readSize dataUnits s + >>= \sz -> Just $ "--max-size=" ++ ccacheSizeUnits sz + +-- Generates size units as used in ccache.conf. The smallest unit we can +-- specify in a ccache config files is a kilobyte +ccacheSizeUnits :: Integer -> String +ccacheSizeUnits sz = filter (/= ' ') (roughSize cfgfileunits True sz) + where + cfgfileunits :: [Unit] + cfgfileunits = + [ Unit (p 4) "Ti" "terabyte" + , Unit (p 3) "Gi" "gigabyte" + , Unit (p 2) "Mi" "megabyte" + , Unit (p 1) "Ki" "kilobyte" + ] + p :: Integer -> Integer + p n = 1024^n + +-- | Set limits on a given ccache +hasLimits :: FilePath -> Limit -> Property DebianLike +path `hasLimits` limit = go `requires` installed + where + go + | null params' = doNothing + -- We invoke ccache itself to set the limits, so that it can + -- handle replacing old limits in the config file, duplicates + -- etc. + | null errors = + cmdPropertyEnv "ccache" params' [("CCACHE_DIR", path)] + `changesFileContent` (path </> "ccache.conf") + | otherwise = property "couldn't parse ccache limits" $ + sequence_ (errorMessage <$> errors) + >> return FailedChange + + params = limitToParams limit + (errors, params') = partitionEithers params + +limitToParams :: Limit -> [Either String String] +limitToParams NoLimit = [] +limitToParams (MaxSize s) = case maxSizeParam s of + Just param -> [Right param] + Nothing -> [Left $ "unable to parse data size " ++ s] +limitToParams (MaxFiles f) = [Right $ "--max-files=" ++ show f] +limitToParams (l1 :+ l2) = limitToParams l1 <> limitToParams l2 + +-- | Configures a ccache in /var/cache for a group +-- +-- If you say +-- +-- > & (Group "foo") `Ccache.hasGroupCache` +-- > (Ccache.MaxSize "4G" <> Ccache.MaxFiles 10000) +-- +-- you instruct propellor to create a ccache in /var/cache/ccache-foo owned and +-- writeable by the foo group, with a maximum cache size of 4GB or 10000 files. +hasCache :: Group -> Limit -> RevertableProperty DebianLike UnixLike +group@(Group g) `hasCache` limit = (make `requires` installed) <!> delete + where + make = propertyList ("ccache for " ++ g ++ " group exists") $ props + & File.dirExists path + & File.ownerGroup path (User "root") group + & File.mode path (combineModes $ + readModes ++ executeModes + ++ [ownerWriteMode, groupWriteMode]) + & hasLimits path limit + + delete = check (doesDirectoryExist path) $ + cmdProperty "rm" ["-r", path] `assume` MadeChange + `describe` ("ccache for " ++ g ++ " does not exist") + + path = "/var/cache/ccache-" ++ g + +installed :: Property DebianLike +installed = Apt.installed ["ccache"] diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs new file mode 100644 index 00000000..09047ce5 --- /dev/null +++ b/src/Propellor/Property/Chroot.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-} + +module Propellor.Property.Chroot ( + debootstrapped, + bootstrapped, + provisioned, + Chroot(..), + ChrootBootstrapper(..), + Debootstrapped(..), + ChrootTarball(..), + noServices, + inChroot, + -- * Internal use + provisioned', + propagateChrootInfo, + propellChroot, + chain, + chrootSystem, +) where + +import Propellor.Base +import Propellor.Container +import Propellor.Types.CmdLine +import Propellor.Types.Chroot +import Propellor.Types.Info +import Propellor.Types.Core +import Propellor.Property.Chroot.Util +import qualified Propellor.Property.Debootstrap as Debootstrap +import qualified Propellor.Property.Systemd.Core as Systemd +import qualified Propellor.Property.File as File +import qualified Propellor.Shim as Shim +import Propellor.Property.Mount +import Utility.FileMode + +import qualified Data.Map as M +import Data.List.Utils +import System.Posix.Directory +import System.Console.Concurrent + +-- | Specification of a chroot. Normally you'll use `debootstrapped` or +-- `bootstrapped` to construct a Chroot value. +data Chroot where + Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot + +instance IsContainer Chroot where + containerProperties (Chroot _ _ h) = containerProperties h + containerInfo (Chroot _ _ h) = containerInfo h + setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) + +chrootSystem :: Chroot -> Maybe System +chrootSystem = fromInfoVal . fromInfo . containerInfo + +instance Show Chroot where + show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) + +-- | Class of things that can do initial bootstrapping of an operating +-- System in a chroot. +class ChrootBootstrapper b where + -- | Do initial bootstrapping of an operating system in a chroot. + -- If the operating System is not supported, return + -- Left error message. + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux) + +-- | Use this to bootstrap a chroot by extracting a tarball. +-- +-- The tarball is expected to contain a root directory (no top-level +-- directory, also known as a "tarbomb"). +-- It may be optionally compressed with any format `tar` knows how to +-- detect automatically. +data ChrootTarball = ChrootTarball FilePath + +instance ChrootBootstrapper ChrootTarball where + buildchroot (ChrootTarball tb) _ loc = Right $ + tightenTargets $ extractTarball loc tb + +extractTarball :: FilePath -> FilePath -> Property UnixLike +extractTarball target src = check (unpopulated target) $ + cmdProperty "tar" params + `assume` MadeChange + `requires` File.dirExists target + where + params = + [ "-C" + , target + , "-xf" + , src + ] + +-- | Use this to bootstrap a chroot with debootstrap. +data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig + +instance ChrootBootstrapper Debootstrapped where + buildchroot (Debootstrapped cf) system loc = case system of + (Just s@(System (Debian _) _)) -> Right $ debootstrap s + (Just s@(System (Buntish _) _)) -> Right $ debootstrap s + (Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap." + Nothing -> Left "Cannot debootstrap; OS not specified" + where + debootstrap s = Debootstrap.built loc s cf + +-- | Defines a Chroot at the given location, built with debootstrap. +-- +-- Properties can be added to configure the Chroot. At a minimum, +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. +-- +-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props +-- > & osDebian Unstable "amd64" +-- > & Apt.installed ["ghc", "haskell-platform"] +-- > & ... +debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot +debootstrapped conf = bootstrapped (Debootstrapped conf) + +-- | Defines a Chroot at the given location, bootstrapped with the +-- specified ChrootBootstrapper. +bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot +bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps) + +-- | Ensures that the chroot exists and is provisioned according to its +-- properties. +-- +-- Reverting this property removes the chroot. Anything mounted inside it +-- is first unmounted. Note that it does not ensure that any processes +-- that might be running inside the chroot are stopped. +provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux +provisioned c = provisioned' (propagateChrootInfo c) c False + +provisioned' + :: (Property Linux -> Property (HasInfo + Linux)) + -> Chroot + -> Bool + -> RevertableProperty (HasInfo + Linux) Linux +provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = + (propigator $ setup `describe` chrootDesc c "exists") + <!> + (teardown `describe` chrootDesc c "removed") + where + setup :: Property Linux + setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly + `requires` built + + built = case buildchroot bootstrapper (chrootSystem c) loc of + Right p -> p + Left e -> cantbuild e + + cantbuild e = property (chrootDesc c "built") (error e) + + teardown :: Property Linux + teardown = check (not <$> unpopulated loc) $ + property ("removed " ++ loc) $ + makeChange (removeChroot loc) + +propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) +propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ + p `setInfoProperty` chrootInfo c + +chrootInfo :: Chroot -> Info +chrootInfo (Chroot loc _ h) = mempty `addInfo` + mempty { _chroots = M.singleton loc h } + +-- | Propellor is run inside the chroot to provision it. +propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike +propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do + let d = localdir </> shimdir c + let me = localdir </> "propellor" + shim <- liftIO $ ifM (doesDirectoryExist d) + ( pure (Shim.file me d) + , Shim.setup me Nothing d + ) + ifM (liftIO $ bindmount shim) + ( chainprovision shim + , return FailedChange + ) + where + bindmount shim = ifM (doesFileExist (loc ++ shim)) + ( return True + , do + let mntpnt = loc ++ localdir + createDirectoryIfMissing True mntpnt + boolSystem "mount" + [ Param "--bind" + , File localdir, File mntpnt + ] + ) + + chainprovision shim = do + parenthost <- asks hostName + cmd <- liftIO $ toChain parenthost c systemdonly + pe <- liftIO standardPathEnv + (p, cleanup) <- liftIO $ mkproc + [ shim + , "--continue" + , show cmd + ] + let p' = p { env = Just pe } + r <- liftIO $ withHandle StdoutHandle createProcessSuccess p' + processChainOutput + liftIO cleanup + return r + +toChain :: HostName -> Chroot -> Bool -> IO CmdLine +toChain parenthost (Chroot loc _ _) systemdonly = do + onconsole <- isConsole <$> getMessageHandle + return $ ChrootChain parenthost loc systemdonly onconsole + +chain :: [Host] -> CmdLine -> IO () +chain hostlist (ChrootChain hn loc systemdonly onconsole) = + case findHostNoAlias hostlist hn of + Nothing -> errorMessage ("cannot find host " ++ hn) + Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of + Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn) + Just h -> go h + where + go h = do + changeWorkingDirectory localdir + when onconsole forceConsole + onlyProcess (provisioningLock loc) $ do + r <- runPropellor (setInChroot h) $ ensureChildProperties $ + if systemdonly + then [toChildProperty Systemd.installed] + else hostProperties h + flushConcurrentOutput + putStrLn $ "\n" ++ show r +chain _ _ = errorMessage "bad chain command" + +inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) +inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do + mountproc + return (proc "chroot" (loc:cmd), cleanup) + where + -- /proc needs to be mounted in the chroot for the linker to use + -- /proc/self/exe which is necessary for some commands to work + mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $ + void $ mount "proc" "proc" procloc mempty + + procloc = loc </> "proc" + + cleanup + | keepprocmounted = noop + | otherwise = whenM (elem procloc <$> mountPointsBelow loc) $ + umountLazy procloc + +provisioningLock :: FilePath -> FilePath +provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock" + +shimdir :: Chroot -> FilePath +shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim" + +mungeloc :: FilePath -> String +mungeloc = replace "/" "_" + +chrootDesc :: Chroot -> String -> String +chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc + +-- | Adding this property to a chroot prevents daemons and other services +-- from being started, which is often something you want to prevent when +-- building a chroot. +-- +-- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d> +-- script that does not let any daemons be started by packages that use +-- invoke-rc.d. Reverting the property removes the script. +-- +-- This property has no effect on non-Debian systems. +noServices :: RevertableProperty UnixLike UnixLike +noServices = setup <!> teardown + where + f = "/usr/sbin/policy-rc.d" + script = [ "#!/bin/sh", "exit 101" ] + setup = combineProperties "no services started" $ toProps + [ File.hasContent f script + , File.mode f (combineModes (readModes ++ executeModes)) + ] + teardown = File.notPresent f + +-- | Check if propellor is currently running within a chroot. +-- +-- This allows properties to check and avoid performing actions that +-- should not be done in a chroot. +inChroot :: Propellor Bool +inChroot = extract . fromMaybe (InChroot False) . fromInfoVal <$> askInfo + where + extract (InChroot b) = b + +setInChroot :: Host -> Host +setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) } + +newtype InChroot = InChroot Bool + deriving (Typeable, Show) diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs new file mode 100644 index 00000000..ac703136 --- /dev/null +++ b/src/Propellor/Property/Chroot/Util.hs @@ -0,0 +1,33 @@ +module Propellor.Property.Chroot.Util where + +import Propellor.Property.Mount + +import Utility.Exception +import Utility.Env +import Utility.Directory + +import Control.Applicative +import Prelude + +-- | When chrooting, it's useful to ensure that PATH has all the standard +-- directories in it. This adds those directories to whatever PATH is +-- already set. +standardPathEnv :: IO [(String, String)] +standardPathEnv = do + path <- getEnvDefault "PATH" "/bin" + addEntry "PATH" (path ++ stdPATH) + <$> getEnvironment + +stdPATH :: String +stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" + +-- | Removes the contents of a chroot. First, unmounts any filesystems +-- mounted within it. +removeChroot :: FilePath -> IO () +removeChroot c = do + unmountBelow c + removeDirectoryRecursive c + +-- | Returns true if a chroot directory is empty. +unpopulated :: FilePath -> IO Bool +unpopulated d = null <$> catchDefaultIO [] (dirContents d) diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index 725f5757..6b84acb5 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -1,49 +1,98 @@ {-# LANGUAGE PackageImports #-} +-- | This module lets you construct Properties by running commands and +-- scripts. To get from an `UncheckedProperty` to a `Property`, it's +-- up to the user to check if the command made a change to the system. +-- +-- The best approach is to `check` a property, so that the command is only +-- run when it needs to be. With this method, you avoid running the +-- `cmdProperty` unnecessarily. +-- +-- > check (not <$> userExists "bob") +-- > (cmdProperty "useradd" ["bob"]) +-- +-- Sometimes it's just as expensive to check a property as it would be to +-- run the command that ensures the property. So you can let the command +-- run every time, and use `changesFile` or `checkResult` to determine if +-- anything changed: +-- +-- > cmdProperty "chmod" ["600", "/etc/secret"] +-- > `changesFile` "/etc/secret" +-- +-- Or you can punt and `assume` a change was made, but then propellor will +-- always say it make a change, and `onChange` will always fire. +-- +-- > cmdProperty "service" ["foo", "reload"] +-- > `assume` MadeChange + module Propellor.Property.Cmd ( + -- * Constricting properties running commands and scripts cmdProperty, cmdProperty', + cmdPropertyEnv, + Script, scriptProperty, userScriptProperty, + -- * Lower-level interface for running commands + CommandParam(..), + boolSystem, + boolSystemEnv, + safeSystem, + safeSystemEnv, + shellEscape, + createProcess, + waitForProcess, ) where -import Control.Applicative import Data.List import "mtl" Control.Monad.Reader +import Control.Applicative +import Prelude import Propellor.Types import Propellor.Property -import Utility.Monad import Utility.SafeCommand import Utility.Env +import Utility.Process (createProcess, CreateProcess, waitForProcess) -- | A property that can be satisfied by running a command. -- -- The command must exit 0 on success. -cmdProperty :: String -> [String] -> Property -cmdProperty cmd params = cmdProperty' cmd params [] +cmdProperty :: String -> [String] -> UncheckedProperty UnixLike +cmdProperty cmd params = cmdProperty' cmd params id + +cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty UnixLike +cmdProperty' cmd params mkprocess = unchecked $ property desc $ liftIO $ + cmdResult <$> boolSystem' cmd (map Param params) mkprocess + where + desc = unwords $ cmd : params + +cmdResult :: Bool -> Result +cmdResult False = FailedChange +cmdResult True = NoChange -- | A property that can be satisfied by running a command, --- with added environment. -cmdProperty' :: String -> [String] -> [(String, String)] -> Property -cmdProperty' cmd params env = property desc $ liftIO $ do +-- with added environment variables in addition to the standard +-- environment. +cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty UnixLike +cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do env' <- addEntries env <$> getEnvironment - ifM (boolSystemEnv cmd (map Param params) (Just env')) - ( return MadeChange - , return FailedChange - ) + cmdResult <$> boolSystemEnv cmd (map Param params) (Just env') where desc = unwords $ cmd : params --- | A property that can be satisfied by running a series of shell commands. -scriptProperty :: [String] -> Property +-- | A series of shell commands. (Without a leading hashbang.) +type Script = [String] + +-- | A property that can be satisfied by running a script. +scriptProperty :: Script -> UncheckedProperty UnixLike scriptProperty script = cmdProperty "sh" ["-c", shellcmd] where shellcmd = intercalate " ; " ("set -e" : script) --- | A property that can satisfied by running a series of shell commands, +-- | A property that can satisfied by running a script -- as user (cd'd to their home directory). -userScriptProperty :: UserName -> [String] -> Property -userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user] +userScriptProperty :: User -> Script -> UncheckedProperty UnixLike +userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user] where shellcmd = intercalate " ; " ("set -e" : "cd" : script) diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs new file mode 100644 index 00000000..e69dc17d --- /dev/null +++ b/src/Propellor/Property/Concurrent.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Propellor properties can be made to run concurrently, using this +-- module. This can speed up propellor, at the expense of using more CPUs +-- and other resources. +-- +-- It's up to you to make sure that properties that you make run concurrently +-- don't implicitly depend on one-another. The worst that can happen +-- though, is that propellor fails to ensure some of the properties, +-- and tells you what went wrong. +-- +-- Another potential problem is that output of concurrent properties could +-- interleave into a scrambled mess. This is mostly prevented; all messages +-- output by propellor are concurrency safe, including `errorMessage`, +-- `infoMessage`, etc. However, if you write a property that directly +-- uses `print` or `putStrLn`, you can still experience this problem. +-- +-- Similarly, when properties run external commands, the command's output +-- can be a problem for concurrency. No need to worry; +-- `Propellor.Property.Cmd.createProcess` is concurrent output safe +-- (it actually uses `Propellor.Message.createProcessConcurrent`), and +-- everything else in propellor that runs external commands is built on top +-- of that. Of course, if you import System.Process and use it in a +-- property, you can bypass that and shoot yourself in the foot. +-- +-- Finally, anything that directly accesses the tty can bypass +-- these protections. That's sometimes done for eg, password prompts. +-- A well-written property should avoid running interactive commands +-- anyway. + +module Propellor.Property.Concurrent ( + concurrently, + concurrentList, + props, + getNumProcessors, + concurrentSatisfy, +) where + +import Propellor.Base +import Propellor.Types.Core +import Propellor.Types.MetaTypes + +import Control.Concurrent +import qualified Control.Concurrent.Async as A +import GHC.Conc (getNumProcessors) +import Control.Monad.RWS.Strict + +-- | Ensures two properties concurrently. +-- +-- > & foo `concurrently` bar +-- +-- To ensure three properties concurrently, just use this combinator twice: +-- +-- > & foo `concurrently` bar `concurrently` baz +concurrently + :: (IsProp p1, IsProp p2, Combines p1 p2, IsProp (CombinedType p1 p2)) + => p1 + -> p2 + -> CombinedType p1 p2 +concurrently p1 p2 = (combineWith go go p1 p2) + `describe` d + where + d = getDesc p1 ++ " `concurrently` " ++ getDesc p2 + -- Increase the number of capabilities right up to the number of + -- processors, so that A `concurrently` B `concurrently` C + -- runs all 3 properties on different processors when possible. + go a1 a2 = do + n <- liftIO getNumProcessors + withCapabilities n $ + concurrentSatisfy a1 a2 + +-- | Ensures all the properties in the list, with a specified amount of +-- concurrency. +-- +-- > concurrentList (pure 2) "demo" $ props +-- > & foo +-- > & bar +-- > & baz +-- +-- The above example will run foo and bar concurrently, and once either of +-- those 2 properties finishes, will start running baz. +concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) +concurrentList getn d (Props ps) = property d go `addChildren` ps + where + go = do + n <- liftIO getn + withCapabilities n $ + startworkers n =<< liftIO (newMVar ps) + startworkers n q + | n < 1 = return NoChange + | n == 1 = worker q NoChange + | otherwise = + worker q NoChange + `concurrentSatisfy` + startworkers (n-1) q + worker q r = do + v <- liftIO $ modifyMVar q $ \v -> case v of + [] -> return ([], Nothing) + (p:rest) -> return (rest, Just p) + case v of + Nothing -> return r + Just p -> do + hn <- asks hostName + r' <- actionMessageOn hn + (getDesc p) + (getSatisfy p) + worker q (r <> r') + +-- | Run an action with the number of capabiities increased as necessary to +-- allow running on the specified number of cores. +-- +-- Never increases the number of capabilities higher than the actual number +-- of processors. +withCapabilities :: Int -> Propellor a -> Propellor a +withCapabilities n a = bracket setup cleanup (const a) + where + setup = do + np <- liftIO getNumProcessors + let n' = min n np + c <- liftIO getNumCapabilities + when (n' > c) $ + liftIO $ setNumCapabilities n' + return c + cleanup = liftIO . setNumCapabilities + +-- | Running Propellor actions concurrently. +concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result +concurrentSatisfy a1 a2 = do + h <- ask + ((r1, w1), (r2, w2)) <- liftIO $ + runp a1 h `A.concurrently` runp a2 h + tell (w1 <> w2) + return (r1 <> r2) + where + runp a h = evalRWST (runWithHost (catchPropellor a)) h () diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs new file mode 100644 index 00000000..8aa18d20 --- /dev/null +++ b/src/Propellor/Property/Conductor.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-} + +-- | This module adds conductors to propellor. A conductor is a Host that +-- is responsible for running propellor on other hosts +-- +-- This eliminates the need to manually run propellor --spin to +-- update the conducted hosts, and can be used to orchestrate updates +-- to hosts. +-- +-- The conductor needs to be able to ssh to the hosts it conducts, +-- and run propellor, as root. To this end, +-- the `Propellor.Property.Ssh.knownHost` property is automatically +-- added to the conductor, so it knows the host keys of the relevant hosts. +-- Also, each conducted host is configured to let its conductor +-- ssh in as root, by automatically adding the +-- `Propellor.Property.Ssh.authorizedKeysFrom` property. +-- +-- It's left up to you to use `Propellor.Property.Ssh.userKeys` to +-- configure the ssh keys for the root user on conductor hosts, +-- and to use `Ssh.hostKeys` to configure the host keys for the +-- conducted hosts. +-- +-- For example, if you have some webservers and a dnsserver, +-- and want the master host to conduct all of them: +-- +-- > import Propellor +-- > import Propellor.Property.Conductor +-- > import qualified Propellor.Property.Ssh as Ssh +-- > import qualified Propellor.Property.Cron as Cron +-- > +-- > main = defaultMain (orchestrate hosts) +-- > +-- > hosts = +-- > [ master +-- > , dnsserver +-- > ] ++ webservers +-- > +-- > dnsserver = host "dns.example.com" +-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI")] +-- > & ... +-- > +-- > webservers = +-- > [ host "www1.example.com" +-- > & Ssh.hostKeys hostContext [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAICfFntnesZcYz2B2T41ay45igfckXRSh5uVffkuCQkLv")] +-- > & ... +-- > , ... +-- > ] +-- > +-- > master = host "master.example.com" +-- > & Ssh.userKeys (User "root") [(SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFWD0Hau5FDLeNrDHKilNMKm9c68R3WD+NJOp2jPWvJV")] +-- > & conducts webservers +-- > `before` conducts dnsserver +-- > & Cron.runPropellor +-- +-- Notice that, in the above example, the the webservers are conducted +-- first. Only once the webservers have successfully been set up is the +-- dnsserver updated. This way, when adding a new web server, the dns +-- won't list it until it's ready. +-- +-- There can be multiple conductors, and conductors can conduct other +-- conductors if you need such a hierarchy. (Loops in the hierarchy, such +-- as a host conducting itself, are detected and automatically broken.) +-- +-- While it's allowed for a single host to be conducted by +-- multiple conductors, the results can be discordent. +-- Since only one propellor process can be run on a host at a time, +-- one of the conductors will fail to communicate with it. +-- +-- Note that a conductor can see all PrivData of the hosts it conducts. + +module Propellor.Property.Conductor ( + orchestrate, + Conductable(..), +) where + +import Propellor.Base +import Propellor.Container +import Propellor.Spin (spin') +import Propellor.PrivData.Paths +import Propellor.Types.Info +import qualified Propellor.Property.Ssh as Ssh + +import qualified Data.Set as S + +-- | Class of things that can be conducted. +-- +-- There are instances for single hosts, and for lists of hosts. +-- With a list, each listed host will be conducted in turn. Failure to conduct +-- one host does not prevent conducting subsequent hosts in the list, but +-- will be propagated as an overall failure of the property. +class Conductable c where + conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike) + +instance Conductable Host where + conducts h = conductorFor h <!> notConductorFor h + +instance Conductable [Host] where + conducts hs = + propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) + <!> + propertyList desc (toProps $ map (undoRevertableProperty . conducts) hs) + where + desc = cdesc $ unwords $ map hostName hs + +data Orchestra + = Conductor Host [Orchestra] + | Conducted Host + +instance Show Orchestra where + show (Conductor h l) = "Conductor " ++ hostName h ++ " (" ++ show l ++ ")" + show (Conducted h) = "Conducted " ++ hostName h + +fullOrchestra :: Orchestra -> Bool +fullOrchestra (Conductor _ _) = True +fullOrchestra (Conducted _) = False + +topHost :: Orchestra -> Host +topHost (Conducted h) = h +topHost (Conductor h _) = h + +allHosts :: Orchestra -> [Host] +allHosts (Conducted h) = [h] +allHosts (Conductor h l) = h : concatMap allHosts l + +-- Makes an Orchestra for the host, and any hosts it's conducting. +mkOrchestra :: Host -> Orchestra +mkOrchestra = fromJust . go S.empty + where + go seen h + | S.member (hostName h) seen = Nothing -- break loop + | otherwise = Just $ case fromInfo (hostInfo h) of + ConductorFor [] -> Conducted h + ConductorFor l -> + let seen' = S.insert (hostName h) seen + in Conductor h (mapMaybe (go seen') l) + +-- Combines the two orchestras, if there's a place, or places where they +-- can be grafted together. +combineOrchestras :: Orchestra -> Orchestra -> Maybe Orchestra +combineOrchestras a b = combineOrchestras' a b <|> combineOrchestras' b a + +combineOrchestras' :: Orchestra -> Orchestra -> Maybe Orchestra +combineOrchestras' (Conducted h) b + | sameHost h (topHost b) = Just b + | otherwise = Nothing +combineOrchestras' (Conductor h os) (Conductor h' os') + | sameHost h h' = Just $ Conductor h (concatMap combineos os') + where + combineos o = case mapMaybe (`combineOrchestras` o) os of + [] -> [o] + os'' -> os'' +combineOrchestras' a@(Conductor h _) (Conducted h') + | sameHost h h' = Just a +combineOrchestras' (Conductor h os) b + | null (catMaybes (map snd osgrafts)) = Nothing + | otherwise = Just $ Conductor h (map (uncurry fromMaybe) osgrafts) + where + osgrafts = zip os (map (`combineOrchestras` b) os) + +sameHost :: Host -> Host -> Bool +sameHost a b = hostName a == hostName b + +-- Removes any loops that may be present in the Orchestra involving +-- the passed Host. This is a matter of traversing the Orchestra +-- top-down, and removing all occurrances of the host after the first +-- one seen. +deloop :: Host -> Orchestra -> Orchestra +deloop _ (Conducted h) = Conducted h +deloop thehost (Conductor htop ostop) = Conductor htop $ + fst $ seekh [] ostop (sameHost htop thehost) + where + seekh l [] seen = (l, seen) + seekh l ((Conducted h) : rest) seen + | sameHost h thehost = + if seen + then seekh l rest seen + else seekh (Conducted h : l) rest True + | otherwise = seekh (Conducted h:l) rest seen + seekh l ((Conductor h os) : rest) seen + | sameHost h thehost = + if seen + then seekh l rest seen + else + let (os', _seen') = seekh [] os True + in seekh (Conductor h os' : l) rest True + | otherwise = + let (os', seen') = seekh [] os seen + in seekh (Conductor h os' : l) rest seen' + +-- Extracts the Orchestras from a list of hosts. +-- +-- Method: For each host that is a conductor, check the +-- list of orchesteras to see if any already contain that host, or +-- any of the hosts it conducts. If so, add the host to that +-- orchestra. If not, start a new orchestra. +-- +-- The result is a set of orchestras, which are each fully disconnected +-- from the other. Some may contain loops. +extractOrchestras :: [Host] -> [Orchestra] +extractOrchestras = filter fullOrchestra . go [] . map mkOrchestra + where + go os [] = os + go os (o:rest) = + let os' = zip os (map (combineOrchestras o) os) + in case catMaybes (map snd os') of + [] -> go (o:os) rest + [_] -> go (map (uncurry fromMaybe) os') rest + _ -> error "Bug: Host somehow ended up in multiple Orchestras!" + +-- | Pass this a list of all your hosts; it will finish setting up +-- orchestration as configured by the `conducts` properties you add to +-- hosts. +-- +-- > main = defaultMain $ orchestrate hosts +orchestrate :: [Host] -> [Host] +orchestrate hs = map go hs + where + go h + | isOrchestrated (fromInfo (hostInfo h)) = h + | otherwise = foldl orchestrate' (removeold h) (map (deloop h) os) + os = extractOrchestras hs + + removeold h = foldl removeold' h (oldconductorsof h) + removeold' h oldconductor = setContainerProps h $ containerProps h + ! conductedBy oldconductor + + oldconductors = zip hs (map (fromInfo . hostInfo) hs) + oldconductorsof h = flip mapMaybe oldconductors $ + \(oldconductor, NotConductorFor l) -> + if any (sameHost h) l + then Just oldconductor + else Nothing + +orchestrate' :: Host -> Orchestra -> Host +orchestrate' h (Conducted _) = h +orchestrate' h (Conductor c l) + | sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l) + | any (sameHost h) (map topHost l) = cont $ + setContainerProps h $ containerProps h + & conductedBy c + | otherwise = cont h + where + cont h' = foldl orchestrate' h' l + +-- The host this property is added to becomes the conductor for the +-- specified Host. Note that `orchestrate` must be used for this property +-- to have any effect. +conductorFor :: Host -> Property (HasInfo + UnixLike) +conductorFor h = go + `setInfoProperty` (toInfo (ConductorFor [h])) + `requires` setupRevertableProperty (conductorKnownHost h) + `requires` Ssh.installed + where + desc = cdesc (hostName h) + + go :: Property UnixLike + go = property desc $ ifM (isOrchestrated <$> askInfo) + ( do + pm <- liftIO $ filterPrivData h + <$> readPrivDataFile privDataLocal + liftIO $ spin' (Just pm) Nothing (hostName h) h + -- Don't know if the spin made a change to + -- the remote host or not, but in any case, + -- the local host was not changed. + noChange + , do + warningMessage "Can't conduct; either orchestrate has not been used, or there is a conductor loop." + return FailedChange + ) + +-- Reverts conductorFor. +notConductorFor :: Host -> Property (HasInfo + UnixLike) +notConductorFor h = (doNothing :: Property UnixLike) + `setInfoProperty` (toInfo (NotConductorFor [h])) + `describe` desc + `requires` undoRevertableProperty (conductorKnownHost h) + where + desc = "not " ++ cdesc (hostName h) + +conductorKnownHost :: Host -> RevertableProperty UnixLike UnixLike +conductorKnownHost h = + mk Ssh.knownHost + <!> + mk Ssh.unknownHost + where + mk p = p [h] (hostName h) (User "root") + +-- Gives a conductor access to all the PrivData of the specified hosts. +-- This allows it to send it on the the hosts when conducting it. +-- +-- This is not done in conductorFor, so that it can be added +-- at the orchestration stage, and so is not added when there's a loop. +addConductorPrivData :: Host -> [Host] -> Host +addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } + where + i = mempty + `addInfo` mconcat (map privinfo hs) + `addInfo` Orchestrated (Any True) + privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h') + +-- Use this property to let the specified conductor ssh in and run propellor. +conductedBy :: Host -> RevertableProperty UnixLike UnixLike +conductedBy h = (setup <!> teardown) + `describe` ("conducted by " ++ hostName h) + where + setup = User "root" `Ssh.authorizedKeysFrom` (User "root", h) + `requires` Ssh.installed + teardown = User "root" `Ssh.unauthorizedKeysFrom` (User "root", h) + +cdesc :: String -> Desc +cdesc n = "conducting " ++ n + +-- A Host's Info indicates when it's a conductor for hosts, and when it's +-- stopped being a conductor. +newtype ConductorFor = ConductorFor [Host] + deriving (Typeable, Monoid) +newtype NotConductorFor = NotConductorFor [Host] + deriving (Typeable, Monoid) + +instance Show ConductorFor where + show (ConductorFor l) = "ConductorFor " ++ show (map hostName l) +instance Show NotConductorFor where + show (NotConductorFor l) = "NotConductorFor " ++ show (map hostName l) + +instance IsInfo ConductorFor where + propagateInfo _ = False +instance IsInfo NotConductorFor where + propagateInfo _ = False + +-- Added to Info when a host has been orchestrated. +newtype Orchestrated = Orchestrated Any + deriving (Typeable, Monoid, Show) +instance IsInfo Orchestrated where + propagateInfo _ = False + +isOrchestrated :: Orchestrated -> Bool +isOrchestrated (Orchestrated v) = getAny v diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs new file mode 100644 index 00000000..270e04f1 --- /dev/null +++ b/src/Propellor/Property/ConfFile.hs @@ -0,0 +1,103 @@ +module Propellor.Property.ConfFile ( + -- * Generic conffiles with sections + SectionStart, + SectionPast, + AdjustSection, + InsertSection, + adjustSection, + -- * Windows .ini files + IniSection, + IniKey, + containsIniSetting, + lacksIniSection, +) where + +import Propellor.Base +import Propellor.Property.File + +import Data.List (isPrefixOf, foldl') + +-- | find the line that is the start of the wanted section (eg, == "<Foo>") +type SectionStart = Line -> Bool +-- | find a line that indicates we are past the section +-- (eg, a new section header) +type SectionPast = Line -> Bool +-- | run on all lines in the section, including the SectionStart line; +-- can add, delete, and modify lines, or even delete entire section +type AdjustSection = [Line] -> [Line] +-- | if SectionStart does not find the section in the file, this is used to +-- insert the section somewhere within it +type InsertSection = [Line] -> [Line] + +-- | Adjusts a section of conffile. +adjustSection + :: Desc + -> SectionStart + -> SectionPast + -> AdjustSection + -> InsertSection + -> FilePath + -> Property UnixLike +adjustSection desc start past adjust insert = fileProperty desc go + where + go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls + in if null wanted + then insert ls + else pre ++ (adjust wanted) ++ post + find (pre, wanted, post) l + | null wanted && null post && (not . start) l = + (pre ++ [l], wanted, post) + | (start l && null wanted && null post) + || ((not . null) wanted && null post && (not . past) l) = + (pre, wanted ++ [l], post) + | otherwise = (pre, wanted, post ++ [l]) + +-- | Name of a section of an .ini file. This value is put +-- in square braces to generate the section header. +type IniSection = String + +-- | Name of a configuration setting within a .ini file. +type IniKey = String + +iniHeader :: IniSection -> String +iniHeader header = '[' : header ++ "]" + +adjustIniSection + :: Desc + -> IniSection + -> AdjustSection + -> InsertSection + -> FilePath + -> Property UnixLike +adjustIniSection desc header = + adjustSection + desc + (== iniHeader header) + ("[" `isPrefixOf`) + +-- | Ensures that a .ini file exists and contains a section +-- with a key=value setting. +containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike +containsIniSetting f (header, key, value) = + adjustIniSection + (f ++ " section [" ++ header ++ "] contains " ++ key ++ "=" ++ value) + header + go + (++ [confheader, confline]) -- add missing section at end + f + where + confheader = iniHeader header + confline = key ++ "=" ++ value + go [] = [confline] + go (l:ls) = if isKeyVal l then confline : ls else l : (go ls) + isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key] + +-- | Ensures that a .ini file does not contain the specified section. +lacksIniSection :: FilePath -> IniSection -> Property UnixLike +lacksIniSection f header = + adjustIniSection + (f ++ " lacks section [" ++ header ++ "]") + header + (const []) -- remove all lines of section + id -- add no lines if section is missing + f diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs index d55c3dbb..0966a7e5 100644 --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -1,50 +1,72 @@ module Propellor.Property.Cron where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt -import Utility.SafeCommand +import Propellor.Bootstrap import Utility.FileMode import Data.Char -type CronTimes = String +-- | When to run a cron job. +-- +-- The Daily, Monthly, and Weekly options allow the cron job to be run +-- by anacron, which is useful for non-servers. +data Times + = Times String -- ^ formatted as in crontab(5) + | Daily + | Weekly + | Monthly --- | Installs a cron job, run as a specified user, in a particular --- directory. Note that the Desc must be unique, as it is used for the --- cron.d/ filename. --- +-- | Installs a cron job, that will run as a specified user in a particular +-- directory. Note that the Desc must be unique, as it is used for the +-- cron job filename. +-- -- Only one instance of the cron job is allowed to run at a time, no matter -- how long it runs. This is accomplished using flock locking of the cron -- job file. -- -- The cron job's output will only be emailed if it exits nonzero. -job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property -job desc times user cddir command = combineProperties ("cronned " ++ desc) - [ cronjobfile `File.hasContent` - [ "# Generated by propellor" +job :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike +job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) $ props + & Apt.serviceInstalledRunning "cron" + & Apt.installed ["util-linux", "moreutils"] + & cronjobfile `File.hasContent` + [ case times of + Times _ -> "" + _ -> "#!/bin/sh\nset -e" + , "# Generated by propellor" , "" , "SHELL=/bin/sh" , "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" , "" - , times ++ "\t" ++ user ++ "\tchronic " ++ shellEscape scriptfile + , case times of + Times t -> t ++ "\t" ++ u ++ "\tchronic " ++ shellEscape scriptfile + _ -> case u of + "root" -> "chronic " ++ shellEscape scriptfile + _ -> "chronic su " ++ u ++ " -c " ++ shellEscape scriptfile ] - -- Use a separate script because it makes the cron job name + & case times of + Times _ -> doNothing + _ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes) + -- Use a separate script because it makes the cron job name -- prettier in emails, and also allows running the job manually. - , scriptfile `File.hasContent` + & scriptfile `File.hasContent` [ "#!/bin/sh" , "# Generated by propellor" , "set -e" , "flock -n " ++ shellEscape cronjobfile ++ " sh -c " ++ shellEscape cmdline ] - , scriptfile `File.mode` combineModes (readModes ++ executeModes) - ] - `requires` Apt.serviceInstalledRunning "cron" - `requires` Apt.installed ["util-linux", "moreutils"] + & scriptfile `File.mode` combineModes (readModes ++ executeModes) where cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )" - cronjobfile = "/etc/cron.d/" ++ name + cronjobfile = "/etc" </> cronjobdir </> name + cronjobdir = case times of + Times _ -> "cron.d" + Daily -> "cron.daily" + Weekly -> "cron.weekly" + Monthly -> "cron.monthly" scriptfile = "/usr/local/bin/" ++ name ++ "_cronjob" name = map sanitize desc sanitize c @@ -52,10 +74,13 @@ job desc times user cddir command = combineProperties ("cronned " ++ desc) | otherwise = '_' -- | Installs a cron job, and runs it niced and ioniced. -niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +niceJob :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike niceJob desc times user cddir command = job desc times user cddir ("nice ionice -c 3 sh -c " ++ shellEscape command) -- | Installs a cron job to run propellor. -runPropellor :: CronTimes -> Property -runPropellor times = niceJob "propellor" times "root" localdir "make" +runPropellor :: Times -> Property UnixLike +runPropellor times = withOS "propellor cron job" $ \w o -> + ensureProperty w $ + niceJob "propellor" times (User "root") localdir + (bootstrapPropellorCommand o ++ "; ./propellor") diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs new file mode 100644 index 00000000..b86d8e0b --- /dev/null +++ b/src/Propellor/Property/DebianMirror.hs @@ -0,0 +1,156 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> + +module Propellor.Property.DebianMirror + ( DebianPriority (..) + , showPriority + , mirror + , RsyncExtra (..) + , Method (..) + , DebianMirror + , debianMirrorHostName + , debianMirrorSuites + , debianMirrorArchitectures + , debianMirrorSections + , debianMirrorSourceBool + , debianMirrorPriorities + , debianMirrorMethod + , debianMirrorKeyring + , debianMirrorRsyncExtra + , mkDebianMirror + ) where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.User as User + +import Data.List + + +data DebianPriority = Essential | Required | Important | Standard | Optional | Extra + deriving (Show, Eq) + +showPriority :: DebianPriority -> String +showPriority Essential = "essential" +showPriority Required = "required" +showPriority Important = "important" +showPriority Standard = "standard" +showPriority Optional = "optional" +showPriority Extra = "extra" + +data RsyncExtra = Doc | Indices | Tools | Trace + deriving (Show, Eq) + +showRsyncExtra :: RsyncExtra -> String +showRsyncExtra Doc = "doc" +showRsyncExtra Indices = "indices" +showRsyncExtra Tools = "tools" +showRsyncExtra Trace = "trace" + +data Method = Ftp | Http | Https | Rsync | MirrorFile + +showMethod :: Method -> String +showMethod Ftp = "ftp" +showMethod Http = "http" +showMethod Https = "https" +showMethod Rsync = "rsync" +showMethod MirrorFile = "file" + +-- | To get a new DebianMirror and set options, use: +-- +-- > mkDebianMirror mymirrordir mycrontimes +-- > . debianMirrorHostName "otherhostname" +-- > . debianMirrorSourceBool True + +data DebianMirror = DebianMirror + { _debianMirrorHostName :: HostName + , _debianMirrorDir :: FilePath + , _debianMirrorSuites :: [DebianSuite] + , _debianMirrorArchitectures :: [Architecture] + , _debianMirrorSections :: [Apt.Section] + , _debianMirrorSourceBool :: Bool + , _debianMirrorPriorities :: [DebianPriority] + , _debianMirrorMethod :: Method + , _debianMirrorKeyring :: FilePath + , _debianMirrorRsyncExtra :: [RsyncExtra] + , _debianMirrorCronTimes :: Cron.Times + } + +mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror +mkDebianMirror dir crontimes = DebianMirror + { _debianMirrorHostName = "httpredir.debian.org" + , _debianMirrorDir = dir + , _debianMirrorSuites = [] + , _debianMirrorArchitectures = [] + , _debianMirrorSections = [] + , _debianMirrorSourceBool = False + , _debianMirrorPriorities = [] + , _debianMirrorMethod = Http + , _debianMirrorKeyring = "/usr/share/keyrings/debian-archive-keyring.gpg" + , _debianMirrorRsyncExtra = [Trace] + , _debianMirrorCronTimes = crontimes + } + +debianMirrorHostName :: HostName -> DebianMirror -> DebianMirror +debianMirrorHostName hn m = m { _debianMirrorHostName = hn } + +debianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror +debianMirrorSuites s m = m { _debianMirrorSuites = s } + +debianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror +debianMirrorArchitectures a m = m { _debianMirrorArchitectures = a } + +debianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror +debianMirrorSections s m = m { _debianMirrorSections = s } + +debianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror +debianMirrorSourceBool s m = m { _debianMirrorSourceBool = s } + +debianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror +debianMirrorPriorities p m = m { _debianMirrorPriorities = p } + +debianMirrorMethod :: Method -> DebianMirror -> DebianMirror +debianMirrorMethod me m = m { _debianMirrorMethod = me } + +debianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror +debianMirrorKeyring k m = m { _debianMirrorKeyring = k } + +debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror +debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r } + +mirror :: DebianMirror -> Property DebianLike +mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props + & Apt.installed ["debmirror"] + & User.accountFor (User "debmirror") + & File.dirExists dir + & File.ownerGroup dir (User "debmirror") (Group "debmirror") + & check (not . and <$> mapM suitemirrored suites) + (cmdProperty "debmirror" args) + `describe` "debmirror setup" + & Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" + (unwords ("/usr/bin/debmirror" : args)) + where + dir = _debianMirrorDir mirror' + suites = _debianMirrorSuites mirror' + suitemirrored suite = doesDirectoryExist $ dir </> "dists" </> Apt.showSuite suite + architecturearg = intercalate "," + suitearg = intercalate "," $ map Apt.showSuite suites + priorityRegex pp = "(" ++ intercalate "|" (map showPriority pp) ++ ")" + rsyncextraarg [] = "none" + rsyncextraarg res = intercalate "," $ map showRsyncExtra res + args = + [ "--dist" , suitearg + , "--arch", architecturearg $ _debianMirrorArchitectures mirror' + , "--section", intercalate "," $ _debianMirrorSections mirror' + , "--limit-priority", "\"" ++ priorityRegex (_debianMirrorPriorities mirror') ++ "\"" + ] + ++ + (if _debianMirrorSourceBool mirror' then [] else ["--nosource"]) + ++ + [ "--host", _debianMirrorHostName mirror' + , "--method", showMethod $ _debianMirrorMethod mirror' + , "--rsync-extra", rsyncextraarg $ _debianMirrorRsyncExtra mirror' + , "--keyring", _debianMirrorKeyring mirror' + , dir + ] diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs new file mode 100644 index 00000000..87f30776 --- /dev/null +++ b/src/Propellor/Property/Debootstrap.hs @@ -0,0 +1,277 @@ +module Propellor.Property.Debootstrap ( + Url, + DebootstrapConfig(..), + built, + built', + extractSuite, + installed, + sourceInstall, + programPath, +) where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.Chroot.Util +import Utility.Path +import Utility.FileMode + +import Data.List +import Data.Char +import System.Posix.Directory +import System.Posix.Files + +type Url = String + +-- | A monoid for debootstrap configuration. +-- mempty is a default debootstrapped system. +data DebootstrapConfig + = DefaultConfig + | MinBase + | BuilddD + | DebootstrapParam String + | DebootstrapConfig :+ DebootstrapConfig + deriving (Show) + +instance Monoid DebootstrapConfig where + mempty = DefaultConfig + mappend = (:+) + +toParams :: DebootstrapConfig -> [CommandParam] +toParams DefaultConfig = [] +toParams MinBase = [Param "--variant=minbase"] +toParams BuilddD = [Param "--variant=buildd"] +toParams (DebootstrapParam p) = [Param p] +toParams (c1 :+ c2) = toParams c1 <> toParams c2 + +-- | Builds a chroot in the given directory using debootstrap. +-- +-- The System can be any OS and architecture that debootstrap +-- and the kernel support. +built :: FilePath -> System -> DebootstrapConfig -> Property Linux +built target system config = built' (setupRevertableProperty installed) target system config + +built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux +built' installprop target system@(System _ arch) config = + check (unpopulated target <||> ispartial) setupprop + `requires` installprop + where + setupprop :: Property Linux + setupprop = property ("debootstrapped " ++ target) $ liftIO $ do + createDirectoryIfMissing True target + -- Don't allow non-root users to see inside the chroot, + -- since doing so can allow them to do various attacks + -- including hard link farming suid programs for later + -- exploitation. + modifyFileMode target (removeModes [otherReadMode, otherExecuteMode, otherWriteMode]) + suite <- case extractSuite system of + Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system + Just s -> pure s + let params = toParams config ++ + [ Param $ "--arch=" ++ arch + , Param suite + , Param target + ] + cmd <- fromMaybe "debootstrap" <$> programPath + de <- standardPathEnv + ifM (boolSystemEnv cmd params (Just de)) + ( do + fixForeignDev target + return MadeChange + , return FailedChange + ) + + -- A failed debootstrap run will leave a debootstrap directory; + -- recover by deleting it and trying again. + ispartial = ifM (doesDirectoryExist (target </> "debootstrap")) + ( do + removeChroot target + return True + , return False + ) + +extractSuite :: System -> Maybe String +extractSuite (System (Debian s) _) = Just $ Apt.showSuite s +extractSuite (System (Buntish r) _) = Just r +extractSuite (System (FreeBSD _) _) = Nothing + +-- | Ensures debootstrap is installed. +-- +-- When necessary, falls back to installing debootstrap from source. +-- Note that installation from source is done by downloading the tarball +-- from a Debian mirror, with no cryptographic verification. +installed :: RevertableProperty Linux Linux +installed = install <!> remove + where + install = check (isJust <$> programPath) $ + (aptinstall `pickOS` sourceInstall) + `describe` "debootstrap installed" + + remove = (aptremove `pickOS` sourceRemove) + `describe` "debootstrap removed" + + aptinstall = Apt.installed ["debootstrap"] + aptremove = Apt.removed ["debootstrap"] + +sourceInstall :: Property Linux +sourceInstall = go + `requires` perlInstalled + `requires` arInstalled + where + go :: Property Linux + go = property "debootstrap installed from source" (liftIO sourceInstall') + +perlInstalled :: Property Linux +perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ + liftIO $ toResult . isJust <$> firstM id + [ yumInstall "perl" + ] + +arInstalled :: Property Linux +arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ + liftIO $ toResult . isJust <$> firstM id + [ yumInstall "binutils" + ] + +yumInstall :: String -> IO Bool +yumInstall p = boolSystem "yum" [Param "-y", Param "install", Param p] + +sourceInstall' :: IO Result +sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do + let indexfile = tmpd </> "index.html" + unlessM (download baseurl indexfile) $ + errorMessage $ "Failed to download " ++ baseurl + urls <- sortBy (flip compare) -- highest version first + . filter ("debootstrap_" `isInfixOf`) + . filter (".tar." `isInfixOf`) + . extractUrls baseurl <$> + readFileStrictAnyEncoding indexfile + nukeFile indexfile + + tarfile <- case urls of + (tarurl:_) -> do + let f = tmpd </> takeFileName tarurl + unlessM (download tarurl f) $ + errorMessage $ "Failed to download " ++ tarurl + return f + _ -> errorMessage $ "Failed to find any debootstrap tarballs listed on " ++ baseurl + + createDirectoryIfMissing True localInstallDir + bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do + changeWorkingDirectory localInstallDir + unlessM (boolSystem "tar" [Param "xf", File tarfile]) $ + errorMessage "Failed to extract debootstrap tar file" + nukeFile tarfile + l <- dirContents "." + case l of + (subdir:[]) -> do + changeWorkingDirectory subdir + makeDevicesTarball + makeWrapperScript (localInstallDir </> subdir) + return MadeChange + _ -> errorMessage "debootstrap tar file did not contain exactly one dirctory" + +sourceRemove :: Property Linux +sourceRemove = property "debootstrap not installed from source" $ liftIO $ + ifM (doesDirectoryExist sourceInstallDir) + ( do + removeDirectoryRecursive sourceInstallDir + return MadeChange + , return NoChange + ) + +sourceInstallDir :: FilePath +sourceInstallDir = "/usr/local/propellor/debootstrap" + +wrapperScript :: FilePath +wrapperScript = sourceInstallDir </> "debootstrap.wrapper" + +-- | Finds debootstrap in PATH, but fall back to looking for the +-- wrapper script that is installed, outside the PATH, when debootstrap +-- is installed from source. +programPath :: IO (Maybe FilePath) +programPath = getM searchPath + [ "debootstrap" + , wrapperScript + ] + +makeWrapperScript :: FilePath -> IO () +makeWrapperScript dir = do + createDirectoryIfMissing True (takeDirectory wrapperScript) + writeFile wrapperScript $ unlines + [ "#!/bin/sh" + , "set -e" + , "DEBOOTSTRAP_DIR=" ++ dir + , "export DEBOOTSTRAP_DIR" + , dir </> "debootstrap" ++ " \"$@\"" + ] + modifyFileMode wrapperScript (addModes $ readModes ++ executeModes) + +-- Work around for <http://bugs.debian.org/770217> +makeDevicesTarball :: IO () +makeDevicesTarball = do + -- TODO append to tarball; avoid writing to /dev + writeFile foreignDevFlag "1" + ok <- boolSystem "sh" [Param "-c", Param tarcmd] + nukeFile foreignDevFlag + unless ok $ + errorMessage "Failed to tar up /dev to generate devices.tar.gz" + where + tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz" + +fixForeignDev :: FilePath -> IO () +fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ do + de <- standardPathEnv + void $ boolSystemEnv "chroot" + [ File target + , Param "sh" + , Param "-c" + , Param $ intercalate " && " + [ "apt-get update" + , "apt-get -y install makedev" + , "rm -rf /dev" + , "mkdir /dev" + , "cd /dev" + , "mount -t proc proc /proc" + , "/sbin/MAKEDEV std ptmx fd consoleonly" + ] + ] + (Just de) + +foreignDevFlag :: FilePath +foreignDevFlag = "/dev/.propellor-foreign-dev" + +localInstallDir :: FilePath +localInstallDir = "/usr/local/debootstrap" + +-- This http server directory listing is relied on to be fairly sane, +-- which is one reason why it's using a specific server and not a +-- round-robin address. +baseurl :: Url +baseurl = "http://ftp.debian.org/debian/pool/main/d/debootstrap/" + +download :: Url -> FilePath -> IO Bool +download url dest = anyM id + [ boolSystem "curl" [Param "-o", File dest, Param url] + , boolSystem "wget" [Param "-O", File dest, Param url] + ] + +-- Pretty hackish, but I don't want to pull in a whole html parser +-- or parsec dependency just for this. +-- +-- To simplify parsing, lower case everything. This is ok because +-- the filenames are all lower-case anyway. +extractUrls :: Url -> String -> [Url] +extractUrls base = collect [] . map toLower + where + collect l [] = l + collect l ('h':'r':'e':'f':'=':r) = case r of + ('"':r') -> findend l r' + _ -> findend l r + collect l (_:cs) = collect l cs + + findend l s = + let (u, r) = break (== '"') s + u' = if "http" `isPrefixOf` u + then u + else base </> u + in collect (u':l) r diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs new file mode 100644 index 00000000..afeaa287 --- /dev/null +++ b/src/Propellor/Property/DiskImage.hs @@ -0,0 +1,346 @@ +-- | Disk image generation. +-- +-- This module is designed to be imported unqualified. + +{-# LANGUAGE TypeFamilies #-} + +module Propellor.Property.DiskImage ( + -- * Partition specification + module Propellor.Property.DiskImage.PartSpec, + -- * Properties + DiskImage, + imageBuilt, + imageRebuilt, + imageBuiltFrom, + imageExists, + -- * Finalization + Finalization, + grubBooted, + Grub.BIOS(..), + noFinalization, +) where + +import Propellor.Base +import Propellor.Property.DiskImage.PartSpec +import Propellor.Property.Chroot (Chroot) +import Propellor.Property.Chroot.Util (removeChroot) +import qualified Propellor.Property.Chroot as Chroot +import qualified Propellor.Property.Grub as Grub +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.Parted +import Propellor.Property.Mount +import Propellor.Property.Fstab (SwapPartition(..), genFstab) +import Propellor.Property.Partition +import Propellor.Property.Rsync +import Propellor.Container +import Utility.Path + +import Data.List (isPrefixOf, isInfixOf, sortBy) +import Data.Function (on) +import qualified Data.Map.Strict as M +import qualified Data.ByteString.Lazy as L +import System.Posix.Files + +type DiskImage = FilePath + +-- | Creates a bootable disk image. +-- +-- First the specified Chroot is set up, and its properties are satisfied. +-- +-- Then, the disk image is set up, and the chroot is copied into the +-- appropriate partition(s) of it. +-- +-- Example use: +-- +-- > import Propellor.Property.DiskImage +-- +-- > let chroot d = Chroot.debootstrapped mempty d +-- > & osDebian Unstable "amd64" +-- > & Apt.installed ["linux-image-amd64"] +-- > & User.hasPassword (User "root") +-- > & User.accountFor (User "demo") +-- > & User.hasPassword (User "demo") +-- > & User.hasDesktopGroups (User "demo") +-- > & ... +-- > in imageBuilt "/srv/images/foo.img" chroot +-- > MSDOS (grubBooted PC) +-- > [ partition EXT2 `mountedAt` "/boot" +-- > `setFlag` BootFlag +-- > , partition EXT4 `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 100 +-- > `mountOpt` errorReadonly +-- > , swapPartition (MegaBytes 256) +-- > ] +-- +-- Note that the disk image file is reused if it already exists, +-- to avoid expensive IO to generate a new one. And, it's updated in-place, +-- so its contents are undefined during the build process. +-- +-- Note that the `Chroot.noServices` property is automatically added to the +-- chroot while the disk image is being built, which should prevent any +-- daemons that are included from being started on the system that is +-- building the disk image. +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux +imageBuilt = imageBuilt' False + +-- | Like 'built', but the chroot is deleted and rebuilt from scratch each +-- time. This is more expensive, but useful to ensure reproducible results +-- when the properties of the chroot have been changed. +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux +imageRebuilt = imageBuilt' True + +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux +imageBuilt' rebuild img mkchroot tabletype final partspec = + imageBuiltFrom img chrootdir tabletype final partspec + `requires` Chroot.provisioned chroot + `requires` (cleanrebuild <!> (doNothing :: Property UnixLike)) + `describe` desc + where + desc = "built disk image " ++ img + cleanrebuild :: Property Linux + cleanrebuild + | rebuild = property desc $ do + liftIO $ removeChroot chrootdir + return MadeChange + | otherwise = doNothing + chrootdir = img ++ ".chroot" + chroot = + let c = mkchroot chrootdir + in setContainerProps c $ containerProps c + -- Before ensuring any other properties of the chroot, + -- avoid starting services. Reverted by imageFinalized. + &^ Chroot.noServices + -- First stage finalization. + & fst final + & cachesCleaned + +-- | This property is automatically added to the chroot when building a +-- disk image. It cleans any caches of information that can be omitted; +-- eg the apt cache on Debian. +cachesCleaned :: Property UnixLike +cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit) + where + skipit = doNothing :: Property UnixLike + +-- | Builds a disk image from the contents of a chroot. +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike +imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg + where + desc = img ++ " built from " ++ chrootdir + mkimg = property' desc $ \w -> do + -- unmount helper filesystems such as proc from the chroot + -- before getting sizes + liftIO $ unmountBelow chrootdir + szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize + <$> liftIO (dirSizes chrootdir) + let calcsz mnts = maybe defSz fudge . getMountSz szm mnts + -- tie the knot! + let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ + map (calcsz mnts) mnts + ensureProperty w $ + imageExists img (partTableSize parttable) + `before` + partitioned YesReallyDeleteDiskContents img parttable + `before` + kpartx img (mkimg' mnts mntopts parttable) + mkimg' mnts mntopts parttable devs = + partitionsPopulated chrootdir mnts mntopts devs + `before` + imageFinalized final mnts mntopts devs parttable + rmimg = File.notPresent img + +partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux +partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> + mconcat $ zipWith3 (go w) mnts mntopts devs + where + desc = "partitions populated from " ++ chrootdir + + go _ Nothing _ _ = noChange + go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket + (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) + (const $ liftIO $ umountLazy tmpdir) + $ \ismounted -> if ismounted + then ensureProperty w $ + syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir + else return FailedChange + + filtersfor mnt = + let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $ + filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m) + (catMaybes mnts) + in concatMap (\m -> + -- Include the child mount point, but exclude its contents. + [ Include (Pattern m) + , Exclude (filesUnder m) + -- Preserve any lost+found directory that mkfs made + , Protect (Pattern "lost+found") + ]) childmnts + +-- The constructor for each Partition is passed the size of the files +-- from the chroot that will be put in that partition. +fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable) +fitChrootSize tt l basesizes = (mounts, mountopts, parttable) + where + (mounts, mountopts, sizers) = unzip3 l + parttable = PartTable tt (zipWith id sizers basesizes) + +-- | Generates a map of the sizes of the contents of +-- every directory in a filesystem tree. +-- +-- (Hard links are counted multiple times for simplicity) +-- +-- Should be same values as du -bl +dirSizes :: FilePath -> IO (M.Map FilePath Integer) +dirSizes top = go M.empty top [top] + where + go m _ [] = return m + go m dir (i:is) = flip catchIO (\_ioerr -> go m dir is) $ do + s <- getSymbolicLinkStatus i + let sz = fromIntegral (fileSize s) + if isDirectory s + then do + subm <- go M.empty i =<< dirContents i + let sz' = M.foldr' (+) sz + (M.filterWithKey (const . subdirof i) subm) + go (M.insertWith (+) i sz' (M.union m subm)) dir is + else go (M.insertWith (+) dir sz m) dir is + subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent + +getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize +getMountSz _ _ Nothing = Nothing +getMountSz szm l (Just mntpt) = + fmap (`reducePartSize` childsz) (M.lookup mntpt szm) + where + childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l) + +-- | Ensures that a disk image file of the specified size exists. +-- +-- If the file doesn't exist, or is too small, creates a new one, full of 0's. +-- +-- If the file is too large, truncates it down to the specified size. +imageExists :: FilePath -> ByteSize -> Property Linux +imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do + ms <- catchMaybeIO $ getFileStatus img + case ms of + Just s + | toInteger (fileSize s) == toInteger sz -> return NoChange + | toInteger (fileSize s) > toInteger sz -> do + setFileSize img (fromInteger sz) + return MadeChange + _ -> do + L.writeFile img (L.replicate (fromIntegral sz) 0) + return MadeChange + +-- | A pair of properties. The first property is satisfied within the +-- chroot, and is typically used to download the boot loader. +-- +-- The second property is run after the disk image is created, +-- with its populated partition tree mounted in the provided +-- location from the provided loop devices. This will typically +-- take care of installing the boot loader to the image. +-- +-- It's ok if the second property leaves additional things mounted +-- in the partition tree. +type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) + +imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux +imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = + property' "disk image finalized" $ \w -> + withTmpDir "mnt" $ \top -> + go w top `finally` liftIO (unmountall top) + where + go w top = do + liftIO $ mountall top + liftIO $ writefstab top + liftIO $ allowservices top + ensureProperty w $ final top devs + + -- Ordered lexographically by mount point, so / comes before /usr + -- comes before /usr/local + orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))] + orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs) + + swaps = map (SwapPartition . partitionLoopDev . snd) $ + filter ((== LinuxSwap) . partFs . fst) $ + zip parts devs + + mountall top = forM_ orderedmntsdevs $ \(mp, (mopts, loopdev)) -> case mp of + Nothing -> noop + Just p -> do + let mnt = top ++ p + createDirectoryIfMissing True mnt + unlessM (mount "auto" (partitionLoopDev loopdev) mnt mopts) $ + error $ "failed mounting " ++ mnt + + unmountall top = do + unmountBelow top + umountLazy top + + writefstab top = do + let fstab = top ++ "/etc/fstab" + old <- catchDefaultIO [] $ filter (not . unconfigured) . lines + <$> readFileStrict fstab + new <- genFstab (map (top ++) (catMaybes mnts)) + swaps (toSysDir top) + writeFile fstab $ unlines $ new ++ old + -- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM" + unconfigured s = "UNCONFIGURED" `isInfixOf` s + + allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d") + +noFinalization :: Finalization +noFinalization = (doNothing, \_ _ -> doNothing) + +-- | Makes grub be the boot loader of the disk image. +grubBooted :: Grub.BIOS -> Finalization +grubBooted bios = (Grub.installed' bios, boots) + where + boots mnt loopdevs = combineProperties "disk image boots using grub" $ props + -- bind mount host /dev so grub can access the loop devices + & bindMount "/dev" (inmnt "/dev") + & mounted "proc" "proc" (inmnt "/proc") mempty + & mounted "sysfs" "sys" (inmnt "/sys") mempty + -- update the initramfs so it gets the uuid of the root partition + & inchroot "update-initramfs" ["-u"] + `assume` MadeChange + -- work around for http://bugs.debian.org/802717 + & check haveosprober (inchroot "chmod" ["-x", osprober]) + & inchroot "update-grub" [] + `assume` MadeChange + & check haveosprober (inchroot "chmod" ["+x", osprober]) + & inchroot "grub-install" [wholediskloopdev] + `assume` MadeChange + -- sync all buffered changes out to the disk image + -- may not be necessary, but seemed needed sometimes + -- when using the disk image right away. + & cmdProperty "sync" [] + `assume` NoChange + where + -- cannot use </> since the filepath is absolute + inmnt f = mnt ++ f + + inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps) + + haveosprober = doesFileExist (inmnt osprober) + osprober = "/etc/grub.d/30_os-prober" + + -- It doesn't matter which loopdev we use; all + -- come from the same disk image, and it's the loop dev + -- for the whole disk image we seek. + wholediskloopdev = case loopdevs of + (l:_) -> wholeDiskLoopDev l + [] -> error "No loop devs provided!" + +isChild :: FilePath -> Maybe MountPoint -> Bool +isChild mntpt (Just d) + | d `equalFilePath` mntpt = False + | otherwise = mntpt `dirContains` d +isChild _ Nothing = False + +-- | From a location in a chroot (eg, /tmp/chroot/usr) to +-- the corresponding location inside (eg, /usr). +toSysDir :: FilePath -> FilePath -> FilePath +toSysDir chrootdir d = case makeRelative chrootdir d of + "." -> "/" + sysdir -> "/" ++ sysdir diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs new file mode 100644 index 00000000..4b05df03 --- /dev/null +++ b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -0,0 +1,81 @@ +-- | Disk image partition specification and combinators. + +module Propellor.Property.DiskImage.PartSpec ( + module Propellor.Property.DiskImage.PartSpec, + Partition, + PartSize(..), + PartFlag(..), + TableType(..), + Fs(..), + MountPoint, +) where + +import Propellor.Base +import Propellor.Property.Parted +import Propellor.Property.Mount + +-- | Specifies a mount point, mount options, and a constructor for a Partition. +-- +-- The size that is eventually provided is the amount of space needed to +-- hold the files that appear in the directory where the partition is to be +-- mounted. Plus a fudge factor, since filesystems have some space +-- overhead. +type PartSpec = (Maybe MountPoint, MountOpts, PartSize -> Partition) + +-- | Partitions that are not to be mounted (ie, LinuxSwap), or that have +-- no corresponding directory in the chroot will have 128 MegaBytes +-- provided as a default size. +defSz :: PartSize +defSz = MegaBytes 128 + +-- | Add 2% for filesystem overhead. Rationalle for picking 2%: +-- A filesystem with 1% overhead might just sneak by as acceptable. +-- Double that just in case. Add an additional 3 mb to deal with +-- non-scaling overhead of filesystems (eg, superblocks). +-- Add an additional 200 mb for temp files, journals, etc. +fudge :: PartSize -> PartSize +fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) + +-- | Specifies a swap partition of a given size. +swapPartition :: PartSize -> PartSpec +swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz)) + +-- | Specifies a partition with a given filesystem. +-- +-- The partition is not mounted anywhere by default; use the combinators +-- below to configure it. +partition :: Fs -> PartSpec +partition fs = (Nothing, mempty, mkPartition fs) + +-- | Specifies where to mount a partition. +mountedAt :: PartSpec -> FilePath -> PartSpec +mountedAt (_, o, p) mp = (Just mp, o, p) + +-- | Specifies a mount option, such as "noexec" +mountOpt :: ToMountOpts o => PartSpec -> o -> PartSpec +mountOpt (mp, o, p) o' = (mp, o <> toMountOpts o', p) + +-- | Mount option to make a partition be remounted readonly when there's an +-- error accessing it. +errorReadonly :: MountOpts +errorReadonly = toMountOpts "errors=remount-ro" + +-- | Adds additional free space to the partition. +addFreeSpace :: PartSpec -> PartSize -> PartSpec +addFreeSpace (mp, o, p) freesz = (mp, o, \sz -> p (sz <> freesz)) + +-- | Forced a partition to be a specific size, instead of scaling to the +-- size needed for the files in the chroot. +setSize :: PartSpec -> PartSize -> PartSpec +setSize (mp, o, p) sz = (mp, o, const (p sz)) + +-- | Sets a flag on the partition. +setFlag :: PartSpec -> PartFlag -> PartSpec +setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } + +-- | Makes a MSDOS partition be Extended, rather than Primary. +extended :: PartSpec -> PartSpec +extended s = adjustp s $ \p -> p { partType = Extended } + +adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec +adjustp (mp, o, p) f = (mp, o, f . p) diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 135c765d..2e2710a6 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -1,6 +1,7 @@ module Propellor.Property.Dns ( module Propellor.Types.Dns, primary, + signedPrimary, secondary, secondaryFor, mkSOA, @@ -12,19 +13,24 @@ module Propellor.Property.Dns ( genZone, ) where -import Propellor +import Propellor.Base import Propellor.Types.Dns -import Propellor.Property.File import Propellor.Types.Info +import Propellor.Property.File import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Service as Service +import Propellor.Property.Scheduled +import Propellor.Property.DnsSec import Utility.Applicative import qualified Data.Map as M import qualified Data.Set as S import Data.List --- | Primary dns server for a domain. +-- | Primary dns server for a domain, using bind. +-- +-- Currently, this only configures bind to serve forward DNS, not reverse DNS. -- -- Most of the content of the zone file is configured by setting properties -- of hosts. For example, @@ -36,6 +42,9 @@ import Data.List -- Will cause that hostmame and its alias to appear in the zone file, -- with the configured IP address. -- +-- Also, if a host has a ssh public key configured, a SSHFP record will +-- be automatically generated for it. +-- -- The [(BindDomain, Record)] list can be used for additional records -- that cannot be configured elsewhere. This often includes NS records, -- TXT records and perhaps CNAMEs pointing at hosts that propellor does @@ -51,34 +60,47 @@ import Data.List -- -- In either case, the secondary dns server Host should have an ipv4 and/or -- ipv6 property defined. -primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty -primary hosts domain soa rs = RevertableProperty setup cleanup +primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike +primary hosts domain soa rs = setup <!> cleanup where - setup = withwarnings (check needupdate baseprop) - `requires` servingZones + setup = setupPrimary zonefile id hosts domain soa rs `onChange` Service.reloaded "bind9" - cleanup = check (doesFileExist zonefile) $ - property ("removed dns primary for " ++ domain) - (makeChange $ removeZoneFile zonefile) - `requires` namedConfWritten - `onChange` Service.reloaded "bind9" - - (partialzone, zonewarnings) = genZone hosts domain soa - zone = partialzone { zHosts = zHosts partialzone ++ rs } + cleanup = cleanupPrimary zonefile domain + `onChange` Service.reloaded "bind9" + zonefile = "/etc/bind/propellor/db." ++ domain - baseprop = Property ("dns primary for " ++ domain) - (makeChange $ writeZoneFile zone zonefile) - (addNamedConf conf) - withwarnings p = adjustProperty p $ \satisfy -> do + +setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property (HasInfo + DebianLike) +setupPrimary zonefile mknamedconffile hosts domain soa rs = + withwarnings baseprop + `requires` servingZones + where + hostmap = hostMap hosts + -- Known hosts with hostname located in the domain. + indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap + + (partialzone, zonewarnings) = genZone indomain hostmap domain soa + baseprop = primaryprop + `setInfoProperty` (toInfo (addNamedConf conf)) + primaryprop :: Property DebianLike + primaryprop = property ("dns primary for " ++ domain) $ do + sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) + let zone = partialzone + { zHosts = zHosts partialzone ++ rs ++ sshfps } + ifM (liftIO $ needupdate zone) + ( makeChange $ writeZoneFile zone zonefile + , noChange + ) + withwarnings p = adjustPropertySatisfy p $ \a -> do mapM_ warningMessage $ zonewarnings ++ secondarywarnings - satisfy + a conf = NamedConf { confDomain = domain , confDnsServerType = Master - , confFile = zonefile + , confFile = mknamedconffile zonefile , confMasters = [] , confAllowTransfer = nub $ - concatMap (\h -> hostAddresses h hosts) $ + concatMap (`hostAddresses` hosts) $ secondaries ++ nssecondaries , confLines = [] } @@ -88,7 +110,7 @@ primary hosts domain soa rs = RevertableProperty setup cleanup nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords rootRecords = map snd $ filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs - needupdate = do + needupdate zone = do v <- readZonePropellorFile zonefile return $ case v of Nothing -> True @@ -98,6 +120,66 @@ primary hosts domain soa rs = RevertableProperty setup cleanup z = zone { zSOA = (zSOA zone) { sSerial = oldserial } } in z /= oldzone || oldserial < sSerial (zSOA zone) + +cleanupPrimary :: FilePath -> Domain -> Property DebianLike +cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ + go `requires` namedConfWritten + where + desc = "removed dns primary for " ++ domain + go :: Property DebianLike + go = property desc (makeChange $ removeZoneFile zonefile) + +-- | Primary dns server for a domain, secured with DNSSEC. +-- +-- This is like `primary`, except the resulting zone +-- file is signed. +-- The Zone Signing Key (ZSK) and Key Signing Key (KSK) +-- used in signing it are taken from the PrivData. +-- +-- As a side effect of signing the zone, a +-- </var/cache/bind/dsset-domain.> +-- file will be created. This file contains the DS records +-- which need to be communicated to your domain registrar +-- to make DNSSEC be used for your domain. Doing so is outside +-- the scope of propellor (currently). See for example the tutorial +-- <https://www.digitalocean.com/community/tutorials/how-to-setup-dnssec-on-an-authoritative-bind-dns-server--2> +-- +-- The 'Recurrance' controls how frequently the signature +-- should be regenerated, using a new random salt, to prevent +-- zone walking attacks. `Weekly Nothing` is a reasonable choice. +-- +-- To transition from 'primary' to 'signedPrimary', you can revert +-- the 'primary' property, and add this property. +-- +-- Note that DNSSEC zone files use a serial number based on the unix epoch. +-- This is different from the serial number used by 'primary', so if you +-- want to later disable DNSSEC you will need to adjust the serial number +-- passed to mkSOA to ensure it is larger. +signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike +signedPrimary recurrance hosts domain soa rs = setup <!> cleanup + where + setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") + (props + & setupPrimary zonefile signedZoneFile hosts domain soa rs' + & zoneSigned domain zonefile + & forceZoneSigned domain zonefile `period` recurrance + ) + `onChange` Service.reloaded "bind9" + + cleanup = cleanupPrimary zonefile domain + `onChange` revert (zoneSigned domain zonefile) + `onChange` Service.reloaded "bind9" + + -- Include the public keys into the zone file. + rs' = include PubKSK : include PubZSK : rs + include k = (RootDomain, INCLUDE (keyFn domain k)) + + -- Put DNSSEC zone files in a different directory than is used for + -- the regular ones. This allows 'primary' to be reverted and + -- 'signedPrimary' enabled, without the reverted property stomping + -- on the new one's settings. + zonefile = "/etc/bind/propellor/dnssec/db." ++ domain + -- | Secondary dns server for a domain. -- -- The primary server is determined by looking at the properties of other @@ -105,13 +187,13 @@ primary hosts domain soa rs = RevertableProperty setup cleanup -- -- Note that if a host is declared to be a primary and a secondary dns -- server for the same domain, the primary server config always wins. -secondary :: [Host] -> Domain -> RevertableProperty +secondary :: [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain -- | This variant is useful if the primary server does not have its DNS -- configured via propellor. -secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty -secondaryFor masters hosts domain = RevertableProperty setup cleanup +secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike +secondaryFor masters hosts domain = setup <!> cleanup where setup = pureInfoProperty desc (addNamedConf conf) `requires` servingZones @@ -122,7 +204,7 @@ secondaryFor masters hosts domain = RevertableProperty setup cleanup { confDomain = domain , confDnsServerType = Secondary , confFile = "db." ++ domain - , confMasters = concatMap (\m -> hostAddresses m hosts) masters + , confMasters = concatMap (`hostAddresses` hosts) masters , confAllowTransfer = [] , confLines = [] } @@ -131,7 +213,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] otherServers wantedtype hosts domain = M.keys $ M.filter wanted $ hostMap hosts where - wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostInfo h) of + wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of Nothing -> False Just conf -> confDnsServerType conf == wantedtype && confDomain conf == domain @@ -139,15 +221,15 @@ otherServers wantedtype hosts domain = -- | Rewrites the whole named.conf.local file to serve the zones -- configured by `primary` and `secondary`, and ensures that bind9 is -- running. -servingZones :: Property +servingZones :: Property DebianLike servingZones = namedConfWritten `onChange` Service.reloaded "bind9" `requires` Apt.serviceInstalledRunning "bind9" -namedConfWritten :: Property -namedConfWritten = property "named.conf configured" $ do +namedConfWritten :: Property DebianLike +namedConfWritten = property' "named.conf configured" $ \w -> do zs <- getNamedConf - ensureProperty $ + ensureProperty w $ hasContent namedConfFile $ concatMap confStanza $ M.elems zs @@ -166,7 +248,7 @@ confStanza c = ] where cfgline f v = "\t" ++ f ++ " " ++ v ++ ";" - ipblock name l = + ipblock name l = [ "\t" ++ name ++ " {" ] ++ (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++ [ "\t};" ] @@ -209,30 +291,40 @@ dValue (RelDomain d) = d dValue (AbsDomain d) = d ++ "." dValue (RootDomain) = "@" -rField :: Record -> String -rField (Address (IPv4 _)) = "A" -rField (Address (IPv6 _)) = "AAAA" -rField (CNAME _) = "CNAME" -rField (MX _ _) = "MX" -rField (NS _) = "NS" -rField (TXT _) = "TXT" -rField (SRV _ _ _ _) = "SRV" - -rValue :: Record -> String -rValue (Address (IPv4 addr)) = addr -rValue (Address (IPv6 addr)) = addr -rValue (CNAME d) = dValue d -rValue (MX pri d) = show pri ++ " " ++ dValue d -rValue (NS d) = dValue d -rValue (SRV priority weight port target) = unwords +rField :: Record -> Maybe String +rField (Address (IPv4 _)) = Just "A" +rField (Address (IPv6 _)) = Just "AAAA" +rField (CNAME _) = Just "CNAME" +rField (MX _ _) = Just "MX" +rField (NS _) = Just "NS" +rField (TXT _) = Just "TXT" +rField (SRV _ _ _ _) = Just "SRV" +rField (SSHFP _ _ _) = Just "SSHFP" +rField (INCLUDE _) = Just "$INCLUDE" +rField (PTR _) = Nothing + +rValue :: Record -> Maybe String +rValue (Address (IPv4 addr)) = Just addr +rValue (Address (IPv6 addr)) = Just addr +rValue (CNAME d) = Just $ dValue d +rValue (MX pri d) = Just $ show pri ++ " " ++ dValue d +rValue (NS d) = Just $ dValue d +rValue (SRV priority weight port target) = Just $ unwords [ show priority , show weight , show port , dValue target ] -rValue (TXT s) = [q] ++ filter (/= q) s ++ [q] +rValue (SSHFP x y s) = Just $ unwords + [ show x + , show y + , s + ] +rValue (INCLUDE f) = Just f +rValue (TXT s) = Just $ [q] ++ filter (/= q) s ++ [q] where q = '"' +rValue (PTR _) = Nothing -- | Adjusts the serial number of the zone to always be larger -- than the serial number in the Zone record, @@ -290,23 +382,28 @@ readZonePropellorFile f = catchDefaultIO Nothing $ -- | Generating a zone file. genZoneFile :: Zone -> String genZoneFile (Zone zdomain soa rs) = unlines $ - header : genSOA soa ++ map (genRecord zdomain) rs + header : genSOA soa ++ mapMaybe (genRecord zdomain) rs where header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit." -genRecord :: Domain -> (BindDomain, Record) -> String -genRecord zdomain (domain, record) = intercalate "\t" - [ domainHost zdomain domain - , "IN" - , rField record - , rValue record - ] +genRecord :: Domain -> (BindDomain, Record) -> Maybe String +genRecord zdomain (domain, record) = case (rField record, rValue record) of + (Nothing, _) -> Nothing + (_, Nothing) -> Nothing + (Just rfield, Just rvalue) -> Just $ intercalate "\t" $ case record of + INCLUDE _ -> [ rfield, rvalue ] + _ -> + [ domainHost zdomain domain + , "IN" + , rfield + , rvalue + ] genSOA :: SOA -> [String] -genSOA soa = +genSOA soa = -- "@ IN SOA ns1.example.com. root (" [ intercalate "\t" - [ dValue RootDomain + [ dValue RootDomain , "IN" , "SOA" , dValue (sDomain soa) @@ -332,19 +429,17 @@ type WarningMessage = String -- | Generates a Zone for a particular Domain from the DNS properies of all -- hosts that propellor knows about that are in that Domain. -genZone :: [Host] -> Domain -> SOA -> (Zone, [WarningMessage]) -genZone hosts zdomain soa = - let (warnings, zhosts) = partitionEithers $ concat $ map concat +-- +-- Does not include SSHFP records. +genZone :: [Host] -> M.Map HostName Host -> Domain -> SOA -> (Zone, [WarningMessage]) +genZone inzdomain hostmap zdomain soa = + let (warnings, zhosts) = partitionEithers $ concatMap concat [ map hostips inzdomain , map hostrecords inzdomain - , map addcnames (M.elems m) + , map addcnames (M.elems hostmap) ] in (Zone zdomain soa (simplify zhosts), warnings) where - m = hostMap hosts - -- Known hosts with hostname located in the zone's domain. - inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m - -- Each host with a hostname located in the zdomain -- should have 1 or more IPAddrs in its Info. -- @@ -373,7 +468,7 @@ genZone hosts zdomain soa = -- So we can just use the IPAddrs. addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] addcnames h = concatMap gen $ filter (inDomain zdomain) $ - mapMaybe getCNAME $ S.toList (_dns info) + mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info where info = hostInfo h gen c = case getAddresses info of @@ -381,14 +476,14 @@ genZone hosts zdomain soa = l -> map (ret . Address) l where ret record = Right (c, record) - + -- Adds any other DNS records for a host located in the zdomain. hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)] hostrecords h = map Right l where info = hostInfo h l = zip (repeat $ AbsDomain $ hostName h) - (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns info)) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info)) -- Simplifies the list of hosts. Remove duplicate entries. -- Also, filter out any CHAMES where the same domain has an @@ -417,10 +512,39 @@ domainHost base (AbsDomain d) where dotbase = '.':base -addNamedConf :: NamedConf -> Info -addNamedConf conf = mempty { _namedconf = NamedConfMap (M.singleton domain conf) } +addNamedConf :: NamedConf -> NamedConfMap +addNamedConf conf = NamedConfMap (M.singleton domain conf) where domain = confDomain conf getNamedConf :: Propellor (M.Map Domain NamedConf) -getNamedConf = asks $ fromNamedConfMap . _namedconf . hostInfo +getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo + +-- | Generates SSHFP records for hosts in the domain (or with CNAMES +-- in the domain) that have configured ssh public keys. +-- +-- This is done using ssh-keygen, so sadly needs IO. +genSSHFP :: Domain -> Host -> Propellor [(BindDomain, Record)] +genSSHFP domain h = concatMap mk . concat <$> (gen =<< get) + where + get = fromHost [h] hostname Ssh.getHostPubKey + gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty + mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing) + (AbsDomain hostname : cnames) + cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info + hostname = hostName h + info = hostInfo h + +genSSHFP' :: String -> IO [Record] +genSSHFP' pubkey = withTmpFile "sshfp" $ \tmp tmph -> do + hPutStrLn tmph pubkey + hClose tmph + s <- catchDefaultIO "" $ + readProcess "ssh-keygen" ["-r", "dummy", "-f", tmp] + return $ mapMaybe (parse . words) $ lines s + where + parse ("dummy":"IN":"SSHFP":x:y:s:[]) = do + x' <- readish x + y' <- readish y + return $ SSHFP x' y' s + parse _ = Nothing diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs new file mode 100644 index 00000000..aa58dc60 --- /dev/null +++ b/src/Propellor/Property/DnsSec.hs @@ -0,0 +1,122 @@ +module Propellor.Property.DnsSec where + +import Propellor.Base +import qualified Propellor.Property.File as File + +-- | Puts the DNSSEC key files in place from PrivData. +-- +-- signedPrimary uses this, so this property does not normally need to be +-- used directly. +keysInstalled :: Domain -> RevertableProperty (HasInfo + UnixLike) UnixLike +keysInstalled domain = setup <!> cleanup + where + setup = propertyList "DNSSEC keys installed" $ toProps $ + map installkey keys + + cleanup = propertyList "DNSSEC keys removed" $ toProps $ + map (File.notPresent . keyFn domain) keys + + installkey k = writer (keysrc k) (keyFn domain k) (Context domain) + where + writer + | isPublic k = File.hasPrivContentExposedFrom + | otherwise = File.hasPrivContentFrom + + keys = [ PubZSK, PrivZSK, PubKSK, PrivKSK ] + + keysrc k = PrivDataSource (DnsSec k) $ unwords + [ "The file with extension" + , keyExt k + , "created by running:" + , if isZoneSigningKey k + then "dnssec-keygen -a RSASHA256 -b 2048 -n ZONE " ++ domain + else "dnssec-keygen -f KSK -a RSASHA256 -b 4096 -n ZONE " ++ domain + ] + +-- | Uses dnssec-signzone to sign a domain's zone file. +-- +-- signedPrimary uses this, so this property does not normally need to be +-- used directly. +zoneSigned :: Domain -> FilePath -> RevertableProperty (HasInfo + UnixLike) UnixLike +zoneSigned domain zonefile = setup <!> cleanup + where + setup :: Property (HasInfo + UnixLike) + setup = check needupdate (forceZoneSigned domain zonefile) + `requires` keysInstalled domain + + cleanup :: Property UnixLike + cleanup = File.notPresent (signedZoneFile zonefile) + `before` File.notPresent dssetfile + `before` revert (keysInstalled domain) + + dssetfile = dir </> "-" ++ domain ++ "." + dir = takeDirectory zonefile + + -- Need to update the signed zone file if the zone file or + -- any of the keys have a newer timestamp. + needupdate = do + v <- catchMaybeIO $ getModificationTime (signedZoneFile zonefile) + case v of + Nothing -> return True + Just t1 -> anyM (newerthan t1) $ + zonefile : map (keyFn domain) [minBound..maxBound] + + newerthan t1 f = do + t2 <- getModificationTime f + return (t2 >= t1) + +forceZoneSigned :: Domain -> FilePath -> Property UnixLike +forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do + salt <- take 16 <$> saltSha1 + let p = proc "dnssec-signzone" + [ "-A" + , "-3", salt + -- The serial number needs to be increased each time the + -- zone is resigned, even if there are no other changes, + -- so that it will propagate to secondaries. So, use the + -- unixtime serial format. + , "-N", "unixtime" + , "-o", domain + , zonefile + -- the ordering of these key files does not matter + , keyFn domain PubZSK + , keyFn domain PubKSK + ] + -- Run in the same directory as the zonefile, so it will + -- write the dsset file there. + (_, _, _, h) <- createProcess $ + p { cwd = Just (takeDirectory zonefile) } + ifM (checkSuccessProcess h) + ( return MadeChange + , return FailedChange + ) + +saltSha1 :: IO String +saltSha1 = readProcess "sh" + [ "-c" + , "head -c 1024 /dev/urandom | sha1sum | cut -d ' ' -f 1" + ] + +-- | The file used for a given key. +keyFn :: Domain -> DnsSecKey -> FilePath +keyFn domain k = "/etc/bind/propellor/dnssec" </> concat + [ "K" ++ domain ++ "." + , if isZoneSigningKey k then "ZSK" else "KSK" + , keyExt k + ] + +-- | These are the extensions that dnssec-keygen looks for. +keyExt :: DnsSecKey -> String +keyExt k + | isPublic k = ".key" + | otherwise = ".private" + +isPublic :: DnsSecKey -> Bool +isPublic k = k `elem` [PubZSK, PubKSK] + +isZoneSigningKey :: DnsSecKey -> Bool +isZoneSigningKey k = k `elem` [PubZSK, PrivZSK] + +-- | dnssec-signzone makes a .signed file +signedZoneFile :: FilePath -> FilePath +signedZoneFile zonefile = zonefile ++ ".signed" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 5a7a0840..2ef97438 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} -- | Docker support for propellor -- @@ -11,114 +11,146 @@ module Propellor.Property.Docker ( configured, container, docked, + imageBuilt, + imagePulled, memoryLimited, garbageCollected, tweaked, - Image, + Image(..), + latestImage, ContainerName, + Container(..), + HasImage(..), -- * Container configuration dns, hostname, + Publishable, publish, expose, user, + Mountable, volume, volumes_from, workdir, memory, cpuShares, link, + environment, ContainerAlias, restartAlways, restartOnFailure, restartNever, -- * Internal use + init, chain, ) where -import Propellor -import Propellor.SimpleSh +import Propellor.Base hiding (init) +import Propellor.Types.Docker +import Propellor.Types.Container +import Propellor.Types.Core +import Propellor.Types.CmdLine import Propellor.Types.Info +import Propellor.Container import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt -import qualified Propellor.Property.Docker.Shim as Shim -import Utility.SafeCommand +import qualified Propellor.Property.Cmd as Cmd +import qualified Propellor.Shim as Shim import Utility.Path +import Utility.ThreadScheduler import Control.Concurrent.Async hiding (link) import System.Posix.Directory import System.Posix.Process -import Data.List +import Prelude hiding (init) +import Data.List hiding (init) import Data.List.Utils -import qualified Data.Set as S +import qualified Data.Map as M +import System.Console.Concurrent -installed :: Property +installed :: Property DebianLike installed = Apt.installed ["docker.io"] -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional. -configured :: Property +configured :: Property (HasInfo + DebianLike) configured = prop `requires` installed where - prop = withPrivData DockerAuthentication anyContext $ \getcfg -> - property "docker configured" $ getcfg $ \cfg -> ensureProperty $ - "/root/.dockercfg" `File.hasContent` (lines cfg) + prop :: Property (HasInfo + DebianLike) + prop = withPrivData src anyContext $ \getcfg -> + property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $ + "/root/.dockercfg" `File.hasContent` privDataLines cfg + src = PrivDataSourceFileFromCommand DockerAuthentication + "/root/.dockercfg" "docker login" -- | A short descriptive name for a container. -- Should not contain whitespace or other unusual characters, -- only [a-zA-Z0-9_-] are allowed type ContainerName = String --- | Starts accumulating the properties of a Docker container. +-- | A docker container. +data Container = Container Image Host + +instance IsContainer Container where + containerProperties (Container _ h) = containerProperties h + containerInfo (Container _ h) = containerInfo h + setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps) + +class HasImage a where + getImageName :: a -> Image + +instance HasImage Image where + getImageName = id + +instance HasImage Container where + getImageName (Container i _) = i + +-- | Defines a Container with a given name, image, and properties. +-- Add properties to configure the Container. -- --- > container "web-server" "debian" +-- > container "web-server" (latestImage "debian") $ props -- > & publish "80:80" -- > & Apt.installed {"apache2"] -- > & ... -container :: ContainerName -> Image -> Host -container cn image = Host hn [] info +container :: ContainerName -> Image -> Props metatypes -> Container +container cn image (Props ps) = Container image (Host cn ps info) where - info = dockerInfo $ mempty { _dockerImage = Val image } - hn = cn2hn cn - -cn2hn :: ContainerName -> HostName -cn2hn cn = cn ++ ".docker" + info = dockerInfo mempty <> mconcat (map getInfoRecursive ps) --- | Ensures that a docker container is set up and running, finding --- its configuration in the passed list of hosts. --- +-- | Ensures that a docker container is set up and running. +-- -- The container has its own Properties which are handled by running -- propellor inside the container. -- -- When the container's Properties include DNS info, such as a CNAME, --- that is propigated to the Info of the host(s) it's docked in. +-- that is propagated to the Info of the Host it's docked in. -- -- Reverting this property ensures that the container is stopped and -- removed. -docked - :: [Host] - -> ContainerName - -> RevertableProperty -docked hosts cn = RevertableProperty - ((maybe id propigateInfo mhost) (go "docked" setup)) +docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +docked ctr@(Container _ h) = + (propagateContainerInfo ctr (go "docked" setup)) + <!> (go "undocked" teardown) where - go desc a = property (desc ++ " " ++ cn) $ do + cn = hostName h + + go desc a = property' (desc ++ " " ++ cn) $ \w -> do hn <- asks hostName let cid = ContainerId hn cn - ensureProperties [findContainer mhost cid cn $ a cid] - - mhost = findHostNoAlias hosts (cn2hn cn) + ensureProperty w $ a cid (mkContainerInfo cid ctr) - setup cid (Container image runparams) = + setup :: ContainerId -> ContainerInfo -> Property Linux + setup cid (ContainerInfo image runparams) = provisionContainer cid `requires` runningContainer cid image runparams `requires` installed - teardown cid (Container image _runparams) = - combineProperties ("undocked " ++ fromContainerId cid) + teardown :: ContainerId -> ContainerInfo -> Property Linux + teardown cid (ContainerInfo image _runparams) = + combineProperties ("undocked " ++ fromContainerId cid) $ toProps [ stoppedContainer cid , property ("cleaned up " ++ fromContainerId cid) $ liftIO $ report <$> mapM id @@ -127,35 +159,45 @@ docked hosts cn = RevertableProperty ] ] -propigateInfo :: Host -> Property -> Property -propigateInfo (Host _ _ containerinfo) p = - combineProperties (propertyDesc p) $ p : dnsprops ++ privprops +-- | Build the image from a directory containing a Dockerfile. +imageBuilt :: HasImage c => FilePath -> c -> Property Linux +imageBuilt directory ctr = built `describe` msg where - dnsprops = map addDNS (S.toList $ _dns containerinfo) - privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo) - -findContainer - :: Maybe Host - -> ContainerId - -> ContainerName - -> (Container -> Property) - -> Property -findContainer mhost cid cn mk = case mhost of - Nothing -> cantfind - Just h -> maybe cantfind mk (mkContainer cid h) + msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory + built :: Property Linux + built = tightenTargets $ + Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir + `assume` MadeChange + workDir p = p { cwd = Just directory } + image = getImageName ctr + +-- | Pull the image from the standard Docker Hub registry. +imagePulled :: HasImage c => c -> Property Linux +imagePulled ctr = pulled `describe` msg where - cantfind = containerDesc cid $ property "" $ do - liftIO $ warningMessage $ - "missing definition for docker container \"" ++ cn2hn cn - return FailedChange + msg = "docker image " ++ (imageIdentifier image) ++ " pulled" + pulled :: Property Linux + pulled = tightenTargets $ + Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] + `assume` MadeChange + image = getImageName ctr + +propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) +propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ + p `addInfoProperty` dockerinfo + where + dockerinfo = dockerInfo $ + mempty { _dockerContainers = M.singleton cn h } + cn = hostName h -mkContainer :: ContainerId -> Host -> Maybe Container -mkContainer cid@(ContainerId hn _cn) h = Container - <$> fromVal (_dockerImage info) - <*> pure (map (\mkparam -> mkparam hn) (_dockerRunParams info)) +mkContainerInfo :: ContainerId -> Container -> ContainerInfo +mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = + ContainerInfo img runparams where - info = _dockerinfo $ hostInfo h' - h' = h + runparams = map (\(DockerRunParam mkparam) -> mkparam hn) + (_dockerRunParams info) + info = fromInfo $ hostInfo h' + h' = setContainerProps h $ containerProps h -- Restart by default so container comes up on -- boot or when docker is upgraded. &^ restartAlways @@ -172,88 +214,156 @@ mkContainer cid@(ContainerId hn _cn) h = Container -- that were not set up using propellor. -- -- Generally, should come after the properties for the desired containers. -garbageCollected :: Property -garbageCollected = propertyList "docker garbage collected" - [ gccontainers - , gcimages - ] +garbageCollected :: Property Linux +garbageCollected = propertyList "docker garbage collected" $ props + & gccontainers + & gcimages where + gccontainers :: Property Linux gccontainers = property "docker containers garbage collected" $ liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) - gcimages = property "docker images garbage collected" $ do + gcimages :: Property Linux + gcimages = property "docker images garbage collected" $ liftIO $ report <$> (mapM removeImage =<< listImages) -- | Tweaks a container to work well with docker. -- -- Currently, this consists of making pam_loginuid lines optional in --- the pam config, to work around https://github.com/docker/docker/issues/5663 +-- the pam config, to work around <https://github.com/docker/docker/issues/5663> -- which affects docker 1.2.0. -tweaked :: Property -tweaked = trivial $ - cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"] +tweaked :: Property Linux +tweaked = tightenTargets $ cmdProperty "sh" + [ "-c" + , "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*" + ] + `assume` NoChange `describe` "tweaked for docker" --- | Configures the kernel to respect docker memory limits. +-- | Configures the kernel to respect docker memory limits. -- -- This assumes the system boots using grub 2. And that you don't need any -- other GRUB_CMDLINE_LINUX_DEFAULT settings. -- -- Only takes effect after reboot. (Not automated.) -memoryLimited :: Property -memoryLimited = "/etc/default/grub" `File.containsLine` cfg - `describe` "docker memory limited" - `onChange` cmdProperty "update-grub" [] +memoryLimited :: Property DebianLike +memoryLimited = tightenTargets $ + "/etc/default/grub" `File.containsLine` cfg + `describe` "docker memory limited" + `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) where cmdline = "cgroup_enable=memory swapaccount=1" cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\"" -data Container = Container Image [RunParam] +data ContainerInfo = ContainerInfo Image [RunParam] -- | Parameters to pass to `docker run` when creating a container. type RunParam = String --- | A docker image, that can be used to run a container. -type Image = String +-- | ImageID is an image identifier to perform action on images. An +-- ImageID can be the name of an container image, a UID, etc. +-- +-- It just encapsulates a String to avoid the definition of a String +-- instance of ImageIdentifier. +newtype ImageID = ImageID String + +-- | Used to perform Docker action on an image. +-- +-- Minimal complete definition: `imageIdentifier` +class ImageIdentifier i where + -- | For internal purposes only. + toImageID :: i -> ImageID + toImageID = ImageID . imageIdentifier + -- | A string that Docker can use as an image identifier. + imageIdentifier :: i -> String + +instance ImageIdentifier ImageID where + imageIdentifier (ImageID i) = i + toImageID = id + +-- | A docker image, that can be used to run a container. The user has +-- to specify a name and can provide an optional tag. +-- See <http://docs.docker.com/userguide/dockerimages/ Docker Image Documention> +-- for more information. +data Image = Image + { repository :: String + , tag :: Maybe String + } + deriving (Eq, Read, Show) + +-- | Defines a Docker image without any tag. This is considered by +-- Docker as the latest image of the provided repository. +latestImage :: String -> Image +latestImage repo = Image repo Nothing + +instance ImageIdentifier Image where + -- | The format of the imageIdentifier of an `Image` is: + -- repository | repository:tag + imageIdentifier i = repository i ++ (maybe "" ((++) ":") $ tag i) + +-- | The UID of an image. This UID is generated by Docker. +newtype ImageUID = ImageUID String + +instance ImageIdentifier ImageUID where + imageIdentifier (ImageUID uid) = uid -- | Set custom dns server for container. -dns :: String -> Property +dns :: String -> Property (HasInfo + Linux) dns = runProp "dns" -- | Set container host name. -hostname :: String -> Property +hostname :: String -> Property (HasInfo + Linux) hostname = runProp "hostname" -- | Set name of container. -name :: String -> Property +name :: String -> Property (HasInfo + Linux) name = runProp "name" +class Publishable p where + toPublish :: p -> String + +instance Publishable (Bound Port) where + toPublish p = fromPort (hostSide p) ++ ":" ++ fromPort (containerSide p) + +-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort +instance Publishable String where + toPublish = id + -- | Publish a container's port to the host --- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) -publish :: String -> Property -publish = runProp "publish" +publish :: Publishable p => p -> Property (HasInfo + Linux) +publish = runProp "publish" . toPublish -- | Expose a container's port without publishing it. -expose :: String -> Property +expose :: String -> Property (HasInfo + Linux) expose = runProp "expose" -- | Username or UID for container. -user :: String -> Property +user :: String -> Property (HasInfo + Linux) user = runProp "user" --- | Mount a volume --- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] +class Mountable p where + toMount :: p -> String + +instance Mountable (Bound FilePath) where + toMount p = hostSide p ++ ":" ++ containerSide p + +-- | string format: [host-dir]:[container-dir]:[rw|ro] +-- -- With just a directory, creates a volume in the container. -volume :: String -> Property -volume = runProp "volume" +instance Mountable String where + toMount = id + +-- | Mount a volume +volume :: Mountable v => v -> Property (HasInfo + Linux) +volume = runProp "volume" . toMount -- | Mount a volume from the specified container into the current -- container. -volumes_from :: ContainerName -> Property +volumes_from :: ContainerName -> Property (HasInfo + Linux) volumes_from cn = genProp "volumes-from" $ \hn -> fromContainerId (ContainerId hn cn) --- | Work dir inside the container. -workdir :: String -> Property +-- | Work dir inside the container. +workdir :: String -> Property (HasInfo + Linux) workdir = runProp "workdir" -- | Memory limit for container. @@ -261,18 +371,18 @@ workdir = runProp "workdir" -- -- Note: Only takes effect when the host has the memoryLimited property -- enabled. -memory :: String -> Property +memory :: String -> Property (HasInfo + Linux) memory = runProp "memory" -- | CPU shares (relative weight). -- -- By default, all containers run at the same priority, but you can tell -- the kernel to give more CPU time to a container using this property. -cpuShares :: Int -> Property +cpuShares :: Int -> Property (HasInfo + Linux) cpuShares = runProp "cpu-shares" . show -- | Link with another container on the same host. -link :: ContainerName -> ContainerAlias -> Property +link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux) link linkwith calias = genProp "link" $ \hn -> fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias @@ -284,24 +394,32 @@ type ContainerAlias = String -- propellor; as well as keeping badly behaved containers running, -- it ensures that containers get started back up after reboot or -- after docker is upgraded. -restartAlways :: Property +restartAlways :: Property (HasInfo + Linux) restartAlways = runProp "restart" "always" -- | Docker will restart the container if it exits nonzero. -- If a number is provided, it will be restarted only up to that many -- times. -restartOnFailure :: Maybe Int -> Property +restartOnFailure :: Maybe Int -> Property (HasInfo + Linux) restartOnFailure Nothing = runProp "restart" "on-failure" restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n) -- | Makes docker not restart a container when it exits -- Note that this includes not restarting it on boot! -restartNever :: Property +restartNever :: Property (HasInfo + Linux) restartNever = runProp "restart" "no" +-- | Set environment variable with a tuple composed by the environment +-- variable name and its value. +environment :: (String, String) -> Property (HasInfo + Linux) +environment (k, v) = runProp "env" $ k ++ "=" ++ v + -- | A container is identified by its name, and the host -- on which it's deployed. -data ContainerId = ContainerId HostName ContainerName +data ContainerId = ContainerId + { containerHostName :: HostName + , containerName :: ContainerName + } deriving (Eq, Read, Show) -- | Two containers with the same ContainerIdent were started from @@ -324,22 +442,19 @@ toContainerId s fromContainerId :: ContainerId -> String fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix -containerHostName :: ContainerId -> HostName -containerHostName (ContainerId _ cn) = cn2hn cn - myContainerSuffix :: String myContainerSuffix = ".propellor" -containerDesc :: ContainerId -> Property -> Property +containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i containerDesc cid p = p `describe` desc where - desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p + desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p -runningContainer :: ContainerId -> Image -> [RunParam] -> Property +runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do l <- liftIO $ listContainers RunningContainers if cid `elem` l - then checkident =<< liftIO (getrunningident simpleShClient) + then checkident =<< liftIO getrunningident else ifM (liftIO $ elem cid <$> listContainers AllContainers) ( do -- The container exists, but is not @@ -348,9 +463,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope -- starting it up first. void $ liftIO $ startContainer cid -- It can take a while for the container to - -- start up enough to get its ident, so - -- retry for up to 60 seconds. - checkident =<< liftIO (getrunningident (simpleShClientRetry 60)) + -- start up enough for its ident file to be + -- written, so retry for up to 60 seconds. + checkident =<< liftIO (retry 60 $ getrunningident) , go image ) where @@ -359,33 +474,55 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope -- Check if the ident has changed; if so the -- parameters of the container differ and it must -- be restarted. - checkident runningident + checkident (Right runningident) | runningident == Just ident = noChange | otherwise = do void $ liftIO $ stopContainer cid restartcontainer + checkident (Left errmsg) = do + warningMessage errmsg + return FailedChange restartcontainer = do - oldimage <- liftIO $ fromMaybe image <$> commitContainer cid + oldimage <- liftIO $ + maybe (toImageID image) toImageID <$> commitContainer cid void $ liftIO $ removeContainer cid go oldimage - getrunningident shclient = shclient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do - let !v = extractident rs - return v - - extractident :: [Resp] -> Maybe ContainerIdent - extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout + getrunningident = withTmpFile "dockerrunsane" $ \t h -> do + -- detect #774376 which caused docker exec to not enter + -- the container namespace, and be able to access files + -- outside + hClose h + void . checkSuccessProcess . processHandle =<< + createProcess (inContainerProcess cid [] + ["rm", "-f", t]) + ifM (doesFileExist t) + ( Right . readish <$> + readProcess' (inContainerProcess cid [] + ["cat", propellorIdent]) + , return $ Left "docker exec failed to enter chroot properly (maybe an old kernel version?)" + ) - go img = do - liftIO $ do - clearProvisionedFlag cid - createDirectoryIfMissing True (takeDirectory $ identFile cid) - shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid) - liftIO $ writeFile (identFile cid) (show ident) - ensureProperty $ boolProperty "run" $ runContainer img + retry :: Int -> IO (Either e (Maybe a)) -> IO (Either e (Maybe a)) + retry 0 _ = return (Right Nothing) + retry n a = do + v <- a + case v of + Right Nothing -> do + threadDelaySeconds (Seconds 1) + retry (n-1) a + _ -> return v + + go :: ImageIdentifier i => i -> Propellor Result + go img = liftIO $ do + clearProvisionedFlag cid + createDirectoryIfMissing True (takeDirectory $ identFile cid) + shim <- Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid) + writeFile (identFile cid) (show ident) + toResult <$> runContainer img (runps ++ ["-i", "-d", "-t"]) - [shim, "--docker", fromContainerId cid] + [shim, "--continue", show (DockerInit (fromContainerId cid))] -- | Called when propellor is running inside a docker container. -- The string should be the container's ContainerId. @@ -393,7 +530,6 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope -- This process is effectively init inside the container. -- It even needs to wait on zombie processes! -- --- Fork a thread to run the SimpleSh server in the background. -- In the foreground, run an interactive bash (or sh) shell, -- so that the user can interact with it when attached to the container. -- @@ -401,26 +537,24 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope -- again. So, to make the necessary services get started on boot, this needs -- to provision the container then. However, if the container is already -- being provisioned by the calling propellor, it would be redundant and --- problimatic to also provisoon it here. +-- problimatic to also provisoon it here, when not booting up. -- -- The solution is a flag file. If the flag file exists, then the container -- was already provisioned. So, it must be a reboot, and time to provision -- again. If the flag file doesn't exist, don't provision here. -chain :: String -> IO () -chain s = case toContainerId s of +init :: String -> IO () +init s = case toContainerId s of Nothing -> error $ "Invalid ContainerId: " ++ s Just cid -> do changeWorkingDirectory localdir writeFile propellorIdent . show =<< readIdentFile cid - -- Run boot provisioning before starting simpleSh, - -- to avoid ever provisioning twice at the same time. whenM (checkProvisionedFlag cid) $ do let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) - unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $ + unlessM (boolSystem shim [Param "--continue", Param $ show $ toChain cid]) $ warningMessage "Boot provision failed!" void $ async $ job reapzombies - void $ async $ job $ simpleSh $ namedPipe cid job $ do + flushConcurrentOutput void $ tryIO $ ifM (inPath "bash") ( boolSystem "bash" [Param "-l"] , boolSystem "/bin/sh" [] @@ -432,36 +566,38 @@ chain s = case toContainerId s of -- | Once a container is running, propellor can be run inside -- it to provision it. --- --- Note that there is a race here, between the simplesh --- server starting up in the container, and this property --- being run. So, retry connections to the client for up to --- 1 minute. -provisionContainer :: ContainerId -> Property +provisionContainer :: ContainerId -> Property Linux provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) - r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing) + let params = ["--continue", show $ toChain cid] + msgh <- getMessageHandle + let p = inContainerProcess cid + (if isConsole msgh then ["-it"] else []) + (shim : params) + r <- withHandle StdoutHandle createProcessSuccess p $ + processChainOutput when (r /= FailedChange) $ - setProvisionedFlag cid + setProvisionedFlag cid return r + +toChain :: ContainerId -> CmdLine +toChain cid = DockerChain (containerHostName cid) (fromContainerId cid) + +chain :: [Host] -> HostName -> String -> IO () +chain hostlist hn s = case toContainerId s of + Nothing -> errorMessage "bad container id" + Just cid -> case findHostNoAlias hostlist hn of + Nothing -> errorMessage ("cannot find host " ++ hn) + Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of + Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn) + Just h -> go cid h where - params = ["--continue", show $ Chain $ containerHostName cid] - - go lastline (v:rest) = case v of - StdoutLine s -> do - maybe noop putStrLn lastline - hFlush stdout - go (Just s) rest - StderrLine s -> do - maybe noop putStrLn lastline - hFlush stdout - hPutStrLn stderr s - hFlush stderr - go Nothing rest - Done -> ret lastline - go lastline [] = ret lastline - - ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline + go cid h = do + changeWorkingDirectory localdir + onlyProcess (provisioningLock cid) $ do + r <- runPropellor h $ ensureChildProperties $ hostProperties h + flushConcurrentOutput + putStrLn $ "\n" ++ show r stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] @@ -469,17 +605,17 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId startContainer :: ContainerId -> IO Bool startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] -stoppedContainer :: ContainerId -> Property -stoppedContainer cid = containerDesc cid $ property desc $ +stoppedContainer :: ContainerId -> Property Linux +stoppedContainer cid = containerDesc cid $ property' desc $ \w -> ifM (liftIO $ elem cid <$> listContainers RunningContainers) - ( liftIO cleanup `after` ensureProperty - (boolProperty desc $ stopContainer cid) + ( liftIO cleanup `after` ensureProperty w stop , return NoChange ) where desc = "stopped" + stop :: Property Linux + stop = property desc $ liftIO $ toResult <$> stopContainer cid cleanup = do - nukeFile $ namedPipe cid nukeFile $ identFile cid removeDirectoryRecursive $ shimdir cid clearProvisionedFlag cid @@ -488,17 +624,20 @@ removeContainer :: ContainerId -> IO Bool removeContainer cid = catchBoolIO $ snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing -removeImage :: Image -> IO Bool +removeImage :: ImageIdentifier i => i -> IO Bool removeImage image = catchBoolIO $ - snd <$> processTranscript dockercmd ["rmi", image ] Nothing + snd <$> processTranscript dockercmd ["rmi", imageIdentifier image] Nothing -runContainer :: Image -> [RunParam] -> [String] -> IO Bool +runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool runContainer image ps cmd = boolSystem dockercmd $ map Param $ - "run" : (ps ++ image : cmd) + "run" : (ps ++ (imageIdentifier image) : cmd) + +inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess +inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd) -commitContainer :: ContainerId -> IO (Maybe Image) +commitContainer :: ContainerId -> IO (Maybe ImageUID) commitContainer cid = catchMaybeIO $ - takeWhile (/= '\n') + ImageUID . takeWhile (/= '\n') <$> readProcess dockercmd ["commit", fromContainerId cid] data ContainerFilter = RunningContainers | AllContainers @@ -506,9 +645,9 @@ data ContainerFilter = RunningContainers | AllContainers -- | Only lists propellor managed containers. listContainers :: ContainerFilter -> IO [ContainerId] -listContainers status = - catMaybes . map toContainerId . concat . map (split ",") - . catMaybes . map (lastMaybe . words) . lines +listContainers status = + mapMaybe toContainerId . concatMap (split ",") + . mapMaybe (lastMaybe . words) . lines <$> readProcess dockercmd ps where ps @@ -516,32 +655,28 @@ listContainers status = | otherwise = baseps baseps = ["ps", "--no-trunc"] -listImages :: IO [Image] -listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] +listImages :: IO [ImageUID] +listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> Property -runProp field val = pureInfoProperty (param) $ dockerInfo $ - mempty { _dockerRunParams = [\_ -> "--"++param] } +runProp :: String -> RunParam -> Property (HasInfo + Linux) +runProp field val = tightenTargets $ pureInfoProperty (param) $ + mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } where param = field++"="++val -genProp :: String -> (HostName -> RunParam) -> Property -genProp field mkval = pureInfoProperty field $ dockerInfo $ - mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] } +genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux) +genProp field mkval = tightenTargets $ pureInfoProperty field $ + mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] } dockerInfo :: DockerInfo -> Info -dockerInfo i = mempty { _dockerinfo = i } +dockerInfo i = mempty `addInfo` i -- | The ContainerIdent of a container is written to --- /.propellor-ident inside it. This can be checked to see if +-- </.propellor-ident> inside it. This can be checked to see if -- the container has the same ident later. propellorIdent :: FilePath propellorIdent = "/.propellor-ident" --- | Named pipe used for communication with the container. -namedPipe :: ContainerId -> FilePath -namedPipe cid = "docker" </> fromContainerId cid - provisionedFlag :: ContainerId -> FilePath provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned" @@ -556,6 +691,9 @@ setProvisionedFlag cid = do checkProvisionedFlag :: ContainerId -> IO Bool checkProvisionedFlag = doesFileExist . provisionedFlag +provisioningLock :: ContainerId -> FilePath +provisioningLock cid = "docker" </> fromContainerId cid ++ ".lock" + shimdir :: ContainerId -> FilePath shimdir cid = "docker" </> fromContainerId cid ++ ".shim" diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs new file mode 100644 index 00000000..9f147943 --- /dev/null +++ b/src/Propellor/Property/Fail2Ban.hs @@ -0,0 +1,30 @@ +module Propellor.Property.Fail2Ban where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import Propellor.Property.ConfFile + +installed :: Property DebianLike +installed = Apt.serviceInstalledRunning "fail2ban" + +reloaded :: Property DebianLike +reloaded = Service.reloaded "fail2ban" + +type Jail = String + +-- | By default, fail2ban only enables the ssh jail, but many others +-- are available to be enabled, for example "postfix-sasl" +jailEnabled :: Jail -> Property DebianLike +jailEnabled name = jailConfigured name "enabled" "true" + `onChange` reloaded + +-- | Configures a jail. For example: +-- +-- > jailConfigured "sshd" "port" "2222" +jailConfigured :: Jail -> IniKey -> String -> Property UnixLike +jailConfigured name key value = + jailConfFile name `containsIniSetting` (name, key, value) + +jailConfFile :: Jail -> FilePath +jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf" diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index bc499e07..e072fcaa 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -1,46 +1,62 @@ module Propellor.Property.File where -import Propellor +import Propellor.Base import Utility.FileMode import System.Posix.Files -import System.PosixCompat.Types +import System.Exit type Line = String -- | Replaces all the content of a file. -hasContent :: FilePath -> [Line] -> Property -f `hasContent` newcontent = fileProperty ("replace " ++ f) +hasContent :: FilePath -> [Line] -> Property UnixLike +f `hasContent` newcontent = fileProperty + ("replace " ++ f) + (\_oldcontent -> newcontent) f + +-- | Replaces all the content of a file, ensuring that its modes do not +-- allow it to be read or written by anyone other than the current user +hasContentProtected :: FilePath -> [Line] -> Property UnixLike +f `hasContentProtected` newcontent = fileProperty' writeFileProtected + ("replace " ++ f) (\_oldcontent -> newcontent) f -- | Ensures a file has contents that comes from PrivData. -- -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600. -hasPrivContent :: FilePath -> Context -> Property -hasPrivContent = hasPrivContent' writeFileProtected +hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f + +-- | Like hasPrivContent, but allows specifying a source +-- for PrivData, rather than using PrivDataSourceFile . +hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContentFrom = hasPrivContent' writeFileProtected -- | Leaves the file at its default or current mode, -- allowing "private" data to be read. -- -- Use with caution! -hasPrivContentExposed :: FilePath -> Context -> Property -hasPrivContentExposed = hasPrivContent' writeFile - -hasPrivContent' :: (String -> FilePath -> IO ()) -> FilePath -> Context -> Property -hasPrivContent' writer f context = - withPrivData (PrivFile f) context $ \getcontent -> - property desc $ getcontent $ \privcontent -> - ensureProperty $ fileProperty' writer desc - (\_oldcontent -> lines privcontent) f +hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f + +hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContentExposedFrom = hasPrivContent' writeFile + +hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property (HasInfo + UnixLike) +hasPrivContent' writer source f context = + withPrivData source context $ \getcontent -> + property' desc $ \o -> getcontent $ \privcontent -> + ensureProperty o $ fileProperty' writer desc + (\_oldcontent -> privDataLines privcontent) f where desc = "privcontent " ++ f -- | Ensures that a line is present in a file, adding it to the end if not. -containsLine :: FilePath -> Line -> Property +containsLine :: FilePath -> Line -> Property UnixLike f `containsLine` l = f `containsLines` [l] -containsLines :: FilePath -> [Line] -> Property +containsLines :: FilePath -> [Line] -> Property UnixLike f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f where go content = content ++ filter (`notElem` content) ls @@ -48,52 +64,134 @@ f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f -- | 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 +lacksLine :: FilePath -> Line -> Property UnixLike f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f +lacksLines :: FilePath -> [Line] -> Property UnixLike +f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f + +-- | Replaces the content of a file with the transformed content of another file +basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike +f `basedOn` (f', a) = property' desc $ \o -> do + tmpl <- liftIO $ readFile f' + ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f + where + desc = "replace " ++ f + -- | Removes a file. Does not remove symlinks or non-plain-files. -notPresent :: FilePath -> Property +notPresent :: FilePath -> Property UnixLike notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ makeChange $ nukeFile f -fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike fileProperty = fileProperty' writeFile -fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) where go True = do - ls <- liftIO $ lines <$> readFile f - let ls' = a ls - if ls' == ls + old <- liftIO $ readFile f + let new = unlines (a (lines old)) + if old == new then noChange - else makeChange $ viaTmp updatefile f (unlines ls') + else makeChange $ updatefile new `viaStableTmp` f go False = makeChange $ writer f (unlines $ a []) - -- viaTmp makes the temp file mode 600. -- Replicate the original file's owner and mode. - updatefile f' content = do + updatefile content f' = do writer f' content s <- getFileStatus f setFileMode f' (fileMode s) setOwnerAndGroup f' (fileOwner s) (fileGroup s) -- | Ensures a directory exists. -dirExists :: FilePath -> Property +dirExists :: FilePath -> Property UnixLike dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d +-- | The location that a symbolic link points to. +newtype LinkTarget = LinkTarget FilePath + +-- | Creates or atomically updates a symbolic link. +-- +-- Does not overwrite regular files or directories. +isSymlinkedTo :: FilePath -> LinkTarget -> Property UnixLike +link `isSymlinkedTo` (LinkTarget target) = property desc $ + go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link) + where + desc = link ++ " is symlinked to " ++ target + go (Right stat) = + if isSymbolicLink stat + then checkLink + else nonSymlinkExists + go (Left _) = makeChange $ createSymbolicLink target link + + nonSymlinkExists = do + warningMessage $ link ++ " exists and is not a symlink" + return FailedChange + checkLink = do + target' <- liftIO $ readSymbolicLink link + if target == target' + then noChange + else makeChange updateLink + updateLink = createSymbolicLink target `viaStableTmp` link + +-- | Ensures that a file is a copy of another (regular) file. +isCopyOf :: FilePath -> FilePath -> Property UnixLike +f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f') + where + desc = f ++ " is copy of " ++ f' + go (Right stat) = if isRegularFile stat + then gocmp =<< (liftIO $ cmp) + else warningMessage (f' ++ " is not a regular file") >> + return FailedChange + go (Left e) = warningMessage (show e) >> return FailedChange + + cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File f'] + gocmp ExitSuccess = noChange + gocmp (ExitFailure 1) = doit + gocmp _ = warningMessage "cmp failed" >> return FailedChange + + doit = makeChange $ copy f' `viaStableTmp` f + copy src dest = unlessM (runcp src dest) $ errorMessage "cp failed" + runcp src dest = boolSystem "cp" + [Param "--preserve=all", Param "--", File src, File dest] + -- | Ensures that a file/dir has the specified owner and group. -ownerGroup :: FilePath -> UserName -> GroupName -> Property -ownerGroup f owner group = property (f ++ " owner " ++ og) $ do - r <- ensureProperty $ cmdProperty "chown" [og, f] - if r == FailedChange - then return r - else noChange +ownerGroup :: FilePath -> User -> Group -> Property UnixLike +ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og) where + p = cmdProperty "chown" [og, f] + `changesFile` f og = owner ++ ":" ++ group -- | Ensures that a file/dir has the specfied mode. -mode :: FilePath -> FileMode -> Property -mode f v = property (f ++ " mode " ++ show v) $ do - liftIO $ modifyFileMode f (\_old -> v) - noChange +mode :: FilePath -> FileMode -> Property UnixLike +mode f v = p `changesFile` f + where + p = property (f ++ " mode " ++ show v) $ do + liftIO $ modifyFileMode f (const v) + return NoChange + +-- | A temp file to use when writing new content for a file. +-- +-- This is a stable name so it can be removed idempotently. +-- +-- It ends with "~" so that programs that read many config files from a +-- directory will treat it as an editor backup file, and not read it. +stableTmpFor :: FilePath -> FilePath +stableTmpFor f = f ++ ".propellor-new~" + +-- | Creates/updates a file atomically, running the action to create the +-- stable tmp file, and then renaming it into place. +viaStableTmp :: (MonadMask m, MonadIO m) => (FilePath -> m ()) -> FilePath -> m () +viaStableTmp a f = bracketIO setup cleanup go + where + setup = do + createDirectoryIfMissing True (takeDirectory f) + let tmpfile = stableTmpFor f + nukeFile tmpfile + return tmpfile + cleanup tmpfile = tryIO $ removeFile tmpfile + go tmpfile = do + a tmpfile + liftIO $ rename tmpfile f diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index b660207b..3ea19ffa 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -1,88 +1,202 @@ --- |Properties for configuring firewall (iptables) rules +-- | Maintainer: Arnaud Bailly <arnaud.oqube@gmail.com> -- --- Copyright 2014 Arnaud Bailly <arnaud.oqube@gmail.com> --- License: BSD-2-Clause +-- Properties for configuring firewall (iptables) rules + module Propellor.Property.Firewall ( rule, installed, Chain(..), + Table(..), Target(..), Proto(..), Rules(..), - ConnectionState(..) + ConnectionState(..), + ICMPTypeMatch(..), + TCPFlag(..), + Frequency(..), + IPWithMask(..), + fromIPWithMask ) where import Data.Monoid import Data.Char import Data.List -import Propellor -import Utility.SafeCommand +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network -installed :: Property +installed :: Property DebianLike installed = Apt.installed ["iptables"] -rule :: Chain -> Target -> Rules -> Property -rule c t rs = property ("firewall rule: " <> show r) addIpTable +rule :: Chain -> Table -> Target -> Rules -> Property Linux +rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable where - r = Rule c t rs + r = Rule c tb tg rs addIpTable = liftIO $ do let args = toIpTable r exist <- boolSystem "iptables" (chk args) if exist then return NoChange - else ifM (boolSystem "iptables" (add args)) - ( return MadeChange , return FailedChange) - add params = (Param "-A") : params - chk params = (Param "-C") : params + else toResult <$> boolSystem "iptables" (add args) + add params = Param "-A" : params + chk params = Param "-C" : params toIpTable :: Rule -> [CommandParam] toIpTable r = map Param $ - (show $ ruleChain r) : - (toIpTableArg (ruleRules r)) ++ [ "-j" , show $ ruleTarget r ] + fromChain (ruleChain r) : + toIpTableArg (ruleRules r) ++ + ["-t", fromTable (ruleTable r), "-j", fromTarget (ruleTarget r)] toIpTableArg :: Rules -> [String] -toIpTableArg Everything = [] -toIpTableArg (Proto proto) = ["-p", map toLower $ show proto] -toIpTableArg (Port port) = ["--dport", show port] -toIpTableArg (PortRange (f,t)) = ["--dport", show f ++ ":" ++ show t] -toIpTableArg (IFace iface) = ["-i", iface] -toIpTableArg (Ctstate states) = ["-m", "conntrack","--ctstate", concat $ intersperse "," (map show states)] -toIpTableArg (r :- r') = toIpTableArg r <> toIpTableArg r' +toIpTableArg Everything = [] +toIpTableArg (Proto proto) = ["-p", map toLower $ show proto] +toIpTableArg (DPort port) = ["--dport", fromPort port] +toIpTableArg (DPortRange (portf, portt)) = + ["--dport", fromPort portf ++ ":" ++ fromPort portt] +toIpTableArg (InIFace iface) = ["-i", iface] +toIpTableArg (OutIFace iface) = ["-o", iface] +toIpTableArg (Ctstate states) = + [ "-m" + , "conntrack" + , "--ctstate", intercalate "," (map show states) + ] +toIpTableArg (ICMPType i) = + [ "-m" + , "icmp" + , "--icmp-type", fromICMPTypeMatch i + ] +toIpTableArg (RateLimit f) = + [ "-m" + , "limit" + , "--limit", fromFrequency f + ] +toIpTableArg (TCPFlags m c) = + [ "-m" + , "tcp" + , "--tcp-flags" + , intercalate "," (map show m) + , intercalate "," (map show c) + ] +toIpTableArg TCPSyn = ["--syn"] +toIpTableArg (GroupOwner (Group g)) = + [ "-m" + , "owner" + , "--gid-owner" + , g + ] +toIpTableArg (Source ipwm) = + [ "-s" + , intercalate "," (map fromIPWithMask ipwm) + ] +toIpTableArg (Destination ipwm) = + [ "-d" + , intercalate "," (map fromIPWithMask ipwm) + ] +toIpTableArg (NotDestination ipwm) = + [ "!" + , "-d" + , intercalate "," (map fromIPWithMask ipwm) + ] +toIpTableArg (NatDestination ip mport) = + [ "--to-destination" + , fromIPAddr ip ++ maybe "" (\p -> ":" ++ fromPort p) mport + ] +toIpTableArg (r :- r') = toIpTableArg r <> toIpTableArg r' + +data IPWithMask = IPWithNoMask IPAddr | IPWithIPMask IPAddr IPAddr | IPWithNumMask IPAddr Int + deriving (Eq, Show) + +fromIPWithMask :: IPWithMask -> String +fromIPWithMask (IPWithNoMask ip) = fromIPAddr ip +fromIPWithMask (IPWithIPMask ip ipm) = fromIPAddr ip ++ "/" ++ fromIPAddr ipm +fromIPWithMask (IPWithNumMask ip m) = fromIPAddr ip ++ "/" ++ show m data Rule = Rule - { ruleChain :: Chain + { ruleChain :: Chain + , ruleTable :: Table , ruleTarget :: Target - , ruleRules :: Rules - } deriving (Eq, Show, Read) + , ruleRules :: Rules + } deriving (Eq, Show) -data Chain = INPUT | OUTPUT | FORWARD - deriving (Eq,Show,Read) +data Table = Filter | Nat | Mangle | Raw | Security + deriving (Eq, Show) -data Target = ACCEPT | REJECT | DROP | LOG - deriving (Eq,Show,Read) +fromTable :: Table -> String +fromTable Filter = "filter" +fromTable Nat = "nat" +fromTable Mangle = "mangle" +fromTable Raw = "raw" +fromTable Security = "security" -data Proto = TCP | UDP | ICMP - deriving (Eq,Show,Read) +data Target = ACCEPT | REJECT | DROP | LOG | TargetCustom String + deriving (Eq, Show) -type Port = Int +fromTarget :: Target -> String +fromTarget ACCEPT = "ACCEPT" +fromTarget REJECT = "REJECT" +fromTarget DROP = "DROP" +fromTarget LOG = "LOG" +fromTarget (TargetCustom t) = t + +data Chain = INPUT | OUTPUT | FORWARD | PREROUTING | POSTROUTING | ChainCustom String + deriving (Eq, Show) + +fromChain :: Chain -> String +fromChain INPUT = "INPUT" +fromChain OUTPUT = "OUTPUT" +fromChain FORWARD = "FORWARD" +fromChain PREROUTING = "PREROUTING" +fromChain POSTROUTING = "POSTROUTING" +fromChain (ChainCustom c) = c + +data Proto = TCP | UDP | ICMP + deriving (Eq, Show) data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID - deriving (Eq,Show,Read) + deriving (Eq, Show) + +data ICMPTypeMatch = ICMPTypeName String | ICMPTypeCode Int + deriving (Eq, Show) + +fromICMPTypeMatch :: ICMPTypeMatch -> String +fromICMPTypeMatch (ICMPTypeName t) = t +fromICMPTypeMatch (ICMPTypeCode c) = show c + +data Frequency = NumBySecond Int + deriving (Eq, Show) + +fromFrequency :: Frequency -> String +fromFrequency (NumBySecond n) = show n ++ "/second" + +type TCPFlagMask = [TCPFlag] + +type TCPFlagComp = [TCPFlag] + +data TCPFlag = SYN | ACK | FIN | RST | URG | PSH | ALL | NONE + deriving (Eq, Show) data Rules = Everything | Proto Proto -- ^There is actually some order dependency between proto and port so this should be a specific -- data type with proto + ports - | Port Port - | PortRange (Port,Port) - | IFace Network.Interface + | DPort Port + | DPortRange (Port, Port) + | InIFace Network.Interface + | OutIFace Network.Interface | Ctstate [ ConnectionState ] + | ICMPType ICMPTypeMatch + | RateLimit Frequency + | TCPFlags TCPFlagMask TCPFlagComp + | TCPSyn + | GroupOwner Group + | Source [ IPWithMask ] + | Destination [ IPWithMask ] + | NotDestination [ IPWithMask ] + | NatDestination IPAddr (Maybe Port) | Rules :- Rules -- ^Combine two rules - deriving (Eq,Show,Read) + deriving (Eq, Show) infixl 0 :- diff --git a/src/Propellor/Property/FreeBSD.hs b/src/Propellor/Property/FreeBSD.hs new file mode 100644 index 00000000..af83fa8c --- /dev/null +++ b/src/Propellor/Property/FreeBSD.hs @@ -0,0 +1,13 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- FreeBSD Properties +-- +-- This module is designed to be imported unqualified. + +module Propellor.Property.FreeBSD ( + module Propellor.Property.FreeBSD.Pkg, + module Propellor.Property.FreeBSD.Poudriere +) where + +import Propellor.Property.FreeBSD.Pkg +import Propellor.Property.FreeBSD.Poudriere diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs new file mode 100644 index 00000000..704c1db9 --- /dev/null +++ b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -0,0 +1,88 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- FreeBSD pkgng properties + +{-# Language ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} + +module Propellor.Property.FreeBSD.Pkg where + +import Propellor.Base +import Propellor.Types.Info + +noninteractiveEnv :: [([Char], [Char])] +noninteractiveEnv = [("ASSUME_ALWAYS_YES", "yes")] + +pkgCommand :: String -> [String] -> (String, [String]) +pkgCommand cmd args = ("pkg", (cmd:args)) + +runPkg :: String -> [String] -> IO [String] +runPkg cmd args = + let + (p, a) = pkgCommand cmd args + in + lines <$> readProcess p a + +pkgCmdProperty :: String -> [String] -> UncheckedProperty FreeBSD +pkgCmdProperty cmd args = tightenTargets $ + let + (p, a) = pkgCommand cmd args + in + cmdPropertyEnv p a noninteractiveEnv + +pkgCmd :: String -> [String] -> IO [String] +pkgCmd cmd args = + let + (p, a) = pkgCommand cmd args + in + lines <$> readProcessEnv p a (Just noninteractiveEnv) + +newtype PkgUpdate = PkgUpdate String + deriving (Typeable, Monoid, Show) +instance IsInfo PkgUpdate where + propagateInfo _ = False + +pkgUpdated :: PkgUpdate -> Bool +pkgUpdated (PkgUpdate _) = True + +update :: Property (HasInfo + FreeBSD) +update = + let + upd = pkgCmd "update" [] + go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) + in + (property "pkg update has run" go :: Property FreeBSD) + `setInfoProperty` (toInfo (PkgUpdate "")) + +newtype PkgUpgrade = PkgUpgrade String + deriving (Typeable, Monoid, Show) +instance IsInfo PkgUpgrade where + propagateInfo _ = False + +pkgUpgraded :: PkgUpgrade -> Bool +pkgUpgraded (PkgUpgrade _) = True + +upgrade :: Property (HasInfo + FreeBSD) +upgrade = + let + upd = pkgCmd "upgrade" [] + go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) + in + (property "pkg upgrade has run" go :: Property FreeBSD) + `setInfoProperty` (toInfo (PkgUpdate "")) + `requires` update + +type Package = String + +installed :: Package -> Property FreeBSD +installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg] + +isInstallable :: Package -> IO Bool +isInstallable p = (not <$> isInstalled p) <&&> exists p + +isInstalled :: Package -> IO Bool +isInstalled p = (runPkg "info" [p] >> return True) + `catchIO` (\_ -> return False) + +exists :: Package -> IO Bool +exists p = (runPkg "search" ["--search", "name", "--exact", p] >> return True) + `catchIO` (\_ -> return False) diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs new file mode 100644 index 00000000..fcad9e87 --- /dev/null +++ b/src/Propellor/Property/FreeBSD/Poudriere.hs @@ -0,0 +1,144 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- FreeBSD Poudriere properties + +{-# Language GeneralizedNewtypeDeriving, DeriveDataTypeable #-} + +module Propellor.Property.FreeBSD.Poudriere where + +import Propellor.Base +import Propellor.Types.Info +import Data.List +import Data.String (IsString(..)) + +import qualified Propellor.Property.FreeBSD.Pkg as Pkg +import qualified Propellor.Property.ZFS as ZFS +import qualified Propellor.Property.File as File + +poudriereConfigPath :: FilePath +poudriereConfigPath = "/usr/local/etc/poudriere.conf" + +newtype PoudriereConfigured = PoudriereConfigured String + deriving (Typeable, Monoid, Show) +instance IsInfo PoudriereConfigured where + propagateInfo _ = False + +poudriereConfigured :: PoudriereConfigured -> Bool +poudriereConfigured (PoudriereConfigured _) = True + +setConfigured :: Property (HasInfo + FreeBSD) +setConfigured = tightenTargets $ + pureInfoProperty "Poudriere Configured" (PoudriereConfigured "") + +poudriere :: Poudriere -> Property (HasInfo + FreeBSD) +poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop + `requires` Pkg.installed "poudriere" + `before` setConfigured + where + confProp :: Property FreeBSD + confProp = tightenTargets $ + File.containsLines poudriereConfigPath (toLines conf) + setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS" + prop :: Property FreeBSD + prop + | isJust zfs = ((setZfs $ fromJust zfs) `before` confProp) + | otherwise = confProp `describe` "Configuring Poudriere without ZFS" + +poudriereCommand :: String -> [String] -> (String, [String]) +poudriereCommand cmd args = ("poudriere", cmd:args) + +runPoudriere :: String -> [String] -> IO [String] +runPoudriere cmd args = + let + (p, a) = poudriereCommand cmd args + in + lines <$> readProcess p a + +listJails :: IO [String] +listJails = mapMaybe (headMaybe . take 1 . words) + <$> runPoudriere "jail" ["-l", "-q"] + +jailExists :: Jail -> IO Bool +jailExists (Jail name _ _) = isInfixOf [name] <$> listJails + +jail :: Jail -> Property FreeBSD +jail j@(Jail name version arch) = tightenTargets $ + let + chk = do + c <- poudriereConfigured <$> askInfo + nx <- liftIO $ not <$> jailExists j + return $ c && nx + + (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", show arch, "-v", show version] + createJail = cmdProperty cmd args + in + check chk createJail + `describe` unwords ["Create poudriere jail", name] + +data JailInfo = JailInfo String + +data Poudriere = Poudriere + { _resolvConf :: String + , _freebsdHost :: String + , _baseFs :: String + , _usePortLint :: Bool + , _distFilesCache :: FilePath + , _svnHost :: String + , _zfs :: Maybe PoudriereZFS + } + +defaultConfig :: Poudriere +defaultConfig = Poudriere + "/etc/resolv.conf" + "ftp://ftp5.us.FreeBSD.org" + "/usr/local/poudriere" + True + "/usr/ports/distfiles" + "svn.freebsd.org" + Nothing + +data PoudriereZFS = PoudriereZFS ZFS.ZFS ZFS.ZFSProperties + +data Jail = Jail String FBSDVersion PoudriereArch + +data PoudriereArch = I386 | AMD64 deriving (Eq) +instance Show PoudriereArch where + show I386 = "i386" + show AMD64 = "amd64" + +instance IsString PoudriereArch where + fromString "i386" = I386 + fromString "amd64" = AMD64 + fromString _ = error "Not a valid Poudriere architecture." + +yesNoProp :: Bool -> String +yesNoProp b = if b then "yes" else "no" + +instance ToShellConfigLines Poudriere where + toAssoc c = map (\(k, f) -> (k, f c)) + [ ("RESOLV_CONF", _resolvConf) + , ("FREEBSD_HOST", _freebsdHost) + , ("BASEFS", _baseFs) + , ("USE_PORTLINT", yesNoProp . _usePortLint) + , ("DISTFILES_CACHE", _distFilesCache) + , ("SVN_HOST", _svnHost) + ] ++ maybe [ ("NO_ZFS", "yes") ] toAssoc (_zfs c) + +instance ToShellConfigLines PoudriereZFS where + toAssoc (PoudriereZFS (ZFS.ZFS (ZFS.ZPool pool) dataset) _) = + [ ("NO_ZFS", "no") + , ("ZPOOL", pool) + , ("ZROOTFS", show dataset) + ] + +type ConfigLine = String +type ConfigFile = [ConfigLine] + +class ToShellConfigLines a where + toAssoc :: a -> [(String, String)] + + toLines :: a -> [ConfigLine] + toLines c = map (\(k, v) -> intercalate "=" [k, v]) (toAssoc c) + +confFile :: FilePath +confFile = "/usr/local/etc/poudriere.conf" diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs new file mode 100644 index 00000000..60f11d8e --- /dev/null +++ b/src/Propellor/Property/Fstab.hs @@ -0,0 +1,111 @@ +module Propellor.Property.Fstab ( + FsType, + Source, + MountPoint, + MountOpts(..), + module Propellor.Property.Fstab, +) where + +import Propellor.Base +import qualified Propellor.Property.File as File +import Propellor.Property.Mount + +import Data.Char +import Data.List +import Utility.Table + +-- | Ensures that </etc/fstab> contains a line mounting the specified +-- `Source` on the specified `MountPoint`, and that it's currently mounted. +-- +-- For example: +-- +-- > mounted "auto" "/dev/sdb1" "/srv" mempty +-- +-- Note that if anything else is already mounted at the `MountPoint`, it +-- will be left as-is by this property. +mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux +mounted fs src mnt opts = tightenTargets $ + "/etc/fstab" `File.containsLine` l + `describe` (mnt ++ " mounted by fstab") + `onChange` mountnow + where + l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] + dump = "0" + passno = "2" + -- This use of mountPoints, which is linux-only, is why this + -- property currently only supports linux. + mountnow = check (notElem mnt <$> mountPoints) $ + cmdProperty "mount" [mnt] + +newtype SwapPartition = SwapPartition FilePath + +-- | Replaces </etc/fstab> with a file that should cause the currently +-- mounted partitions to be re-mounted the same way on boot. +-- +-- For each specified MountPoint, the UUID of each partition +-- (or if there is no UUID, its label), its filesystem type, +-- and its mount options are all automatically probed. +-- +-- The SwapPartitions are also included in the generated fstab. +fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux +fstabbed mnts swaps = property' "fstabbed" $ \o -> do + fstab <- liftIO $ genFstab mnts swaps id + ensureProperty o $ + "/etc/fstab" `File.hasContent` fstab + +genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String] +genFstab mnts swaps mnttransform = do + fstab <- liftIO $ mapM getcfg (sort mnts) + swapfstab <- liftIO $ mapM getswapcfg swaps + return $ header ++ formatTable (legend : fstab ++ swapfstab) + where + header = + [ "# /etc/fstab: static file system information. See fstab(5)" + , "# " + ] + legend = ["# <file system>", "<mount point>", "<type>", "<options>", "<dump>", "<pass>"] + getcfg mnt = sequence + [ fromMaybe (error $ "unable to find mount source for " ++ mnt) + <$> getM (\a -> a mnt) + [ uuidprefix getMountUUID + , sourceprefix getMountLabel + , getMountSource + ] + , pure (mnttransform mnt) + , fromMaybe "auto" <$> getFsType mnt + , formatMountOpts <$> getFsMountOpts mnt + , pure "0" + , pure (if mnt == "/" then "1" else "2") + ] + getswapcfg (SwapPartition swap) = sequence + [ fromMaybe swap <$> getM (\a -> a swap) + [ uuidprefix getSourceUUID + , sourceprefix getSourceLabel + ] + , pure "none" + , pure "swap" + , pure (formatMountOpts mempty) + , pure "0" + , pure "0" + ] + prefix s getter m = fmap (s ++) <$> getter m + uuidprefix = prefix "UUID=" + sourceprefix = prefix "LABEL=" + +-- | Checks if </etc/fstab> is not configured. +-- This is the case if it doesn't exist, or +-- consists entirely of blank lines or comments. +-- +-- So, if you want to only replace the fstab once, and then never touch it +-- again, allowing local modifications: +-- +-- > check noFstab (fstabbed mnts []) +noFstab :: IO Bool +noFstab = ifM (doesFileExist "/etc/fstab") + ( null . filter iscfg . lines <$> readFile "/etc/fstab" + , return True + ) + where + iscfg l + | null l = False + | otherwise = not $ "#" `isPrefixOf` dropWhile isSpace l diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index e5df7e48..5d7c8b4d 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -1,10 +1,9 @@ module Propellor.Property.Git where -import Propellor +import Propellor.Base import Propellor.Property.File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import Utility.SafeCommand import Data.List @@ -12,8 +11,8 @@ import Data.List -- using git-daemon, run from inetd. -- -- Note that reverting this property does not remove or stop inetd. -daemonRunning :: FilePath -> RevertableProperty -daemonRunning exportdir = RevertableProperty setup unsetup +daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike +daemonRunning exportdir = setup <!> unsetup where setup = containsLine conf (mkl "tcp4") `requires` @@ -23,7 +22,7 @@ daemonRunning exportdir = RevertableProperty setup unsetup `requires` Apt.serviceInstalledRunning "openbsd-inetd" `onChange` - Service.running "openbsd-inetd" + Service.reloaded "openbsd-inetd" `describe` ("git-daemon exporting " ++ exportdir) unsetup = lacksLine conf (mkl "tcp4") `requires` @@ -48,7 +47,7 @@ daemonRunning exportdir = RevertableProperty setup unsetup , exportdir ] -installed :: Property +installed :: Property DebianLike installed = Apt.installed ["git"] type RepoUrl = String @@ -57,12 +56,13 @@ type Branch = String -- | Specified git repository is cloned to the specified directory. -- --- If the firectory exists with some other content, it will be recursively --- deleted. +-- If the directory exists with some other content (either a non-git +-- repository, or a git repository cloned from some other location), +-- it will be recursively deleted first. -- -- A branch can be specified, to check out. -cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property -cloned owner url dir mbranch = check originurl (property desc checkout) +cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike +cloned owner url dir mbranch = check originurl go `requires` installed where desc = "git cloned " ++ url ++ " to " ++ dir @@ -74,20 +74,90 @@ cloned owner url dir mbranch = check originurl (property desc checkout) return (v /= Just url) , return True ) - checkout = do + go :: Property DebianLike + go = property' desc $ \w -> do liftIO $ do whenM (doesDirectoryExist dir) $ removeDirectoryRecursive dir createDirectoryIfMissing True (takeDirectory dir) - ensureProperty $ userScriptProperty owner $ catMaybes - -- The </dev/null fixes an intermittent - -- "fatal: read error: Bad file descriptor" - -- when run across ssh with propellor --spin - [ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null" - , Just $ "cd " ++ shellEscape dir - , ("git checkout " ++) <$> mbranch - -- In case this repo is exposted via the web, - -- although the hook to do this ongoing is not - -- installed here. - , Just "git update-server-info" + ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds) + `assume` MadeChange + checkoutcmds = + -- The </dev/null fixes an intermittent + -- "fatal: read error: Bad file descriptor" + -- when run across ssh with propellor --spin + [ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null" + , Just $ "cd " ++ shellEscape dir + , ("git checkout " ++) <$> mbranch + -- In case this repo is exposted via the web, + -- although the hook to do this ongoing is not + -- installed here. + , Just "git update-server-info" + ] + +isGitDir :: FilePath -> IO Bool +isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", dir]) + +data GitShared = Shared Group | SharedAll | NotShared + +bareRepo :: FilePath -> User -> GitShared -> Property UnixLike +bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $ + dirExists repo : case gitshared of + NotShared -> + [ ownerGroup repo user (userGroup user) + , userScriptProperty user ["git init --bare --shared=false " ++ shellEscape repo] + `assume` MadeChange + ] + SharedAll -> + [ ownerGroup repo user (userGroup user) + , userScriptProperty user ["git init --bare --shared=all " ++ shellEscape repo] + `assume` MadeChange ] + Shared group' -> + [ ownerGroup repo user group' + , userScriptProperty user ["git init --bare --shared=group " ++ shellEscape repo] + `assume` MadeChange + ] + where + isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo']) + +-- | Set a key value pair in a git repo's configuration. +repoConfigured :: FilePath -> (String, String) -> Property UnixLike +repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $ + userScriptProperty (User "root") + [ "cd " ++ repo + , "git config " ++ key ++ " " ++ value + ] + `assume` MadeChange + `describe` desc + where + alreadyconfigured = do + vs <- getRepoConfig repo key + return $ value `elem` vs + desc = "git repo at " ++ repo ++ " config setting " ++ key ++ " set to " ++ value + +-- | Gets the value that a key is set to in a git repo's configuration. +getRepoConfig :: FilePath -> String -> IO [String] +getRepoConfig repo key = catchDefaultIO [] $ + lines <$> readProcess "git" ["-C", repo, "config", key] + +-- | Whether a repo accepts non-fast-forward pushes. +repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike +repoAcceptsNonFFs repo = accepts <!> refuses + where + accepts = repoConfigured repo ("receive.denyNonFastForwards", "false") + `describe` desc "accepts" + refuses = repoConfigured repo ("receive.denyNonFastForwards", "true") + `describe` desc "rejects" + desc s = "git repo " ++ repo ++ " " ++ s ++ " non-fast-forward pushes" + +-- | Sets a bare repository's default branch, which will be checked out +-- when cloning it. +bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike +bareRepoDefaultBranch repo branch = + userScriptProperty (User "root") + [ "cd " ++ repo + , "git symbolic-ref HEAD refs/heads/" ++ branch + ] + `changesFileContent` (repo </> "HEAD") + `describe` ("git repo at " ++ repo ++ " has default branch " ++ branch) diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs index b4698663..74e9df5a 100644 --- a/src/Propellor/Property/Gpg.hs +++ b/src/Propellor/Property/Gpg.hs @@ -1,15 +1,18 @@ module Propellor.Property.Gpg where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import Utility.FileSystemEncoding import System.PosixCompat -installed :: Property +installed :: Property DebianLike installed = Apt.installed ["gnupg"] -type GpgKeyId = String +-- A numeric id, or a description of the key, in a form understood by gpg. +newtype GpgKeyId = GpgKeyId { getGpgKeyId :: String } + +data GpgKeyType = GpgPubKey | GpgPrivKey -- | Sets up a user with a gpg key from the privdata. -- @@ -19,26 +22,42 @@ type GpgKeyId = String -- -- Recommend only using this for low-value dedicated role keys. -- No attempt has been made to scrub the key out of memory once it's used. --- --- The GpgKeyId does not have to be a numeric id; it can just as easily --- be a description of the key. -keyImported :: GpgKeyId -> UserName -> Property -keyImported keyid user = flagFile' prop genflag +keyImported :: GpgKeyId -> User -> Property (HasInfo + DebianLike) +keyImported key@(GpgKeyId keyid) user@(User u) = prop `requires` installed where - desc = user ++ " has gpg key " ++ show keyid - genflag = do - d <- dotDir user - return $ d </> ".propellor-imported-keyid-" ++ keyid - prop = withPrivData GpgKey (Context keyid) $ \getkey -> - property desc $ getkey $ \key -> makeChange $ - withHandle StdinHandle createProcessSuccess - (proc "su" ["-c", "gpg --import", user]) $ \h -> do - fileEncoding h - hPutStr h key - hClose h - -dotDir :: UserName -> IO FilePath -dotDir user = do - home <- homeDirectory <$> getUserEntryForName user + desc = u ++ " has gpg key " ++ show keyid + prop :: Property (HasInfo + DebianLike) + prop = withPrivData src (Context keyid) $ \getkey -> + property desc $ getkey $ \key' -> do + let keylines = privDataLines key' + ifM (liftIO $ hasGpgKey (parse keylines)) + ( return NoChange + , makeChange $ withHandle StdinHandle createProcessSuccess + (proc "su" ["-c", "gpg --import", u]) $ \h -> do + fileEncoding h + hPutStr h (unlines keylines) + hClose h + ) + src = PrivDataSource GpgKey "Either a gpg public key, exported with gpg --export -a, or a gpg private key, exported with gpg --export-secret-key -a" + + parse ("-----BEGIN PGP PUBLIC KEY BLOCK-----":_) = Just GpgPubKey + parse ("-----BEGIN PGP PRIVATE KEY BLOCK-----":_) = Just GpgPrivKey + parse _ = Nothing + + hasGpgKey Nothing = error $ "Failed to run gpg parser on armored key " ++ keyid + hasGpgKey (Just GpgPubKey) = hasPubKey key user + hasGpgKey (Just GpgPrivKey) = hasPrivKey key user + +hasPrivKey :: GpgKeyId -> User -> IO Bool +hasPrivKey (GpgKeyId keyid) (User u) = catchBoolIO $ + snd <$> processTranscript "su" ["-c", "gpg --list-secret-keys " ++ shellEscape keyid, u] Nothing + +hasPubKey :: GpgKeyId -> User -> IO Bool +hasPubKey (GpgKeyId keyid) (User u) = catchBoolIO $ + snd <$> processTranscript "su" ["-c", "gpg --list-public-keys " ++ shellEscape keyid, u] Nothing + +dotDir :: User -> IO FilePath +dotDir (User u) = do + home <- homeDirectory <$> getUserEntryForName u return $ home </> ".gnupg" diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs new file mode 100644 index 00000000..58e49a86 --- /dev/null +++ b/src/Propellor/Property/Group.hs @@ -0,0 +1,14 @@ +module Propellor.Property.Group where + +import Propellor.Base + +type GID = Int + +exists :: Group -> Maybe GID -> Property UnixLike +exists (Group group') mgid = check test (cmdProperty "addgroup" (args mgid)) + `describe` unwords ["group", group'] + where + groupFile = "/etc/group" + test = not . elem group' . words <$> readProcess "cut" ["-d:", "-f1", groupFile] + args Nothing = [group'] + args (Just gid) = ["--gid", show gid, group'] diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 841861f4..a03fc5a0 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -1,26 +1,73 @@ module Propellor.Property.Grub where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt --- | Eg, hd0,0 or xen/xvda1 +-- | Eg, \"hd0,0\" or \"xen/xvda1\" type GrubDevice = String +-- | Eg, \"\/dev/sda\" +type OSDevice = String + type TimeoutSecs = Int +-- | Types of machines that grub can boot. +data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen + +-- | Installs the grub package. This does not make grub be used as the +-- bootloader. +-- +-- This includes running update-grub. +installed :: BIOS -> Property DebianLike +installed bios = installed' bios `onChange` mkConfig + +-- Run update-grub, to generate the grub boot menu. It will be +-- automatically updated when kernel packages are installed. +mkConfig :: Property DebianLike +mkConfig = tightenTargets $ cmdProperty "update-grub" [] + `assume` MadeChange + +-- | Installs grub; does not run update-grub. +installed' :: BIOS -> Property Linux +installed' bios = (aptinstall `pickOS` unsupportedOS) + `describe` "grub package installed" + where + aptinstall :: Property DebianLike + aptinstall = Apt.installed [debpkg] + debpkg = case bios of + PC -> "grub-pc" + EFI64 -> "grub-efi-amd64" + EFI32 -> "grub-efi-ia32" + Coreboot -> "grub-coreboot" + Xen -> "grub-xen" + +-- | Installs grub onto a device, so the system can boot from that device. +-- +-- You may want to install grub to multiple devices; eg for a system +-- that uses software RAID. +-- +-- Note that this property does not check if grub is already installed +-- on the device; it always does the work to reinstall it. It's a good idea +-- to arrange for this property to only run once, by eg making it be run +-- onChange after OS.cleanInstallOnce. +boots :: OSDevice -> Property Linux +boots dev = tightenTargets $ cmdProperty "grub-install" [dev] + `assume` MadeChange + `describe` ("grub boots " ++ dev) + -- | Use PV-grub chaining to boot -- -- Useful when the VPS's pv-grub is too old to boot a modern kernel image. -- --- http://notes.pault.ag/linode-pv-grub-chainning/ +-- <http://notes.pault.ag/linode-pv-grub-chainning/> -- -- The rootdev should be in the form "hd0", while the bootdev is in the form -- "xen/xvda". -chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property -chainPVGrub rootdev bootdev timeout = combineProperties desc - [ File.dirExists "/boot/grub" - , "/boot/grub/menu.lst" `File.hasContent` +chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike +chainPVGrub rootdev bootdev timeout = combineProperties desc $ props + & File.dirExists "/boot/grub" + & "/boot/grub/menu.lst" `File.hasContent` [ "default 1" , "timeout " ++ show timeout , "" @@ -29,11 +76,12 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc , "kernel /boot/xen-shim" , "boot" ] - , "/boot/load.cf" `File.hasContent` + & "/boot/load.cf" `File.hasContent` [ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ] - , Apt.installed ["grub-xen"] - , flagFile (scriptProperty ["update-grub; grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]) "/boot/xen-shim" - `describe` "/boot-xen-shim" - ] + & installed Xen + & flip flagFile "/boot/xen-shim" xenshim where desc = "chain PV-grub" + xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"] + `assume` MadeChange + `describe` "/boot-xen-shim" diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs index 003bd3c5..5c4788e2 100644 --- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -1,24 +1,29 @@ module Propellor.Property.HostingProvider.CloudAtCost where -import Propellor +import Propellor.Base import qualified Propellor.Property.Hostname as Hostname import qualified Propellor.Property.File as File -import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.User as User -- Clean up a system as installed by cloudatcost.com -decruft :: Property -decruft = propertyList "cloudatcost cleanup" - [ Hostname.sane - , Ssh.randomHostKeys - , "worked around grub/lvm boot bug #743126" ==> +decruft :: Property DebianLike +decruft = propertyList "cloudatcost cleanup" $ props + & Hostname.sane + & grubbugfix + & nukecruft + where + grubbugfix :: Property DebianLike + grubbugfix = tightenTargets $ "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" - `onChange` cmdProperty "update-grub" [] - `onChange` cmdProperty "update-initramfs" ["-u"] - , combineProperties "nuked cloudatcost cruft" - [ File.notPresent "/etc/rc.local" - , File.notPresent "/etc/init.d/S97-setup.sh" - , User.nuked "user" User.YesReallyDeleteHome - ] - ] + `describe` "worked around grub/lvm boot bug #743126" + `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) + `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange) + nukecruft :: Property Linux + nukecruft = tightenTargets $ + combineProperties "nuked cloudatcost cruft" $ props + & File.notPresent "/etc/rc.local" + & File.notPresent "/etc/init.d/S97-setup.sh" + & File.notPresent "/zang-debian.sh" + & File.notPresent "/bin/npasswd" + & User.nuked (User "user") User.YesReallyDeleteHome diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs index 4565935f..c1e0ffc9 100644 --- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs +++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -1,21 +1,49 @@ -module Propellor.Property.HostingProvider.DigitalOcean where +module Propellor.Property.HostingProvider.DigitalOcean ( + distroKernel +) where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File +import qualified Propellor.Property.Reboot as Reboot --- Digital Ocean does not provide any way to boot +import Data.List + +-- | Digital Ocean does not provide any way to boot -- the kernel provided by the distribution, except using kexec. -- Without this, some old, and perhaps insecure kernel will be used. -- --- Note that this only causes the new kernel to be loaded on reboot. --- If the power is cycled, the old kernel still boots up. --- TODO: detect this and reboot immediately? -distroKernel :: Property -distroKernel = propertyList "digital ocean distro kernel hack" - [ Apt.installed ["grub-pc", "kexec-tools"] - , "/etc/default/kexec" `File.containsLines` +-- This property causes the distro kernel to be loaded on reboot, using kexec. +-- +-- If the power is cycled, the non-distro kernel still boots up. +-- So, this property also checks if the running kernel is present in /boot, +-- and if not, reboots immediately into a distro kernel. +distroKernel :: Property DebianLike +distroKernel = propertyList "digital ocean distro kernel hack" $ props + & Apt.installed ["grub-pc", "kexec-tools", "file"] + & "/etc/default/kexec" `File.containsLines` [ "LOAD_KEXEC=true" , "USE_GRUB_CONFIG=true" ] `describe` "kexec configured" - ] + & check (not <$> runningInstalledKernel) Reboot.now + `describe` "running installed kernel" + +runningInstalledKernel :: IO Bool +runningInstalledKernel = do + kernelver <- takeWhile (/= '\n') <$> readProcess "uname" ["-r"] + when (null kernelver) $ + error "failed to read uname -r" + kernelimages <- concat <$> mapM kernelsIn ["/", "/boot/"] + when (null kernelimages) $ + error "failed to find any installed kernel images" + findVersion kernelver <$> + readProcess "file" ("-L" : kernelimages) + +-- | File output looks something like this, we want to unambiguously +-- match the running kernel version: +-- Linux kernel x86 boot executable bzImage, version 3.16-3-amd64 (debian-kernel@lists.debian.org) #1 SMP Debian 3.1, RO-rootFS, swap_dev 0x2, Normal VGA +findVersion :: String -> String -> Bool +findVersion ver s = (" version " ++ ver ++ " ") `isInfixOf` s + +kernelsIn :: FilePath -> IO [FilePath] +kernelsIn d = filter ("vmlinu" `isInfixOf`) <$> dirContents d diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs index 34d72184..71719d87 100644 --- a/src/Propellor/Property/HostingProvider/Linode.hs +++ b/src/Propellor/Property/HostingProvider/Linode.hs @@ -1,10 +1,20 @@ module Propellor.Property.HostingProvider.Linode where -import Propellor +import Propellor.Base import qualified Propellor.Property.Grub as Grub +import qualified Propellor.Property.File as File +import Utility.FileMode -- | Linode's pv-grub-x86_64 does not currently support booting recent --- Debian kernels compressed with xz. This sets up pv-grub chaing to enable +-- Debian kernels compressed with xz. This sets up pv-grub chaining to enable -- it. -chainPVGrub :: Grub.TimeoutSecs -> Property +chainPVGrub :: Grub.TimeoutSecs -> Property DebianLike chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda" + +-- | Linode disables mlocate's cron job's execute permissions, +-- presumably to avoid disk IO. This ensures it's executable. +mlocateEnabled :: Property DebianLike +mlocateEnabled = tightenTargets $ + "/etc/cron.daily/mlocate" + `File.mode` combineModes (readModes ++ executeModes) + diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs index c489e2fb..e1342d91 100644 --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -1,57 +1,80 @@ module Propellor.Property.Hostname where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File +import Propellor.Property.Chroot (inChroot) import Data.List +import Data.List.Utils --- | Ensures that the hostname is set using best practices. +-- | Ensures that the hostname is set using best practices, to whatever +-- name the `Host` has. -- --- Configures /etc/hostname and the current hostname. +-- Configures both </etc/hostname> and the current hostname. +-- (However, when used inside a chroot, avoids setting the current hostname +-- as that would impact the system outside the chroot.) -- --- Configures /etc/mailname with the domain part of the hostname. +-- Configures </etc/mailname> with the domain part of the hostname. -- --- /etc/hosts is also configured, with an entry for 127.0.1.1, which is +-- </etc/hosts> is also configured, with an entry for 127.0.1.1, which is -- standard at least on Debian to set the FDQN. -- --- Also, the /etc/hosts 127.0.0.1 line is set to localhost. Putting any +-- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any -- other hostnames there is not best practices and can lead to annoying -- messages from eg, apache. -sane :: Property -sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName) +sane :: Property UnixLike +sane = sane' extractDomain -setTo :: HostName -> Property -setTo hn = combineProperties desc go - where - desc = "hostname " ++ hn - (basehost, domain) = separate (== '.') hn +sane' :: ExtractDomain -> Property UnixLike +sane' extractdomain = property' ("sane hostname") $ \w -> + ensureProperty w . setTo' extractdomain =<< asks hostName + +-- Like `sane`, but you can specify the hostname to use, instead +-- of the default hostname of the `Host`. +setTo :: HostName -> Property UnixLike +setTo = setTo' extractDomain - go = catMaybes - [ Just $ "/etc/hostname" `File.hasContent` [basehost] - , if null domain +setTo' :: ExtractDomain -> HostName -> Property UnixLike +setTo' extractdomain hn = combineProperties desc $ toProps + [ "/etc/hostname" `File.hasContent` [basehost] + , hostslines $ catMaybes + [ if null domain then Nothing - else Just $ trivial $ hostsline "127.0.1.1" [hn, basehost] - , Just $ trivial $ hostsline "127.0.0.1" ["localhost"] - , Just $ trivial $ cmdProperty "hostname" [basehost] - , Just $ "/etc/mailname" `File.hasContent` - [if null domain then hn else domain] + else Just ("127.0.1.1", [hn, basehost]) + , Just ("127.0.0.1", ["localhost"]) ] + , check (not <$> inChroot) $ + cmdProperty "hostname" [basehost] + `assume` NoChange + , "/etc/mailname" `File.hasContent` + [if null domain then hn else domain] + ] + where + desc = "hostname " ++ hn + basehost = takeWhile (/= '.') hn + domain = extractdomain hn - hostsline ip names = File.fileProperty desc - (addhostsline ip names) - "/etc/hosts" - addhostsline ip names ls = - (ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls - hasip ip l = headMaybe (words l) == Just ip - --- | Makes /etc/resolv.conf contain search and domain lines for + hostslines ipsnames = + File.fileProperty desc (addhostslines ipsnames) "/etc/hosts" + addhostslines :: [(String, [String])] -> [String] -> [String] + addhostslines ipsnames ls = + let ips = map fst ipsnames + hasip l = maybe False (`elem` ips) (headMaybe (words l)) + mkline (ip, names) = ip ++ "\t" ++ (unwords names) + in map mkline ipsnames ++ filter (not . hasip) ls + +-- | Makes </etc/resolv.conf> contain search and domain lines for -- the domain that the hostname is in. -searchDomain :: Property -searchDomain = property desc (ensureProperty . go =<< asks hostName) +searchDomain :: Property UnixLike +searchDomain = searchDomain' extractDomain + +searchDomain' :: ExtractDomain -> Property UnixLike +searchDomain' extractdomain = property' desc $ \w -> + (ensureProperty w . go =<< asks hostName) where desc = "resolv.conf search and domain configured" go hn = - let (_basehost, domain) = separate (== '.') hn + let domain = extractdomain hn in File.fileProperty desc (use domain) "/etc/resolv.conf" use domain ls = filter wanted $ nub (ls ++ cfgs) where @@ -61,3 +84,21 @@ searchDomain = property desc (ensureProperty . go =<< asks hostName) | "domain " `isPrefixOf` l = False | "search " `isPrefixOf` l = False | otherwise = True + +-- | Function to extract the domain name from a HostName. +type ExtractDomain = HostName -> String + +-- | hostname of foo.example.com has a domain of example.com. +-- But, when the hostname is example.com, the domain is +-- example.com too. +-- +-- This doesn't work for eg, foo.co.uk, or when foo.sci.uni.edu +-- is in a sci.uni.edu subdomain. If you are in such a network, +-- provide your own ExtractDomain function to the properties above. +extractDomain :: ExtractDomain +extractDomain hn = + let bits = split "." hn + in intercalate "." $ + if length bits > 2 + then drop 1 bits + else bits diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs new file mode 100644 index 00000000..d0261626 --- /dev/null +++ b/src/Propellor/Property/Journald.hs @@ -0,0 +1,55 @@ +module Propellor.Property.Journald where + +import Propellor.Base +import qualified Propellor.Property.Systemd as Systemd +import Utility.DataUnits + +-- | Configures journald, restarting it so the changes take effect. +configured :: Systemd.Option -> String -> Property Linux +configured option value = + Systemd.configured "/etc/systemd/journald.conf" option value + `onChange` Systemd.restarted "systemd-journald" + +-- The string is parsed to get a data size. +-- Examples: "100 megabytes" or "0.5tb" +type DataSize = String + +configuredSize :: Systemd.Option -> DataSize -> Property Linux +configuredSize option s = case readSize dataUnits s of + Just sz -> configured option (systemdSizeUnits sz) + Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) $ + return FailedChange + +systemMaxUse :: DataSize -> Property Linux +systemMaxUse = configuredSize "SystemMaxUse" + +runtimeMaxUse :: DataSize -> Property Linux +runtimeMaxUse = configuredSize "RuntimeMaxUse" + +systemKeepFree :: DataSize -> Property Linux +systemKeepFree = configuredSize "SystemKeepFree" + +runtimeKeepFree :: DataSize -> Property Linux +runtimeKeepFree = configuredSize "RuntimeKeepFree" + +systemMaxFileSize :: DataSize -> Property Linux +systemMaxFileSize = configuredSize "SystemMaxFileSize" + +runtimeMaxFileSize :: DataSize -> Property Linux +runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize" + +-- Generates size units as used in journald.conf. +systemdSizeUnits :: Integer -> String +systemdSizeUnits sz = filter (/= ' ') (roughSize cfgfileunits True sz) + where + cfgfileunits :: [Unit] + cfgfileunits = + [ Unit (p 6) "E" "exabyte" + , Unit (p 5) "P" "petabyte" + , Unit (p 4) "T" "terabyte" + , Unit (p 3) "G" "gigabyte" + , Unit (p 2) "M" "megabyte" + , Unit (p 1) "K" "kilobyte" + ] + p :: Integer -> Integer + p n = 1024^n diff --git a/src/Propellor/Property/Kerberos.hs b/src/Propellor/Property/Kerberos.hs new file mode 100644 index 00000000..3c351943 --- /dev/null +++ b/src/Propellor/Property/Kerberos.hs @@ -0,0 +1,95 @@ +-- | Maintainer: Jelmer Vernooij <jelmer@samba.org> + +module Propellor.Property.Kerberos where + +import Utility.Process + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import Propellor.Property.User + +type Realm = String +type Principal = String +type Kvno = Integer + +-- Standard paths in MIT Kerberos + +defaultKeyTab :: FilePath +defaultKeyTab = "/etc/krb5.keytab" + +kadmAclPath :: FilePath +kadmAclPath = "/etc/krb5kdc/kadm5.acl" + +kpropdAclPath :: FilePath +kpropdAclPath = "/etc/krb5kdc/kpropd.acl" + +kdcConfPath :: FilePath +kdcConfPath = "/etc/krb5kdc/kdc.conf" + +keyTabPath :: Maybe FilePath -> FilePath +keyTabPath = maybe defaultKeyTab id + +-- | Create a principal from a primary, instance and realm +principal :: String -> Maybe String -> Maybe Realm -> Principal +principal p i r = p ++ maybe "" ("/"++) i ++ maybe "" ("@" ++) r + +installed :: Property DebianLike +installed = Apt.installed ["krb5-user"] + +kdcInstalled :: Property DebianLike +kdcInstalled = Apt.serviceInstalledRunning "krb5-kdc" + +adminServerInstalled :: Property DebianLike +adminServerInstalled = Apt.serviceInstalledRunning "krb5-admin-server" + +kpropServerInstalled :: Property DebianLike +kpropServerInstalled = propertyList "kprop server installed" $ props + & kdcInstalled + & Apt.installed ["openbsd-inetd"] + & "/etc/inetd.conf" `File.containsLines` + [ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd" + , "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd" + ] + +kpropAcls :: [String] -> Property UnixLike +kpropAcls ps = kpropdAclPath `File.hasContent` ps `describe` "kprop server ACLs" + +k5srvutil :: (Maybe FilePath) -> [String] -> IO String +k5srvutil kt cmd = readProcess "k5srvutil" (maybe [] (\x -> ["-f", x]) kt ++ cmd) + +-- Keytab management +keytabEntries :: Maybe FilePath -> IO [(Kvno, Principal)] +keytabEntries p = do + c <- k5srvutil p ["list"] + return $ map parseLine (drop 3 $ lines c) + where + parseLine l = (Prelude.read x, y) where (x, y) = splitAt 5 l + +checkKeyTabEntry' :: Maybe FilePath -> (Kvno, Principal) -> IO Bool +checkKeyTabEntry' path entry = do + entries <- keytabEntries path + return $ entry `elem` entries + +checkKeyTabEntry :: Maybe FilePath -> Principal -> IO Bool +checkKeyTabEntry path princ = do + entries <- keytabEntries path + return $ princ `elem` (map snd entries) + +-- k5login files +k5loginPath :: User -> IO FilePath +k5loginPath user = do + h <- homedir user + return $ h </> ".k5login" + +k5login :: User -> [Principal] -> Property UnixLike +k5login user@(User u) ps = property' desc $ \w -> do + f <- liftIO $ k5loginPath user + liftIO $ do + createDirectoryIfMissing True (takeDirectory f) + writeFile f (unlines ps) + ensureProperty w $ combineProperties desc $ props + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) + where + desc = u ++ " has k5login" diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs new file mode 100644 index 00000000..592a1e1d --- /dev/null +++ b/src/Propellor/Property/LetsEncrypt.hs @@ -0,0 +1,109 @@ +-- | This module gets LetsEncrypt <https://letsencrypt.org/> certificates +-- using CertBot <https://certbot.eff.org/> + +module Propellor.Property.LetsEncrypt where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt + +import System.Posix.Files + +-- Not using the certbot name yet, until it reaches jessie-backports and +-- testing. +installed :: Property DebianLike +installed = Apt.installed ["letsencrypt"] + +-- | Tell the letsencrypt client that you agree with the Let's Encrypt +-- Subscriber Agreement. Providing an email address is recommended, +-- so that letcencrypt can contact you about problems. +data AgreeTOS = AgreeTOS (Maybe Email) + +type Email = String + +type WebRoot = FilePath + +-- | Uses letsencrypt to obtain a certificate for a domain. +-- +-- This should work with any web server, as long as letsencrypt can +-- write its temp files to the web root. The letsencrypt client does +-- not modify the web server's configuration in any way; this only obtains +-- the certificate it does not make the web server use it. +-- +-- This also handles renewing the certificate. +-- For renewel to work well, propellor needs to be +-- run periodically (at least a couple times per month). +-- +-- This property returns `MadeChange` when the certificate is initially +-- obtained, and when it's renewed. So, it can be combined with a property +-- to make the webserver (or other server) use the certificate: +-- +-- > letsEncrypt (AgreeTOS (Just "me@example.com")) "example.com" "/var/www" +-- > `onChange` Apache.reload +-- +-- See `Propellor.Property.Apache.httpsVirtualHost` for a more complete +-- integration of apache with letsencrypt, that's built on top of this. +letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property DebianLike +letsEncrypt tos domain = letsEncrypt' tos domain [] + +-- | Like `letsEncrypt`, but the certificate can be obtained for multiple +-- domains. +letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property DebianLike +letsEncrypt' (AgreeTOS memail) domain domains webroot = + prop `requires` installed + where + prop :: Property UnixLike + prop = property desc $ do + startstats <- liftIO getstats + (transcript, ok) <- liftIO $ + processTranscript "letsencrypt" params Nothing + if ok + then do + endstats <- liftIO getstats + if startstats /= endstats + then return MadeChange + else return NoChange + else do + liftIO $ hPutStr stderr transcript + return FailedChange + + desc = "letsencrypt " ++ unwords alldomains + alldomains = domain : domains + params = + [ "certonly" + , "--agree-tos" + , case memail of + Just email -> "--email="++email + Nothing -> "--register-unsafely-without-email" + , "--webroot" + , "--webroot-path", webroot + , "--text" + , "--noninteractive" + , "--keep-until-expiring" + ] ++ map (\d -> "--domain="++d) alldomains + + getstats = mapM statcertfiles alldomains + statcertfiles d = mapM statfile + [ certFile d + , privKeyFile d + , chainFile d + , fullChainFile d + ] + statfile f = catchMaybeIO $ do + s <- getFileStatus f + return (fileID s, deviceID s, fileMode s, fileSize s, modificationTime s) + +-- | The cerificate files that letsencrypt will make available for a domain. +liveCertDir :: Domain -> FilePath +liveCertDir d = "/etc/letsencrypt/live" </> d + +certFile :: Domain -> FilePath +certFile d = liveCertDir d </> "cert.pem" + +privKeyFile :: Domain -> FilePath +privKeyFile d = liveCertDir d </> "privkey.pem" + +chainFile :: Domain -> FilePath +chainFile d = liveCertDir d </> "chain.pem" + +fullChainFile :: Domain -> FilePath +fullChainFile d = liveCertDir d </> "fullchain.pem" diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs new file mode 100644 index 00000000..339fa9a3 --- /dev/null +++ b/src/Propellor/Property/LightDM.hs @@ -0,0 +1,16 @@ +-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name> + +module Propellor.Property.LightDM where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.ConfFile as ConfFile + +installed :: Property DebianLike +installed = Apt.installed ["lightdm"] + +-- | Configures LightDM to skip the login screen and autologin as a user. +autoLogin :: User -> Property UnixLike +autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting` + ("SeatDefaults", "autologin-user", u) + `describe` "lightdm autologin" diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs new file mode 100644 index 00000000..0eec04c7 --- /dev/null +++ b/src/Propellor/Property/List.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Propellor.Property.List ( + props, + Props, + toProps, + propertyList, + combineProperties, +) where + +import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes +import Propellor.PropAccum +import Propellor.Engine +import Propellor.Exception + +import Data.Monoid + +toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes) +toProps ps = Props (map toChildProperty ps) + +-- | 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 propagate overall success/failure. +-- +-- For example: +-- +-- > propertyList "foo" $ props +-- > & bar +-- > & baz +propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) +propertyList desc (Props ps) = + property desc (ensureChildProperties cs) + `addChildren` cs + where + cs = map toChildProperty ps + +-- | Combines a list of properties, resulting in one property that +-- ensures each in turn. Stops if a property fails. +combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) +combineProperties desc (Props ps) = + property desc (combineSatisfy cs NoChange) + `addChildren` cs + where + cs = map toChildProperty ps + +combineSatisfy :: [ChildProperty] -> Result -> Propellor Result +combineSatisfy [] rs = return rs +combineSatisfy (p:ps) rs = do + r <- catchPropellor $ getSatisfy p + case r of + FailedChange -> return FailedChange + _ -> combineSatisfy ps (r <> rs) diff --git a/src/Propellor/Property/Locale.hs b/src/Propellor/Property/Locale.hs new file mode 100644 index 00000000..b7cf242c --- /dev/null +++ b/src/Propellor/Property/Locale.hs @@ -0,0 +1,83 @@ +-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name> + +module Propellor.Property.Locale where + +import Propellor.Base +import Propellor.Property.File + +import Data.List (isPrefixOf) + +type Locale = String +type LocaleVariable = String + +-- | Select a locale for a list of global locale variables. +-- +-- A locale variable is of the form @LC_BLAH@, @LANG@ or @LANGUAGE@. See +-- @locale(5)@. One might say +-- +-- > & "en_GB.UTF-8" `Locale.selectedFor` ["LC_PAPER", "LC_MONETARY"] +-- +-- to select the British English locale for paper size and currency conventions. +-- +-- Note that reverting this property does not make a locale unavailable. That's +-- because it might be required for other Locale.selectedFor statements. +selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty DebianLike DebianLike +locale `selectedFor` vars = select <!> deselect + where + select = tightenTargets $ + check (not <$> isselected) + (cmdProperty "update-locale" selectArgs) + `requires` available locale + `describe` (locale ++ " locale selected") + deselect = tightenTargets $ + check isselected (cmdProperty "update-locale" vars) + `describe` (locale ++ " locale deselected") + selectArgs = zipWith (++) vars (repeat ('=':locale)) + isselected = locale `isSelectedFor` vars + +isSelectedFor :: Locale -> [LocaleVariable] -> IO Bool +locale `isSelectedFor` vars = do + ls <- catchDefaultIO [] $ lines <$> readFile "/etc/default/locale" + return $ and $ map (\v -> v ++ "=" ++ locale `elem` ls) vars + + +-- | Ensures a locale is generated (or, if reverted, ensure it's not). +-- +-- Fails if a locale is not available to be generated. That is, a commented out +-- entry for the locale and an accompanying charset must be present in +-- /etc/locale.gen. +-- +-- Per Debian bug #684134 we cannot ensure a locale is generated by means of +-- Apt.reConfigure. So localeAvailable edits /etc/locale.gen manually. +available :: Locale -> RevertableProperty DebianLike DebianLike +available locale = ensureAvailable <!> ensureUnavailable + where + f = "/etc/locale.gen" + desc = (locale ++ " locale generated") + ensureAvailable :: Property DebianLike + ensureAvailable = property' desc $ \w -> do + locales <- lines <$> (liftIO $ readFile f) + if locale `presentIn` locales + then ensureProperty w $ + fileProperty desc (foldr uncomment []) f + `onChange` regenerate + else return FailedChange -- locale unavailable for generation + ensureUnavailable :: Property DebianLike + ensureUnavailable = tightenTargets $ + fileProperty (locale ++ " locale not generated") (foldr comment []) f + `onChange` regenerate + + uncomment l ls = + if ("# " ++ locale) `isPrefixOf` l + then drop 2 l : ls + else l:ls + comment l ls = + if locale `isPrefixOf` l + then ("# " ++ l) : ls + else l:ls + + l `presentIn` ls = any (l `isPrefix`) ls + l `isPrefix` x = (l `isPrefixOf` x) || (("# " ++ l) `isPrefixOf` x) + + regenerate = cmdProperty "locale-gen" [] + `assume` MadeChange diff --git a/src/Propellor/Property/Logcheck.hs b/src/Propellor/Property/Logcheck.hs new file mode 100644 index 00000000..ced9fce2 --- /dev/null +++ b/src/Propellor/Property/Logcheck.hs @@ -0,0 +1,36 @@ +-- | Maintainer: Jelmer Vernooij <jelmer@jelmer.uk> + +module Propellor.Property.Logcheck ( + ReportLevel (Workstation, Server, Paranoid), + Service, + defaultPrefix, + ignoreFilePath, + ignoreLines, + installed, +) where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File + +data ReportLevel = Workstation | Server | Paranoid +type Service = String + +instance Show ReportLevel where + show Workstation = "workstation" + show Server = "server" + show Paranoid = "paranoid" + +-- The common prefix used by default in syslog lines. +defaultPrefix :: String +defaultPrefix = "^\\w{3} [ :[:digit:]]{11} [._[:alnum:]-]+ " + +ignoreFilePath :: ReportLevel -> Service -> FilePath +ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (show t) </> n + +ignoreLines :: ReportLevel -> Service -> [String] -> Property UnixLike +ignoreLines t n ls = (ignoreFilePath t n) `File.containsLines` ls + `describe` ("logcheck ignore lines for " ++ n ++ "(" ++ (show t) ++ ")") + +installed :: Property DebianLike +installed = Apt.installed ["logcheck"] diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs new file mode 100644 index 00000000..bb0f60a7 --- /dev/null +++ b/src/Propellor/Property/Mount.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-} + +-- | Properties in this module ensure that things are currently mounted, +-- but without making the mount persistent. Use `Propellor.Property.Fstab` +-- to configure persistent mounts. + +module Propellor.Property.Mount where + +import Propellor.Base +import Utility.Path + +import Data.List + +-- | type of filesystem to mount ("auto" to autodetect) +type FsType = String + +-- | A device or other thing to be mounted. +type Source = String + +-- | A mount point for a filesystem. +type MountPoint = FilePath + +-- | Filesystem mount options. Eg, MountOpts ["errors=remount-ro"] +-- +-- For default mount options, use `mempty`. +newtype MountOpts = MountOpts [String] + deriving Monoid + +class ToMountOpts a where + toMountOpts :: a -> MountOpts + +instance ToMountOpts MountOpts where + toMountOpts = id + +instance ToMountOpts String where + toMountOpts s = MountOpts [s] + +formatMountOpts :: MountOpts -> String +formatMountOpts (MountOpts []) = "defaults" +formatMountOpts (MountOpts l) = intercalate "," l + +-- | Mounts a device, without listing it in </etc/fstab>. +mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike +mounted fs src mnt opts = property (mnt ++ " mounted") $ + toResult <$> liftIO (mount fs src mnt opts) + +-- | Bind mounts the first directory so its contents also appear +-- in the second directory. +bindMount :: FilePath -> FilePath -> Property Linux +bindMount src dest = tightenTargets $ + cmdProperty "mount" ["--bind", src, dest] + `assume` MadeChange + `describe` ("bind mounted " ++ src ++ " to " ++ dest) + +mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool +mount fs src mnt opts = boolSystem "mount" $ + [ Param "-t", Param fs + , Param "-o", Param (formatMountOpts opts) + , Param src + , Param mnt + ] + +-- | Lists all mount points of the system. +mountPoints :: IO [MountPoint] +mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] + +-- | Finds all filesystems mounted inside the specified directory. +mountPointsBelow :: FilePath -> IO [MountPoint] +mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target) + . filter (dirContains target) + <$> mountPoints + +-- | Filesystem type mounted at a given location. +getFsType :: MountPoint -> IO (Maybe FsType) +getFsType = findmntField "fstype" + +-- | Mount options for the filesystem mounted at a given location. +getFsMountOpts :: MountPoint -> IO MountOpts +getFsMountOpts p = maybe mempty toMountOpts + <$> findmntField "fs-options" p + +type UUID = String + +-- | UUID of filesystem mounted at a given location. +getMountUUID :: MountPoint -> IO (Maybe UUID) +getMountUUID = findmntField "uuid" + +-- | UUID of a device +getSourceUUID :: Source -> IO (Maybe UUID) +getSourceUUID = blkidTag "UUID" + +type Label = String + +-- | Label of filesystem mounted at a given location. +getMountLabel :: MountPoint -> IO (Maybe Label) +getMountLabel = findmntField "label" + +-- | Label of a device +getSourceLabel :: Source -> IO (Maybe UUID) +getSourceLabel = blkidTag "LABEL" + +-- | Device mounted at a given location. +getMountSource :: MountPoint -> IO (Maybe Source) +getMountSource = findmntField "source" + +findmntField :: String -> FilePath -> IO (Maybe String) +findmntField field mnt = catchDefaultIO Nothing $ + headMaybe . filter (not . null) . lines + <$> readProcess "findmnt" ["-n", mnt, "--output", field] + +blkidTag :: String -> Source -> IO (Maybe String) +blkidTag tag dev = catchDefaultIO Nothing $ + headMaybe . filter (not . null) . lines + <$> readProcess "blkid" [dev, "-s", tag, "-o", "value"] + +-- | Unmounts a device or mountpoint, +-- lazily so any running processes don't block it. +umountLazy :: FilePath -> IO () +umountLazy mnt = + unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ + errorMessage $ "failed unmounting " ++ mnt + +-- | Unmounts anything mounted inside the specified directory. +unmountBelow :: FilePath -> IO () +unmountBelow d = do + submnts <- mountPointsBelow d + forM_ submnts umountLazy diff --git a/src/Propellor/Property/Munin.hs b/src/Propellor/Property/Munin.hs new file mode 100644 index 00000000..dd74d91b --- /dev/null +++ b/src/Propellor/Property/Munin.hs @@ -0,0 +1,56 @@ +-- | Maintainer: Jelmer Vernooij <jelmer@jelmer.uk> +-- +module Propellor.Property.Munin ( + hostListFragment, + hostListFragment', + nodePort, + nodeInstalled, + nodeRestarted, + nodeConfPath, + masterInstalled, + masterRestarted, + masterConfPath, +) where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +nodePort :: Integer +nodePort = 4949 + +nodeInstalled :: Property DebianLike +nodeInstalled = Apt.serviceInstalledRunning "munin-node" + +nodeRestarted :: Property DebianLike +nodeRestarted = Service.restarted "munin-node" + +nodeConfPath :: FilePath +nodeConfPath = "/etc/munin/munin-node.conf" + +masterInstalled :: Property DebianLike +masterInstalled = Apt.serviceInstalledRunning "munin" + +masterRestarted :: Property DebianLike +masterRestarted = Service.restarted "munin" + +masterConfPath :: FilePath +masterConfPath = "/etc/munin/munin.conf" + + +-- | Create the host list fragment for master config. +-- Takes an optional override list for hosts that are accessible on a non-standard host/port. +-- TODO(jelmer): Only do this on hosts where munin is present (in other words, with Munin.installedNode) +hostListFragment' :: [Host] -> [(HostName, (IPAddr, Port))] -> [String] +hostListFragment' hs os = concatMap muninHost hs + where + muninHost :: Host -> [String] + muninHost h = [ "[" ++ (hostName h) ++ "]" + , " address " ++ maybe (hostName h) (fromIPAddr . fst) (hOverride h) + ] ++ (maybe [] (\x -> [" port " ++ (fromPort $ snd x)]) (hOverride h)) ++ [""] + hOverride :: Host -> Maybe (IPAddr, Port) + hOverride h = lookup (hostName h) os + +-- | Create the host list fragment for master config. +hostListFragment :: [Host] -> [String] +hostListFragment hs = hostListFragment' hs [] diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs index 6009778a..9ed9e591 100644 --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -1,30 +1,116 @@ module Propellor.Property.Network where -import Propellor +import Propellor.Base import Propellor.Property.File -interfaces :: FilePath -interfaces = "/etc/network/interfaces" +import Data.Char + +type Interface = String + +ifUp :: Interface -> Property DebianLike +ifUp iface = tightenTargets $ cmdProperty "ifup" [iface] + `assume` MadeChange + +-- | Resets /etc/network/interfaces to a clean and empty state, +-- containing just the standard loopback interface, and with +-- interfacesD enabled. +-- +-- This can be used as a starting point to defining other interfaces. +-- +-- No interfaces are brought up or down by this property. +cleanInterfacesFile :: Property DebianLike +cleanInterfacesFile = tightenTargets $ hasContent interfacesFile + [ "# Deployed by propellor, do not edit." + , "" + , "source-directory interfaces.d" + , "" + , "# The loopback network interface" + , "auto lo" + , "iface lo inet loopback" + ] + `describe` ("clean " ++ interfacesFile) + +-- | Configures an interface to get its address via dhcp. +dhcp :: Interface -> Property DebianLike +dhcp iface = tightenTargets $ hasContent (interfaceDFile iface) + [ "auto " ++ iface + , "iface " ++ iface ++ " inet dhcp" + ] + `describe` ("dhcp " ++ iface) + `requires` interfacesDEnabled + +-- | Writes a static interface file for the specified interface. +-- +-- The interface has to be up already. It could have been brought up by +-- DHCP, or by other means. The current ipv4 addresses +-- and routing configuration of the interface are written into the file. +-- +-- If the interface file already exists, this property does nothing, +-- no matter its content. +-- +-- (ipv6 addresses are not included because it's assumed they come up +-- automatically in most situations.) +static :: Interface -> Property DebianLike +static iface = tightenTargets $ + check (not <$> doesFileExist f) setup + `describe` desc + `requires` interfacesDEnabled + where + f = interfaceDFile iface + desc = "static " ++ iface + setup :: Property DebianLike + setup = property' desc $ \o -> do + ls <- liftIO $ lines <$> readProcess "ip" + ["-o", "addr", "show", iface, "scope", "global"] + stanzas <- liftIO $ concat <$> mapM mkstanza ls + ensureProperty o $ hasContent f $ ("auto " ++ iface) : stanzas + mkstanza ipline = case words ipline of + -- Note that the IP address is written CIDR style, so + -- the netmask does not need to be specified separately. + (_:iface':"inet":addr:_) | iface' == iface -> do + gw <- getgateway + return $ catMaybes + [ Just $ "iface " ++ iface ++ " inet static" + , Just $ "\taddress " ++ addr + , ("\tgateway " ++) <$> gw + ] + _ -> return [] + getgateway = do + rs <- lines <$> readProcess "ip" + ["route", "show", "scope", "global", "dev", iface] + return $ case words <$> headMaybe rs of + Just ("default":"via":gw:_) -> Just gw + _ -> Nothing -- | 6to4 ipv6 connection, should work anywhere -ipv6to4 :: Property -ipv6to4 = fileProperty "ipv6to4" go interfaces +ipv6to4 :: Property DebianLike +ipv6to4 = tightenTargets $ hasContent (interfaceDFile "sit0") + [ "# Deployed by propellor, do not edit." + , "iface sit0 inet6 static" + , "\taddress 2002:5044:5531::1" + , "\tnetmask 64" + , "\tgateway ::192.88.99.1" + , "auto sit0" + ] + `describe` "ipv6to4" + `requires` interfacesDEnabled `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" - , "auto sit0" - , "# End automatically added by propeller" - ] -type Interface = String +interfacesFile :: FilePath +interfacesFile = "/etc/network/interfaces" + +-- | A file in the interfaces.d directory. +interfaceDFile :: Interface -> FilePath +interfaceDFile i = "/etc/network/interfaces.d" </> escapeInterfaceDName i + +-- | /etc/network/interfaces.d/ files have to match -- ^[a-zA-Z0-9_-]+$ +-- see "man 5 interfaces" +escapeInterfaceDName :: Interface -> FilePath +escapeInterfaceDName = filter (\c -> isAscii c && (isAlphaNum c || c `elem` "_-")) -ifUp :: Interface -> Property -ifUp iface = cmdProperty "ifup" [iface] +-- | Ensures that files in the the interfaces.d directory are used. +-- interfacesDEnabled :: Property DebianLike +interfacesDEnabled :: Property DebianLike +interfacesDEnabled = tightenTargets $ + containsLine interfacesFile "source-directory interfaces.d" + `describe` "interfaces.d directory enabled" diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs index 397570d2..e40ba657 100644 --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -1,37 +1,32 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> + module Propellor.Property.Nginx where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import System.Posix.Files type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty -siteEnabled hn cf = RevertableProperty enable disable +siteEnabled :: HostName -> ConfigFile -> RevertableProperty DebianLike DebianLike +siteEnabled hn cf = enable <!> disable where - enable = check test prop + enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn `describe` ("nginx site enabled " ++ hn) `requires` siteAvailable hn cf `requires` installed `onChange` reloaded - where - test = not <$> doesFileExist (siteVal hn) - prop = property "nginx site in place" $ makeChange $ - createSymbolicLink target dir - target = siteValRelativeCfg hn - dir = siteVal hn - disable = trivial $ File.notPresent (siteVal hn) + disable = File.notPresent (siteVal hn) `describe` ("nginx site disable" ++ hn) `requires` installed `onChange` reloaded -siteAvailable :: HostName -> ConfigFile -> Property -siteAvailable hn cf = ("nginx site available " ++ hn) ==> - siteCfg hn `File.hasContent` (comment : cf) +siteAvailable :: HostName -> ConfigFile -> Property DebianLike +siteAvailable hn cf = "nginx site available " ++ hn ==> tightenTargets go where comment = "# deployed with propellor, do not modify" + go = siteCfg hn `File.hasContent` (comment : cf) siteCfg :: HostName -> FilePath siteCfg hn = "/etc/nginx/sites-available/" ++ hn @@ -39,14 +34,14 @@ siteCfg hn = "/etc/nginx/sites-available/" ++ hn siteVal :: HostName -> FilePath siteVal hn = "/etc/nginx/sites-enabled/" ++ hn -siteValRelativeCfg :: HostName -> FilePath -siteValRelativeCfg hn = "../sites-available/" ++ hn +siteValRelativeCfg :: HostName -> File.LinkTarget +siteValRelativeCfg hn = File.LinkTarget ("../sites-available/" ++ hn) -installed :: Property +installed :: Property DebianLike installed = Apt.installed ["nginx"] -restarted :: Property +restarted :: Property DebianLike restarted = Service.restarted "nginx" -reloaded :: Property +reloaded :: Property DebianLike reloaded = Service.reloaded "nginx" diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs new file mode 100644 index 00000000..5a3ccc70 --- /dev/null +++ b/src/Propellor/Property/OS.hs @@ -0,0 +1,253 @@ +module Propellor.Property.OS ( + cleanInstallOnce, + Confirmation(..), + preserveNetwork, + preserveResolvConf, + preserveRootSshAuthorized, + oldOSRemoved, +) where + +import Propellor.Base +import qualified Propellor.Property.Debootstrap as Debootstrap +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Network as Network +import qualified Propellor.Property.User as User +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Reboot as Reboot +import Propellor.Property.Mount +import Propellor.Property.Chroot.Util (stdPATH) + +import System.Posix.Files (rename, fileExist) +import Control.Exception (throw) + +-- | Replaces whatever OS was installed before with a clean installation +-- of the OS that the Host is configured to have. +-- +-- This is experimental; use with caution! +-- +-- This can replace one Linux distribution with different one. +-- But, it can also fail and leave the system in an unbootable state. +-- +-- To avoid this property being accidentially used, you have to provide +-- a Confirmation containing the name of the host that you intend to apply +-- the property to. +-- +-- This property only runs once. The cleanly installed system will have +-- a file </etc/propellor-cleaninstall>, which indicates it was cleanly +-- installed. +-- +-- The files from the old os will be left in </old-os> +-- +-- After the OS is installed, and if all properties of the host have +-- been successfully satisfied, the host will be rebooted to properly load +-- the new OS. +-- +-- You will typically want to run some more properties after the clean +-- install succeeds, to bootstrap from the cleanly installed system to +-- a fully working system. For example: +-- +-- > & osDebian Unstable "amd64" +-- > & cleanInstallOnce (Confirmed "foo.example.com") +-- > `onChange` propertyList "fixing up after clean install" +-- > [ preserveNetwork +-- > , preserveResolvConf +-- > , preserveRootSshAuthorized +-- > , Apt.update +-- > -- , Grub.boots "/dev/sda" +-- > -- `requires` Grub.installed Grub.PC +-- > -- , oldOsRemoved (Confirmed "foo.example.com") +-- > ] +-- > & Hostname.sane +-- > & Apt.installed ["linux-image-amd64"] +-- > & Apt.installed ["ssh"] +-- > & User.hasSomePassword "root" +-- > & User.accountFor "joey" +-- > & User.hasSomePassword "joey" +-- > -- rest of system properties here +cleanInstallOnce :: Confirmation -> Property Linux +cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ + go `requires` confirmed "clean install confirmed" confirmation + where + go = + finalized + `requires` + -- easy to forget and system may not boot without shadow pw! + User.shadowConfig True + `requires` + -- reboot at end if the rest of the propellor run succeeds + Reboot.atEnd True (/= FailedChange) + `requires` + propellorbootstrapped + `requires` + flipped + `requires` + osbootstrapped + + osbootstrapped :: Property Linux + osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of + (Just d@(System (Debian _) _)) -> ensureProperty w $ + debootstrap d + (Just u@(System (Buntish _) _)) -> ensureProperty w $ + debootstrap u + _ -> unsupportedOS' + + debootstrap :: System -> Property Linux + debootstrap targetos = + -- Install debootstrap from source, since we don't know + -- what OS we're currently running in. + Debootstrap.built' Debootstrap.sourceInstall + newOSDir targetos Debootstrap.DefaultConfig + -- debootstrap, I wish it was faster.. + -- TODO eatmydata to speed it up + -- Problem: Installing eatmydata on some random OS like + -- Fedora may be difficult. Maybe configure dpkg to not + -- sync instead? + + -- This is the fun bit. + flipped :: Property Linux + flipped = property (newOSDir ++ " moved into place") $ liftIO $ do + -- First, unmount most mount points, lazily, so + -- they don't interfere with moving things around. + devfstype <- fromMaybe "devtmpfs" <$> getFsType "/dev" + mnts <- filter (`notElem` ("/": trickydirs)) <$> mountPoints + -- reverse so that deeper mount points come first + forM_ (reverse mnts) umountLazy + + renamesout <- map (\d -> (d, oldOSDir ++ d, pure $ d `notElem` (oldOSDir:newOSDir:trickydirs))) + <$> dirContents "/" + renamesin <- map (\d -> let dest = "/" ++ takeFileName d in (d, dest, not <$> fileExist dest)) + <$> dirContents newOSDir + createDirectoryIfMissing True oldOSDir + massRename (renamesout ++ renamesin) + removeDirectoryRecursive newOSDir + + -- Prepare environment for running additional properties, + -- overriding old OS's environment. + void $ setEnv "PATH" stdPATH True + void $ unsetEnv "LANG" + + -- Remount /dev, so that block devices etc are + -- available for other properties to use. + unlessM (mount devfstype devfstype "/dev" mempty) $ do + warningMessage $ "failed mounting /dev using " ++ devfstype ++ "; falling back to MAKEDEV generic" + void $ boolSystem "sh" [Param "-c", Param "cd /dev && /sbin/MAKEDEV generic"] + + -- Mount /sys too, needed by eg, grub-mkconfig. + unlessM (mount "sysfs" "sysfs" "/sys" mempty) $ + warningMessage "failed mounting /sys" + + -- And /dev/pts, used by apt. + unlessM (mount "devpts" "devpts" "/dev/pts" mempty) $ + warningMessage "failed mounting /dev/pts" + + return MadeChange + + propellorbootstrapped :: Property UnixLike + propellorbootstrapped = property "propellor re-debootstrapped in new os" $ + return NoChange + -- re-bootstrap propellor in /usr/local/propellor, + -- (using git repo bundle, privdata file, and possibly + -- git repo url, which all need to be arranged to + -- be present in /old-os's /usr/local/propellor) + -- TODO + + finalized :: Property UnixLike + finalized = property "clean OS installed" $ do + liftIO $ writeFile flagfile "" + return MadeChange + + flagfile = "/etc/propellor-cleaninstall" + + trickydirs = + -- /tmp can contain X's sockets, which prevent moving it + -- so it's left as-is. + [ "/tmp" + -- /proc is left mounted + , "/proc" + ] + +-- Performs all the renames. If any rename fails, rolls back all +-- previous renames. Thus, this either successfully performs all +-- the renames, or does not change the system state at all. +massRename :: [(FilePath, FilePath, IO Bool)] -> IO () +massRename = go [] + where + go _ [] = return () + go undo ((from, to, test):rest) = ifM test + ( tryNonAsync (rename from to) + >>= either + (rollback undo) + (const $ go ((to, from):undo) rest) + , go undo rest + ) + rollback undo e = do + mapM_ (uncurry rename) undo + throw e + +data Confirmation = Confirmed HostName + +confirmed :: Desc -> Confirmation -> Property UnixLike +confirmed desc (Confirmed c) = property desc $ do + hostname <- asks hostName + if hostname /= c + then do + warningMessage "Run with a bad confirmation, not matching hostname." + return FailedChange + else return NoChange + +-- | </etc/network/interfaces> is configured to bring up the network +-- interface that currently has a default route configured, using +-- the same (static) IP address. +preserveNetwork :: Property DebianLike +preserveNetwork = go `requires` Network.cleanInterfacesFile + where + go :: Property DebianLike + go = property' "preserve network configuration" $ \w -> do + ls <- liftIO $ lines <$> readProcess "ip" + ["route", "list", "scope", "global"] + case words <$> headMaybe ls of + Just ("default":"via":_:"dev":iface:_) -> + ensureProperty w $ Network.static iface + _ -> do + warningMessage "did not find any default ipv4 route" + return FailedChange + +-- | </etc/resolv.conf> is copied from the old OS +preserveResolvConf :: Property Linux +preserveResolvConf = check (fileExist oldloc) $ + property' (newloc ++ " copied from old OS") $ \w -> do + ls <- liftIO $ lines <$> readFile oldloc + ensureProperty w $ newloc `File.hasContent` ls + where + newloc = "/etc/resolv.conf" + oldloc = oldOSDir ++ newloc + +-- | </root/.ssh/authorized_keys> has added to it any ssh keys that +-- were authorized in the old OS. Any other contents of the file are +-- retained. +preserveRootSshAuthorized :: Property UnixLike +preserveRootSshAuthorized = check (fileExist oldloc) $ + property' desc $ \w -> do + ks <- liftIO $ lines <$> readFile oldloc + ensureProperty w $ combineProperties desc $ + toProps $ map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks + where + desc = newloc ++ " copied from old OS" + newloc = "/root/.ssh/authorized_keys" + oldloc = oldOSDir ++ newloc + +-- Removes the old OS's backup from </old-os> +oldOSRemoved :: Confirmation -> Property UnixLike +oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $ + go `requires` confirmed "old OS backup removal confirmed" confirmation + where + go :: Property UnixLike + go = property "old OS backup removed" $ do + liftIO $ removeDirectoryRecursive oldOSDir + return MadeChange + +oldOSDir :: FilePath +oldOSDir = "/old-os" + +newOSDir :: FilePath +newOSDir = "/new-os" diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs index 1e7c2c25..5bf3ff06 100644 --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -1,9 +1,11 @@ +-- | Support for the Obnam backup tool <http://obnam.org/> + module Propellor.Property.Obnam where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cron as Cron -import Utility.SafeCommand +import qualified Propellor.Property.Gpg as Gpg import Data.List @@ -25,41 +27,69 @@ data NumClients = OnlyClient | MultipleClients -- -- So, this property can be used to deploy a directory of content -- to a host, while also ensuring any changes made to it get backed up. --- And since Obnam encrypts, just make this property depend on a gpg --- key, and tell obnam to use the key, and your data will be backed --- up securely. For example: +-- For example: -- -- > & Obnam.backup "/srv/git" "33 3 * * *" -- > [ "--repository=sftp://2318@usw-s002.rsync.net/~/mygitrepos.obnam" --- > , "--encrypt-with=1B169BE1" -- > ] Obnam.OnlyClient --- > `requires` Gpg.keyImported "1B169BE1" "root" -- > `requires` Ssh.keyImported SshRsa "root" (Context hostname) -- -- How awesome is that? -backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property -backup dir crontimes params numclients = backup' dir crontimes params numclients - `requires` restored dir params +-- +-- Note that this property does not make obnam encrypt the backup +-- repository. +-- +-- Since obnam uses a fair amount of system resources, only one obnam +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike +backup dir crontimes params numclients = + backup' dir crontimes params numclients + `requires` restored dir params + +-- | Like backup, but the specified gpg key id is used to encrypt +-- the repository. +-- +-- The gpg secret key will be automatically imported +-- into root's keyring using Propellor.Property.Gpg.keyImported +backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property (HasInfo + DebianLike) +backupEncrypted dir crontimes params numclients keyid = + backup dir crontimes params' numclients + `requires` Gpg.keyImported keyid (User "root") + where + params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params -- | Does a backup, but does not automatically restore. -backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property +backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike backup' dir crontimes params numclients = cronjob `describe` desc where desc = dir ++ " backed up by obnam" - cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $ - intercalate ";" $ catMaybes - [ if numclients == OnlyClient - then Just $ unwords $ - [ "obnam" - , "force-lock" - ] ++ map shellEscape params - else Nothing - , Just $ unwords $ - [ "obnam" - , "backup" - , shellEscape dir - ] ++ map shellEscape params - ] + cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape cmdline + lockfile = "/var/lock/propellor-obnam.lock" + cmdline = unwords $ catMaybes + [ if numclients == OnlyClient + -- forcelock fails if repo does not exist yet + then Just $ forcelockcmd ++ " 2>/dev/null ;" + else Nothing + , Just backupcmd + , if any isKeepParam params + then Just $ "&& " ++ forgetcmd + else Nothing + ] + forcelockcmd = unwords $ + [ "obnam" + , "force-lock" + ] ++ map shellEscape params + backupcmd = unwords $ + [ "obnam" + , "backup" + , shellEscape dir + ] ++ map shellEscape params + forgetcmd = unwords $ + [ "obnam" + , "forget" + ] ++ map shellEscape params -- | Restores a directory from an obnam backup. -- @@ -68,11 +98,12 @@ backup' dir crontimes params numclients = cronjob `describe` desc -- -- The restore is performed atomically; restoring to a temp directory -- and then moving it to the directory. -restored :: FilePath -> [ObnamParam] -> Property -restored dir params = property (dir ++ " restored by obnam") go - `requires` installed +restored :: FilePath -> [ObnamParam] -> Property DebianLike +restored dir params = go `requires` installed where - go = ifM (liftIO needsRestore) + desc = dir ++ " restored by obnam" + go :: Property DebianLike + go = property desc $ ifM (liftIO needsRestore) ( do warningMessage $ dir ++ " is empty/missing; restoring from backup ..." liftIO restore @@ -96,64 +127,33 @@ restored dir params = property (dir ++ " restored by obnam") go , return FailedChange ) -installed :: Property -installed = Apt.installed ["obnam"] +-- | Policy for backup generations to keep. For example, KeepDays 30 will +-- keep the latest backup for each day when a backup was made, and keep the +-- last 30 such backups. When multiple KeepPolicies are combined together, +-- backups meeting any policy are kept. See obnam's man page for details. +data KeepPolicy + = KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int --- | Ensures that a recent version of obnam gets installed. --- --- Only does anything for Debian Stable. -latestVersion :: Property -latestVersion = withOS "obnam latest version" $ \o -> case o of - (Just (System (Debian suite) _)) | isStable suite -> ensureProperty $ - Apt.setSourcesListD (stablesources suite) "obnam" - `requires` toProp (Apt.trustsKey key) - _ -> noChange +-- | Constructs an ObnamParam that specifies which old backup generations +-- to keep. By default, all generations are kept. However, when this parameter +-- is passed to the `backup` or `backupEncrypted` properties, they will run +-- obnam forget to clean out generations not specified here. +keepParam :: [KeepPolicy] -> ObnamParam +keepParam ps = "--keep=" ++ intercalate "," (map go ps) where - stablesources suite = - [ "deb http://code.liw.fi/debian " ++ Apt.showSuite suite ++ " main" - ] - -- gpg key used by the code.liw.fi repository. - key = Apt.AptKey "obnam" $ unlines - [ "-----BEGIN PGP PUBLIC KEY BLOCK-----" - , "Version: GnuPG v1.4.9 (GNU/Linux)" - , "" - , "mQGiBEfzuTgRBACcVNG/H6QJqLx5qiQs2zmPe6D6BWOWHfgNgG4IWzNstm21YDxb" - , "KqwFG0gxcnZJGHkXAhkSfqTokYd0lc5eBemcA1pkceNjzMEX8wwiZ810HzJD4eEH" - , "sjoWR8+qKrZeixzZqReAfqztcXoBGKQ0u1R1vpg1txUa75OM4BUqaUbsmwCgmS4x" - , "DjMxSaUSPuu6vQ7ZGZBXSP0D/RQw8DBHMfsv3DiaqFqk8tkuUkpMFPIekHidSHlO" - , "EACbncqbbyHksyCpFNVNcQIDHrOLjOZK9BAXkSd8I3ww7U+nLdDcCblrW8CZnJtm" - , "ZYrxfaXaHZ/It9/RCAsQ+c8xtmyUPjsf//4Vf8olxNQHzgBSe5/LJRi4Vd53he+K" - , "YP4LA/9IZbjvVmm8+8Y0pQrTHlI6nTImtzdBXHc4+T3lLBj9XODHLozC2kSBOQky" - , "q/EisTITHTXL8vYg4NsKm5RTbPAuBwdtxcny8CXfOqKtGOdrebmKotGllTozzdPv" - , "9p53cuce6oJ2oMUodc074JOGTWwDSgLiJX4nViGcU1wy/vtQnrQkY29kZS5saXcu" - , "ZmkgYXJjaGl2ZSBrZXkgPGxpd0BsaXcuZmk+iGAEExECACAFAkfzuTgCGwMGCwkI" - , "BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRBG53tJR95LscKrAJ0ZtKqa2x6Kplwa2mzx" - , "ItImbIGMJACdETqofDYzUN91yLAFlOnxAyrE+UyIRgQQEQIABgUCSFd5GgAKCRAf" - , "u5W/LZrMjqr8AJ4xPVHpW8ZNlgMwDSVb075RnA2DiACgg2SR69jAHFQOWV6xfLRr" - , "vh0bLKGJAhwEEAEIAAYFAktEyIwACgkQ61zh116FEfm7Lg//Wiy3TjWAk8YHUddv" - , "zOioYzCxQ985GsVhJGAVPqSGOc9vfTWBJZ8J3l0NnYTRpEGucmbF9G+mAt9iGXu6" - , "7yZkxyFdvbo7EDsqMU1wLOM6PiU+Un63MKlbTNmFn7OKE8aXPRAFgcyUO/qjdqoD" - , "sa9FgU5Z0f60m9qah6BPXH6IzMLHYoiP7t8rCBIwLgyl3w2w+Fjt1DFpbW9Kb7jz" - , "i8jFvC8jPmxV8xh2OSgVZyNk4qg6hIV8GVQY7AJt8OurZSckgQd7ifHK9JTGohtF" - , "tXCiqeDEvnMF4A9HI/TcXJBzonZ8ds1JCq42nSSKmL+8TyjtUSD/xHygazuc0CK0" - , "hFnQWBub60IfyV6F0oTagJ8cmARv2sezHAeHDkzPHE8RdjgktazH1eJrA4LheEd6" - , "KeSnVtYWpw8dgMv5PleFyQiAj/t3C/N50fd15tUyfnH15G7nFjMQV2Yx35uwSxOj" - , "376OWnDN/YGTNk283XXULbyVJYR8Q2unso20XQ94yQ2A5EpHHPrHoLxrL/ydM08d" - , "nvKstLZIZtal1seiMkymtlSiGz25A5oqsclwS6VZCKdWA8HO/wlElOMcaHyl6Y1y" - , "gYP7y9O5yFYKFOrCH0nFjJbwmkRiBLsxuuWsYgJigVGq/atSrtawkHdshpCw0HCY" - , "N/RFcWkJ864BdsO0C0sDzueNkQO5Ag0ER/O5RBAIAJiwPH9tyJTgXcC2Y4XWboOq" - , "rx5CkOnr5b45oS9cK2eIJ8TKxE3XgKLxUr3mIH0QR2kZgDOwNl0WY+7/CXjn+Spn" - , "BokPg54rafEUePodGpGdUXdgrHhAMHYjh8fXFJ1SlQcg46/zc1wDI7jBCkGrK3V8" - , "5cXDqwTFTN5LcjoSRWeM4Voa6pEfDdL3rMlnOw9R9gDHRBBb6CDSjWXqM86pR889" - , "5QrR0SDwiJNrMoyxSjMXFKGBQAsYHJ82myZrlbuZbroZjVp5Uh7eB1ZiPljNVtcr" - , "sksACIWBCo1rvLzrPXsLYOeV3cDDtYAkSwGfuzC1Etbe+qgfIroFTOqdefMw4s8A" - , "AwUH/0KLXm4MS54QQspg3evu4Q4U/E8Hem5/FqB0GhBCitQ4rUsucKyY8/ItpUn5" - , "ismLE60bQqka+Mzd/Zw18TCTzImv0ozAaZ2sNtBado7f6jcC8EDfY5zzK1ukcsAr" - , "Qc5hdLHYuTQW5KpA6fKaW969OUzIwPbdVaCOLOBpxKC6N6iBspQYd6uiQtLw6EUO" - , "50oQqUiJABf0eOocvdw5e2KQQpuC3205+VMYtyl4w3pdJihK8NK0AikGXzDVsbQt" - , "l8kmB5ZrN4WIKhMke1FxbqQC5Q3XATvYRzpzzisZb/HYGNti8W6du5EUwJ0D2NRh" - , "cu+twocOzW0VKfmrDApfifJ9OsSISQQYEQIACQUCR/O5RAIbDAAKCRBG53tJR95L" - , "seQOAJ95KUyzjRjdYgZkDC69Mgu25L86UACdGduINUaRly43ag4kwUXxpqswBBM=" - , "=i2c3" - , "-----END PGP PUBLIC KEY BLOCK-----" - ] + go (KeepHours n) = mk n 'h' + go (KeepDays n) = mk n 'd' + go (KeepWeeks n) = mk n 'w' + go (KeepMonths n) = mk n 'm' + go (KeepYears n) = mk n 'y' + mk n c = show n ++ [c] + +isKeepParam :: ObnamParam -> Bool +isKeepParam p = "--keep=" `isPrefixOf` p + +installed :: Property DebianLike +installed = Apt.installed ["obnam"] diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs index 39cb6ff0..0abf38a6 100644 --- a/src/Propellor/Property/OpenId.hs +++ b/src/Propellor/Property/OpenId.hs @@ -1,30 +1,50 @@ module Propellor.Property.OpenId where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt -import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.Apache as Apache import Data.List -providerFor :: [UserName] -> String -> Property -providerFor users baseurl = propertyList desc $ - [ Apt.serviceInstalledRunning "apache2" - , Apt.installed ["simpleid"] - `onChange` Service.restarted "apache2" - , File.fileProperty (desc ++ " configured") +-- | Openid provider, using the simpleid PHP CGI, with apache. +-- +-- Runs on usual port by default. When a nonstandard port is specified, +-- apache is limited to listening only on that port. Warning: Specifying +-- a port won't compose well with other apache properties on the same +-- host. +-- +-- It's probably a good idea to put this property inside a docker or +-- systemd-nspawn container. +providerFor :: [User] -> HostName -> Maybe Port -> Property (HasInfo + DebianLike) +providerFor users hn mp = propertyList desc $ props + & Apt.serviceInstalledRunning "apache2" + & apacheconfigured + & Apt.installed ["simpleid"] + `onChange` Apache.restarted + & File.fileProperty (desc ++ " configured") (map setbaseurl) "/etc/simpleid/config.inc" - ] ++ map identfile users + & propertyList desc (toProps $ map identfile users) where + baseurl = hn ++ case mp of + Nothing -> "" + Just p -> ':' : fromPort p url = "http://"++baseurl++"/simpleid" desc = "openid provider " ++ url setbaseurl l - | "SIMPLEID_BASE_URL" `isInfixOf` l = + | "SIMPLEID_BASE_URL" `isInfixOf` l = "define('SIMPLEID_BASE_URL', '"++url++"');" | otherwise = l - - -- the identitites directory controls access, so open up + + apacheconfigured = case mp of + Nothing -> setupRevertableProperty $ + Apache.virtualHost hn (Port 80) "/var/www/html" + Just p -> propertyList desc $ props + & Apache.listenPorts [p] + & Apache.virtualHost hn p "/var/www/html" + + -- the identities directory controls access, so open up -- file mode - identfile u = File.hasPrivContentExposed + identfile (User u) = File.hasPrivContentExposed (concat [ "/var/lib/simpleid/identities/", u, ".identity" ]) (Context baseurl) diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs new file mode 100644 index 00000000..bc8a256d --- /dev/null +++ b/src/Propellor/Property/Parted.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Parted ( + TableType(..), + PartTable(..), + partTableSize, + Partition(..), + mkPartition, + Partition.Fs(..), + PartSize(..), + ByteSize, + toPartSize, + fromPartSize, + reducePartSize, + Partition.MkfsOpts, + PartType(..), + PartFlag(..), + Eep(..), + partitioned, + parted, + installed, +) where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Partition as Partition +import Utility.DataUnits +import Data.Char +import System.Posix.Files + +class PartedVal a where + val :: a -> String + +-- | Types of partition tables supported by parted. +data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN + deriving (Show) + +instance PartedVal TableType where + val = map toLower . show + +-- | A disk's partition table. +data PartTable = PartTable TableType [Partition] + deriving (Show) + +instance Monoid PartTable where + -- | default TableType is MSDOS + mempty = PartTable MSDOS [] + -- | uses the TableType of the second parameter + mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2) + +-- | Gets the total size of the disk specified by the partition table. +partTableSize :: PartTable -> ByteSize +partTableSize (PartTable _ ps) = fromPartSize $ + -- add 1 megabyte to hold the partition table itself + mconcat (MegaBytes 1 : map partSize ps) + +-- | A partition on the disk. +data Partition = Partition + { partType :: PartType + , partSize :: PartSize + , partFs :: Partition.Fs + , partMkFsOpts :: Partition.MkfsOpts + , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) + , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC) + } + deriving (Show) + +-- | Makes a Partition with defaults for non-important values. +mkPartition :: Partition.Fs -> PartSize -> Partition +mkPartition fs sz = Partition + { partType = Primary + , partSize = sz + , partFs = fs + , partMkFsOpts = [] + , partFlags = [] + , partName = Nothing + } + +-- | Type of a partition. +data PartType = Primary | Logical | Extended + deriving (Show) + +instance PartedVal PartType where + val Primary = "primary" + val Logical = "logical" + val Extended = "extended" + +-- | All partition sizing is done in megabytes, so that parted can +-- automatically lay out the partitions. +-- +-- Note that these are SI megabytes, not mebibytes. +newtype PartSize = MegaBytes Integer + deriving (Show) + +instance PartedVal PartSize where + val (MegaBytes n) + | n > 0 = show n ++ "MB" + -- parted can't make partitions smaller than 1MB; + -- avoid failure in edge cases + | otherwise = show "1MB" + +-- | Rounds up to the nearest MegaByte. +toPartSize :: ByteSize -> PartSize +toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double) + +fromPartSize :: PartSize -> ByteSize +fromPartSize (MegaBytes b) = b * 1000000 + +instance Monoid PartSize where + mempty = MegaBytes 0 + mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) + +reducePartSize :: PartSize -> PartSize -> PartSize +reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b) + +-- | Flags that can be set on a partition. +data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag + deriving (Show) + +instance PartedVal PartFlag where + val BootFlag = "boot" + val RootFlag = "root" + val SwapFlag = "swap" + val HiddenFlag = "hidden" + val RaidFlag = "raid" + val LvmFlag = "lvm" + val LbaFlag = "lba" + val LegacyBootFlag = "legacy_boot" + val IrstFlag = "irst" + val EspFlag = "esp" + val PaloFlag = "palo" + +instance PartedVal Bool where + val True = "on" + val False = "off" + +instance PartedVal Partition.Fs where + val Partition.EXT2 = "ext2" + val Partition.EXT3 = "ext3" + val Partition.EXT4 = "ext4" + val Partition.BTRFS = "btrfs" + val Partition.REISERFS = "reiserfs" + val Partition.XFS = "xfs" + val Partition.FAT = "fat" + val Partition.VFAT = "vfat" + val Partition.NTFS = "ntfs" + val Partition.LinuxSwap = "linux-swap" + +data Eep = YesReallyDeleteDiskContents + +-- | Partitions a disk using parted, and formats the partitions. +-- +-- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file. +-- +-- This deletes any existing partitions in the disk! Use with EXTREME caution! +partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike +partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do + isdev <- liftIO $ isBlockDevice <$> getFileStatus disk + ensureProperty w $ combineProperties desc $ props + & parted eep disk partedparams + & if isdev + then formatl (map (\n -> disk ++ show n) [1 :: Int ..]) + else Partition.kpartx disk (formatl . map Partition.partitionLoopDev) + where + desc = disk ++ " partitioned" + formatl devs = combineProperties desc (toProps $ map format (zip parts devs)) + partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] + format (p, dev) = Partition.formatted' (partMkFsOpts p) + Partition.YesReallyFormatPartition (partFs p) dev + mklabel = ["mklabel", val tabletype] + mkflag partnum (f, b) = + [ "set" + , show partnum + , val f + , val b + ] + mkpart partnum offset p = + [ "mkpart" + , val (partType p) + , val (partFs p) + , val offset + , val (offset <> partSize p) + ] ++ case partName p of + Just n -> ["name", show partnum, n] + Nothing -> [] + mkparts partnum offset (p:ps) c = + mkparts (partnum+1) (offset <> partSize p) ps + (c ++ mkpart partnum offset p : map (mkflag partnum) (partFlags p)) + mkparts _ _ [] c = c + +-- | Runs parted on a disk with the specified parameters. +-- +-- Parted is run in script mode, so it will never prompt for input. +-- It is asked to use cylinder alignment for the disk. +parted :: Eep -> FilePath -> [String] -> Property DebianLike +parted YesReallyDeleteDiskContents disk ps = p `requires` installed + where + p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) + `assume` MadeChange + +-- | Gets parted installed. +installed :: Property DebianLike +installed = Apt.installed ["parted"] diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs new file mode 100644 index 00000000..2bf5b927 --- /dev/null +++ b/src/Propellor/Property/Partition.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Partition where + +import Propellor.Base +import Propellor.Types.Core +import qualified Propellor.Property.Apt as Apt +import Utility.Applicative + +import System.Posix.Files +import Data.List + +-- | Filesystems etc that can be used for a partition. +data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap + deriving (Show, Eq) + +data Eep = YesReallyFormatPartition + +-- | Formats a partition. +formatted :: Eep -> Fs -> FilePath -> Property DebianLike +formatted = formatted' [] + +-- | Options passed to a mkfs.* command when making a filesystem. +-- +-- Eg, ["-m0"] +type MkfsOpts = [String] + +formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike +formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts' + `assume` MadeChange + `requires` Apt.installed [pkg] + where + (cmd, opts', pkg) = case fs of + EXT2 -> ("mkfs.ext2", q $ eff optsdev, "e2fsprogs") + EXT3 -> ("mkfs.ext3", q $ eff optsdev, "e2fsprogs") + EXT4 -> ("mkfs.ext4", q $ eff optsdev, "e2fsprogs") + BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools") + REISERFS -> ("mkfs.reiserfs", q $ "-ff":optsdev, "reiserfsprogs") + XFS -> ("mkfs.xfs", "-f":q optsdev, "xfsprogs") + FAT -> ("mkfs.fat", optsdev, "dosfstools") + VFAT -> ("mkfs.vfat", optsdev, "dosfstools") + NTFS -> ("mkfs.ntfs", q $ eff optsdev, "ntfs-3g") + LinuxSwap -> ("mkswap", optsdev, "util-linux") + optsdev = opts++[dev] + -- -F forces creating a filesystem even if the device already has one + eff l = "-F":l + -- Be quiet. + q l = "-q":l + +data LoopDev = LoopDev + { partitionLoopDev :: FilePath -- ^ device for a loop partition + , wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk + } deriving (Show) + +isLoopDev :: LoopDev -> IO Bool +isLoopDev l = isLoopDev' (partitionLoopDev l) <&&> isLoopDev' (wholeDiskLoopDev l) + +isLoopDev' :: FilePath -> IO Bool +isLoopDev' f + | "loop" `isInfixOf` f = catchBoolIO $ + isBlockDevice <$> getFileStatus f + | otherwise = return False + +-- | Uses the kpartx utility to create device maps for partitions contained +-- within a disk image file. The resulting loop devices are passed to the +-- property, which can operate on them. Always cleans up after itself, +-- by removing the device maps after the property is run. +kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike +kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] + where + go :: Property DebianLike + go = property' (getDesc (mkprop [])) $ \w -> do + cleanup -- idempotency + loopdevs <- liftIO $ kpartxParse + <$> readProcess "kpartx" ["-avs", diskimage] + bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs + unless (null bad) $ + error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad + r <- ensureProperty w (mkprop loopdevs) + cleanup + return r + cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] + +kpartxParse :: String -> [LoopDev] +kpartxParse = mapMaybe (finddev . words) . lines + where + finddev ("add":"map":ld:_:_:_:_:wd:_) = Just $ LoopDev + { partitionLoopDev = "/dev/mapper/" ++ ld + , wholeDiskLoopDev = wd + } + finddev _ = Nothing diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs index b3d12727..45aa4e42 100644 --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -1,73 +1,83 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Postfix where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt -import Propellor.Property.File +import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.User as User import qualified Data.Map as M import Data.List import Data.Char -installed :: Property +installed :: Property DebianLike installed = Apt.serviceInstalledRunning "postfix" -restarted :: Property +restarted :: Property DebianLike restarted = Service.restarted "postfix" -reloaded :: Property +reloaded :: Property DebianLike reloaded = Service.reloaded "postfix" -- | Configures postfix as a satellite system, which --- relays all mail through a relay host, which defaults to smtp.domain. +-- relays all mail through a relay host, which defaults to smtp.domain, +-- but can be changed by @mainCf "relayhost"@. -- -- The smarthost may refuse to relay mail on to other domains, without --- futher coniguration/keys. But this should be enough to get cron job +-- further configuration/keys. But this should be enough to get cron job -- mail flowing to a place where it will be seen. -satellite :: Property +satellite :: Property DebianLike satellite = check (not <$> mainCfIsSet "relayhost") setup `requires` installed where - setup = trivial $ property "postfix satellite system" $ do + desc = "postfix satellite system" + setup :: Property DebianLike + setup = property' desc $ \w -> do hn <- asks hostName let (_, domain) = separate (== '.') hn - ensureProperties - [ Apt.reConfigure "postfix" + ensureProperty w $ combineProperties desc $ props + & Apt.reConfigure "postfix" [ ("postfix/main_mailer_type", "select", "Satellite system") , ("postfix/root_address", "string", "root") - , ("postfix/destinations", "string", " ") + , ("postfix/destinations", "string", "localhost") , ("postfix/mailname", "string", hn) ] - , mainCf ("relayhost", domain) + & mainCf ("relayhost", "smtp." ++ domain) `onChange` reloaded - ] -- | Sets up a file by running a property (which the filename is passed -- to). If the setup property makes a change, postmap will be run on the -- file, and postfix will be reloaded. -mappedFile :: FilePath -> (FilePath -> Property) -> Property +mappedFile + :: Combines (Property x) (Property UnixLike) + => FilePath + -> (FilePath -> Property x) + -> CombinedType (Property x) (Property UnixLike) mappedFile f setup = setup f - `onChange` cmdProperty "postmap" [f] + `onChange` (cmdProperty "postmap" [f] `assume` MadeChange) -- | Run newaliases command, which should be done after changing --- /etc/aliases. -newaliases :: Property -newaliases = trivial $ cmdProperty "newaliases" [] +-- @/etc/aliases@. +newaliases :: Property UnixLike +newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db") + (cmdProperty "newaliases" []) -- | The main config file for postfix. mainCfFile :: FilePath mainCfFile = "/etc/postfix/main.cf" --- | Sets a main.cf name=value pair. Does not reload postfix immediately. -mainCf :: (String, String) -> Property +-- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately. +mainCf :: (String, String) -> Property UnixLike mainCf (name, value) = check notset set - `describe` ("postfix main.cf " ++ setting) + `describe` ("postfix main.cf " ++ setting) where setting = name ++ "=" ++ value notset = (/= Just value) <$> getMainCf name set = cmdProperty "postconf" ["-e", setting] --- | Gets a man.cf setting. +-- | Gets a main.cf setting. getMainCf :: String -> IO (Maybe String) getMainCf name = parse . lines <$> readProcess "postconf" [name] where @@ -77,8 +87,8 @@ getMainCf name = parse . lines <$> readProcess "postconf" [name] (_, v) -> v parse [] = Nothing --- | Checks if a main.cf field is set. A field that is set to "" --- is considered not set. +-- | Checks if a main.cf field is set. A field that is set to +-- the empty string is considered not set. mainCfIsSet :: String -> IO Bool mainCfIsSet name = do v <- getMainCf name @@ -96,8 +106,8 @@ mainCfIsSet name = do -- -- Note that multiline configurations that continue onto the next line -- are not currently supported. -dedupMainCf :: Property -dedupMainCf = fileProperty "postfix main.cf dedupped" dedupCf mainCfFile +dedupMainCf :: Property UnixLike +dedupMainCf = File.fileProperty "postfix main.cf dedupped" dedupCf mainCfFile dedupCf :: [String] -> [String] dedupCf ls = @@ -119,3 +129,193 @@ dedupCf ls = dedup c kc ((Right (k, v)):rest) = case M.lookup k kc of Just n | n > 1 -> dedup c (M.insert k (n - 1) kc) rest _ -> dedup (fmt k v:c) kc rest + +-- | The master config file for postfix. +masterCfFile :: FilePath +masterCfFile = "/etc/postfix/master.cf" + +-- | A service that can be present in the master config file. +data Service = Service + { serviceType :: ServiceType + , serviceCommand :: String + , serviceOpts :: ServiceOpts + } + deriving (Show, Eq) + +data ServiceType + = InetService (Maybe HostName) ServicePort + | UnixService FilePath PrivateService + | FifoService FilePath PrivateService + | PassService FilePath PrivateService + deriving (Show, Eq) + +-- Can be a port number or service name such as "smtp". +type ServicePort = String + +type PrivateService = Bool + +-- | Options for a service. +data ServiceOpts = ServiceOpts + { serviceUnprivileged :: Maybe Bool + , serviceChroot :: Maybe Bool + , serviceWakeupTime :: Maybe Int + , serviceProcessLimit :: Maybe Int + } + deriving (Show, Eq) + +defServiceOpts :: ServiceOpts +defServiceOpts = ServiceOpts + { serviceUnprivileged = Nothing + , serviceChroot = Nothing + , serviceWakeupTime = Nothing + , serviceProcessLimit = Nothing + } + +formatServiceLine :: Service -> File.Line +formatServiceLine s = unwords $ map pad + [ (10, case serviceType s of + InetService (Just h) p -> h ++ ":" ++ p + InetService Nothing p -> p + UnixService f _ -> f + FifoService f _ -> f + PassService f _ -> f) + , (6, case serviceType s of + InetService _ _ -> "inet" + UnixService _ _ -> "unix" + FifoService _ _ -> "fifo" + PassService _ _ -> "pass") + , (8, case serviceType s of + InetService _ _ -> bool False + UnixService _ b -> bool b + FifoService _ b -> bool b + PassService _ b -> bool b) + , (8, v bool serviceUnprivileged) + , (8, v bool serviceChroot) + , (8, v show serviceWakeupTime) + , (8, v show serviceProcessLimit) + , (0, serviceCommand s) + ] + where + v f sel = maybe "-" f (sel (serviceOpts s)) + bool True = "y" + bool False = "n" + pad (n, t) = t ++ replicate (n - 1 - length t) ' ' + +-- | Note that this does not handle multi-line service entries, +-- in which subsequent lines are indented. `serviceLine` does not generate +-- such entries. +parseServiceLine :: File.Line -> Maybe Service +parseServiceLine ('#':_) = Nothing +parseServiceLine (' ':_) = Nothing -- continuation of multiline entry +parseServiceLine l = Service + <$> parsetype + <*> parsecommand + <*> parseopts + where + parsetype = do + t <- getword 2 + case t of + "inet" -> do + v <- getword 1 + let (h,p) = separate (== ':') v + if null p + then Nothing + else Just $ InetService + (if null h then Nothing else Just h) p + "unix" -> UnixService <$> getword 1 <*> parseprivate + "fifo" -> FifoService <$> getword 1 <*> parseprivate + "pass" -> PassService <$> getword 1 <*> parseprivate + _ -> Nothing + parseprivate = join . bool =<< getword 3 + + parsecommand = case unwords (drop 7 ws) of + "" -> Nothing + s -> Just s + + parseopts = ServiceOpts + <$> (bool =<< getword 4) + <*> (bool =<< getword 5) + <*> (int =<< getword 6) + <*> (int =<< getword 7) + + bool "-" = Just Nothing + bool "y" = Just (Just True) + bool "n" = Just (Just False) + bool _ = Nothing + + int "-" = Just Nothing + int n = maybe Nothing (Just . Just) (readish n) + + getword n + | nws >= n = Just (ws !! (n -1)) + | otherwise = Nothing + ws = words l + nws = length ws + +-- | Enables a `Service` in postfix's `masterCfFile`. +service :: Service -> RevertableProperty DebianLike DebianLike +service s = (enable <!> disable) + `describe` desc + where + desc = "enabled postfix service " ++ show (serviceType s) + enable = masterCfFile `File.containsLine` (formatServiceLine s) + `onChange` reloaded + disable = File.fileProperty desc (filter (not . matches)) masterCfFile + `onChange` reloaded + matches l = case parseServiceLine l of + Just s' | s' == s -> True + _ -> False + +-- | Installs saslauthd and configures it for postfix, authenticating +-- against PAM. +-- +-- Does not configure postfix to use it; eg @smtpd_sasl_auth_enable = yes@ +-- needs to be set to enable use. See +-- <https://wiki.debian.org/PostfixAndSASL>. +-- +-- Password brute force attacks are possible when SASL auth is enabled. +-- It would be wise to enable fail2ban, for example: +-- +-- > Fail2Ban.jailEnabled "postfix-sasl" +saslAuthdInstalled :: Property DebianLike +saslAuthdInstalled = setupdaemon + `requires` Service.running "saslauthd" + `requires` postfixgroup + `requires` dirperm + `requires` Apt.installed ["sasl2-bin"] + `requires` smtpdconf + where + setupdaemon = "/etc/default/saslauthd" `File.containsLines` + [ "START=yes" + , "OPTIONS=\"-c -m " ++ dir ++ "\"" + ] + `onChange` Service.restarted "saslauthd" + smtpdconf = "/etc/postfix/sasl/smtpd.conf" `File.containsLines` + [ "pwcheck_method: saslauthd" + , "mech_list: PLAIN LOGIN" + ] + dirperm = check (not <$> doesDirectoryExist dir) $ + cmdProperty "dpkg-statoverride" + [ "--add", "root", "sasl", "710", dir ] + postfixgroup = (User "postfix") `User.hasGroup` (Group "sasl") + `onChange` restarted + dir = "/var/spool/postfix/var/run/saslauthd" + +-- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file. +-- +-- The password is taken from the privdata. +saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike) +saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2" + where + go = withPrivData src ctx $ \getpw -> + property desc $ getpw $ \pw -> liftIO $ + withHandle StdinHandle createProcessSuccess p $ \h -> do + hPutStrLn h (privDataVal pw) + hClose h + return NoChange + desc = "sasl password for " ++ uatd + uatd = user ++ "@" ++ domain + ps = ["-p", "-c", "-u", domain, user] + p = proc "saslpasswd2" ps + ctx = Context "sasl" + src = PrivDataSource (Password uatd) "enter password" diff --git a/src/Propellor/Property/PropellorRepo.hs b/src/Propellor/Property/PropellorRepo.hs new file mode 100644 index 00000000..e60e7848 --- /dev/null +++ b/src/Propellor/Property/PropellorRepo.hs @@ -0,0 +1,19 @@ +module Propellor.Property.PropellorRepo where + +import Propellor.Base +import Propellor.Git.Config + +-- | Sets the url to use as the origin of propellor's git repository. +-- +-- When propellor --spin is used to update a host, the url is taken from +-- the repository that --spin is run in, and passed to the host. So, you +-- don't need to specifiy this property then. +-- +-- This property is useful when hosts are being updated without using +-- --spin, eg when using the `Propellor.Property.Cron.runPropellor` cron job. +hasOriginUrl :: String -> Property UnixLike +hasOriginUrl u = property ("propellor repo url " ++ u) $ do + curru <- liftIO getRepoUrl + if curru == Just u + then return NoChange + else makeChange $ setRepoUrl u diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs new file mode 100644 index 00000000..8017be4a --- /dev/null +++ b/src/Propellor/Property/Prosody.hs @@ -0,0 +1,51 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> + +module Propellor.Property.Prosody where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +type ConfigFile = [String] + +type Conf = String + +confEnabled :: Conf -> ConfigFile -> RevertableProperty DebianLike DebianLike +confEnabled conf cf = enable <!> disable + where + enable = dir `File.isSymlinkedTo` target + `describe` ("prosody conf enabled " ++ conf) + `requires` confAvailable conf cf + `requires` installed + `onChange` reloaded + where + target = confValRelativePath conf + dir = confValPath conf + confValRelativePath conf' = File.LinkTarget $ + "../conf.avail" </> conf' <.> "cfg.lua" + disable = File.notPresent (confValPath conf) + `describe` ("prosody conf disabled " ++ conf) + `requires` installed + `onChange` reloaded + +confAvailable :: Conf -> ConfigFile -> Property DebianLike +confAvailable conf cf = ("prosody conf available " ++ conf) ==> + tightenTargets (confAvailPath conf `File.hasContent` (comment : cf)) + where + comment = "-- deployed with propellor, do not modify" + +confAvailPath :: Conf -> FilePath +confAvailPath conf = "/etc/prosody/conf.avail" </> conf <.> "cfg.lua" + +confValPath :: Conf -> FilePath +confValPath conf = "/etc/prosody/conf.d" </> conf <.> "cfg.lua" + +installed :: Property DebianLike +installed = Apt.installed ["prosody"] + +restarted :: Property DebianLike +restarted = Service.restarted "prosody" + +reloaded :: Property DebianLike +reloaded = Service.reloaded "prosody" diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs index 25e53159..5b854fa3 100644 --- a/src/Propellor/Property/Reboot.hs +++ b/src/Propellor/Property/Reboot.hs @@ -1,7 +1,30 @@ module Propellor.Property.Reboot where -import Propellor +import Propellor.Base -now :: Property -now = cmdProperty "reboot" [] +now :: Property Linux +now = tightenTargets $ cmdProperty "reboot" [] + `assume` MadeChange `describe` "reboot now" + +-- | Schedules a reboot at the end of the current propellor run. +-- +-- The `Result` code of the entire propellor run can be checked; +-- the reboot proceeds only if the function returns True. +-- +-- The reboot can be forced to run, which bypasses the init system. Useful +-- if the init system might not be running for some reason. +atEnd :: Bool -> (Result -> Bool) -> Property Linux +atEnd force resultok = property "scheduled reboot at end of propellor run" $ do + endAction "rebooting" atend + return NoChange + where + atend r + | resultok r = liftIO $ toResult + <$> boolSystem "reboot" rebootparams + | otherwise = do + warningMessage "Not rebooting, due to status of propellor run." + return FailedChange + rebootparams + | force = [Param "--force"] + | otherwise = [] diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs new file mode 100644 index 00000000..b40396de --- /dev/null +++ b/src/Propellor/Property/Rsync.hs @@ -0,0 +1,62 @@ +module Propellor.Property.Rsync where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt + +type Src = FilePath +type Dest = FilePath + +class RsyncParam p where + toRsync :: p -> String + +-- | A pattern that matches all files under a directory, but does not +-- match the directory itself. +filesUnder :: FilePath -> Pattern +filesUnder d = Pattern (d ++ "/*") + +-- | Ensures that the Dest directory exists and has identical contents as +-- the Src directory. +syncDir :: Src -> Dest -> Property DebianLike +syncDir = syncDirFiltered [] + +data Filter + = Include Pattern + | Exclude Pattern + | Protect Pattern + +instance RsyncParam Filter where + toRsync (Include (Pattern p)) = "--include=" ++ p + toRsync (Exclude (Pattern p)) = "--exclude=" ++ p + toRsync (Protect (Pattern p)) = "--filter=P " ++ p + +-- | A pattern to match against files that rsync is going to transfer. +-- +-- See "INCLUDE/EXCLUDE PATTERN RULES" in the rsync(1) man page. +-- +-- For example, Pattern "/foo/*" matches all files under the "foo" +-- directory, relative to the 'Src' that rsync is acting on. +newtype Pattern = Pattern String + +-- | Like syncDir, but avoids copying anything that the filter list +-- excludes. Anything that's filtered out will be deleted from Dest. +-- +-- Rsync checks each name to be transferred against its list of Filter +-- rules, and the first matching one is acted on. If no matching rule +-- is found, the file is processed. +syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike +syncDirFiltered filters src dest = rsync $ + [ "-av" + -- Add trailing '/' to get rsync to sync the Dest directory, + -- rather than a subdir inside it, which it will do without a + -- trailing '/'. + , addTrailingPathSeparator src + , addTrailingPathSeparator dest + , "--delete" + , "--delete-excluded" + , "--quiet" + ] ++ map toRsync filters + +rsync :: [String] -> Property DebianLike +rsync ps = cmdProperty "rsync" ps + `assume` MadeChange + `requires` Apt.installed ["rsync"] diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs new file mode 100644 index 00000000..2647e69e --- /dev/null +++ b/src/Propellor/Property/Sbuild.hs @@ -0,0 +1,383 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Maintainer: Sean Whitton <spwhitton@spwhitton.name> + +Build and maintain schroots for use with sbuild. + +Suggested usage in @config.hs@: + +> & Apt.installed ["piuparts"] +> & Sbuild.builtFor (System (Debian Unstable) "i386") +> & Sbuild.piupartsConfFor (System (Debian Unstable) "i386") +> & Sbuild.updatedFor (System (Debian Unstable) "i386") `period` Weekly 1 +> & Sbuild.usableBy (User "spwhitton") +> & Sbuild.shareAptCache +> & Schroot.overlaysInTmpfs + +In @~/.sbuildrc@: + +> $run_piuparts = 1; +> $piuparts_opts = [ +> '--schroot', +> 'unstable-i386-piuparts', +> '--fail-if-inadequate', +> '--fail-on-broken-symlinks', +> ]; +> +> $external_commands = { +> 'post-build-commands' => [ +> [ +> 'adt-run', +> '--changes', '%c', +> '---', +> 'schroot', 'unstable-i386-sbuild;', +> +> # if adt-run's exit code is 8 then the package had no tests but +> # this isn't a failure, so catch it +> 'adtexit=$?;', +> 'if', 'test', '$adtexit', '=', '8;', 'then', +> 'exit', '0;', 'else', 'exit', '$adtexit;', 'fi' +> ], +> ], +> }; + +We use @sbuild-createchroot(1)@ to create a chroot to the specification of +@sbuild-setup(7)@. This differs from the approach taken by picca's Sbuild.hs, +which uses 'Propellor.Property.Debootstrap' to construct the chroot. This is +because we don't want to run propellor inside the chroot in order to keep the +sbuild environment as standard as possible. +-} + +-- If you wanted to do it with Propellor.Property.Debootstrap, note that +-- sbuild-createchroot has a --setup-only option + +module Propellor.Property.Sbuild ( + -- * Creating and updating sbuild schroots + SbuildSchroot(..), + builtFor, + built, + updated, + updatedFor, + piupartsConfFor, + piupartsConf, + -- * Global sbuild configuration + -- blockNetwork, + installed, + keypairGenerated, + shareAptCache, + usableBy, +) where + +import Propellor.Base +import Propellor.Property.Debootstrap (extractSuite) +import Propellor.Property.Chroot.Util +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Ccache as Ccache +import qualified Propellor.Property.ConfFile as ConfFile +import qualified Propellor.Property.File as File +-- import qualified Propellor.Property.Firewall as Firewall +import qualified Propellor.Property.User as User + +import Utility.FileMode +import Data.List +import Data.List.Utils + +type Suite = String + +-- | An sbuild schroot, such as would be listed by @schroot -l@ +-- +-- Parts of the sbuild toolchain cannot distinguish between schroots with both +-- the same suite and the same architecture, so neither do we +data SbuildSchroot = SbuildSchroot Suite Architecture + +instance Show SbuildSchroot where + show (SbuildSchroot suite arch) = suite ++ "-" ++ arch + +-- | Build and configure a schroot for use with sbuild using a distribution's +-- standard mirror +-- +-- This function is a convenience wrapper around 'Sbuild.builtFor', allowing the +-- user to identify the schroot and distribution using the 'System' type +builtFor :: System -> RevertableProperty DebianLike UnixLike +builtFor sys = go <!> deleted + where + go = property' ("sbuild schroot for " ++ show sys) $ + \w -> case (schrootFromSystem sys, stdMirror sys) of + (Just s, Just u) -> ensureProperty w $ + setupRevertableProperty $ built s u + _ -> errorMessage + ("don't know how to debootstrap " ++ show sys) + deleted = property' ("no sbuild schroot for " ++ show sys) $ + \w -> case schrootFromSystem sys of + Just s -> ensureProperty w $ + undoRevertableProperty $ built s "dummy" + Nothing -> noChange + +-- | Build and configure a schroot for use with sbuild +built :: SbuildSchroot -> Apt.Url -> RevertableProperty DebianLike UnixLike +built s@(SbuildSchroot suite arch) mirror = + (go + `requires` keypairGenerated + `requires` ccachePrepared + `requires` installed) + <!> deleted + where + go :: Property DebianLike + go = check (unpopulated (schrootRoot s) <||> ispartial) $ + property' ("built sbuild schroot for " ++ show s) make + make w = do + de <- liftIO standardPathEnv + let params = Param <$> + [ "--arch=" ++ arch + , "--chroot-suffix=-propellor" + , "--include=eatmydata,ccache" + , suite + , schrootRoot s + , mirror + ] + ifM (liftIO $ + boolSystemEnv "sbuild-createchroot" params (Just de)) + ( ensureProperty w $ + fixConfFile s + `before` aliasesLine + `before` commandPrefix + , return FailedChange + ) + deleted = check (not <$> unpopulated (schrootRoot s)) $ + property ("no sbuild schroot for " ++ show s) $ do + liftIO $ removeChroot $ schrootRoot s + liftIO $ nukeFile + ("/etc/sbuild/chroot" </> show s ++ "-sbuild") + makeChange $ nukeFile (schrootConf s) + + -- if we're building a sid chroot, add useful aliases + aliasesLine :: Property UnixLike + aliasesLine = if suite == "unstable" + then File.containsLine (schrootConf s) + "aliases=UNRELEASED,sid,rc-buggy,experimental" + else doNothing + -- enable ccache and eatmydata for speed + commandPrefix = File.containsLine (schrootConf s) + "command-prefix=/var/cache/ccache-sbuild/sbuild-setup,eatmydata" + + -- A failed debootstrap run will leave a debootstrap directory; + -- recover by deleting it and trying again. + ispartial = ifM (doesDirectoryExist (schrootRoot s </> "debootstrap")) + ( do + removeChroot $ schrootRoot s + return True + , return False + ) + +-- | Ensure that an sbuild schroot's packages and apt indexes are updated +-- +-- This function is a convenience wrapper around 'Sbuild.updated', allowing the +-- user to identify the schroot using the 'System' type +updatedFor :: System -> Property DebianLike +updatedFor system = property' ("updated sbuild schroot for " ++ show system) $ + \w -> case schrootFromSystem system of + Just s -> ensureProperty w $ updated s + Nothing -> errorMessage + ("don't know how to debootstrap " ++ show system) + +-- | Ensure that an sbuild schroot's packages and apt indexes are updated +updated :: SbuildSchroot -> Property DebianLike +updated s@(SbuildSchroot suite arch) = + check (doesDirectoryExist (schrootRoot s)) $ go + `describe` ("updated schroot for " ++ show s) + `requires` keypairGenerated + `requires` installed + where + go :: Property DebianLike + go = tightenTargets $ cmdProperty + "sbuild-update" ["-udr", suite ++ "-" ++ arch] + `assume` MadeChange + +-- Find the conf file that sbuild-createchroot(1) made when we passed it +-- --chroot-suffix=propellor, and edit and rename such that it is as if we +-- passed --chroot-suffix=sbuild (the default). Replace the random suffix with +-- 'propellor'. +-- +-- We had to pass --chroot-suffix=propellor in order that we can find a unique +-- config file for the schroot we just built, despite the random suffix. +-- +-- The properties in this module only permit the creation of one chroot for a +-- given suite and architecture, so we don't need the suffix to be random. +fixConfFile :: SbuildSchroot -> Property UnixLike +fixConfFile s@(SbuildSchroot suite arch) = + property' ("schroot for " ++ show s ++ " config file fixed") $ \w -> do + confs <- liftIO $ dirContents dir + let old = concat $ filter (tempPrefix `isPrefixOf`) confs + liftIO $ moveFile old new + liftIO $ moveFile + ("/etc/sbuild/chroot" </> show s ++ "-propellor") + ("/etc/sbuild/chroot" </> show s ++ "-sbuild") + ensureProperty w $ + File.fileProperty "replace dummy suffix" (map munge) new + where + new = schrootConf s + dir = takeDirectory new + tempPrefix = dir </> suite ++ "-" ++ arch ++ "-propellor-" + munge = replace "-propellor]" "-sbuild]" + +-- | Create a corresponding schroot config file for use with piuparts +-- +-- This function is a convenience wrapper around 'Sbuild.piupartsConf', allowing +-- the user to identify the schroot using the 'System' type. See that +-- function's documentation for why you might want to use this property, and +-- sample config. +piupartsConfFor :: System -> Property DebianLike +piupartsConfFor sys = property' ("piuparts schroot conf for " ++ show sys) $ + \w -> case (schrootFromSystem sys, stdMirror sys) of + (Just s, Just u) -> ensureProperty w $ + piupartsConf s u + _ -> errorMessage + ("don't know how to debootstrap " ++ show sys) + +-- | Create a corresponding schroot config file for use with piuparts +-- +-- This is useful because: +-- +-- - piuparts will clear out the apt cache which makes 'Sbuild.shareAptCache' +-- much less useful +-- +-- - piuparts itself invokes eatmydata, so the command-prefix setting in our +-- regular schroot config would force the user to pass --no-eatmydata to +-- piuparts in their @~/.sbuildrc@, which is inconvenient. +-- +-- To make use of this new schroot config, you can put something like this in +-- your ~/.sbuildrc: +-- +-- > $run_piuparts = 1; +-- > $piuparts_opts = [ +-- > '--schroot', +-- > 'unstable-i386-piuparts', +-- > '--fail-if-inadequate', +-- > '--fail-on-broken-symlinks', +-- > ]; +piupartsConf :: SbuildSchroot -> Apt.Url -> Property DebianLike +piupartsConf s u = go + `requires` (setupRevertableProperty $ built s u) + `describe` ("piuparts schroot conf for " ++ show s) + where + go :: Property DebianLike + go = tightenTargets $ + check (not <$> doesFileExist f) + (File.basedOn f (schrootConf s, map munge)) + `before` + ConfFile.containsIniSetting f (sec, "profile", "piuparts") + `before` + ConfFile.containsIniSetting f (sec, "aliases", "") + `before` + ConfFile.containsIniSetting f (sec, "command-prefix", "") + `before` + File.dirExists dir + `before` + File.isSymlinkedTo (dir </> "copyfiles") + (File.LinkTarget $ orig </> "copyfiles") + `before` + File.isSymlinkedTo (dir </> "nssdatabases") + (File.LinkTarget $ orig </> "nssdatabases") + `before` + File.basedOn (dir </> "fstab") + (orig </> "fstab", filter (/= aptCacheLine)) + + orig = "/etc/schroot/sbuild" + dir = "/etc/schroot/piuparts" + sec = show s ++ "-piuparts" + f = schrootPiupartsConf s + munge = replace "-sbuild]" "-piuparts]" + +-- | Bind-mount @/var/cache/apt/archives@ in all sbuild chroots so that the host +-- system and the chroot share the apt cache +-- +-- This speeds up builds by avoiding unnecessary downloads of build +-- dependencies. +shareAptCache :: Property DebianLike +shareAptCache = File.containsLine "/etc/schroot/sbuild/fstab" aptCacheLine + `requires` installed + `describe` "sbuild schroots share host apt cache" + +aptCacheLine :: String +aptCacheLine = "/var/cache/apt/archives /var/cache/apt/archives none rw,bind 0 0" + +-- | Ensure that sbuild is installed +installed :: Property DebianLike +installed = Apt.installed ["sbuild"] + +-- | Add an user to the sbuild group in order to use sbuild +usableBy :: User -> Property DebianLike +usableBy u = User.hasGroup u (Group "sbuild") `requires` installed + +-- | Generate the apt keys needed by sbuild +keypairGenerated :: Property DebianLike +keypairGenerated = check (not <$> doesFileExist secKeyFile) $ go + `requires` installed + where + go :: Property DebianLike + go = tightenTargets $ + cmdProperty "sbuild-update" ["--keygen"] + `assume` MadeChange + secKeyFile = "/var/lib/sbuild/apt-keys/sbuild-key.sec" + +-- another script from wiki.d.o/sbuild +ccachePrepared :: Property DebianLike +ccachePrepared = propertyList "sbuild group ccache configured" $ props + -- We only set a limit on the cache if it doesn't already exist, so the + -- user can override our default limit + & check (not <$> doesDirectoryExist "/var/cache/ccache-sbuild") + (Ccache.hasLimits "/var/cache/ccache-sbuild" (Ccache.MaxSize "2G")) + `before` Ccache.hasCache (Group "sbuild") Ccache.NoLimit + & "/etc/schroot/sbuild/fstab" `File.containsLine` + "/var/cache/ccache-sbuild /var/cache/ccache-sbuild none rw,bind 0 0" + `describe` "ccache mounted in sbuild schroots" + & "/var/cache/ccache-sbuild/sbuild-setup" `File.hasContent` + [ "#!/bin/sh" + , "" + , "export CCACHE_DIR=/var/cache/ccache-sbuild" + , "export CCACHE_UMASK=002" + , "export CCACHE_COMPRESS=1" + , "unset CCACHE_HARDLINK" + , "export PATH=\"/usr/lib/ccache:$PATH\"" + , "" + , "exec \"$@\"" + ] + & File.mode "/var/cache/ccache-sbuild/sbuild-setup" + (combineModes (readModes ++ executeModes)) + +-- This doesn't seem to work with the current version of sbuild +-- -- | Block network access during builds +-- -- +-- -- This is a hack from <https://wiki.debian.org/sbuild> until #802850 and +-- -- #802849 are resolved. +-- blockNetwork :: Property Linux +-- blockNetwork = Firewall.rule Firewall.OUTPUT Firewall.Filter Firewall.DROP +-- (Firewall.GroupOwner (Group "sbuild") +-- <> Firewall.NotDestination +-- [Firewall.IPWithNumMask (IPv4 "127.0.0.1") 8]) +-- `requires` installed -- sbuild group must exist + +-- ==== utility functions ==== + +schrootFromSystem :: System -> Maybe SbuildSchroot +schrootFromSystem system@(System _ arch) = + extractSuite system + >>= \suite -> return $ SbuildSchroot suite arch + +stdMirror :: System -> Maybe Apt.Url +stdMirror (System (Debian _) _) = Just "http://httpredir.debian.org/debian" +stdMirror (System (Buntish _) _) = Just "mirror://mirrors.ubuntu.com/" +stdMirror _ = Nothing + +schrootRoot :: SbuildSchroot -> FilePath +schrootRoot (SbuildSchroot s a) = "/srv/chroot" </> s ++ "-" ++ a + +schrootConf :: SbuildSchroot -> FilePath +schrootConf (SbuildSchroot s a) = + "/etc/schroot/chroot.d" </> s ++ "-" ++ a ++ "-sbuild-propellor" + +schrootPiupartsConf :: SbuildSchroot -> FilePath +schrootPiupartsConf (SbuildSchroot s a) = + "/etc/schroot/chroot.d" </> s ++ "-" ++ a ++ "-piuparts-propellor" diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index f2911e50..729a3749 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} + module Propellor.Property.Scheduled ( period , periodParse @@ -7,7 +9,8 @@ module Propellor.Property.Scheduled , YearDay ) where -import Propellor +import Propellor.Base +import Propellor.Types.Core import Utility.Scheduled import Data.Time.Clock @@ -18,26 +21,26 @@ import qualified Data.Map as M -- -- This uses the description of the Property to keep track of when it was -- last run. -period :: Property -> Recurrance -> Property -period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do - lasttime <- liftIO $ getLastChecked (propertyDesc prop) +period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i +period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do + lasttime <- liftIO $ getLastChecked (getDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow if Just t >= nexttime then do r <- satisfy - liftIO $ setLastChecked t (propertyDesc prop) + liftIO $ setLastChecked t (getDesc prop) return r else noChange where schedule = Schedule recurrance AnyTime - desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" + desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" -- | Like period, but parse a human-friendly string. -periodParse :: Property -> String -> Property +periodParse :: (IsProp (Property i)) => Property i -> String -> Property i periodParse prop s = case toRecurrance s of Just recurrance -> period prop recurrance - Nothing -> property "periodParse" $ do + Nothing -> adjustPropertySatisfy prop $ \_ -> do liftIO $ warningMessage $ "failed periodParse: " ++ s noChange diff --git a/src/Propellor/Property/Schroot.hs b/src/Propellor/Property/Schroot.hs new file mode 100644 index 00000000..c53ce4f1 --- /dev/null +++ b/src/Propellor/Property/Schroot.hs @@ -0,0 +1,42 @@ +-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name> + +module Propellor.Property.Schroot where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +import Utility.FileMode + +-- | Configure schroot such that all schroots with @union-type=overlay@ in their +-- configuration will run their overlays in a tmpfs. +-- +-- Shell script from <https://wiki.debian.org/sbuild>. +overlaysInTmpfs :: Property DebianLike +overlaysInTmpfs = go `requires` installed + where + f = "/etc/schroot/setup.d/04tmpfs" + go :: Property UnixLike + go = f `File.hasContent` + [ "#!/bin/sh" + , "" + , "set -e" + , "" + , ". \"$SETUP_DATA_DIR/common-data\"" + , ". \"$SETUP_DATA_DIR/common-functions\"" + , ". \"$SETUP_DATA_DIR/common-config\"" + , "" + , "" + , "if [ $STAGE = \"setup-start\" ]; then" + , " mount -t tmpfs overlay /var/lib/schroot/union/overlay" + , "elif [ $STAGE = \"setup-recover\" ]; then" + , " mount -t tmpfs overlay /var/lib/schroot/union/overlay" + , "elif [ $STAGE = \"setup-stop\" ]; then" + , " umount -f /var/lib/schroot/union/overlay" + , "fi" + ] + `onChange` (f `File.mode` (combineModes (readModes ++ executeModes))) + `describe` "schroot overlays in tmpfs" + +installed :: Property DebianLike +installed = Apt.installed ["schroot"] diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs index 14e769d0..46f9e8ef 100644 --- a/src/Propellor/Property/Service.hs +++ b/src/Propellor/Property/Service.hs @@ -1,7 +1,6 @@ module Propellor.Property.Service where -import Propellor -import Utility.SafeCommand +import Propellor.Base type ServiceName = String @@ -12,20 +11,17 @@ type ServiceName = String -- Note that due to the general poor state of init scripts, the best -- we can do is try to start the service, and if it fails, assume -- this means it's already running. -running :: ServiceName -> Property -running svc = property ("running " ++ svc) $ do - void $ ensureProperty $ - scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"] - return NoChange +running :: ServiceName -> Property DebianLike +running = signaled "start" "running" -restarted :: ServiceName -> Property -restarted svc = property ("restarted " ++ svc) $ do - void $ ensureProperty $ - scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"] - return NoChange +restarted :: ServiceName -> Property DebianLike +restarted = signaled "restart" "restarted" -reloaded :: ServiceName -> Property -reloaded svc = property ("reloaded " ++ svc) $ do - void $ ensureProperty $ - scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"] - return NoChange +reloaded :: ServiceName -> Property DebianLike +reloaded = signaled "reload" "reloaded" + +signaled :: String -> Desc -> ServiceName -> Property DebianLike +signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc) + where + p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] + `assume` NoChange diff --git a/src/Propellor/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs new file mode 100644 index 00000000..239bcbeb --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/Branchable.hs @@ -0,0 +1,68 @@ +module Propellor.Property.SiteSpecific.Branchable where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Postfix as Postfix +import qualified Propellor.Property.Gpg as Gpg +import qualified Propellor.Property.Sudo as Sudo + +server :: [Host] -> Property (HasInfo + DebianLike) +server hosts = propertyList "branchable server" $ props + & "/etc/timezone" `File.hasContent` ["Etc/UTC"] + & "/etc/locale.gen" `File.containsLines` + [ "en_GB.UTF-8 UTF-8" + , "en_US.UTF-8 UTF-8" + , "fi_FI.UTF-8 UTF-8" + ] + `onChange` (cmdProperty "locale-gen" [] `assume` MadeChange) + + & Apt.installed ["etckeeper", "ssh", "popularity-contest"] + & Apt.serviceInstalledRunning "apache2" + & Apt.serviceInstalledRunning "ntp" + + & Apt.serviceInstalledRunning "openssh-server" + & Ssh.passwordAuthentication False + & Ssh.hostKeys (Context "branchable.com") + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAK9HnfpyIm8aEhKuF5oz6KyaLwFs2oWeToVkqVuykyy5Y8jWDZPtkpv+1TeOnjcOvJSZ1cCqB8iXlsP9Dr5z98w5MfzsRQM2wIw0n+wvmpPmUhjVdGh+wTpfP9bcyFHhj/f1Ymdq9hEWB26bnf4pbTbJW2ip8ULshMvn5CQ/ugV3AAAAFQCAjpRd1fquRiIuLJMwej0VcyoZKQAAAIBe91Grvz/icL3nlqXYrifXyr9dsw8bPN+BMu+hQtFsQXNJBylxwf8FtbRlmvZXmRjdVYqFVyxSsrL2pMsWlds51iXOr9pdsPG5a4OgJyRHsveBz3tz6HgYYPcr3Oxp7C6G6wrzwsaGK862SgRp/bbD226k9dODRBy3ogMhk/MvAgAAAIEApfknql3vZbDVa88ZnwbNKDOv8L1hb6blbKAMt2vJbqJMvu3EP9CsP9hGyEQh5YCAl2F9KEU3bJXN1BG76b7CiYtWK95lpL1XmCCWnJBCcdEhw998GfJS424frPw7qGmXLxJKYxEyioB90/IDp2dC+WaLcLOYHM9SroCQTIK5A1g= root@pell") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEA1M0aNLgcgcgf0tkmt/8vCDZLok8Xixz7Nun9wB6NqVXxfzAR4te+zyO7FucVwyTY5QHmiwwpmyNfaC21AAILhXGm12SUKSAirF9BkQk7bhQuz4T/dPlEt3d3SxQ3OZlXtPp4LzXWOyS0OXSzIb+HeaDA+hFXlQnp/gE7RyAzR1+xhWPO7Mz1q5O/+4dXANnW32t6P7Puob6NsglVDpLrMRYjkO+0RgCVbYMzB5+UnkthkZsIINaYwsNhW2GKMKbRZeyp5en5t1NJprGXdw0BqdBqd/rcBpOxmhHE1U7rw+GS1uZwCFWWv0aZbaXEJ6wY7mETFkqs0QXi5jtoKn95Gw== root@pell") + ] + + & Apt.installed ["procmail", "bsd-mailx"] + & "/etc/aliases" `File.hasPrivContentExposed` (Context "branchable.com") + `onChange` Postfix.newaliases + & "/etc/mailname" `File.hasContent` ["branchable.com"] + & Postfix.installed + & Postfix.mainCf ("mailbox_command", "procmail -a \"$EXTENSION\"") + + -- Obnam is run by a cron job in ikiwiki-hosting. + & "/etc/obnam.conf" `File.hasContent` + [ "[config]" + , "repository = sftp://joey@eubackup.kitenet.net/home/joey/lib/backup/pell.obnam" + , "log = /var/log/obnam.log" + , "encrypt-with = " ++ obnamkey + , "log-level = info" + , "log-max = 1048576" + , "keep = 7d,5w,12m" + , "upload-queue-size = 128" + , "lru-size = 128" + ] + & Gpg.keyImported (Gpg.GpgKeyId obnamkey) (User "root") + & Ssh.userKeys (User "root") (Context "branchable.com") + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC2PqTSupwncqeffNwZQXacdEWp7L+TxllIxH7WjfRMb3U74mQxWI0lwqLVW6Fox430DvhSqF1y5rJBvTHh4i49Tc9lZ7mwAxA6jNOP6bmdfteaKKYmUw5qwtJW0vISBFu28qBO11Nq3uJ1D3Oj6N+b3mM/0D3Y3NoGgF8+2dLdi81u9+l6AQ5Jsnozi2Ni/Osx2oVGZa+IQDO6gX8VEP4OrcJFNJe8qdnvItcGwoivhjbIfzaqNNvswKgGzhYLOAS5KT8HsjvIpYHWkyQ5QUX7W/lqGSbjP+6B8C3tkvm8VLXbmaD+aSkyCaYbuoXC2BoJdS7Jh8phKMwPJmdYVepn") + ] + & Ssh.knownHost hosts "eubackup.kitenet.net" (User "root") + & Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + + & adminuser "joey" + & adminuser "liw" + where + obnamkey = "41E1A9B9" + adminuser u = propertyList ("admin user " ++ u) $ props + & User.accountFor (User u) + & User.hasSomePassword (User u) + & Sudo.enabledFor (User u) + & User.hasGroup (User u) (Group "adm") + & User.hasGroup (User u) (Group "systemd-journal") diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 901eba2e..b4812c7e 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.SiteSpecific.GitAnnexBuilder where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.User as User import qualified Propellor.Property.Cron as Cron -import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.File as File -import qualified Propellor.Property.Docker as Docker -import Propellor.Property.Cron (CronTimes) +import qualified Propellor.Property.Systemd as Systemd +import qualified Propellor.Property.Chroot as Chroot +import Propellor.Property.Cron (Times) builduser :: UserName builduser = "builder" @@ -23,105 +25,181 @@ builddir = gitbuilderdir </> "build" type TimeOut = String -- eg, 5h -autobuilder :: Architecture -> CronTimes -> TimeOut -> Property -autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" - [ Apt.serviceInstalledRunning "cron" - , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $ - "git pull ; timeout " ++ timeout ++ " ./autobuild" +autobuilder :: Architecture -> Times -> TimeOut -> Property (HasInfo + DebianLike) +autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props + & Apt.serviceInstalledRunning "cron" + & Cron.niceJob "gitannexbuilder" crontimes (User builduser) gitbuilderdir + ("git pull ; timeout " ++ timeout ++ " ./autobuild") + & rsyncpassword + where + context = Context ("gitannexbuilder " ++ arch) + pwfile = homedir </> "rsyncpassword" -- The builduser account does not have a password set, -- instead use the password privdata to hold the rsync server -- password used to upload the built image. - , withPrivData (Password builduser) context $ \getpw -> + rsyncpassword :: Property (HasInfo + DebianLike) + rsyncpassword = withPrivData (Password builduser) context $ \getpw -> property "rsync password" $ getpw $ \pw -> do - oldpw <- liftIO $ catchDefaultIO "" $ + have <- liftIO $ catchDefaultIO "" $ readFileStrict pwfile - if pw /= oldpw - then makeChange $ writeFile pwfile pw + let want = privDataVal pw + if want /= have + then makeChange $ writeFile pwfile want else noChange - ] - where - context = Context ("gitannexbuilder " ++ arch) - pwfile = homedir </> "rsyncpassword" -tree :: Architecture -> Property -tree buildarch = combineProperties "gitannexbuilder tree" - [ Apt.installed ["git"] - -- gitbuilderdir directory already exists when docker volume is used, - -- but with wrong owner. - , File.dirExists gitbuilderdir - , File.ownerGroup gitbuilderdir builduser builduser - , check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $ - userScriptProperty builduser +tree :: Architecture -> Flavor -> Property DebianLike +tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props + & Apt.installed ["git"] + & File.dirExists gitbuilderdir + & File.ownerGroup gitbuilderdir (User builduser) (Group builduser) + & gitannexbuildercloned + & builddircloned + where + gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $ + userScriptProperty (User builduser) [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir , "cd " ++ gitbuilderdir - , "git checkout " ++ buildarch + , "git checkout " ++ buildarch ++ fromMaybe "" flavor ] + `assume` MadeChange `describe` "gitbuilder setup" - , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser + builddircloned = check (not <$> doesDirectoryExist builddir) $ userScriptProperty (User builduser) [ "git clone git://git-annex.branchable.com/ " ++ builddir ] - ] -buildDepsApt :: Property -buildDepsApt = combineProperties "gitannexbuilder build deps" - [ Apt.buildDep ["git-annex"] - , Apt.installed ["liblockfile-simple-perl"] - , buildDepsNoHaskellLibs - , "git-annex source build deps installed" ==> Apt.buildDepIn builddir - ] +buildDepsApt :: Property DebianLike +buildDepsApt = combineProperties "gitannexbuilder build deps" $ props + & Apt.buildDep ["git-annex"] + & buildDepsNoHaskellLibs + & Apt.buildDepIn builddir + `describe` "git-annex source build deps installed" -buildDepsNoHaskellLibs :: Property +buildDepsNoHaskellLibs :: Property DebianLike buildDepsNoHaskellLibs = Apt.installed ["git", "rsync", "moreutils", "ca-certificates", "debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt", "liblockfile-simple-perl", "cabal-install", "vim", "less", -- needed by haskell libs - "libxml2-dev", "libidn11-dev", "libgsasl7-dev", "libgnutls-dev", - "alex", "happy", "c2hs" + "libxml2-dev", "libidn11-dev", "libgsasl7-dev", "libgnutls28-dev", + "libmagic-dev", "alex", "happy", "c2hs" ] +haskellPkgsInstalled :: String -> Property DebianLike +haskellPkgsInstalled dir = tightenTargets $ + flagFile go ("/haskellpkgsinstalled") + where + go = userScriptProperty (User builduser) + [ "cd " ++ builddir ++ " && ./standalone/" ++ dir ++ "/install-haskell-packages" + ] + `assume` MadeChange + -- Installs current versions of git-annex's deps from cabal, but only -- does so once. -cabalDeps :: Property +cabalDeps :: Property UnixLike cabalDeps = flagFile go cabalupdated where - go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"] + go = userScriptProperty (User builduser) + ["cabal update && cabal install git-annex --only-dependencies || true"] + `assume` MadeChange cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache" -standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host -standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder") - (dockerImage $ System (Debian Testing) arch) - & os (System (Debian Testing) arch) - & Apt.stdSourcesList - & Apt.installed ["systemd"] - & Apt.unattendedUpgrades - & User.accountFor builduser - & tree arch - & buildDepsApt - & autobuilder arch (show buildminute ++ " * * * *") timeout - & Docker.tweaked - -androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host -androidAutoBuilderContainer dockerImage crontimes timeout = - androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir +autoBuilderContainer :: (DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)) -> DebianSuite -> Architecture -> Flavor -> Times -> TimeOut -> Systemd.Container +autoBuilderContainer mkprop suite arch flavor crontime timeout = + Systemd.container name $ \d -> Chroot.debootstrapped mempty d $ props + & mkprop suite arch flavor + & autobuilder arch crontime timeout + where + name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder" + +type Flavor = Maybe String + +standardAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian) +standardAutoBuilder suite arch flavor = + propertyList "standard git-annex autobuilder" $ props + & osDebian suite arch + & buildDepsApt + & Apt.stdSourcesList & Apt.unattendedUpgrades - & autobuilder "android" crontimes timeout + & Apt.cacheCleaned + & User.accountFor (User builduser) + & tree arch flavor + +stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian) +stackAutoBuilder suite arch flavor = + propertyList "git-annex autobuilder using stack" $ props + & osDebian suite arch + & buildDepsNoHaskellLibs + & Apt.stdSourcesList + & Apt.unattendedUpgrades + & Apt.cacheCleaned + & User.accountFor (User builduser) + & tree arch flavor + & stackInstalled + -- Workaround https://github.com/commercialhaskell/stack/issues/2093 + & Apt.installed ["libtinfo-dev"] + +stackInstalled :: Property Linux +stackInstalled = withOS "stack installed" $ \w o -> + case o of + (Just (System (Debian (Stable "jessie")) "i386")) -> + ensureProperty w $ manualinstall "i386" + _ -> ensureProperty w $ Apt.installed ["haskell-stack"] + where + -- Warning: Using a binary downloaded w/o validation. + manualinstall :: Architecture -> Property Linux + manualinstall arch = tightenTargets $ check (not <$> doesFileExist binstack) $ + propertyList "stack installed from upstream tarball" $ props + & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar] + `assume` MadeChange + & File.dirExists tmpdir + & cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"] + `assume` MadeChange + & cmdProperty "mv" [tmpdir </> "stack", binstack] + `assume` MadeChange + & cmdProperty "rm" ["-rf", tmpdir, tmptar] + `assume` MadeChange + binstack = "/usr/bin/stack" + tmptar = "/root/stack.tar.gz" + tmpdir = "/root/stack" + +armAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian) +armAutoBuilder suite arch flavor = + propertyList "arm git-annex autobuilder" $ props + & standardAutoBuilder suite arch flavor + & buildDepsNoHaskellLibs + -- Works around ghc crash with parallel builds on arm. + & (homedir </> ".cabal" </> "config") + `File.lacksLine` "jobs: $ncpus" + -- Install patched haskell packages for portability to + -- arm NAS's using old kernel versions. + & haskellPkgsInstalled "linux" + +androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container +androidAutoBuilderContainer crontimes timeout = + androidAutoBuilderContainer' "android-git-annex-builder" + (tree "android" Nothing) builddir crontimes timeout -- Android is cross-built in a Debian i386 container, using the Android NDK. -androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host -androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name - (dockerImage osver) - & os osver - & Apt.stdSourcesList - & Apt.installed ["systemd"] - & Docker.tweaked - & User.accountFor builduser - & File.dirExists gitbuilderdir - & File.ownerGroup homedir builduser builduser - & buildDepsApt - & flagFile chrootsetup ("/chrootsetup") - `requires` setupgitannexdir - & flagFile haskellpkgsinstalled ("/haskellpkgsinstalled") +androidAutoBuilderContainer' + :: Systemd.MachineName + -> Property DebianLike + -> FilePath + -> Times + -> TimeOut + -> Systemd.Container +androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout = + Systemd.container name $ \d -> bootstrap d $ props + & osDebian (Stable "jessie") "i386" + & Apt.stdSourcesList + & User.accountFor (User builduser) + & File.dirExists gitbuilderdir + & File.ownerGroup homedir (User builduser) (Group builduser) + & flagFile chrootsetup ("/chrootsetup") + `requires` setupgitannexdir + & haskellPkgsInstalled "android" + & Apt.unattendedUpgrades + & buildDepsNoHaskellLibs + & autobuilder "android" crontimes timeout where -- Use git-annex's android chroot setup script, which will install -- ghc-android and the NDK, all build deps, etc, in the home @@ -129,54 +207,5 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe chrootsetup = scriptProperty [ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot" ] - haskellpkgsinstalled = userScriptProperty "builder" - [ "cd " ++ gitannexdir ++ " && ./standalone/android/install-haskell-packages" - ] - osver = System (Debian Testing) "i386" -- once jessie is released, use: (Stable "jessie") - --- armel builder has a companion container using amd64 that --- runs the build first to get TH splices. They need --- to have the same versions of all haskell libraries installed. -armelCompanionContainer :: (System -> Docker.Image) -> Host -armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion" - (dockerImage $ System (Debian Unstable) "amd64") - & os (System (Debian Testing) "amd64") - & Apt.stdSourcesList - & Apt.installed ["systemd"] - -- This volume is shared with the armel builder. - & Docker.volume gitbuilderdir - & User.accountFor builduser - -- Install current versions of build deps from cabal. - & tree "armel" - & buildDepsNoHaskellLibs - & cabalDeps - -- The armel builder can ssh to this companion. - & Docker.expose "22" - & Apt.serviceInstalledRunning "ssh" - & Ssh.authorizedKeys builduser (Context "armel-git-annex-builder") - & Docker.tweaked - -armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host -armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder" - (dockerImage $ System (Debian Unstable) "armel") - & os (System (Debian Testing) "armel") - & Apt.stdSourcesList - & Apt.installed ["systemd"] - & Apt.installed ["openssh-client"] - & Docker.link "armel-git-annex-builder-companion" "companion" - & Docker.volumes_from "armel-git-annex-builder-companion" - & User.accountFor builduser - -- TODO: automate installing haskell libs - -- (Currently have to run - -- git-annex/standalone/linux/install-haskell-packages - -- which is not fully automated.) - & buildDepsNoHaskellLibs - & autobuilder "armel" crontimes timeout - `requires` tree "armel" - & Ssh.keyImported SshRsa builduser (Context "armel-git-annex-builder") - & trivial writecompanionaddress - & Docker.tweaked - where - writecompanionaddress = scriptProperty - [ "echo \"$COMPANION_PORT_22_TCP_ADDR\" > " ++ homedir </> "companion_address" - ] `describe` "companion_address file" + `assume` MadeChange + bootstrap = Chroot.debootstrapped mempty diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs index 6ed02146..f14b5f12 100644 --- a/src/Propellor/Property/SiteSpecific/GitHome.hs +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -1,25 +1,27 @@ module Propellor.Property.SiteSpecific.GitHome where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import Propellor.Property.User -import Utility.SafeCommand -- | Clones Joey Hess's git home directory, and runs its fixups script. -installedFor :: UserName -> Property -installedFor user = check (not <$> hasGitDir user) $ - property ("githome " ++ user) (go =<< liftIO (homedir user)) - `requires` Apt.installed ["git"] +installedFor :: User -> Property DebianLike +installedFor user@(User u) = check (not <$> hasGitDir user) $ + go `requires` Apt.installed ["git"] where - go home = do + go :: Property DebianLike + go = property' ("githome " ++ u) $ \w -> do + home <- liftIO (homedir user) let tmpdir = home </> "githome" - ensureProperty $ combineProperties "githome setup" + ensureProperty w $ combineProperties "githome setup" $ toProps [ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir] + `assume` MadeChange , property "moveout" $ makeChange $ void $ moveout tmpdir home , property "rmdir" $ makeChange $ void $ catchMaybeIO $ removeDirectory tmpdir , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"] + `assume` MadeChange ] moveout tmpdir home = do fs <- dirContents tmpdir @@ -28,7 +30,7 @@ installedFor user = check (not <$> hasGitDir user) $ url :: String url = "git://git.kitenet.net/joey/home" -hasGitDir :: UserName -> IO Bool +hasGitDir :: User -> IO Bool hasGitDir user = go =<< homedir user where go home = doesDirectoryExist (home </> ".git") diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs new file mode 100644 index 00000000..b245e444 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/IABak.hs @@ -0,0 +1,121 @@ +module Propellor.Property.SiteSpecific.IABak where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Git as Git +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apache as Apache +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Ssh as Ssh + +repo :: String +repo = "https://github.com/ArchiveTeam/IA.BAK/" + +userrepo :: String +userrepo = "git@gitlab.com:archiveteam/IA.bak.users.git" + +publicFace :: Property DebianLike +publicFace = propertyList "iabak public face" $ props + & Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server") + & Apt.serviceInstalledRunning "apache2" + & Cron.niceJob "graph-gen" (Cron.Times "*/10 * * * *") (User "root") "/" + "/usr/local/IA.BAK/web/graph-gen.sh" + +gitServer :: [Host] -> Property (HasInfo + DebianLike) +gitServer knownhosts = propertyList "iabak git server" $ props + & Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server") + & Git.cloned (User "root") repo "/usr/local/IA.BAK/client" (Just "master") + & Ssh.userKeys (User "root") (Context "IA.bak.users.git") sshKeys + & Ssh.knownHost knownhosts "gitlab.com" (User "root") + & Git.cloned (User "root") userrepo "/usr/local/IA.BAK/pubkeys" (Just "master") + & Apt.serviceInstalledRunning "apache2" + & "/usr/lib/cgi-bin/pushme.cgi" `File.isSymlinkedTo` File.LinkTarget "/usr/local/IA.BAK/pushme.cgi" + & File.containsLine "/etc/sudoers" "www-data ALL=NOPASSWD:/usr/local/IA.BAK/pushed.sh" + & Cron.niceJob "shardstats" (Cron.Times "*/30 * * * *") (User "root") "/" + "/usr/local/IA.BAK/shardstats-all" + & Cron.niceJob "shardmaint" Cron.Daily (User "root") "/" + "/usr/local/IA.BAK/shardmaint-fast; /usr/local/IA.BAK/shardmaint" + & Apt.installed ["git-annex"] + & Apt.installed ["libmail-sendmail-perl"] + & Cron.niceJob "expireemailer" Cron.Daily (User "root") + "/usr/local/IA.BAK" + "./expireemailer" + +registrationServer :: [Host] -> Property (HasInfo + DebianLike) +registrationServer knownhosts = propertyList "iabak registration server" $ props + & User.accountFor (User "registrar") + & Ssh.userKeys (User "registrar") (Context "IA.bak.users.git") sshKeys + & Ssh.knownHost knownhosts "gitlab.com" (User "registrar") + & Git.cloned (User "registrar") repo "/home/registrar/IA.BAK" (Just "server") + & Git.cloned (User "registrar") userrepo "/home/registrar/users" (Just "master") + & Apt.serviceInstalledRunning "apache2" + & Apt.installed ["perl", "perl-modules"] + & link `File.isSymlinkedTo` File.LinkTarget "/home/registrar/IA.BAK/registrar/register.cgi" + & cmdProperty "chown" ["-h", "registrar:registrar", link] + `changesFile` link + & File.containsLine "/etc/sudoers" "www-data ALL=(registrar) NOPASSWD:/home/registrar/IA.BAK/registrar/register.pl" + & Apt.installed ["kgb-client"] + & File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext + `requires` File.dirExists "/etc/kgb-bot/" + where + link = "/usr/lib/cgi-bin/register.cgi" + +sshKeys :: [(SshKeyType, Ssh.PubKeyText)] +sshKeys = + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCoiE+CPiIQyfWnl/E9iKG3eo4QzlH30vi7xAgKolGaTu6qKy4XPtl+8MNm2Dqn9QEYRVyyOT/XH0yP5dRc6uyReT8dBy03MmLkVbj8Q+nKCz5YOMTxrY3sX6RRXU1zVGjeVd0DtC+rKRT7reoCxef42LAJTm8nCyZu/enAuso5qHqBbqulFz2YXEKfU1SEEXLawtvgGck1KmCyg+pqazeI1eHWXrojQf5isTBKfPQLWVppBkWAf5cA4wP5U1vN9dVirIdw66ds1M8vnGlkTBjxP/HLGBWGYhZHE7QXjXRsk2RIXlHN9q6GdNu8+F3HXS22mst47E4UAeRoiXSMMtF5") + ] + +graphiteServer :: Property (HasInfo + DebianLike) +graphiteServer = propertyList "iabak graphite server" $ props + & Apt.serviceInstalledRunning "apache2" + & Apt.installed ["libapache2-mod-wsgi", "graphite-carbon", "graphite-web"] + & File.hasContent "/etc/carbon/storage-schemas.conf" + [ "[carbon]" + , "pattern = ^carbon\\." + , "retentions = 60:90d" + , "[iabak-connections]" + , "pattern = ^iabak\\.shardstats\\.connections" + , "retentions = 1h:1y,3h:10y" + , "[iabak-default]" + , "pattern = ^iabak\\." + , "retentions = 10m:30d,1h:1y,3h:10y" + , "[default_1min_for_1day]" + , "pattern = .*" + , "retentions = 60s:1d" + ] + & graphiteCSRF + & cmdProperty "graphite-manage" ["syncdb", "--noinput"] + `assume` MadeChange + `flagFile` "/etc/flagFiles/graphite-syncdb" + & cmdProperty "graphite-manage" ["createsuperuser", "--noinput", "--username=joey", "--email=joey@localhost"] + `assume` MadeChange + `flagFile` "/etc/flagFiles/graphite-user-joey" + & cmdProperty "graphite-manage" ["createsuperuser", "--noinput", "--username=db48x", "--email=db48x@localhost"] + `assume` MadeChange + `flagFile` "/etc/flagFiles/graphite-user-db48x" + -- TODO: deal with passwords somehow + & File.ownerGroup "/var/lib/graphite/graphite.db" (User "_graphite") (Group "_graphite") + & "/etc/apache2/ports.conf" `File.containsLine` "Listen 8080" + `onChange` Apache.restarted + & Apache.siteEnabled "iabak-graphite-web" + [ "<VirtualHost *:8080>" + , " WSGIDaemonProcess _graphite processes=5 threads=5 display-name='%{GROUP}' inactivity-timeout=120 user=_graphite group=_graphite" + , " WSGIProcessGroup _graphite" + , " WSGIImportScript /usr/share/graphite-web/graphite.wsgi process-group=_graphite application-group=%{GLOBAL}" + , " WSGIScriptAlias / /usr/share/graphite-web/graphite.wsgi" + , " Alias /content/ /usr/share/graphite-web/static/" + , " <Location \"/content/\">" + , " SetHandler None" + , " </Location>" + , " ErrorLog ${APACHE_LOG_DIR}/graphite-web_error.log" + , " LogLevel warn" + , " CustomLog ${APACHE_LOG_DIR}/graphite-web_access.log combined" + , "</VirtualHost>" + ] + where + graphiteCSRF :: Property (HasInfo + DebianLike) + graphiteCSRF = withPrivData (Password "csrf-token") (Context "iabak.archiveteam.org") $ + \gettoken -> property' "graphite-web CSRF token" $ \w -> + gettoken $ \token -> ensureProperty w $ File.containsLine + "/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ privDataVal token ++"'") diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index bd9e01e2..a6cb3794 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -1,11 +1,14 @@ --- | Specific configuation for Joey Hess's sites. Probably not useful to +-- | Specific configuration for Joey Hess's sites. Probably not useful to -- others except as an example. +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + module Propellor.Property.SiteSpecific.JoeySites where -import Propellor +import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File +import qualified Propellor.Property.ConfFile as ConfFile import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Git as Git @@ -15,30 +18,92 @@ import qualified Propellor.Property.User as User import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix -import Utility.SafeCommand +import qualified Propellor.Property.Systemd as Systemd +import qualified Propellor.Property.Fail2Ban as Fail2Ban +import qualified Propellor.Property.LetsEncrypt as LetsEncrypt import Utility.FileMode -import Utility.Path import Data.List import System.Posix.Files import Data.String.Utils -oldUseNetServer :: [Host] -> Property -oldUseNetServer hosts = propertyList ("olduse.net server") - [ oldUseNetInstalled "oldusenet-server" - , Obnam.latestVersion - , Obnam.backup datadir "33 4 * * *" - [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" - , "--client-name=spool" - ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net") - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" - , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $ - property "olduse.net spool in place" $ makeChange $ do - removeDirectoryRecursive newsspool - createSymbolicLink (datadir </> "news") newsspool - , Apt.installed ["leafnode"] - , "/etc/news/leafnode/config" `File.hasContent` +scrollBox :: Property (HasInfo + DebianLike) +scrollBox = propertyList "scroll server" $ props + & User.accountFor (User "scroll") + & Git.cloned (User "scroll") "git://git.kitenet.net/scroll" (d </> "scroll") Nothing + & Apt.installed ["ghc", "make", "cabal-install", "libghc-vector-dev", + "libghc-bytestring-dev", "libghc-mtl-dev", "libghc-ncurses-dev", + "libghc-random-dev", "libghc-monad-loops-dev", "libghc-text-dev", + "libghc-ifelse-dev", "libghc-case-insensitive-dev", + "libghc-data-default-dev", "libghc-optparse-applicative-dev"] + & userScriptProperty (User "scroll") + [ "cd " ++ d </> "scroll" + , "git pull" + , "cabal configure" + , "make" + ] + `assume` MadeChange + & s `File.hasContent` + [ "#!/bin/sh" + , "set -e" + , "echo Preparing to run scroll!" + , "cd " ++ d + , "mkdir -p tmp" + , "TMPDIR= t=$(tempfile -d tmp)" + , "export t" + , "rm -f \"$t\"" + , "mkdir \"$t\"" + , "cd \"$t\"" + , "echo" + , "echo Note that games on this server are time-limited to 2 hours" + , "echo 'Need more time? Run scroll locally instead!'" + , "echo" + , "echo Press Enter to start the game." + , "read me" + , "SHELL=/bin/sh script --timing=timing -c " ++ g + ] `onChange` (s `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) + & g `File.hasContent` + [ "#!/bin/sh" + , "if ! timeout --kill-after 1m --foreground 2h ../../scroll/scroll; then" + , "echo Scroll seems to have ended unexpectedly. Possibly a bug.." + , "else" + , "echo Thanks for playing scroll! https://joeyh.name/code/scroll/" + , "fi" + , "echo Your game was recorded, as ID:$(basename \"$t\")" + , "echo if you would like to talk about how it went, email scroll@joeyh.name" + , "echo 'or, type comments below (finish with a dot on its own line)'" + , "echo" + , "echo Your comments:" + , "timeout --kill-after 1m --foreground 2h mail -E -s \"scroll test $t\" joey@kitenet.net" + ] `onChange` (g `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) + & Apt.installed ["bsd-mailx"] + -- prevent port forwarding etc by not letting scroll log in via ssh + & Ssh.sshdConfig `File.containsLine` ("DenyUsers scroll") + `onChange` Ssh.restarted + & User.shellSetTo (User "scroll") s + & User.hasPassword (User "scroll") + & Apt.serviceInstalledRunning "telnetd" + & Apt.installed ["shellinabox"] + & File.hasContent "/etc/default/shellinabox" + [ "# Deployed by propellor" + , "SHELLINABOX_DAEMON_START=1" + , "SHELLINABOX_PORT=4242" + , "SHELLINABOX_ARGS=\"--disable-ssl --no-beep --service=:scroll:scroll:" ++ d ++ ":" ++ s ++ "\"" + ] + `onChange` Service.restarted "shellinabox" + & Service.running "shellinabox" + where + d = "/home/scroll" + s = d </> "login.sh" + g = d </> "game.sh" + +oldUseNetServer :: [Host] -> Property (HasInfo + DebianLike) +oldUseNetServer hosts = propertyList "olduse.net server" $ props + & Apt.installed ["leafnode"] + & oldUseNetInstalled "oldusenet-server" + & oldUseNetBackup + & spoolsymlink + & "/etc/news/leafnode/config" `File.hasContent` [ "# olduse.net configuration (deployed by propellor)" , "expire = 1000000" -- no expiry via texpire , "server = " -- no upstream server @@ -46,17 +111,22 @@ oldUseNetServer hosts = propertyList ("olduse.net server") , "allowSTRANGERS = 42" -- lets anyone connect , "nopost = 1" -- no new posting (just gather them) ] - , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" - , Apt.serviceInstalledRunning "openbsd-inetd" - , File.notPresent "/etc/cron.daily/leafnode" - , File.notPresent "/etc/cron.d/leafnode" - , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";" + & "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" + & Apt.serviceInstalledRunning "openbsd-inetd" + & File.notPresent "/etc/cron.daily/leafnode" + & File.notPresent "/etc/cron.d/leafnode" + & Cron.niceJob "oldusenet-expire" (Cron.Times "11 1 * * *") (User "news") newsspool expirecommand + & Cron.niceJob "oldusenet-uucp" (Cron.Times "*/5 * * * *") (User "news") "/" uucpcommand + & Apache.siteEnabled "nntp.olduse.net" nntpcfg + where + newsspool = "/var/spool/news" + datadir = "/var/spool/oldusenet" + expirecommand = intercalate ";" [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm" , "find -type d -empty | xargs --no-run-if-empty rmdir" ] - , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $ - "/usr/bin/uucp " ++ datadir - , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False + uucpcommand = "/usr/bin/uucp " ++ datadir + nntpcfg = apachecfg "nntp.olduse.net" [ " DocumentRoot " ++ datadir ++ "/" , " <Directory " ++ datadir ++ "/>" , " Options Indexes FollowSymlinks" @@ -64,23 +134,39 @@ oldUseNetServer hosts = propertyList ("olduse.net server") , Apache.allowAll , " </Directory>" ] - ] - where - newsspool = "/var/spool/news" - datadir = "/var/spool/oldusenet" - -oldUseNetShellBox :: Property -oldUseNetShellBox = propertyList "olduse.net shellbox" - [ oldUseNetInstalled "oldusenet" - , Service.running "shellinabox" - ] + + spoolsymlink :: Property UnixLike + spoolsymlink = check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) + (property "olduse.net spool in place" $ makeChange $ do + removeDirectoryRecursive newsspool + createSymbolicLink (datadir </> "news") newsspool + ) -oldUseNetInstalled :: Apt.Package -> Property + oldUseNetBackup :: Property (HasInfo + DebianLike) + oldUseNetBackup = Obnam.backup datadir (Cron.Times "33 4 * * *") + [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" + , "--client-name=spool" + , "--ssh-key=" ++ keyfile + , Obnam.keepParam [Obnam.KeepDays 30] + ] Obnam.OnlyClient + `requires` Ssh.userKeyAt (Just keyfile) + (User "root") + (Context "olduse.net") + (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQD0F6L76SChMCIGmeyGhlFMUTgZ3BoTbATiOSs0A7KXQoI1LTE5ZtDzzUkrQRJVpJ640pfMR7cQZyBm8tv+kYIPp0238GrX43c1vgm0L78agDnBU7r2iNMyWIwhssK8O3ZAhp8Q4KCz1r8hP2nIiD0y1D1VWW8h4KWOS7I1XCEAjOTvFvEjTh6a9MyHrcIkv7teUUzTBRjNrsyijCFRk1+pEET54RueoOmEjQcWd/sK1tYRiMZjegRLBOus2wUWsUOvznJ2iniLONUTGAWRnEV+O7hLN6CD44osJ+wkZk8bPAumTS0zcSLckX1jpdHJicmAyeniWSd4FCqm1YE6/xDD") + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + keyfile = "/root/.ssh/olduse.net.key" + +oldUseNetShellBox :: Property DebianLike +oldUseNetShellBox = propertyList "olduse.net shellbox" $ props + & oldUseNetInstalled "oldusenet" + & Service.running "shellinabox" + +oldUseNetInstalled :: Apt.Package -> Property DebianLike oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ - propertyList ("olduse.net " ++ pkg) - [ 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") + propertyList ("olduse.net " ++ pkg) $ props + & 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 + & scriptProperty [ "rm -rf /root/tmp/oldusenet" -- idenpotency , "git clone git://olduse.net/ /root/tmp/oldusenet/source" , "cd /root/tmp/oldusenet/source/" @@ -88,78 +174,70 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ , "dpkg -i ../" ++ pkg ++ "_*.deb || true" , "apt-get -fy install" -- dependencies , "rm -rf /root/tmp/oldusenet" - -- screen fails unless the directory has this mode. - -- not sure what's going on. - , "chmod 777 /var/run/screen" - ] `describe` "olduse.net built" - ] - - -kgbServer :: Property -kgbServer = propertyList desc - [ withOS desc $ \o -> case o of + ] + `assume` MadeChange + `describe` "olduse.net built" + +kgbServer :: Property (HasInfo + Debian) +kgbServer = propertyList desc $ props + & installed + & File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext + `onChange` Service.restarted "kgb-bot" + where + desc = "kgb.kitenet.net setup" + installed :: Property Debian + installed = withOS desc $ \w o -> case o of (Just (System (Debian Unstable) _)) -> - ensureProperty $ propertyList desc - [ Apt.serviceInstalledRunning "kgb-bot" - , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1" + ensureProperty w $ propertyList desc $ props + & Apt.serviceInstalledRunning "kgb-bot" + & "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1" `describe` "kgb bot enabled" `onChange` Service.running "kgb-bot" - ] _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" - , File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext - `onChange` Service.restarted "kgb-bot" - ] - where - desc = "kgb.kitenet.net setup" -mumbleServer :: [Host] -> Property -mumbleServer hosts = combineProperties hn - [ Apt.serviceInstalledRunning "mumble-server" - , Obnam.latestVersion - , Obnam.backup "/var/lib/mumble-server" "55 5 * * *" - [ "--repository=sftp://joey@usbackup.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam" +mumbleServer :: [Host] -> Property (HasInfo + DebianLike) +mumbleServer hosts = combineProperties hn $ props + & Apt.serviceInstalledRunning "mumble-server" + & Obnam.backup "/var/lib/mumble-server" (Cron.Times "55 5 * * *") + [ "--repository=sftp://2318@usw-s002.rsync.net/~/" ++ hn ++ ".obnam" + , "--ssh-key=" ++ sshkey , "--client-name=mumble" + , Obnam.keepParam [Obnam.KeepDays 30] ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa "root" (Context hn) - `requires` Ssh.knownHost hosts "usbackup.kitenet.net" "root" - , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] - ] + `requires` Ssh.userKeyAt (Just sshkey) + (User "root") + (Context hn) + (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDSXXSM3mM8SNu+qel9R/LkDIkjpV3bfpUtRtYv2PTNqicHP+DdoThrr0ColFCtLH+k2vQJvR2n8uMzHn53Dq2IO3TtD27+7rJSsJwAZ8oftNzuTir8IjAwX5g6JYJs+L0Ny4RB0ausd+An0k/CPMRl79zKxpZd2MBMDNXt8hyqu0vS0v1ohq5VBEVhBBvRvmNQvWOCj7PdrKQXpUBHruZOeVVEdUUXZkVc1H0t7LVfJnE+nGKyWbw2jM+7r3Rn5Semc4R1DxsfaF8lKkZyE88/5uZQ/ddomv8ptz6YZ5b+Bg6wfooWPC3RWAALjxnHaC2yN1VONAvHmT0uNn1o6v0b") + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + & cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] + `assume` NoChange where hn = "mumble.debian.net" - -obnamLowMem :: Property -obnamLowMem = combineProperties "obnam tuned for low memory use" - [ Obnam.latestVersion - , "/etc/obnam.conf" `File.containsLines` - [ "[config]" - , "# Suggested by liw to keep Obnam memory consumption down (at some speed cost)." - , "upload-queue-size = 128" - , "lru-size = 128" - ] - ] + sshkey = "/root/.ssh/mumble.debian.net.key" -- git.kitenet.net and git.joeyh.name -gitServer :: [Host] -> Property -gitServer hosts = propertyList "git.kitenet.net setup" - [ Obnam.latestVersion - , Obnam.backup "/srv/git" "33 3 * * *" +gitServer :: [Host] -> Property (HasInfo + DebianLike) +gitServer hosts = propertyList "git.kitenet.net setup" $ props + & Obnam.backupEncrypted "/srv/git" (Cron.Times "33 3 * * *") [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" - , "--encrypt-with=1B169BE1" + , "--ssh-key=" ++ sshkey , "--client-name=wren" -- historical - ] Obnam.OnlyClient - `requires` Gpg.keyImported "1B169BE1" "root" - `requires` Ssh.keyImported SshRsa "root" (Context "git.kitenet.net") - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" - `requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net") - `requires` User.accountFor "family" - , Apt.installed ["git", "rsync", "gitweb"] - -- backport avoids channel flooding on branch merge - , Apt.installedBackport ["kgb-client"] - -- backport supports ssh event notification - , Apt.installedBackport ["git-annex"] - , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext - , toProp $ Git.daemonRunning "/srv/git" - , "/etc/gitweb.conf" `File.containsLines` + , Obnam.keepParam [Obnam.KeepDays 30] + ] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1") + `requires` Ssh.userKeyAt (Just sshkey) + (User "root") + (Context "git.kitenet.net") + (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQD0F6L76SChMCIGmeyGhlFMUTgZ3BoTbATiOSs0A7KXQoI1LTE5ZtDzzUkrQRJVpJ640pfMR7cQZyBm8tv+kYIPp0238GrX43c1vgm0L78agDnBU7r2iNMyWIwhssK8O3ZAhp8Q4KCz1r8hP2nIiD0y1D1VWW8h4KWOS7I1XCEAjOTvFvEjTh6a9MyHrcIkv7teUUzTBRjNrsyijCFRk1+pEET54RueoOmEjQcWd/sK1tYRiMZjegRLBOus2wUWsUOvznJ2iniLONUTGAWRnEV+O7hLN6CD44osJ+wkZk8bPAumTS0zcSLckX1jpdHJicmAyeniWSd4FCqm1YE6/xDD") + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + `requires` Ssh.authorizedKeys (User "family") (Context "git.kitenet.net") + `requires` User.accountFor (User "family") + & Apt.installed ["git", "rsync", "gitweb"] + & Apt.installed ["git-annex"] + & Apt.installed ["kgb-client"] + & File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext + `requires` File.dirExists "/etc/kgb-bot/" + & Git.daemonRunning "/srv/git" + & "/etc/gitweb.conf" `File.containsLines` [ "$projectroot = '/srv/git';" , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');" , "# disable snapshot download; overloads server" @@ -167,21 +245,22 @@ gitServer hosts = propertyList "git.kitenet.net setup" ] `describe` "gitweb configured" -- Repos push on to github. - , Ssh.knownHost hosts "github.com" "joey" + & Ssh.knownHost hosts "github.com" (User "joey") -- I keep the website used for gitweb checked into git.. - , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing - , website "git.kitenet.net" - , website "git.joeyh.name" - , toProp $ Apache.modEnabled "cgi" - ] + & Git.cloned (User "root") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing + & website "git.kitenet.net" + & website "git.joeyh.name" + & Apache.modEnabled "cgi" where - website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True - [ " DocumentRoot /srv/web/git.kitenet.net/" + sshkey = "/root/.ssh/git.kitenet.net.key" + website hn = Apache.httpsVirtualHost' hn "/srv/web/git.kitenet.net/" letos + [ Apache.iconDir , " <Directory /srv/web/git.kitenet.net/>" , " Options Indexes ExecCGI FollowSymlinks" , " AllowOverride None" , " AddHandler cgi-script .cgi" , " DirectoryIndex index.cgi" + , Apache.allowAll , " </Directory>" , "" , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/" @@ -194,214 +273,238 @@ gitServer hosts = propertyList "git.kitenet.net setup" type AnnexUUID = String -- | A website, with files coming from a git-annex repository. -annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property -annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") - [ Git.cloned "joey" origin dir Nothing +annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property (HasInfo + DebianLike) +annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props + & Git.cloned (User "joey") origin dir Nothing `onChange` setup - , postupdatehook `File.hasContent` + & alias hn + & postupdatehook `File.hasContent` [ "#!/bin/sh" , "exec git update-server-info" ] `onChange` (postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) - , setupapache - ] + & setupapache where dir = "/srv/web/" ++ hn postupdatehook = dir </> ".git/hooks/post-update" - setup = userScriptProperty "joey" setupscript + setup = userScriptProperty (User "joey") setupscript + `assume` MadeChange setupscript = [ "cd " ++ shellEscape dir - , "git config annex.uuid " ++ shellEscape uuid + , "git annex reinit " ++ shellEscape uuid ] ++ map addremote remotes ++ [ "git annex get" + , "git update-server-info" ] addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url - setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ + setupapache = Apache.httpsVirtualHost' hn dir letos [ " ServerAlias www."++hn - , "" - , " DocumentRoot /srv/web/"++hn - , " <Directory /srv/web/"++hn++">" - , " Options FollowSymLinks" - , " AllowOverride None" - , " </Directory>" - , " <Directory /srv/web/"++hn++">" + , Apache.iconDir + , " <Directory "++dir++">" , " Options Indexes FollowSymLinks ExecCGI" , " AllowOverride None" , " AddHandler cgi-script .cgi" , " DirectoryIndex index.html index.cgi" - , " Order allow,deny" - , " allow from all" + , Apache.allowAll , " </Directory>" ] -apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile -apachecfg hn withssl middle - | withssl = vhost False ++ vhost True - | otherwise = vhost False - where - vhost ssl = - [ "<VirtualHost *:"++show port++">" - , " ServerAdmin grue@joeyh.name" - , " ServerName "++hn++":"++show port - ] - ++ mainhttpscert ssl - ++ middle ++ - [ "" - , " ErrorLog /var/log/apache2/error.log" - , " LogLevel warn" - , " CustomLog /var/log/apache2/access.log combined" - , " ServerSignature On" - , " " - , " <Directory \"/usr/share/apache2/icons\">" - , " Options Indexes MultiViews" - , " AllowOverride None" - , " Order allow,deny" - , " Allow from all" - , " </Directory>" - , "</VirtualHost>" - ] - where - port = if ssl then 443 else 80 :: Int - -mainhttpscert :: Bool -> Apache.ConfigFile -mainhttpscert False = [] -mainhttpscert True = - [ " SSLEngine on" - , " SSLCertificateFile /etc/ssl/certs/web.pem" - , " SSLCertificateKeyFile /etc/ssl/private/web.pem" - , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" +letos :: LetsEncrypt.AgreeTOS +letos = LetsEncrypt.AgreeTOS (Just "id@joeyh.name") + +apacheSite :: HostName -> Apache.ConfigFile -> RevertableProperty DebianLike DebianLike +apacheSite hn middle = Apache.siteEnabled hn $ apachecfg hn middle + +apachecfg :: HostName -> Apache.ConfigFile -> Apache.ConfigFile +apachecfg hn middle = + [ "<VirtualHost *:"++show port++">" + , " ServerAdmin grue@joeyh.name" + , " ServerName "++hn++":"++show port ] + ++ middle ++ + [ "" + , " ErrorLog /var/log/apache2/error.log" + , " LogLevel warn" + , " CustomLog /var/log/apache2/access.log combined" + , " ServerSignature On" + , " " + , Apache.iconDir + , "</VirtualHost>" + ] + where + port = 80 :: Int -gitAnnexDistributor :: Property -gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" - [ Apt.installed ["rsync"] - , File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") +gitAnnexDistributor :: Property (HasInfo + DebianLike) +gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props + & Apt.installed ["rsync"] + & File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") `onChange` Service.restarted "rsync" - , File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") + & File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") `onChange` Service.restarted "rsync" - , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" + & "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" `onChange` Service.running "rsync" - , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" - , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" + & Systemd.enabled "rsync" + & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" + & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-yosemite" + & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/windows" -- git-annex distribution signing key - , Gpg.keyImported "89C809CB" "joey" - ] + & Gpg.keyImported (Gpg.GpgKeyId "89C809CB") (User "joey") where - endpoint d = combineProperties ("endpoint " ++ d) - [ File.dirExists d - , File.ownerGroup d "joey" "joey" - ] + endpoint d = combineProperties ("endpoint " ++ d) $ props + & File.dirExists d + & File.ownerGroup d (User "joey") (Group "joey") + +downloads :: [Host] -> Property (HasInfo + DebianLike) +downloads hosts = annexWebSite "/srv/git/downloads.git" + "downloads.kitenet.net" + "840760dc-08f0-11e2-8c61-576b7e66acfd" + [("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")] + `requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "joey") + +tmp :: Property (HasInfo + DebianLike) +tmp = propertyList "tmp.kitenet.net" $ props + & annexWebSite "/srv/git/joey/tmp.git" + "tmp.kitenet.net" + "26fd6e38-1226-11e2-a75f-ff007033bdba" + [] + & twitRss + & pumpRss -- Twitter, you kill us. -twitRss :: Property -twitRss = combineProperties "twitter rss" - [ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing - , check (not <$> doesFileExist (dir </> "twitRss")) $ - userScriptProperty "joey" - [ "cd " ++ dir - , "ghc --make twitRss" - ] - `requires` Apt.installed - [ "libghc-xml-dev" - , "libghc-feed-dev" - , "libghc-tagsoup-dev" - ] - , feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" - , feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" - ] +twitRss :: Property DebianLike +twitRss = combineProperties "twitter rss" $ props + & Git.cloned (User "joey") "git://git.kitenet.net/twitrss.git" dir Nothing + & check (not <$> doesFileExist (dir </> "twitRss")) compiled + & feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" + & feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" where dir = "/srv/web/tmp.kitenet.net/twitrss" - crontime = "15 * * * *" - feed url desc = Cron.job desc crontime "joey" dir $ + crontime = Cron.Times "15 * * * *" + feed url desc = Cron.job desc crontime (User "joey") dir $ "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") + compiled = userScriptProperty (User "joey") + [ "cd " ++ dir + , "ghc --make twitRss" + ] + `assume` NoChange + `requires` Apt.installed + [ "libghc-xml-dev" + , "libghc-feed-dev" + , "libghc-tagsoup-dev" + ] -- Work around for expired ssl cert. -pumpRss :: Property -pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/" - "wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null" - -ircBouncer :: Property -ircBouncer = propertyList "IRC bouncer" - [ Apt.installed ["znc"] - , User.accountFor "znc" - , File.dirExists (parentDir conf) - , File.hasPrivContent conf anyContext - , File.ownerGroup conf "znc" "znc" - , Cron.job "znconboot" "@reboot" "znc" "~" "znc" +pumpRss :: Property DebianLike +pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.kitenet.net/" + "wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom" + +ircBouncer :: Property (HasInfo + DebianLike) +ircBouncer = propertyList "IRC bouncer" $ props + & Apt.installed ["znc"] + & User.accountFor (User "znc") + & File.dirExists (takeDirectory conf) + & File.hasPrivContent conf anyContext + & File.ownerGroup conf (User "znc") (Group "znc") + & Cron.job "znconboot" (Cron.Times "@reboot") (User "znc") "~" "znc" -- ensure running if it was not already - , trivial $ userScriptProperty "znc" ["znc || true"] + & userScriptProperty (User "znc") ["znc || true"] + `assume` NoChange `describe` "znc running" - ] where conf = "/home/znc/.znc/configs/znc.conf" -kiteShellBox :: Property -kiteShellBox = propertyList "kitenet.net shellinabox" - [ Apt.installed ["shellinabox"] - , File.hasContent "/etc/default/shellinabox" +kiteShellBox :: Property DebianLike +kiteShellBox = propertyList "kitenet.net shellinabox" $ props + & Apt.installed ["openssl", "shellinabox", "openssh-client"] + & File.hasContent "/etc/default/shellinabox" [ "# Deployed by propellor" , "SHELLINABOX_DAEMON_START=1" , "SHELLINABOX_PORT=443" , "SHELLINABOX_ARGS=\"--no-beep --service=/:SSH:kitenet.net\"" ] `onChange` Service.restarted "shellinabox" - , Service.running "shellinabox" - ] - -githubBackup :: Property -githubBackup = propertyList "github-backup box" - [ Apt.installed ["github-backup", "moreutils"] - , let f = "/home/joey/.github-keys" - in File.hasPrivContent f anyContext - `onChange` File.ownerGroup f "joey" "joey" - , Cron.niceJob "github-backup run" "30 4 * * *" "joey" - "/home/joey/lib/backup" $ intercalate "&&" - [ "mkdir -p github" - , "cd github" - , ". $HOME/.github-keys && github-backup joeyh" - ] + & Service.running "shellinabox" + +githubBackup :: Property (HasInfo + DebianLike) +githubBackup = propertyList "github-backup box" $ props + & Apt.installed ["github-backup", "moreutils"] + & githubKeys + & Cron.niceJob "github-backup run" (Cron.Times "30 4 * * *") (User "joey") + "/home/joey/lib/backup" backupcmd + & Cron.niceJob "gitriddance" (Cron.Times "30 4 * * *") (User "joey") + "/home/joey/lib/backup" gitriddancecmd + where + backupcmd = intercalate "&&" $ + [ "mkdir -p github" + , "cd github" + , ". $HOME/.github-keys" + , "github-backup joeyh" + ] + gitriddancecmd = intercalate "&&" $ + [ "cd github" + , ". $HOME/.github-keys" + ] ++ map gitriddance githubMirrors + gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" + +githubKeys :: Property (HasInfo + UnixLike) +githubKeys = + let f = "/home/joey/.github-keys" + in File.hasPrivContent f anyContext + `onChange` File.ownerGroup f (User "joey") (Group "joey") + + +-- these repos are only mirrored on github, I don't want +-- all the proprietary features +githubMirrors :: [(String, String)] +githubMirrors = + [ ("ikiwiki", plzuseurl "http://ikiwiki.info/todo/") + , ("git-annex", plzuseurl "http://git-annex.branchable.com/todo/") + , ("myrepos", plzuseurl "http://myrepos.branchable.com/todo/") + , ("propellor", plzuseurl "http://propellor.branchable.com/todo/") + , ("etckeeper", plzuseurl "http://etckeeper.branchable.com/todo/") ] + where + plzuseurl u = "Please submit changes to " ++ u ++ " instead of using github pull requests, which are not part of my workflow. Just open a todo item there and link to a git repository containing your changes. Did you know, git is a distributed system? The git repository doesn't even need to be on github! Please send any complaints to Github; they don't allow turning off pull requests or redirecting them elsewhere. -- A robot acting on behalf of Joey Hess" -rsyncNetBackup :: [Host] -> Property -rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" "30 5 * * *" - "joey" "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net" - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "joey" +rsyncNetBackup :: [Host] -> Property DebianLike +rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" (Cron.Times "30 5 * * *") + (User "joey") "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net" + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "joey") -backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property -backupsBackedupTo hosts desthost destdir = Cron.niceJob desc - "1 1 * * 3" "joey" "/" cmd - `requires` Ssh.knownHost hosts desthost "joey" +backupsBackedupFrom :: [Host] -> HostName -> FilePath -> Property DebianLike +backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc + (Cron.Times "@reboot") (User "joey") "/" cmd + `requires` Ssh.knownHost hosts srchost (User "joey") where - desc = "backups copied to " ++ desthost ++ " weekly" - cmd = "rsync -az --delete /home/joey/lib/backup " ++ desthost ++ ":" ++ destdir + desc = "backups copied from " ++ srchost ++ " on boot" + cmd = "sleep 30m && rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir </> srchost -obnamRepos :: [String] -> Property -obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) - (mkbase : map mkrepo rs) +obnamRepos :: [String] -> Property UnixLike +obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) $ + toProps (mkbase : map mkrepo rs) where mkbase = mkdir "/home/joey/lib/backup" `requires` mkdir "/home/joey/lib" mkrepo r = mkdir ("/home/joey/lib/backup/" ++ r ++ ".obnam") mkdir d = File.dirExists d - `before` File.ownerGroup d "joey" "joey" + `before` File.ownerGroup d (User "joey") (Group "joey") -podcatcher :: Property -podcatcher = Cron.niceJob "podcatcher run hourly" "55 * * * *" - "joey" "/home/joey/lib/sound/podcasts" +podcatcher :: Property DebianLike +podcatcher = Cron.niceJob "podcatcher run hourly" (Cron.Times "55 * * * *") + (User "joey") "/home/joey/lib/sound/podcasts" "xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update" `requires` Apt.installed ["git-annex", "myrepos"] -kiteMailServer :: Property -kiteMailServer = propertyList "kitenet.net mail server" - [ Postfix.installed - , Apt.installed ["postfix-pcre"] - , Apt.serviceInstalledRunning "postgrey" +kiteMailServer :: Property (HasInfo + DebianLike) +kiteMailServer = propertyList "kitenet.net mail server" $ props + & Postfix.installed + & Apt.installed ["postfix-pcre"] + & Apt.serviceInstalledRunning "postgrey" - , Apt.serviceInstalledRunning "spamassassin" - , "/etc/default/spamassassin" `File.containsLines` + & Apt.serviceInstalledRunning "spamassassin" + & "/etc/default/spamassassin" `File.containsLines` [ "# Propellor deployed" , "ENABLED=1" - , "CRON=1" , "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\"" , "CRON=1" , "NICE=\"--nicelevel 15\"" @@ -409,15 +512,15 @@ kiteMailServer = propertyList "kitenet.net mail server" `describe` "spamd enabled" `requires` Apt.serviceInstalledRunning "cron" - , Apt.serviceInstalledRunning "spamass-milter" + & Apt.serviceInstalledRunning "spamass-milter" -- Add -m to prevent modifying messages Subject or body. - , "/etc/default/spamass-milter" `File.containsLine` + & "/etc/default/spamass-milter" `File.containsLine` "OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\"" `onChange` Service.restarted "spamass-milter" `describe` "spamass-milter configured" - , Apt.serviceInstalledRunning "amavisd-milter" - , "/etc/default/amavisd-milter" `File.containsLines` + & Apt.serviceInstalledRunning "amavisd-milter" + & "/etc/default/amavisd-milter" `File.containsLines` [ "# Propellor deployed" , "MILTERSOCKET=/var/spool/postfix/amavis/amavis.sock" , "MILTERSOCKETOWNER=\"postfix:postfix\"" @@ -425,10 +528,21 @@ kiteMailServer = propertyList "kitenet.net mail server" ] `onChange` Service.restarted "amavisd-milter" `describe` "amavisd-milter configured for postfix" - , Apt.serviceInstalledRunning "clamav-freshclam" + & Apt.serviceInstalledRunning "clamav-freshclam" + -- Workaround https://bugs.debian.org/569150 + & Cron.niceJob "amavis-expire" Cron.Daily (User "root") "/" + "find /var/lib/amavis/virusmails/ -type f -ctime +7 -delete" + + & dkimInstalled - , Apt.installed ["maildrop"] - , "/etc/maildroprc" `File.hasContent` + & Postfix.saslAuthdInstalled + & Fail2Ban.installed + & Fail2Ban.jailEnabled "postfix-sasl" + & "/etc/default/saslauthd" `File.containsLine` "MECHANISMS=sasldb" + & Postfix.saslPasswdSet "kitenet.net" (User "errol") + + & Apt.installed ["maildrop"] + & "/etc/maildroprc" `File.hasContent` [ "# Global maildrop filter file (deployed with propellor)" , "DEFAULT=\"$HOME/Maildir\"" , "MAILBOX=\"$DEFAULT/.\"" @@ -442,41 +556,40 @@ kiteMailServer = propertyList "kitenet.net mail server" ] `describe` "maildrop configured" - , "/etc/aliases" `File.hasPrivContentExposed` ctx + & "/etc/aliases" `File.hasPrivContentExposed` ctx `onChange` Postfix.newaliases - , hasJoeyCAChain - , "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx - , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx + & hasJoeyCAChain + & hasPostfixCert ctx - , "/etc/postfix/mydomain" `File.containsLines` + & "/etc/postfix/mydomain" `File.containsLines` [ "/.*\\.kitenet\\.net/\tOK" , "/ikiwiki\\.info/\tOK" , "/joeyh\\.name/\tOK" ] `onChange` Postfix.reloaded `describe` "postfix mydomain file configured" - , "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` + & "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` -- Remove received lines for mails relayed from trusted - -- clients. These can be a privacy vilation, or trigger + -- clients. These can be a privacy violation, or trigger -- spam filters. [ "/^Received: from ([^.]+)\\.kitenet\\.net.*using TLS.*by kitenet\\.net \\(([^)]+)\\) with (E?SMTPS?A?) id ([A-F[:digit:]]+)(.*)/ IGNORE" -- Munge local Received line for postfix running on a -- trusted client that relays through. These can trigger -- spam filters. - , "/^Received: by ([^.]+)\\.kitenet\\.net.*/ REPLACE Received: by kitenet.net" + , "/^Received: by ([^.]+)\\.kitenet\\.net.*/ REPLACE X-Question: 42" ] `onChange` Postfix.reloaded `describe` "postfix obscure_client_relay file configured" - , Postfix.mappedFile "/etc/postfix/virtual" + & Postfix.mappedFile "/etc/postfix/virtual" (flip File.containsLines [ "# *@joeyh.name to joey" , "@joeyh.name\tjoey" ] ) `describe` "postfix virtual file configured" `onChange` Postfix.reloaded - , Postfix.mappedFile "/etc/postfix/relay_clientcerts" $ - flip File.hasPrivContentExposed ctx - , Postfix.mainCfFile `File.containsLines` + & Postfix.mappedFile "/etc/postfix/relay_clientcerts" + (flip File.hasPrivContentExposed ctx) + & Postfix.mainCfFile `File.containsLines` [ "myhostname = kitenet.net" , "mydomain = $myhostname" , "append_dot_mydomain = no" @@ -492,12 +605,21 @@ kiteMailServer = propertyList "kitenet.net mail server" , "# Filter out client relay lines from headers." , "header_checks = pcre:$config_directory/obscure_client_relay.pcre" + , "# Password auth for relaying (used by errol)" + , "smtpd_sasl_auth_enable = yes" + , "smtpd_sasl_security_options = noanonymous" + , "smtpd_sasl_local_domain = kitenet.net" + , "# Enable postgrey." - , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" + , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_sasl_authenticated,,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" - , "# Enable spamass-milter and amavis-milter." - , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock" + , "# Enable spamass-milter, amavis-milter, opendkim" + , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock inet:localhost:8891" + , "# opendkim is used for outgoing mail" + , "non_smtpd_milters = inet:localhost:8891" , "milter_connect_macros = j {daemon_name} v {if_name} _" + , "# If a milter is broken, fall back to just accepting mail." + , "milter_default_action = accept" , "# TLS setup -- server" , "smtpd_tls_CAfile = /etc/ssl/certs/joeyca.pem" @@ -521,24 +643,24 @@ kiteMailServer = propertyList "kitenet.net mail server" `onChange` Postfix.reloaded `describe` "postfix configured" - , Apt.serviceInstalledRunning "dovecot-imapd" - , Apt.serviceInstalledRunning "dovecot-pop3d" - , "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` + & Apt.serviceInstalledRunning "dovecot-imapd" + & Apt.serviceInstalledRunning "dovecot-pop3d" + & "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` "mail_location = maildir:~/Maildir" `onChange` Service.reloaded "dovecot" `describe` "dovecot mail.conf" - , "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine` + & "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine` "!include auth-passwdfile.conf.ext" `onChange` Service.restarted "dovecot" `describe` "dovecot auth.conf" - , File.hasPrivContent dovecotusers ctx + & File.hasPrivContent dovecotusers ctx `onChange` (dovecotusers `File.mode` combineModes [ownerReadMode, groupReadMode]) - , File.ownerGroup dovecotusers "root" "dovecot" + & File.ownerGroup dovecotusers (User "root") (Group "dovecot") - , Apt.installed ["mutt", "bsd-mailx", "alpine"] + & Apt.installed ["mutt", "bsd-mailx", "alpine"] - , pinescript `File.hasContent` + & pinescript `File.hasContent` [ "#!/bin/sh" , "# deployed with propellor" , "set -e" @@ -552,44 +674,98 @@ kiteMailServer = propertyList "kitenet.net mail server" `onChange` (pinescript `File.mode` combineModes (readModes ++ executeModes)) `describe` "pine wrapper script" - , "/etc/pine.conf" `File.hasContent` + & "/etc/pine.conf" `File.hasContent` [ "# deployed with propellor" , "inbox-path={localhost/novalidate-cert/NoRsh}inbox" ] `describe` "pine configured to use local imap server" - , Apt.serviceInstalledRunning "mailman" - ] + & Apt.serviceInstalledRunning "mailman" + + & Postfix.service ssmtp where ctx = Context "kitenet.net" pinescript = "/usr/local/bin/pine" dovecotusers = "/etc/dovecot/users" -hasJoeyCAChain :: Property + ssmtp = Postfix.Service + (Postfix.InetService Nothing "ssmtp") + "smtpd" Postfix.defServiceOpts + +-- Configures postfix to relay outgoing mail to kitenet.net, with +-- verification via tls cert. +postfixClientRelay :: Context -> Property (HasInfo + DebianLike) +postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` + -- Using smtps not smtp because more networks firewall smtp + [ "relayhost = kitenet.net:smtps" + , "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem" + , "smtp_tls_cert_file = /etc/ssl/certs/postfix.pem" + , "smtp_tls_key_file = /etc/ssl/private/postfix.pem" + , "smtp_tls_loglevel = 0" + , "smtp_use_tls = yes" + ] + `describe` "postfix client relay" + `onChange` Postfix.dedupMainCf + `onChange` Postfix.reloaded + `requires` hasJoeyCAChain + `requires` hasPostfixCert ctx + +-- Configures postfix to have the dkim milter, and no other milters. +dkimMilter :: Property (HasInfo + DebianLike) +dkimMilter = Postfix.mainCfFile `File.containsLines` + [ "smtpd_milters = inet:localhost:8891" + , "non_smtpd_milters = inet:localhost:8891" + , "milter_default_action = accept" + ] + `describe` "postfix dkim milter" + `onChange` Postfix.dedupMainCf + `onChange` Postfix.reloaded + `requires` dkimInstalled + +-- This does not configure postfix to use the dkim milter, +-- nor does it set up domainkey DNS. +dkimInstalled :: Property (HasInfo + DebianLike) +dkimInstalled = go `onChange` Service.restarted "opendkim" + where + go = propertyList "opendkim installed" $ props + & Apt.serviceInstalledRunning "opendkim" + & File.dirExists "/etc/mail" + & File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") + & File.ownerGroup "/etc/mail/dkim.key" (User "opendkim") (Group "opendkim") + & "/etc/default/opendkim" `File.containsLine` + "SOCKET=\"inet:8891@localhost\"" + & "/etc/opendkim.conf" `File.containsLines` + [ "KeyFile /etc/mail/dkim.key" + , "SubDomains yes" + , "Domain *" + , "Selector mail" + ] + +-- This is the dkim public key, corresponding with /etc/mail/dkim.key +-- This value can be included in a domain's additional records to make +-- it use this domainkey. +domainKey :: (BindDomain, Record) +domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") + +hasJoeyCAChain :: Property (HasInfo + UnixLike) hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` Context "joeyca.pem" -kitenetHttps :: Property -kitenetHttps = propertyList "kitenet.net https certs" - [ File.hasPrivContent "/etc/ssl/certs/web.pem" ctx - , File.hasPrivContent "/etc/ssl/private/web.pem" ctx - , File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx - , toProp $ Apache.modEnabled "ssl" - ] - where - ctx = Context "kitenet.net" +hasPostfixCert :: Context -> Property (HasInfo + UnixLike) +hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props + & "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx + & "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx -- Legacy static web sites and redirections from kitenet.net to newer -- sites. -legacyWebSites :: Property -legacyWebSites = propertyList "legacy web sites" - [ Apt.serviceInstalledRunning "apache2" - , toProp $ Apache.modEnabled "rewrite" - , toProp $ Apache.modEnabled "cgi" - , toProp $ Apache.modEnabled "speling" - , userDirHtml - , kitenetHttps - , toProp $ Apache.siteEnabled "kitenet.net" $ apachecfg "kitenet.net" True +legacyWebSites :: Property (HasInfo + DebianLike) +legacyWebSites = propertyList "legacy web sites" $ props + & Apt.serviceInstalledRunning "apache2" + & Apache.modEnabled "rewrite" + & Apache.modEnabled "cgi" + & Apache.modEnabled "speling" + & userDirHtml + & Apache.httpsVirtualHost' "kitenet.net" "/var/www" letos -- /var/www is empty [ "DocumentRoot /var/www" , "<Directory /var/www>" @@ -676,8 +852,8 @@ legacyWebSites = propertyList "legacy web sites" , "rewriterule /~kyle/family/wiki/(.*).rss http://macleawiki.branchable.com/$1/index.rss [L]" , "rewriterule /~kyle/family/wiki(.*) http://macleawiki.branchable.com$1 [L]" ] - , alias "anna.kitenet.net" - , toProp $ Apache.siteEnabled "anna.kitenet.net" $ apachecfg "anna.kitenet.net" False + & alias "anna.kitenet.net" + & apacheSite "anna.kitenet.net" [ "DocumentRoot /home/anna/html" , "<Directory /home/anna/html/>" , " Options Indexes ExecCGI" @@ -685,9 +861,9 @@ legacyWebSites = propertyList "legacy web sites" , Apache.allowAll , "</Directory>" ] - , alias "sows-ear.kitenet.net" - , alias "www.sows-ear.kitenet.net" - , toProp $ Apache.siteEnabled "sows-ear.kitenet.net" $ apachecfg "sows-ear.kitenet.net" False + & alias "sows-ear.kitenet.net" + & alias "www.sows-ear.kitenet.net" + & apacheSite "sows-ear.kitenet.net" [ "ServerAlias www.sows-ear.kitenet.net" , "DocumentRoot /srv/web/sows-ear.kitenet.net" , "<Directory /srv/web/sows-ear.kitenet.net>" @@ -695,10 +871,12 @@ legacyWebSites = propertyList "legacy web sites" , " AllowOverride None" , Apache.allowAll , "</Directory>" + , "RewriteEngine On" + , "RewriteRule .* http://www.sowsearpoetry.org/ [L]" ] - , alias "wortroot.kitenet.net" - , alias "www.wortroot.kitenet.net" - , toProp $ Apache.siteEnabled "wortroot.kitenet.net" $ apachecfg "wortroot.kitenet.net" False + & alias "wortroot.kitenet.net" + & alias "www.wortroot.kitenet.net" + & apacheSite "wortroot.kitenet.net" [ "ServerAlias www.wortroot.kitenet.net" , "DocumentRoot /srv/web/wortroot.kitenet.net" , "<Directory /srv/web/wortroot.kitenet.net>" @@ -707,8 +885,8 @@ legacyWebSites = propertyList "legacy web sites" , Apache.allowAll , "</Directory>" ] - , alias "creeksidepress.com" - , toProp $ Apache.siteEnabled "creeksidepress.com" $ apachecfg "creeksidepress.com" False + & alias "creeksidepress.com" + & apacheSite "creeksidepress.com" [ "ServerAlias www.creeksidepress.com" , "DocumentRoot /srv/web/www.creeksidepress.com" , "<Directory /srv/web/www.creeksidepress.com>" @@ -717,8 +895,8 @@ legacyWebSites = propertyList "legacy web sites" , Apache.allowAll , "</Directory>" ] - , alias "joey.kitenet.net" - , toProp $ Apache.siteEnabled "joey.kitenet.net" $ apachecfg "joey.kitenet.net" False + & alias "joey.kitenet.net" + & apacheSite "joey.kitenet.net" [ "DocumentRoot /var/www" , "<Directory /var/www/>" , " Options Indexes ExecCGI" @@ -738,12 +916,50 @@ legacyWebSites = propertyList "legacy web sites" , "# Redirect all to joeyh.name." , "rewriterule (.*) http://joeyh.name$1 [r]" ] - ] -userDirHtml :: Property +userDirHtml :: Property DebianLike userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf `onChange` Apache.reloaded - `requires` (toProp $ Apache.modEnabled "userdir") + `requires` Apache.modEnabled "userdir" where munge = replace "public_html" "html" conf = "/etc/apache2/mods-available/userdir.conf" + +-- Alarm clock: see +-- <http://joeyh.name/blog/entry/a_programmable_alarm_clock_using_systemd/> +-- +-- oncalendar example value: "*-*-* 7:30" +alarmClock :: String -> User -> String -> Property DebianLike +alarmClock oncalendar (User user) command = combineProperties "goodmorning timer installed" $ props + & "/etc/systemd/system/goodmorning.timer" `File.hasContent` + [ "[Unit]" + , "Description=good morning" + , "" + , "[Timer]" + , "Unit=goodmorning.service" + , "OnCalendar=" ++ oncalendar + , "WakeSystem=true" + , "Persistent=false" + , "" + , "[Install]" + , "WantedBy=multi-user.target" + ] + `onChange` (Systemd.daemonReloaded + `before` Systemd.restarted "goodmorning.timer") + & "/etc/systemd/system/goodmorning.service" `File.hasContent` + [ "[Unit]" + , "Description=good morning" + , "RefuseManualStart=true" + , "RefuseManualStop=true" + , "ConditionACPower=true" + , "StopWhenUnneeded=yes" + , "" + , "[Service]" + , "Type=oneshot" + , "ExecStart=/bin/systemd-inhibit --what=handle-lid-switch --why=goodmorning /bin/su " ++ user ++ " -c \"" ++ command ++ "\"" + ] + `onChange` Systemd.daemonReloaded + & Systemd.enabled "goodmorning.timer" + & Systemd.started "goodmorning.timer" + & "/etc/systemd/logind.conf" `ConfFile.containsIniSetting` + ("Login", "LidSwitchIgnoreInhibited", "no") diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 4ecdf23e..6e1690d2 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -1,26 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-} + module Propellor.Property.Ssh ( + installed, + restarted, + PubKeyText, + SshKeyType(..), + -- * Daemon configuration + sshdConfig, + ConfigKeyword, + setSshdConfigBool, setSshdConfig, + RootLogin(..), permitRootLogin, passwordAuthentication, - hasAuthorizedKeys, - restarted, + noPasswords, + listenPort, + -- * Host keys randomHostKeys, hostKeys, hostKey, - keyImported, + hostPubKey, + getHostPubKey, + -- * User keys and configuration + userKeys, + userKeyAt, knownHost, + unknownHost, + authorizedKeysFrom, + unauthorizedKeysFrom, authorizedKeys, - listenPort + authorizedKey, + hasAuthorizedKeys, + getUserPubKeys, ) where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.Apt as Apt import Propellor.Property.User -import Utility.SafeCommand +import Propellor.Types.Info import Utility.FileMode import System.PosixCompat +import qualified Data.Map as M +import qualified Data.Set as S +import Data.List + +installed :: Property UnixLike +installed = "ssh installed" ==> (aptinstall `pickOS` unsupportedOS) + where + aptinstall :: Property DebianLike + aptinstall = Apt.installed ["ssh"] + +restarted :: Property DebianLike +restarted = Service.restarted "ssh" sshBool :: Bool -> String sshBool True = "yes" @@ -29,107 +63,251 @@ sshBool False = "no" sshdConfig :: FilePath sshdConfig = "/etc/ssh/sshd_config" -setSshdConfig :: String -> Bool -> Property -setSshdConfig setting allowed = combineProperties "sshd config" - [ sshdConfig `File.lacksLine` (sshline $ not allowed) - , sshdConfig `File.containsLine` (sshline allowed) - ] +type ConfigKeyword = String + +setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike +setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed) + +setSshdConfig :: ConfigKeyword -> String -> Property DebianLike +setSshdConfig setting val = File.fileProperty desc f sshdConfig `onChange` restarted - `describe` unwords [ "ssh config:", setting, sshBool allowed ] where - sshline v = setting ++ " " ++ sshBool v + desc = unwords [ "ssh config:", setting, val ] + cfgline = setting ++ " " ++ val + wantedline s + | s == cfgline = True + | (setting ++ " ") `isPrefixOf` s = False + | otherwise = True + f ls + | cfgline `elem` ls = filter wantedline ls + | otherwise = filter wantedline ls ++ [cfgline] + +data RootLogin + = RootLogin Bool -- ^ allow or prevent root login + | WithoutPassword -- ^ disable password authentication for root, while allowing other authentication methods + | ForcedCommandsOnly -- ^ allow root login with public-key authentication, but only if a forced command has been specified for the public key -permitRootLogin :: Bool -> Property -permitRootLogin = setSshdConfig "PermitRootLogin" +permitRootLogin :: RootLogin -> Property DebianLike +permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b +permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password" +permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only" -passwordAuthentication :: Bool -> Property -passwordAuthentication = setSshdConfig "PasswordAuthentication" +passwordAuthentication :: Bool -> Property DebianLike +passwordAuthentication = setSshdConfigBool "PasswordAuthentication" -dotDir :: UserName -> IO FilePath +-- | Configure ssh to not allow password logins. +-- +-- To prevent lock-out, this is done only once root's +-- authorized_keys is in place. +noPasswords :: Property DebianLike +noPasswords = check (hasAuthorizedKeys (User "root")) $ + passwordAuthentication False + +dotDir :: User -> IO FilePath dotDir user = do h <- homedir user return $ h </> ".ssh" -dotFile :: FilePath -> UserName -> IO FilePath +dotFile :: FilePath -> User -> IO FilePath dotFile f user = do d <- dotDir user return $ d </> f -hasAuthorizedKeys :: UserName -> IO Bool +-- | Makes the ssh server listen on a given port, in addition to any other +-- ports it is configured to listen on. +-- +-- Revert to prevent it listening on a particular port. +listenPort :: Port -> RevertableProperty DebianLike DebianLike +listenPort port = enable <!> disable + where + portline = "Port " ++ fromPort port + enable = sshdConfig `File.containsLine` portline + `describe` ("ssh listening on " ++ portline) + `onChange` restarted + disable = sshdConfig `File.lacksLine` portline + `describe` ("ssh not listening on " ++ portline) + `onChange` restarted + +hasAuthorizedKeys :: User -> IO Bool hasAuthorizedKeys = go <=< dotFile "authorized_keys" where go f = not . null <$> catchDefaultIO "" (readFile f) -restarted :: Property -restarted = Service.restarted "ssh" - -- | Blows away existing host keys and make new ones. -- Useful for systems installed from an image that might reuse host keys. -- A flag file is used to only ever do this once. -randomHostKeys :: Property +randomHostKeys :: Property DebianLike randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restarted where - prop = property "ssh random host keys" $ do + prop :: Property UnixLike + prop = property' "ssh random host keys" $ \w -> do void $ liftIO $ boolSystem "sh" [ Param "-c" , Param "rm -f /etc/ssh/ssh_host_*" ] - ensureProperty $ scriptProperty - [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] - --- | Sets all types of ssh host keys from the privdata. -hostKeys :: Context -> Property -hostKeys ctx = propertyList "known ssh host keys" - [ hostKey SshDsa ctx - , hostKey SshRsa ctx - , hostKey SshEcdsa ctx - ] - --- | Sets a single ssh host key from the privdata. -hostKey :: SshKeyType -> Context -> Property -hostKey keytype context = combineProperties desc - [ installkey (SshPubKey keytype "") (install writeFile ".pub") - , installkey (SshPrivKey keytype "") (install writeFileProtected "") - ] - `onChange` restarted + ensureProperty w $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] + `assume` MadeChange + +-- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI" +type PubKeyText = String + +-- | Installs the specified list of ssh host keys. +-- +-- The corresponding private keys come from the privdata. +-- +-- Any host keys that are not in the list are removed from the host. +hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike) +hostKeys ctx l = go `before` cleanup + where + desc = "ssh host keys configured " ++ typelist (map fst l) + go :: Property (HasInfo + DebianLike) + go = propertyList desc $ toProps $ catMaybes $ + map (\(t, pub) -> Just $ hostKey ctx t pub) l + typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")" + alltypes = [minBound..maxBound] + staletypes = let have = map fst l in filter (`notElem` have) alltypes + removestale :: Bool -> [Property DebianLike] + removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes + cleanup :: Property DebianLike + cleanup + | null staletypes || null l = doNothing + | otherwise = + combineProperties ("any other ssh host keys removed " ++ typelist staletypes) + (toProps $ removestale True ++ removestale False) + `onChange` restarted + +-- | Installs a single ssh host key of a particular type. +-- +-- The public key is provided to this function; +-- the private key comes from the privdata; +hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike) +hostKey context keytype pub = go `onChange` restarted where - desc = "known ssh host key (" ++ fromKeyType keytype ++ ")" - installkey p a = withPrivData p context $ \getkey -> - property desc $ getkey a - install writer ext key = do - let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext - s <- liftIO $ readFileStrict f - if s == key - then noChange - else makeChange $ writer f key - --- | Sets up a user with a ssh private key and public key pair from the --- PrivData. -keyImported :: SshKeyType -> UserName -> Context -> Property -keyImported keytype user context = combineProperties desc - [ installkey (SshPubKey keytype user) (install writeFile ".pub") - , installkey (SshPrivKey keytype user) (install writeFileProtected "") - ] - where - desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")" - installkey p a = withPrivData p context $ \getkey -> - property desc $ getkey a - install writer ext key = do + go = combineProperties desc $ props + & hostPubKey keytype pub + & installpub + & installpriv + desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")" + keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext) + ("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey") + installpub :: Property UnixLike + installpub = keywriter File.hasContent True (lines pub) + installpriv :: Property (HasInfo + UnixLike) + installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> + property' desc $ \w -> getkey $ + ensureProperty w + . keywriter File.hasContentProtected False + . privDataLines + keywriter p ispub keylines = do + let f = keyFile keytype ispub + p f (keyFileContent keylines) + +-- Make sure that there is a newline at the end; +-- ssh requires this for some types of private keys. +keyFileContent :: [String] -> [File.Line] +keyFileContent keylines = keylines ++ [""] + +keyFile :: SshKeyType -> Bool -> FilePath +keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext + where + ext = if ispub then ".pub" else "" + +-- | Indicates the host key that is used by a Host, but does not actually +-- configure the host to use it. Normally this does not need to be used; +-- use 'hostKey' instead. +hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + UnixLike) +hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t + +getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText) +getHostPubKey = fromHostKeyInfo <$> askInfo + +newtype HostKeyInfo = HostKeyInfo + { fromHostKeyInfo :: M.Map SshKeyType PubKeyText } + deriving (Eq, Ord, Typeable, Show) + +instance IsInfo HostKeyInfo where + propagateInfo _ = False + +instance Monoid HostKeyInfo where + mempty = HostKeyInfo M.empty + mappend (HostKeyInfo old) (HostKeyInfo new) = + -- new first because union prefers values from the first + -- parameter when there is a duplicate key + HostKeyInfo (new `M.union` old) + +userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) +userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $ + UserKeyInfo (M.singleton u (S.fromList l)) + +getUserPubKeys :: User -> Propellor [(SshKeyType, PubKeyText)] +getUserPubKeys u = maybe [] S.toList . M.lookup u . fromUserKeyInfo <$> askInfo + +newtype UserKeyInfo = UserKeyInfo + { fromUserKeyInfo :: M.Map User (S.Set (SshKeyType, PubKeyText)) } + deriving (Eq, Ord, Typeable, Show) + +instance IsInfo UserKeyInfo where + propagateInfo _ = False + +instance Monoid UserKeyInfo where + mempty = UserKeyInfo M.empty + mappend (UserKeyInfo old) (UserKeyInfo new) = + UserKeyInfo (M.unionWith S.union old new) + +-- | Sets up a user with the specified public keys, and the corresponding +-- private keys from the privdata. +-- +-- The public keys are added to the Info, so other properties like +-- `authorizedKeysFrom` can use them. +userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) +userKeys user@(User name) context ks = combineProperties desc $ toProps $ + userPubKeys user ks : map (userKeyAt Nothing user context) ks + where + desc = unwords + [ name + , "has ssh key" + , "(" ++ unwords (map (fromKeyType . fst) ks) ++ ")" + ] + +-- | Sets up a user with the specified pubic key, and a private +-- key from the privdata. +-- +-- A file can be specified to write the key to somewhere other than +-- the default locations. Allows a user to have multiple keys for +-- different roles. +userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property (HasInfo + UnixLike) +userKeyAt dest user@(User u) context (keytype, pubkeytext) = + combineProperties desc $ props + & pubkey + & privkey + where + desc = unwords $ catMaybes + [ Just u + , Just "has ssh key" + , dest + , Just $ "(" ++ fromKeyType keytype ++ ")" + ] + pubkey :: Property UnixLike + pubkey = property' desc $ \w -> + ensureProperty w =<< installprop File.hasContent ".pub" [pubkeytext] + privkey :: Property (HasInfo + UnixLike) + privkey = withPrivData (SshPrivKey keytype u) context privkey' + privkey' :: ((PrivData -> Propellor Result) -> Propellor Result) -> Property (HasInfo + UnixLike) + privkey' getkey = property' desc $ \w -> getkey $ \k -> + ensureProperty w + =<< installprop File.hasContentProtected "" (privDataLines k) + installprop writer ext key = do f <- liftIO $ keyfile ext - ifM (liftIO $ doesFileExist f) - ( noChange - , ensureProperties - [ property desc $ makeChange $ do - createDirectoryIfMissing True (takeDirectory f) - writer f key - , File.ownerGroup f user user - , File.ownerGroup (takeDirectory f) user user - ] - ) - keyfile ext = do - home <- homeDirectory <$> getUserEntryForName user - return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext + return $ combineProperties desc $ props + & writer f (keyFileContent key) + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) + keyfile ext = case dest of + Nothing -> do + home <- homeDirectory <$> getUserEntryForName u + return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext + Just f -> return $ f ++ ext fromKeyType :: SshKeyType -> String fromKeyType SshRsa = "rsa" @@ -137,47 +315,119 @@ fromKeyType SshDsa = "dsa" fromKeyType SshEcdsa = "ecdsa" fromKeyType SshEd25519 = "ed25519" --- | Puts some host's ssh public key into the known_hosts file for a user. -knownHost :: [Host] -> HostName -> UserName -> Property -knownHost hosts hn user = property desc $ - go =<< fromHost hosts hn getSshPubKey +-- | Puts some host's ssh public key(s), as set using `hostPubKey` +-- or `hostKey` into the known_hosts file for a user. +knownHost :: [Host] -> HostName -> User -> Property UnixLike +knownHost hosts hn user@(User u) = property' desc $ \w -> + go w =<< knownHostLines hosts hn where - desc = user ++ " knows ssh key for " ++ hn - go (Just (Just k)) = do + desc = u ++ " knows ssh key for " ++ hn + + go _ [] = do + warningMessage $ "no configured ssh host keys for " ++ hn + return FailedChange + go w ls = do f <- liftIO $ dotFile "known_hosts" user - ensureProperty $ combineProperties desc - [ File.dirExists (takeDirectory f) - , f `File.containsLine` (hn ++ " " ++ k) - , File.ownerGroup f user user - ] - go _ = do - warningMessage $ "no configred sshPubKey for " ++ hn + ensureProperty w $ modKnownHost user f $ + f `File.containsLines` ls + `requires` File.dirExists (takeDirectory f) + +-- | Reverts `knownHost` +unknownHost :: [Host] -> HostName -> User -> Property UnixLike +unknownHost hosts hn user@(User u) = property' desc $ \w -> + go w =<< knownHostLines hosts hn + where + desc = u ++ " does not know ssh key for " ++ hn + + go _ [] = return NoChange + go w ls = do + f <- liftIO $ dotFile "known_hosts" user + ifM (liftIO $ doesFileExist f) + ( ensureProperty w $ modKnownHost user f $ + f `File.lacksLines` ls + , return NoChange + ) + +knownHostLines :: [Host] -> HostName -> Propellor [File.Line] +knownHostLines hosts hn = keylines <$> fromHost hosts hn getHostPubKey + where + keylines (Just m) = map (\k -> hn ++ " " ++ k) (M.elems m) + keylines Nothing = [] + +modKnownHost :: User -> FilePath -> Property UnixLike -> Property UnixLike +modKnownHost user f p = p + `requires` File.ownerGroup f user (userGroup user) + `requires` File.ownerGroup (takeDirectory f) user (userGroup user) + +-- | Ensures that a local user's authorized_keys contains lines allowing +-- logins from a remote user on the specified Host. +-- +-- The ssh keys of the remote user can be set using `keysImported` +-- +-- Any other lines in the authorized_keys file are preserved as-is. +authorizedKeysFrom :: User -> (User, Host) -> Property UnixLike +localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) = + property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost) + where + remote = rn ++ "@" ++ hostName remotehost + desc = ln ++ " authorized_keys from " ++ remote + + go _ [] = do + warningMessage $ "no configured ssh user keys for " ++ remote return FailedChange + go w ls = ensureProperty w $ combineProperties desc $ toProps $ + map (setupRevertableProperty . authorizedKey localuser) ls + +-- | Reverts `authorizedKeysFrom` +unauthorizedKeysFrom :: User -> (User, Host) -> Property UnixLike +localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) = + property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost) + where + remote = rn ++ "@" ++ hostName remotehost + desc = ln ++ " unauthorized_keys from " ++ remote + + go _ [] = return NoChange + go w ls = ensureProperty w $ combineProperties desc $ toProps $ + map (undoRevertableProperty . authorizedKey localuser) ls + +authorizedKeyLines :: User -> Host -> Propellor [File.Line] +authorizedKeyLines remoteuser remotehost = + map snd <$> fromHost' remotehost (getUserPubKeys remoteuser) -- | Makes a user have authorized_keys from the PrivData -authorizedKeys :: UserName -> Context -> Property -authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get -> - property (user ++ " has authorized_keys") $ get $ \v -> do +-- +-- This removes any other lines from the file. +authorizedKeys :: IsContext c => User -> c -> Property (HasInfo + UnixLike) +authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get -> + property' desc $ \w -> get $ \v -> do f <- liftIO $ dotFile "authorized_keys" user - liftIO $ do - createDirectoryIfMissing True (takeDirectory f) - writeFileProtected f v - ensureProperties - [ File.ownerGroup f user user - , File.ownerGroup (takeDirectory f) user user - ] + ensureProperty w $ combineProperties desc $ props + & File.hasContentProtected f (keyFileContent (privDataLines v)) + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) + where + desc = u ++ " has authorized_keys" --- | Makes the ssh server listen on a given port, in addition to any other --- ports it is configured to listen on. --- --- Revert to prevent it listening on a particular port. -listenPort :: Int -> RevertableProperty -listenPort port = RevertableProperty enable disable +-- | Ensures that a user's authorized_keys contains a line. +-- Any other lines in the file are preserved as-is. +authorizedKey :: User -> String -> RevertableProperty UnixLike UnixLike +authorizedKey user@(User u) l = add <!> remove where - portline = "Port " ++ show port - enable = sshdConfig `File.containsLine` portline - `describe` ("ssh listening on " ++ portline) - `onChange` restarted - disable = sshdConfig `File.lacksLine` portline - `describe` ("ssh not listening on " ++ portline) - `onChange` restarted + add = property' (u ++ " has authorized_keys") $ \w -> do + f <- liftIO $ dotFile "authorized_keys" user + ensureProperty w $ modAuthorizedKey f user $ + f `File.containsLine` l + `requires` File.dirExists (takeDirectory f) + remove = property' (u ++ " lacks authorized_keys") $ \w -> do + f <- liftIO $ dotFile "authorized_keys" user + ifM (liftIO $ doesFileExist f) + ( ensureProperty w $ modAuthorizedKey f user $ + f `File.lacksLine` l + , return NoChange + ) + +modAuthorizedKey :: FilePath -> User -> Property UnixLike -> Property UnixLike +modAuthorizedKey f user p = p + `before` File.mode f (combineModes [ownerWriteMode, ownerReadMode]) + `before` File.ownerGroup f user (userGroup user) + `before` File.ownerGroup (takeDirectory f) user (userGroup user) diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs index 3651891d..45ab8af2 100644 --- a/src/Propellor/Property/Sudo.hs +++ b/src/Propellor/Property/Sudo.hs @@ -2,24 +2,25 @@ module Propellor.Property.Sudo where import Data.List -import Propellor +import Propellor.Base 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. -enabledFor :: UserName -> Property -enabledFor user = property desc go `requires` Apt.installed ["sudo"] +enabledFor :: User -> Property DebianLike +enabledFor user@(User u) = go `requires` Apt.installed ["sudo"] where - go = do + go :: Property UnixLike + go = property' desc $ \w -> do locked <- liftIO $ isLockedPassword user - ensureProperty $ + ensureProperty w $ fileProperty desc (modify locked . filter (wanted locked)) "/etc/sudoers" - desc = user ++ " is sudoer" - sudobaseline = user ++ " ALL=(ALL:ALL)" + desc = u ++ " is sudoer" + sudobaseline = u ++ " ALL=(ALL:ALL)" sudoline True = sudobaseline ++ " NOPASSWD:ALL" sudoline False = sudobaseline ++ " ALL" wanted locked l diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs new file mode 100644 index 00000000..e11c991e --- /dev/null +++ b/src/Propellor/Property/Systemd.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE FlexibleInstances, TypeFamilies #-} + +module Propellor.Property.Systemd ( + -- * Services + ServiceName, + started, + stopped, + enabled, + disabled, + masked, + running, + restarted, + networkd, + journald, + logind, + -- * Configuration + installed, + Option, + configured, + daemonReloaded, + -- * Journal + persistentJournal, + journaldConfigured, + -- * Logind + logindConfigured, + killUserProcesses, + -- * Containers and machined + machined, + MachineName, + Container, + container, + debContainer, + nspawned, + -- * Container configuration + containerCfg, + resolvConfed, + linkJournal, + privateNetwork, + module Propellor.Types.Container, + Proto(..), + Publishable, + publish, + Bindable, + bind, + bindRo, +) where + +import Propellor.Base +import Propellor.Types.Chroot +import Propellor.Types.Container +import Propellor.Container +import Propellor.Types.Info +import qualified Propellor.Property.Chroot as Chroot +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import Propellor.Property.Systemd.Core +import Utility.FileMode + +import Data.List +import Data.List.Utils +import qualified Data.Map as M + +type ServiceName = String + +type MachineName = String + +data Container = Container MachineName Chroot.Chroot Host + deriving (Show) + +instance IsContainer Container where + containerProperties (Container _ _ h) = containerProperties h + containerInfo (Container _ _ h) = containerInfo h + setContainerProperties (Container n c h) ps = Container n c (setContainerProperties h ps) + +-- | Starts a systemd service. +-- +-- Note that this does not configure systemd to start the service on boot, +-- it only ensures that the service is currently running. +started :: ServiceName -> Property Linux +started n = tightenTargets $ cmdProperty "systemctl" ["start", n] + `assume` NoChange + `describe` ("service " ++ n ++ " started") + +-- | Stops a systemd service. +stopped :: ServiceName -> Property Linux +stopped n = tightenTargets $ cmdProperty "systemctl" ["stop", n] + `assume` NoChange + `describe` ("service " ++ n ++ " stopped") + +-- | Enables a systemd service. +-- +-- This does not ensure the service is started, it only configures systemd +-- to start it on boot. +enabled :: ServiceName -> Property Linux +enabled n = tightenTargets $ cmdProperty "systemctl" ["enable", n] + `assume` NoChange + `describe` ("service " ++ n ++ " enabled") + +-- | Disables a systemd service. +disabled :: ServiceName -> Property Linux +disabled n = tightenTargets $ cmdProperty "systemctl" ["disable", n] + `assume` NoChange + `describe` ("service " ++ n ++ " disabled") + +-- | Masks a systemd service. +masked :: ServiceName -> RevertableProperty Linux Linux +masked n = systemdMask <!> systemdUnmask + where + systemdMask = tightenTargets $ cmdProperty "systemctl" ["mask", n] + `assume` NoChange + `describe` ("service " ++ n ++ " masked") + systemdUnmask = tightenTargets $ cmdProperty "systemctl" ["unmask", n] + `assume` NoChange + `describe` ("service " ++ n ++ " unmasked") + +-- | Ensures that a service is both enabled and started +running :: ServiceName -> Property Linux +running n = started n `requires` enabled n + +-- | Restarts a systemd service. +restarted :: ServiceName -> Property Linux +restarted n = tightenTargets $ cmdProperty "systemctl" ["restart", n] + `assume` NoChange + `describe` ("service " ++ n ++ " restarted") + +-- | The systemd-networkd service. +networkd :: ServiceName +networkd = "systemd-networkd" + +-- | The systemd-journald service. +journald :: ServiceName +journald = "systemd-journald" + +-- | The systemd-logind service. +logind :: ServiceName +logind = "systemd-logind" + +-- | Enables persistent storage of the journal. +persistentJournal :: Property DebianLike +persistentJournal = check (not <$> doesDirectoryExist dir) $ + combineProperties "persistent systemd journal" $ props + & cmdProperty "install" ["-d", "-g", "systemd-journal", dir] + `assume` MadeChange + & Apt.installed ["acl"] + & cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir] + `assume` MadeChange + & started "systemd-journal-flush" + where + dir = "/var/log/journal" + +type Option = String + +-- | Ensures that an option is configured in one of systemd's config files. +-- Does not ensure that the relevant daemon notices the change immediately. +-- +-- This assumes that there is only one [Header] per file, which is +-- currently the case for files like journald.conf and system.conf. +-- And it assumes the file already exists with +-- the right [Header], so new lines can just be appended to the end. +configured :: FilePath -> Option -> String -> Property Linux +configured cfgfile option value = tightenTargets $ combineProperties desc $ props + & File.fileProperty desc (mapMaybe removeother) cfgfile + & File.containsLine cfgfile line + where + setting = option ++ "=" + line = setting ++ value + desc = cfgfile ++ " " ++ line + removeother l + | setting `isPrefixOf` l && l /= line = Nothing + | otherwise = Just l + +-- | Causes systemd to reload its configuration files. +daemonReloaded :: Property Linux +daemonReloaded = tightenTargets $ cmdProperty "systemctl" ["daemon-reload"] + `assume` NoChange + +-- | Configures journald, restarting it so the changes take effect. +journaldConfigured :: Option -> String -> Property Linux +journaldConfigured option value = + configured "/etc/systemd/journald.conf" option value + `onChange` restarted journald + +-- | Configures logind, restarting it so the changes take effect. +logindConfigured :: Option -> String -> Property Linux +logindConfigured option value = + configured "/etc/systemd/logind.conf" option value + `onChange` restarted logind + +-- | Configures whether leftover processes started from the +-- user's login session are killed after the user logs out. +-- +-- The default configuration varies depending on the version of systemd. +-- +-- Revert the property to ensure that screen sessions etc keep running: +-- +-- > ! killUserProcesses +killUserProcesses :: RevertableProperty Linux Linux +killUserProcesses = set "yes" <!> set "no" + where + set = logindConfigured "KillUserProcesses" + +-- | Ensures machined and machinectl are installed +machined :: Property Linux +machined = withOS "machined installed" $ \w o -> + case o of + -- Split into separate debian package since systemd 225. + (Just (System (Debian suite) _)) + | not (isStable suite) -> ensureProperty w $ + Apt.installed ["systemd-container"] + _ -> noChange + +-- | Defines a container with a given machine name, +-- and how to create its chroot if not already present. +-- +-- Properties can be added to configure the Container. At a minimum, +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. +-- +-- > container "webserver" $ \d -> Chroot.debootstrapped mempty d $ props +-- > & osDebian Unstable "amd64" +-- > & Apt.installedRunning "apache2" +-- > & ... +container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container +container name mkchroot = + let c = Container name chroot h + in setContainerProps c $ containerProps c + &^ resolvConfed + &^ linkJournal + where + chroot = mkchroot (containerDir name) + h = Host name (containerProperties chroot) (containerInfo chroot) + +-- | Defines a container with a given machine name, with the chroot +-- created using debootstrap. +-- +-- Properties can be added to configure the Container. At a minimum, +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. +-- +-- > debContainer "webserver" $ props +-- > & osDebian Unstable "amd64" +-- > & Apt.installedRunning "apache2" +-- > & ... +debContainer :: MachineName -> Props metatypes -> Container +debContainer name ps = container name $ \d -> Chroot.debootstrapped mempty d ps + +-- | Runs a container using systemd-nspawn. +-- +-- A systemd unit is set up for the container, so it will automatically +-- be started on boot. +-- +-- Systemd is automatically installed inside the container, and will +-- communicate with the host's systemd. This allows systemctl to be used to +-- examine the status of services running inside the container. +-- +-- When the host system has persistentJournal enabled, journactl can be +-- used to examine logs forwarded from the container. +-- +-- Reverting this property stops the container, removes the systemd unit, +-- and deletes the chroot and all its contents. +nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux +nspawned c@(Container name (Chroot.Chroot loc builder _) h) = + p `describe` ("nspawned " ++ name) + where + p :: RevertableProperty (HasInfo + Linux) Linux + p = enterScript c + `before` chrootprovisioned + `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h) + `before` containerprovisioned + + -- Chroot provisioning is run in systemd-only mode, + -- which sets up the chroot and ensures systemd and dbus are + -- installed, but does not handle the other properties. + chrootprovisioned = Chroot.provisioned' (Chroot.propagateChrootInfo chroot) chroot True + + -- Use nsenter to enter container and and run propellor to + -- finish provisioning. + containerprovisioned :: RevertableProperty Linux Linux + containerprovisioned = + tightenTargets (Chroot.propellChroot chroot (enterContainerProcess c) False) + <!> + doNothing + + chroot = Chroot.Chroot loc builder h + +-- | Sets up the service file for the container, and then starts +-- it running. +nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux +nspawnService (Container name _ _) cfg = setup <!> teardown + where + service = nspawnServiceName name + servicefile = "/etc/systemd/system/multi-user.target.wants" </> service + + servicefilecontent = do + ls <- lines <$> readFile "/lib/systemd/system/systemd-nspawn@.service" + return $ unlines $ + "# deployed by propellor" : map addparams ls + addparams l + | "ExecStart=" `isPrefixOf` l = unwords $ + [ "ExecStart = /usr/bin/systemd-nspawn" + , "--quiet" + , "--keep-unit" + , "--boot" + , "--directory=" ++ containerDir name + , "--machine=%i" + ] ++ nspawnServiceParams cfg + | otherwise = l + + goodservicefile = (==) + <$> servicefilecontent + <*> catchDefaultIO "" (readFile servicefile) + + writeservicefile :: Property Linux + writeservicefile = property servicefile $ makeChange $ do + c <- servicefilecontent + File.viaStableTmp (\t -> writeFile t c) servicefile + + setupservicefile :: Property Linux + setupservicefile = check (not <$> goodservicefile) $ + -- if it's running, it has the wrong configuration, + -- so stop it + stopped service + `requires` daemonReloaded + `requires` writeservicefile + + setup :: Property Linux + setup = started service + `requires` setupservicefile + `requires` machined + + teardown :: Property Linux + teardown = check (doesFileExist servicefile) $ + disabled service `requires` stopped service + +nspawnServiceParams :: ChrootCfg -> [String] +nspawnServiceParams NoChrootCfg = [] +nspawnServiceParams (SystemdNspawnCfg ps) = + M.keys $ M.filter id $ M.fromList ps + +-- | Installs a "enter-machinename" script that root can use to run a +-- command inside the container. +-- +-- This uses nsenter to enter the container, by looking up the pid of the +-- container's init process and using its namespace. +enterScript :: Container -> RevertableProperty Linux Linux +enterScript c@(Container name _ _) = + tightenTargets setup <!> tightenTargets teardown + where + setup = combineProperties ("generated " ++ enterScriptFile c) $ props + & scriptfile `File.hasContent` + [ "#!/usr/bin/perl" + , "# Generated by propellor" + , "my $pid=`machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2`;" + , "chomp $pid;" + , "if (length $pid) {" + , "\tforeach my $var (keys %ENV) {" + , "\t\tdelete $ENV{$var} unless $var eq 'PATH' || $var eq 'TERM';" + , "\t}" + , "\texec('nsenter', '-p', '-u', '-n', '-i', '-m', '-t', $pid, @ARGV);" + , "} else {" + , "\tdie 'container not running';" + , "}" + , "exit(1);" + ] + & scriptfile `File.mode` combineModes (readModes ++ executeModes) + teardown = File.notPresent scriptfile + scriptfile = enterScriptFile c + +enterScriptFile :: Container -> FilePath +enterScriptFile (Container name _ _ ) = "/usr/local/bin/enter-" ++ mungename name + +enterContainerProcess :: Container -> [String] -> IO (CreateProcess, IO ()) +enterContainerProcess c ps = pure (proc (enterScriptFile c) ps, noop) + +nspawnServiceName :: MachineName -> ServiceName +nspawnServiceName name = "systemd-nspawn@" ++ name ++ ".service" + +containerDir :: MachineName -> FilePath +containerDir name = "/var/lib/container" </> mungename name + +mungename :: MachineName -> String +mungename = replace "/" "_" + +-- | This configures how systemd-nspawn(1) starts the container, +-- by specifying a parameter, such as "--private-network", or +-- "--link-journal=guest" +-- +-- When there is no leading dash, "--" is prepended to the parameter. +-- +-- Reverting the property will remove a parameter, if it's present. +containerCfg :: String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +containerCfg p = RevertableProperty (mk True) (mk False) + where + mk b = tightenTargets $ + pureInfoProperty desc $ + mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] } + where + desc = "container configuration " ++ (if b then "" else "without ") ++ p' + p' = case p of + ('-':_) -> p + _ -> "--" ++ p + +-- | Bind mounts </etc/resolv.conf> from the host into the container. +-- +-- This property is enabled by default. Revert it to disable it. +resolvConfed :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +resolvConfed = containerCfg "bind=/etc/resolv.conf" + +-- | Link the container's journal to the host's if possible. +-- (Only works if the host has persistent journal enabled.) +-- +-- This property is enabled by default. Revert it to disable it. +linkJournal :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +linkJournal = containerCfg "link-journal=try-guest" + +-- | Disconnect networking of the container from the host. +privateNetwork :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +privateNetwork = containerCfg "private-network" + +class Publishable a where + toPublish :: a -> String + +instance Publishable Port where + toPublish port = fromPort port + +instance Publishable (Bound Port) where + toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v) + +data Proto = TCP | UDP + +instance Publishable (Proto, Bound Port) where + toPublish (TCP, fp) = "tcp:" ++ toPublish fp + toPublish (UDP, fp) = "udp:" ++ toPublish fp + +-- | Publish a port from the container to the host. +-- +-- This feature was first added in systemd version 220. +-- +-- This property is only needed (and will only work) if the container +-- is configured to use private networking. Also, networkd should be enabled +-- both inside the container, and on the host. For example: +-- +-- > foo :: Host +-- > foo = host "foo.example.com" +-- > & Systemd.nspawned webserver +-- > `requires` Systemd.running Systemd.networkd +-- > +-- > webserver :: Systemd.container +-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped mempty) +-- > & os (System (Debian Testing) "amd64") +-- > & Systemd.privateNetwork +-- > & Systemd.running Systemd.networkd +-- > & Systemd.publish (Port 80 ->- Port 8080) +-- > & Apt.installedRunning "apache2" +publish :: Publishable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +publish p = containerCfg $ "--port=" ++ toPublish p + +class Bindable a where + toBind :: a -> String + +instance Bindable FilePath where + toBind f = f + +instance Bindable (Bound FilePath) where + toBind v = hostSide v ++ ":" ++ containerSide v + +-- | Bind mount a file or directory from the host into the container. +bind :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +bind p = containerCfg $ "--bind=" ++ toBind p + +-- | Read-only mind mount. +bindRo :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) +bindRo p = containerCfg $ "--bind-ro=" ++ toBind p diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs new file mode 100644 index 00000000..0290bce5 --- /dev/null +++ b/src/Propellor/Property/Systemd/Core.hs @@ -0,0 +1,10 @@ +module Propellor.Property.Systemd.Core where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt + +-- dbus is only a Recommends of systemd, but is needed for communication +-- from the systemd inside a container to the one outside, so make sure it +-- gets installed. +installed :: Property DebianLike +installed = Apt.installed ["systemd", "dbus"] diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs index 409bb63e..92dbd507 100644 --- a/src/Propellor/Property/Tor.hs +++ b/src/Propellor/Property/Tor.hs @@ -1,20 +1,190 @@ +{-# LANGUAGE TypeFamilies #-} + module Propellor.Property.Tor where -import Propellor +import Propellor.Base import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.ConfFile as ConfFile +import Utility.FileMode +import Utility.DataUnits + +import System.Posix.Files +import Data.Char +import Data.List + +type HiddenServiceName = String + +type NodeName = String -isBridge :: Property -isBridge = setup `requires` Apt.installed ["tor"] +-- | Sets up a tor bridge. (Not a relay or exit node.) +-- +-- Uses port 443 +isBridge :: Property DebianLike +isBridge = configured + [ ("BridgeRelay", "1") + , ("Exitpolicy", "reject *:*") + , ("ORPort", "443") + ] `describe` "tor bridge" + `requires` server + +-- | Sets up a tor relay. +-- +-- Uses port 443 +isRelay :: Property DebianLike +isRelay = configured + [ ("BridgeRelay", "0") + , ("Exitpolicy", "reject *:*") + , ("ORPort", "443") + ] + `describe` "tor relay" + `requires` server + +-- | Makes the tor node be named, with a known private key. +-- +-- This can be moved to a different IP without needing to wait to +-- accumulate trust. +named :: NodeName -> Property (HasInfo + DebianLike) +named n = configured [("Nickname", n')] + `describe` ("tor node named " ++ n') + `requires` torPrivKey (Context ("tor " ++ n)) + where + n' = saneNickname n + +torPrivKey :: Context -> Property (HasInfo + DebianLike) +torPrivKey context = f `File.hasPrivContent` context + `onChange` File.ownerGroup f user (userGroup user) + `requires` torPrivKeyDirExists where - setup = "/etc/tor/torrc" `File.hasContent` - [ "SocksPort 0" - , "ORPort 443" - , "BridgeRelay 1" - , "Exitpolicy reject *:*" - ] `onChange` restarted + f = torPrivKeyDir </> "secret_id_key" + +torPrivKeyDirExists :: Property DebianLike +torPrivKeyDirExists = File.dirExists torPrivKeyDir + `onChange` setperms + `requires` installed + where + setperms = File.ownerGroup torPrivKeyDir user (userGroup user) + `before` File.mode torPrivKeyDir 0O2700 + +torPrivKeyDir :: FilePath +torPrivKeyDir = "/var/lib/tor/keys" + +-- | A tor server (bridge, relay, or exit) +-- Don't use if you just want to run tor for personal use. +server :: Property DebianLike +server = configured [("SocksPort", "0")] + `requires` installed + `requires` Apt.installed ["ntp"] + `describe` "tor server" + +installed :: Property DebianLike +installed = Apt.installed ["tor"] + +-- | Specifies configuration settings. Any lines in the config file +-- that set other values for the specified settings will be removed, +-- while other settings are left as-is. Tor is restarted when +-- configuration is changed. +configured :: [(String, String)] -> Property DebianLike +configured settings = File.fileProperty "tor configured" go mainConfig + `onChange` restarted + where + ks = map fst settings + go ls = sort $ map toconfig $ + filter (\(k, _) -> k `notElem` ks) (map fromconfig ls) + ++ settings + toconfig (k, v) = k ++ " " ++ v + fromconfig = separate (== ' ') + +data BwLimit + = PerSecond String + | PerDay String + | PerMonth String -restarted :: Property +-- | Limit incoming and outgoing traffic to the specified +-- amount each. +-- +-- For example, PerSecond "30 kibibytes" is the minimum limit +-- for a useful relay. +bandwidthRate :: BwLimit -> Property DebianLike +bandwidthRate (PerSecond s) = bandwidthRate' s 1 +bandwidthRate (PerDay s) = bandwidthRate' s (24*60*60) +bandwidthRate (PerMonth s) = bandwidthRate' s (31*24*60*60) + +bandwidthRate' :: String -> Integer -> Property DebianLike +bandwidthRate' s divby = case readSize dataUnits s of + Just sz -> let v = show (sz `div` divby) ++ " bytes" + in configured [("BandwidthRate", v)] + `describe` ("tor BandwidthRate " ++ v) + Nothing -> property ("unable to parse " ++ s) noChange + +hiddenServiceAvailable :: HiddenServiceName -> Int -> Property DebianLike +hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port + where + hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do + r <- satisfy + h <- liftIO $ readFile (varLib </> hn </> "hostname") + warningMessage $ unwords ["hidden service hostname:", h] + return r + +hiddenService :: HiddenServiceName -> Int -> Property DebianLike +hiddenService hn port = ConfFile.adjustSection + (unwords ["hidden service", hn, "available on port", show port]) + (== oniondir) + (not . isPrefixOf "HiddenServicePort") + (const [oniondir, onionport]) + (++ [oniondir, onionport]) + mainConfig + `onChange` restarted + where + oniondir = unwords ["HiddenServiceDir", varLib </> hn] + onionport = unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port] + +hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property (HasInfo + DebianLike) +hiddenServiceData hn context = combineProperties desc $ props + & installonion "hostname" + & installonion "private_key" + where + desc = unwords ["hidden service data available in", varLib </> hn] + installonion :: FilePath -> Property (HasInfo + DebianLike) + installonion f = withPrivData (PrivFile $ varLib </> hn </> f) context $ \getcontent -> + property' desc $ \w -> getcontent $ install w $ varLib </> hn </> f + install w f privcontent = ifM (liftIO $ doesFileExist f) + ( noChange + , ensureProperty w $ propertyList desc $ toProps + [ property desc $ makeChange $ do + createDirectoryIfMissing True (takeDirectory f) + writeFileProtected f (unlines (privDataLines privcontent)) + , File.mode (takeDirectory f) $ combineModes + [ownerReadMode, ownerWriteMode, ownerExecuteMode] + , File.ownerGroup (takeDirectory f) user (userGroup user) + , File.ownerGroup f user (userGroup user) + ] + ) + +restarted :: Property DebianLike restarted = Service.restarted "tor" + +mainConfig :: FilePath +mainConfig = "/etc/tor/torrc" + +varLib :: FilePath +varLib = "/var/lib/tor" + +varRun :: FilePath +varRun = "/var/run/tor" + +user :: User +user = User "debian-tor" + +type NickName = String + +-- | Convert String to a valid tor NickName. +saneNickname :: String -> NickName +saneNickname s + | null n = "unnamed" + | otherwise = n + where + legal c = isNumber c || isAsciiUpper c || isAsciiLower c + n = take 19 $ filter legal s diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs new file mode 100644 index 00000000..23a5b30d --- /dev/null +++ b/src/Propellor/Property/Unbound.hs @@ -0,0 +1,142 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> +-- +-- Properties for the Unbound caching DNS server + +module Propellor.Property.Unbound + ( installed + , restarted + , reloaded + , UnboundSection + , UnboundZone + , UnboundHost + , UnboundSetting + , UnboundValue + , UnboundKey + , ConfSection + , ZoneType + , cachingDnsServer + ) where + +import Propellor.Base +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +import Data.List (find) + + +type ConfSection = String + +type UnboundSetting = (UnboundKey, UnboundValue) + +type UnboundSection = (ConfSection, [UnboundSetting]) + +type UnboundZone = (BindDomain, ZoneType) + +type UnboundHost = (BindDomain, Record) + +type UnboundKey = String + +type UnboundValue = String + +type ZoneType = String + +installed :: Property DebianLike +installed = Apt.installed ["unbound"] + +restarted :: Property DebianLike +restarted = Service.restarted "unbound" + +reloaded :: Property DebianLike +reloaded = Service.reloaded "unbound" + +dValue :: BindDomain -> String +dValue (RelDomain d) = d +dValue (AbsDomain d) = d ++ "." +dValue (RootDomain) = "@" + +sectionHeader :: ConfSection -> String +sectionHeader header = header ++ ":" + +config :: FilePath +config = "/etc/unbound/unbound.conf.d/propellor.conf" + +-- | Provided a [UnboundSection], a [UnboundZone] and a [UnboundHost], +-- cachingDnsServer ensure unbound is configured accordingly. +-- +-- Example property: +-- +-- > cachingDnsServer +-- > [ ("remote-control", [("control-enable", "no")] +-- > , ("server", +-- > [ ("interface", "0.0.0.0") +-- > , ("access-control", "192.168.1.0/24 allow") +-- > , ("do-tcp", "no") +-- > ]) +-- > [ (AbsDomain "example.com", "transparent") +-- > , (AbsDomain $ reverseIP $ IPv4 "192.168.1", "static") +-- > ] +-- > [ (AbsDomain "example.com", Address $ IPv4 "192.168.1.2") +-- > , (AbsDomain "myhost.example.com", Address $ IPv4 "192.168.1.2") +-- > , (AbsDomain "myrouter.example.com", Address $ IPv4 "192.168.1.1") +-- > , (AbsDomain "www.example.com", Address $ IPv4 "192.168.1.2") +-- > , (AbsDomain "example.com", MX 10 "mail.example.com") +-- > , (AbsDomain "mylaptop.example.com", Address $ IPv4 "192.168.1.2") +-- > -- ^ connected via ethernet +-- > , (AbsDomain "mywifi.example.com", Address $ IPv4 "192.168.2.1") +-- > , (AbsDomain "mylaptop.example.com", Address $ IPv4 "192.168.2.2") +-- > -- ^ connected via wifi, use round robin +-- > , (AbsDomain "myhost.example.com", PTR $ reverseIP $ IPv4 "192.168.1.2") +-- > , (AbsDomain "myrouter.example.com", PTR $ reverseIP $ IPv4 "192.168.1.1") +-- > , (AbsDomain "mylaptop.example.com", PTR $ reverseIP $ IPv4 "192.168.1.2") +-- > ] +cachingDnsServer :: [UnboundSection] -> [UnboundZone] -> [UnboundHost] -> Property DebianLike +cachingDnsServer sections zones hosts = + config `hasContent` (comment : otherSections ++ serverSection) + `onChange` restarted + where + comment = "# deployed with propellor, do not modify" + serverSection = genSection (fromMaybe ("server", []) $ find ((== "server") . fst) sections) + ++ map genZone zones + ++ map (uncurry genRecord') hosts + otherSections = foldr ((++) . genSection) [] $ filter ((/= "server") . fst) sections + +genSection :: UnboundSection -> [Line] +genSection (section, settings) = sectionHeader section : map genSetting settings + +genSetting :: UnboundSetting -> Line +genSetting (key, value) = " " ++ key ++ ": " ++ value + +genZone :: UnboundZone -> Line +genZone (dom, zt) = " local-zone: \"" ++ dValue dom ++ "\" " ++ zt + +genRecord' :: BindDomain -> Record -> Line +genRecord' dom r = " local-data: \"" ++ fromMaybe "" (genRecord dom r) ++ "\"" + +genRecord :: BindDomain -> Record -> Maybe String +genRecord dom (Address addr) = Just $ genAddressNoTtl dom addr +genRecord dom (MX priority dest) = Just $ genMX dom priority dest +genRecord dom (PTR revip) = Just $ genPTR dom revip +genRecord _ (CNAME _) = Nothing +genRecord _ (NS _) = Nothing +genRecord _ (TXT _) = Nothing +genRecord _ (SRV _ _ _ _) = Nothing +genRecord _ (SSHFP _ _ _) = Nothing +genRecord _ (INCLUDE _) = Nothing + +genAddressNoTtl :: BindDomain -> IPAddr -> String +genAddressNoTtl dom = genAddress dom Nothing + +genAddress :: BindDomain -> Maybe Int -> IPAddr -> String +genAddress dom ttl addr = case addr of + IPv4 _ -> genAddress' "A" dom ttl addr + IPv6 _ -> genAddress' "AAAA" dom ttl addr + +genAddress' :: String -> BindDomain -> Maybe Int -> IPAddr -> String +genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> show ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ fromIPAddr addr + +genMX :: BindDomain -> Int -> BindDomain -> String +genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ show priority ++ " " ++ dValue dest + +genPTR :: BindDomain -> ReverseIP -> String +genPTR dom revip = revip ++ ". " ++ "PTR" ++ " " ++ dValue dom diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index f9c400a8..76eae647 100644 --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -2,61 +2,204 @@ module Propellor.Property.User where import System.Posix -import Propellor +import Propellor.Base +import qualified Propellor.Property.File as File data Eep = YesReallyDeleteHome -accountFor :: UserName -> Property -accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser" - [ "--disabled-password" - , "--gecos", "" - , user - ] - `describe` ("account for " ++ user) +accountFor :: User -> Property DebianLike +accountFor user@(User u) = tightenTargets $ check nohomedir go + `describe` ("account for " ++ u) + where + nohomedir = isNothing <$> catchMaybeIO (homedir user) + go = cmdProperty "adduser" + [ "--disabled-password" + , "--gecos", "" + , u + ] + +systemAccountFor :: User -> Property DebianLike +systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u)) + +systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property DebianLike +systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go + `describe` ("system account for " ++ u) + where + nouser = isNothing <$> catchMaybeIO (getUserEntryForName u) + go = cmdProperty "adduser" $ + [ "--system" ] + ++ + "--home" : maybe + ["/nonexistent", "--no-create-home"] + ( \h -> [ h ] ) + mhome + ++ + maybe [] ( \(Group g) -> ["--ingroup", g] ) mgroup + ++ + [ "--shell", "/usr/bin/nologin" + , "--disabled-login" + , "--disabled-password" + , u + ] -- | Removes user home directory!! Use with caution. -nuked :: UserName -> Eep -> Property -nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel" - [ "-r" - , user - ] - `describe` ("nuked user " ++ user) +nuked :: User -> Eep -> Property DebianLike +nuked user@(User u) _ = tightenTargets $ check hashomedir go + `describe` ("nuked user " ++ u) + where + hashomedir = isJust <$> catchMaybeIO (homedir user) + go = cmdProperty "userdel" + [ "-r" + , u + ] -- | Only ensures that the user has some password set. It may or may --- not be the password from the PrivData. -hasSomePassword :: UserName -> Context -> Property -hasSomePassword user context = check ((/= HasPassword) <$> getPasswordStatus user) $ - hasPassword user context - -hasPassword :: UserName -> Context -> Property -hasPassword user context = withPrivData (Password user) context $ \getpassword -> - property (user ++ " has password") $ - getpassword $ \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" - [ "--lock" - , user - ] - `describe` ("locked " ++ user ++ " password") +-- not be a password from the PrivData. +hasSomePassword :: User -> Property (HasInfo + DebianLike) +hasSomePassword user = hasSomePassword' user hostContext + +-- | While hasSomePassword uses the name of the host as context, +-- this allows specifying a different context. This is useful when +-- you want to use the same password on multiple hosts, for example. +hasSomePassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike) +hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $ + hasPassword' user context + +-- | Ensures that a user's password is set to a password from the PrivData. +-- (Will change any existing password.) +-- +-- A user's password can be stored in the PrivData in either of two forms; +-- the full cleartext <Password> or a <CryptPassword> hash. The latter +-- is obviously more secure. +hasPassword :: User -> Property (HasInfo + DebianLike) +hasPassword user = hasPassword' user hostContext + +hasPassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike) +hasPassword' (User u) context = go + `requires` shadowConfig True + where + go :: Property (HasInfo + UnixLike) + go = withSomePrivData srcs context $ + property (u ++ " has password") . setPassword + srcs = + [ PrivDataSource (CryptPassword u) + "a crypt(3)ed password, which can be generated by, for example: perl -e 'print crypt(shift, q{$6$}.shift)' 'somepassword' 'somesalt'" + , PrivDataSource (Password u) ("a password for " ++ u) + ] + +setPassword :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result +setPassword getpassword = getpassword $ go + where + go (Password user, password) = chpasswd (User user) (privDataVal password) [] + go (CryptPassword user, hash) = chpasswd (User user) (privDataVal hash) ["--encrypted"] + go (f, _) = error $ "Unexpected type of privdata: " ++ show f + +-- | Makes a user's password be the passed String. Highly insecure: +-- The password is right there in your config file for anyone to see! +hasInsecurePassword :: User -> String -> Property DebianLike +hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $ + chpasswd u p [] + +chpasswd :: User -> String -> [String] -> Propellor Result +chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuccess + (proc "chpasswd" ps) $ \h -> do + hPutStrLn h $ user ++ ":" ++ v + hClose h + +lockedPassword :: User -> Property DebianLike +lockedPassword user@(User u) = tightenTargets $ + check (not <$> isLockedPassword user) go + `describe` ("locked " ++ u ++ " password") + where + go = cmdProperty "passwd" + [ "--lock" + , u + ] data PasswordStatus = NoPassword | LockedPassword | HasPassword deriving (Eq) -getPasswordStatus :: UserName -> IO PasswordStatus -getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user] +getPasswordStatus :: User -> IO PasswordStatus +getPasswordStatus (User u) = parse . words <$> readProcess "passwd" ["-S", u] where parse (_:"L":_) = LockedPassword parse (_:"NP":_) = NoPassword parse (_:"P":_) = HasPassword parse _ = NoPassword -isLockedPassword :: UserName -> IO Bool +isLockedPassword :: User -> IO Bool isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user -homedir :: UserName -> IO FilePath -homedir user = homeDirectory <$> getUserEntryForName user +homedir :: User -> IO FilePath +homedir (User user) = homeDirectory <$> getUserEntryForName user + +hasGroup :: User -> Group -> Property DebianLike +hasGroup (User user) (Group group') = tightenTargets $ check test go + `describe` unwords ["user", user, "in group", group'] + where + test = not . elem group' . words <$> readProcess "groups" [user] + go = cmdProperty "adduser" + [ user + , group' + ] + +-- | Gives a user access to the secondary groups, including audio and +-- video, that the OS installer normally gives a desktop user access to. +-- +-- Note that some groups may only exit after installation of other +-- software. When a group does not exist yet, the user won't be added to it. +hasDesktopGroups :: User -> Property DebianLike +hasDesktopGroups user@(User u) = property' desc $ \o -> do + existinggroups <- map (fst . break (== ':')) . lines + <$> liftIO (readFile "/etc/group") + let toadd = filter (`elem` existinggroups) desktopgroups + ensureProperty o $ propertyList desc $ toProps $ + map (hasGroup user . Group) toadd + where + desc = "user " ++ u ++ " is in standard desktop groups" + -- This list comes from user-setup's debconf + -- template named "passwd/user-default-groups" + desktopgroups = + [ "audio" + , "cdrom" + , "dip" + , "floppy" + , "video" + , "plugdev" + , "netdev" + , "scanner" + , "bluetooth" + , "debian-tor" + , "lpadmin" + ] + +-- | Controls whether shadow passwords are enabled or not. +shadowConfig :: Bool -> Property DebianLike +shadowConfig True = tightenTargets $ check (not <$> shadowExists) + (cmdProperty "shadowconfig" ["on"]) + `describe` "shadow passwords enabled" +shadowConfig False = tightenTargets $ check shadowExists + (cmdProperty "shadowconfig" ["off"]) + `describe` "shadow passwords disabled" + +shadowExists :: IO Bool +shadowExists = doesFileExist "/etc/shadow" + +-- | Ensures that a user has a specified login shell, and that the shell +-- is enabled in /etc/shells. +hasLoginShell :: User -> FilePath -> Property DebianLike +hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabled loginshell + +shellSetTo :: User -> FilePath -> Property DebianLike +shellSetTo (User u) loginshell = tightenTargets $ check needchangeshell + (cmdProperty "chsh" ["--shell", loginshell, u]) + `describe` (u ++ " has login shell " ++ loginshell) + where + needchangeshell = do + currshell <- userShell <$> getUserEntryForName u + return (currshell /= loginshell) + +-- | Ensures that /etc/shells contains a shell. +shellEnabled :: FilePath -> Property DebianLike +shellEnabled loginshell = tightenTargets $ + "/etc/shells" `File.containsLine` loginshell diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs new file mode 100644 index 00000000..4eb94103 --- /dev/null +++ b/src/Propellor/Property/Uwsgi.hs @@ -0,0 +1,49 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> + +module Propellor.Property.Uwsgi where + +import Propellor.Base +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +type ConfigFile = [String] + +type AppName = String + +appEnabled :: AppName -> ConfigFile -> RevertableProperty DebianLike DebianLike +appEnabled an cf = enable <!> disable + where + enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an + `describe` ("uwsgi app enabled " ++ an) + `requires` appAvailable an cf + `requires` installed + `onChange` reloaded + disable = File.notPresent (appVal an) + `describe` ("uwsgi app disable" ++ an) + `requires` installed + `onChange` reloaded + +appAvailable :: AppName -> ConfigFile -> Property DebianLike +appAvailable an cf = ("uwsgi app available " ++ an) ==> + tightenTargets (appCfg an `File.hasContent` (comment : cf)) + where + comment = "# deployed with propellor, do not modify" + +appCfg :: AppName -> FilePath +appCfg an = "/etc/uwsgi/apps-available" </> an <.> "ini" + +appVal :: AppName -> FilePath +appVal an = "/etc/uwsgi/apps-enabled/" </> an <.> "ini" + +appValRelativeCfg :: AppName -> File.LinkTarget +appValRelativeCfg an = File.LinkTarget $ "../apps-available" </> an <.> "ini" + +installed :: Property DebianLike +installed = Apt.installed ["uwsgi"] + +restarted :: Property DebianLike +restarted = Service.restarted "uwsgi" + +reloaded :: Property DebianLike +reloaded = Service.reloaded "uwsgi" diff --git a/src/Propellor/Property/ZFS.hs b/src/Propellor/Property/ZFS.hs new file mode 100644 index 00000000..7118a515 --- /dev/null +++ b/src/Propellor/Property/ZFS.hs @@ -0,0 +1,11 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- ZFS properties + +module Propellor.Property.ZFS ( + module Propellor.Property.ZFS.Properties, + module Propellor.Types.ZFS +) where + +import Propellor.Property.ZFS.Properties +import Propellor.Types.ZFS diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs new file mode 100644 index 00000000..372bac6d --- /dev/null +++ b/src/Propellor/Property/ZFS/Process.hs @@ -0,0 +1,32 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- Functions running zfs processes. + +module Propellor.Property.ZFS.Process where + +import Propellor.Base +import Data.String.Utils (split) +import Data.List + +-- | Gets the properties of a ZFS volume. +zfsGetProperties :: ZFS -> IO ZFSProperties +zfsGetProperties z = + let plist = fromPropertyList . map (\(_:k:v:_) -> (k, v)) . (map (split "\t")) + in plist <$> runZfs "get" [Just "-H", Just "-p", Just "all"] z + +zfsExists :: ZFS -> IO Bool +zfsExists z = any id . map (isInfixOf (zfsName z)) + <$> runZfs "list" [Just "-H"] z + +-- | Runs the zfs command with the arguments. +-- +-- Runs the command with -H which will skip the header line and +-- separate all fields with tabs. +-- +-- Replaces Nothing in the argument list with the ZFS pool/dataset. +runZfs :: String -> [Maybe String] -> ZFS -> IO [String] +runZfs cmd args z = lines <$> uncurry readProcess (zfsCommand cmd args z) + +-- | Return the ZFS command line suitable for readProcess or cmdProperty. +zfsCommand :: String -> [Maybe String] -> ZFS -> (String, [String]) +zfsCommand cmd args z = ("zfs", cmd:(map (maybe (zfsName z) id) args)) diff --git a/src/Propellor/Property/ZFS/Properties.hs b/src/Propellor/Property/ZFS/Properties.hs new file mode 100644 index 00000000..47d5a9d1 --- /dev/null +++ b/src/Propellor/Property/ZFS/Properties.hs @@ -0,0 +1,40 @@ +-- | Maintainer: 2016 Evan Cofsky <evan@theunixman.com> +-- +-- Functions defining zfs Properties. + +module Propellor.Property.ZFS.Properties ( + ZFSOS, + zfsExists, + zfsSetProperties +) where + +import Propellor.Base +import Data.List (intercalate) +import qualified Propellor.Property.ZFS.Process as ZP + +-- | OS's that support ZFS +type ZFSOS = Linux + FreeBSD + +-- | Will ensure that a ZFS volume exists with the specified mount point. +-- This requires the pool to exist as well, but we don't create pools yet. +zfsExists :: ZFS -> Property ZFSOS +zfsExists z = check (not <$> ZP.zfsExists z) create + `describe` unwords ["Creating", zfsName z] + where + (p, a) = ZP.zfsCommand "create" [Nothing] z + create = cmdProperty p a + +-- | Sets the given properties. Returns True if all were successfully changed, False if not. +zfsSetProperties :: ZFS -> ZFSProperties -> Property ZFSOS +zfsSetProperties z setProperties = setall + `requires` zfsExists z + where + spcmd :: String -> String -> (String, [String]) + spcmd p v = ZP.zfsCommand "set" [Just (intercalate "=" [p, v]), Nothing] z + + setprop :: (String, String) -> Property ZFSOS + setprop (p, v) = check (ZP.zfsExists z) $ + cmdProperty (fst (spcmd p v)) (snd (spcmd p v)) + + setall = combineProperties (unwords ["Setting properties on", zfsName z]) $ + toProps $ map setprop $ toPropertyList setProperties diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs new file mode 100644 index 00000000..e90155f3 --- /dev/null +++ b/src/Propellor/Protocol.hs @@ -0,0 +1,72 @@ +-- | This is a simple line-based protocol used for communication between +-- a local and remote propellor. It's sent over a ssh channel, and lines of +-- the protocol can be interspersed with other, non-protocol lines +-- that should be passed through to be displayed. +-- +-- Avoid making backwards-incompatible changes to this protocol, +-- since propellor needs to use this protocol to update itself to new +-- versions speaking newer versions of the protocol. + +module Propellor.Protocol where + +import Data.List + +import Propellor.Base + +data Stage = NeedGitClone | NeedRepoUrl | NeedPrivData | NeedGitPush | NeedPrecompiled + deriving (Read, Show, Eq) + +type Marker = String +type Marked = String + +statusMarker :: Marker +statusMarker = "STATUS" + +privDataMarker :: String +privDataMarker = "PRIVDATA " + +repoUrlMarker :: String +repoUrlMarker = "REPOURL " + +gitPushMarker :: String +gitPushMarker = "GITPUSH" + +toMarked :: Marker -> String -> String +toMarked = (++) + +fromMarked :: Marker -> Marked -> Maybe String +fromMarked marker s + | marker `isPrefixOf` s = Just $ drop (length marker) s + | otherwise = Nothing + +sendMarked :: Handle -> Marker -> String -> IO () +sendMarked h marker s = do + debug ["sent marked", marker] + sendMarked' h marker s + +sendMarked' :: Handle -> Marker -> String -> IO () +sendMarked' h marker s = do + -- Prefix string with newline because sometimes a + -- incomplete line has been output, and the marker needs to + -- come at the start of a line. + hPutStrLn h ("\n" ++ toMarked marker s) + hFlush h + +getMarked :: Handle -> Marker -> IO (Maybe String) +getMarked h marker = go =<< catchMaybeIO (hGetLine h) + where + go Nothing = return Nothing + go (Just l) = case fromMarked marker l of + Nothing -> do + unless (null l) $ + hPutStrLn stderr l + getMarked h marker + Just v -> do + debug ["received marked", marker] + return (Just v) + +req :: Stage -> Marker -> (String -> IO ()) -> IO () +req stage marker a = do + debug ["requested marked", marker] + sendMarked' stdout statusMarker (show stage) + maybe noop a =<< getMarked stdin marker diff --git a/src/Propellor/Property/Docker/Shim.hs b/src/Propellor/Shim.hs index c2f35d0c..27545afb 100644 --- a/src/Propellor/Property/Docker/Shim.hs +++ b/src/Propellor/Shim.hs @@ -1,23 +1,26 @@ --- | Support for running propellor, as built outside a docker container, --- inside the container. +-- | Support for running propellor, as built outside a container, +-- inside the container, without needing to install anything into the +-- container. -- -- Note: This is currently Debian specific, due to glibcLibs. -module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where +module Propellor.Shim (setup, cleanEnv, file) where -import Propellor +import Propellor.Base import Utility.LinuxMkLibs -import Utility.SafeCommand -import Utility.Path import Utility.FileMode +import Utility.FileSystemEncoding import Data.List import System.Posix.Files -- | Sets up a shimmed version of the program, in a directory, and -- returns its path. -setup :: FilePath -> FilePath -> IO FilePath -setup propellorbin dest = do +-- +-- Propellor may be running from an existing shim, in which case it's +-- simply reused. +setup :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath +setup propellorbin propellorbinpath dest = checkAlreadyShimmed shim $ do createDirectoryIfMissing True dest libs <- parseLdd <$> readProcess "ldd" [propellorbin] @@ -29,21 +32,41 @@ setup propellorbin dest = do let linker = (dest ++) $ fromMaybe (error "cannot find ld-linux linker") $ headMaybe $ filter ("ld-linux" `isInfixOf`) libs' - let gconvdir = (dest ++) $ parentDir $ + let linkersym = takeDirectory linker </> takeFileName propellorbin + createSymbolicLink (takeFileName linker) linkersym + + let gconvdir = (dest ++) $ takeDirectory $ fromMaybe (error "cannot find gconv directory") $ headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs let linkerparams = ["--library-path", intercalate ":" libdirs ] - let shim = file propellorbin dest writeFile shim $ unlines - [ "#!/bin/sh" + [ shebang , "GCONV_PATH=" ++ shellEscape gconvdir , "export GCONV_PATH" - , "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ - " " ++ shellEscape propellorbin ++ " \"$@\"" + , "exec " ++ unwords (map shellEscape $ linkersym : linkerparams) ++ + " " ++ shellEscape (fromMaybe propellorbin propellorbinpath) ++ " \"$@\"" ] modifyFileMode shim (addModes executeModes) return shim + where + shim = file propellorbin dest + +shebang :: String +shebang = "#!/bin/sh" + +checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath +checkAlreadyShimmed f nope = ifM (doesFileExist f) + ( withFile f ReadMode $ \h -> do + fileEncoding h + s <- hGetLine h + if s == shebang + then return f + else nope + , nope + ) +-- Called when the shimmed propellor is running, so that commands it runs +-- don't see it. cleanEnv :: IO () cleanEnv = void $ unsetEnv "GCONV_PATH" @@ -54,8 +77,8 @@ installFile :: FilePath -> FilePath -> IO () installFile top f = do createDirectoryIfMissing True destdir nukeFile dest - createLink f dest `catchIO` (const copy) + createLink f dest `catchIO` const copy where copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest] - destdir = inTop top $ parentDir f + destdir = inTop top $ takeDirectory f dest = inTop top f diff --git a/src/Propellor/SimpleSh.hs b/src/Propellor/SimpleSh.hs deleted file mode 100644 index cc5c62cd..00000000 --- a/src/Propellor/SimpleSh.hs +++ /dev/null @@ -1,101 +0,0 @@ --- | Simple server, using a named pipe. Client connects, sends a command, --- and gets back all the output from the command, in a stream. --- --- This is useful for eg, docker. - -module Propellor.SimpleSh where - -import Network.Socket -import Control.Concurrent -import Control.Concurrent.Async -import System.Process (std_in, std_out, std_err) - -import Propellor -import Utility.FileMode -import Utility.ThreadScheduler - -data Cmd = Cmd String [String] - deriving (Read, Show) - -data Resp = StdoutLine String | StderrLine String | Done - deriving (Read, Show) - -simpleSh :: FilePath -> IO () -simpleSh namedpipe = do - nukeFile namedpipe - let dir = takeDirectory namedpipe - createDirectoryIfMissing True dir - modifyFileMode dir (removeModes otherGroupModes) - s <- socket AF_UNIX Stream defaultProtocol - bindSocket s (SockAddrUnix namedpipe) - listen s 2 - forever $ do - (client, _addr) <- accept s - forkIO $ do - h <- socketToHandle client ReadWriteMode - maybe noop (run h) . readish =<< hGetLine h - where - run h (Cmd cmd params) = do - chan <- newChan - let runwriter = do - v <- readChan chan - hPutStrLn h (show v) - hFlush h - case v of - Done -> noop - _ -> runwriter - writer <- async runwriter - - flip catchIO (\_e -> writeChan chan Done) $ do - let p = (proc cmd params) - { std_in = Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } - (Nothing, Just outh, Just errh, pid) <- createProcess p - - let mkreader t from = maybe noop (const $ mkreader t from) - =<< catchMaybeIO (writeChan chan . t =<< hGetLine from) - void $ concurrently - (mkreader StdoutLine outh) - (mkreader StderrLine errh) - - void $ tryIO $ waitForProcess pid - - writeChan chan Done - - hClose outh - hClose errh - - wait writer - hClose h - -simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a -simpleShClient namedpipe cmd params handler = do - s <- socket AF_UNIX Stream defaultProtocol - connect s (SockAddrUnix namedpipe) - h <- socketToHandle s ReadWriteMode - hPutStrLn h $ show $ Cmd cmd params - hFlush h - resps <- catMaybes . map readish . lines <$> hGetContents h - v <- hClose h `after` handler resps - return v - -simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a -simpleShClientRetry retries namedpipe cmd params handler = go retries - where - run = simpleShClient namedpipe cmd params handler - go n - | n < 1 = run - | otherwise = do - v <- tryIO run - case v of - Right r -> return r - Left e -> do - debug ["simplesh connection retry", show e] - threadDelaySeconds (Seconds 1) - go (n - 1) - -getStdout :: Resp -> Maybe String -getStdout (StdoutLine s) = Just s -getStdout _ = Nothing diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs new file mode 100644 index 00000000..c6699961f --- /dev/null +++ b/src/Propellor/Spin.hs @@ -0,0 +1,390 @@ +{-# Language ScopedTypeVariables #-} + +module Propellor.Spin ( + commitSpin, + spin, + spin', + update, + gitPushHelper, + mergeSpin, +) where + +import Data.List +import System.Exit +import System.PosixCompat +import System.Posix.IO +import System.Posix.Directory +import Control.Concurrent.Async +import qualified Data.ByteString as B +import qualified Data.Set as S +import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr) + +import Propellor.Base +import Propellor.Protocol +import Propellor.PrivData.Paths +import Propellor.Git +import Propellor.Git.Config +import Propellor.Ssh +import Propellor.Gpg +import Propellor.Bootstrap +import Propellor.Types.CmdLine +import Propellor.Types.Info +import qualified Propellor.Shim as Shim +import Utility.FileMode +import Utility.SafeCommand +import Utility.Process.NonConcurrent + +commitSpin :: IO () +commitSpin = do + -- safety check #1: check we're on the configured spin branch + spinBranch <- getGitConfigValue "propellor.spin-branch" + case spinBranch of + Nothing -> return () -- just a noop + Just b -> do + currentBranch <- getCurrentBranch + when (b /= currentBranch) $ + error ("spin aborted: check out " + ++ b ++ " branch first") + + -- safety check #2: check we can commit with a dirty tree + noDirtySpin <- getGitConfigBool "propellor.forbid-dirty-spin" + when noDirtySpin $ do + status <- takeWhile (/= '\n') + <$> readProcess "git" ["status", "--porcelain"] + when (not . null $ status) $ + error "spin aborted: commit changes first" + + void $ actionMessage "Git commit" $ + gitCommit (Just spinCommitMessage) + [Param "--allow-empty", Param "-a"] + -- Push to central origin repo first, if possible. + -- The remote propellor will pull from there, which avoids + -- us needing to send stuff directly to the remote host. + whenM hasOrigin $ + void $ actionMessage "Push to central git repository" $ + boolSystemNonConcurrent "git" [Param "push"] + +spin :: Maybe HostName -> HostName -> Host -> IO () +spin = spin' Nothing + +spin' :: Maybe PrivMap -> Maybe HostName -> HostName -> Host -> IO () +spin' mprivdata relay target hst = do + cacheparams <- if viarelay + then pure ["-A"] + else toCommand <$> sshCachingParams hn + when viarelay $ + void $ boolSystem "ssh-add" [] + + sshtarget <- ("root@" ++) <$> case relay of + Just r -> pure r + Nothing -> getSshTarget target hst + + -- Install, or update the remote propellor. + updateServer target relay hst + (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd]) + (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd]) + =<< getprivdata + + -- And now we can run it. + unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ + error "remote propellor failed" + where + hn = fromMaybe target relay + sys = case fromInfo (hostInfo hst) of + InfoVal o -> Just o + NoInfoVal -> Nothing + + relaying = relay == Just target + viarelay = isJust relay && not relaying + + probecmd = intercalate " ; " + [ "if [ ! -d " ++ localdir ++ "/.git ]" + , "then (" ++ intercalate " && " + [ installGitCommand sys + , "echo " ++ toMarked statusMarker (show NeedGitClone) + ] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled) + , "else " ++ updatecmd + , "fi" + ] + + updatecmd = intercalate " && " + [ "cd " ++ localdir + , bootstrapPropellorCommand sys + , if viarelay + then "./propellor --continue " ++ + shellEscape (show (Relay target)) + -- Still using --boot for back-compat... + else "./propellor --boot " ++ target + ] + + runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd + cmd = "--serialized " ++ shellEscape (show cmdline) + cmdline + | viarelay = Spin [target] (Just target) + | otherwise = SimpleRun target + + getprivdata = case mprivdata of + Nothing + | relaying -> do + let f = privDataRelay hn + d <- readPrivDataFile f + nukeFile f + return d + | otherwise -> + filterPrivData hst <$> decryptPrivData + Just pd -> pure pd + +-- Check if the Host contains an IP address that matches one of the IPs +-- in the DNS for the HostName. If so, the HostName is used as-is, +-- but if the DNS is out of sync with the Host config, or doesn't have +-- the host in it at all, use one of the Host's IPs instead. +getSshTarget :: HostName -> Host -> IO String +getSshTarget target hst + | null configips = return target + | otherwise = go =<< tryIO (dnslookup target) + where + go (Left e) = useip (show e) + go (Right addrinfos) = do + configaddrinfos <- catMaybes <$> mapM iptoaddr configips + if any (`elem` configaddrinfos) (map addrAddress addrinfos) + then return target + else useip ("DNS lookup did not return any of the expected addresses " ++ show configips) + + dnslookup h = getAddrInfo (Just $ defaultHints { addrFlags = [AI_CANONNAME] }) (Just h) Nothing + + -- Convert a string containing an IP address into a SockAddr. + iptoaddr :: String -> IO (Maybe SockAddr) + iptoaddr ip = catchDefaultIO Nothing $ headMaybe . map addrAddress + <$> getAddrInfo (Just $ defaultHints { addrFlags = [AI_NUMERICHOST] }) (Just ip) Nothing + + useip why = case headMaybe configips of + Nothing -> return target + Just ip -> do + -- If we're being asked to run on the local host, + -- ignore DNS. + s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] + if s == target + then return target + else do + warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead." + return ip + + configips = map fromIPAddr $ mapMaybe getIPAddr $ + S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst + +-- Update the privdata, repo url, and git repo over the ssh +-- connection, talking to the user's local propellor instance which is +-- running the updateServer +update :: Maybe HostName -> IO () +update forhost = do + whenM hasGitRepo $ + req NeedRepoUrl repoUrlMarker setRepoUrl + + makePrivDataDir + createDirectoryIfMissing True (takeDirectory privfile) + req NeedPrivData privDataMarker $ + writeFileProtected privfile + + whenM hasGitRepo $ + req NeedGitPush gitPushMarker $ \_ -> do + hin <- dup stdInput + hout <- dup stdOutput + hClose stdin + hClose stdout + -- Not using git pull because git 2.5.0 badly + -- broke its option parser. + unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $ + errorMessage "git fetch from client failed" + unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $ + errorMessage "git merge from client failed" + where + pullparams hin hout = + [ Param "fetch" + , Param "--progress" + , Param "--upload-pack" + , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout + , Param "." + ] + + -- When --spin --relay is run, get a privdata file + -- to be relayed to the target host. + privfile = maybe privDataLocal privDataRelay forhost + +updateServer + :: HostName + -> Maybe HostName + -> Host + -> CreateProcess + -> CreateProcess + -> PrivMap + -> IO () +updateServer target relay hst connect haveprecompiled privdata = do + (Just toh, Just fromh, _, pid) <- createProcessNonConcurrent $ connect + { std_in = CreatePipe + , std_out = CreatePipe + } + go (toh, fromh) + forceSuccessProcess' connect =<< waitForProcessNonConcurrent pid + where + hn = fromMaybe target relay + + go (toh, fromh) = do + let loop = go (toh, fromh) + let restart = updateServer hn relay hst connect haveprecompiled privdata + let done = return () + v <- maybe Nothing readish <$> getMarked fromh statusMarker + case v of + (Just NeedRepoUrl) -> do + sendRepoUrl toh + loop + (Just NeedPrivData) -> do + sendPrivData hn toh privdata + loop + (Just NeedGitClone) -> do + hClose toh + hClose fromh + sendGitClone hn + restart + (Just NeedPrecompiled) -> do + hClose toh + hClose fromh + sendPrecompiled hn + updateServer hn relay hst haveprecompiled (error "loop") privdata + (Just NeedGitPush) -> do + sendGitUpdate hn fromh toh + hClose fromh + hClose toh + done + Nothing -> done + +sendRepoUrl :: Handle -> IO () +sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl) + +sendPrivData :: HostName -> Handle -> PrivMap -> IO () +sendPrivData hn toh privdata = void $ actionMessage msg $ do + sendMarked toh privDataMarker d + return True + where + msg = "Sending privdata (" ++ show (length d) ++ " bytes) to " ++ hn + d = show privdata + +sendGitUpdate :: HostName -> Handle -> Handle -> IO () +sendGitUpdate hn fromh toh = + void $ actionMessage ("Sending git update to " ++ hn) $ do + sendMarked toh gitPushMarker "" + (Nothing, Nothing, Nothing, h) <- createProcess p + (==) ExitSuccess <$> waitForProcess h + where + p = (proc "git" ["upload-pack", "."]) + { std_in = UseHandle fromh + , std_out = UseHandle toh + } + +-- Initial git clone, used for bootstrapping. +sendGitClone :: HostName -> IO () +sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do + branch <- getCurrentBranch + cacheparams <- sshCachingParams hn + withTmpFile "propellor.git" $ \tmp _ -> allM id + [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] + , boolSystemNonConcurrent "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] + , boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] + ] + where + remotebundle = "/usr/local/propellor.git" + unpackcmd branch = shellWrap $ intercalate " && " + [ "git clone " ++ remotebundle ++ " " ++ localdir + , "cd " ++ localdir + , "git checkout -b " ++ branch + , "git remote rm origin" + , "rm -f " ++ remotebundle + ] + +-- Send a tarball containing the precompiled propellor, and libraries. +-- This should be reasonably portable, as long as the remote host has the +-- same architecture as the build host. +sendPrecompiled :: HostName -> IO () +sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor as a last resort" $ + bracket getWorkingDirectory changeWorkingDirectory $ \_ -> + withTmpDir "propellor" go + where + go tmpdir = do + cacheparams <- sshCachingParams hn + let shimdir = takeFileName localdir + createDirectoryIfMissing True (tmpdir </> shimdir) + changeWorkingDirectory (tmpdir </> shimdir) + me <- readSymbolicLink "/proc/self/exe" + createDirectoryIfMissing True "bin" + unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $ + errorMessage "failed copying in propellor" + let bin = "bin/propellor" + let binpath = Just $ localdir </> bin + void $ Shim.setup bin binpath "." + changeWorkingDirectory tmpdir + withTmpFile "propellor.tar." $ \tarball _ -> allM id + [ boolSystem "strip" [File me] + , boolSystem "tar" [Param "czf", File tarball, File shimdir] + , boolSystemNonConcurrent "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)] + , boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd] + ] + + remotetarball = "/usr/local/propellor.tar" + + unpackcmd = shellWrap $ intercalate " && " + [ "cd " ++ takeDirectory remotetarball + , "tar xzf " ++ remotetarball + , "rm -f " ++ remotetarball + ] + +-- Shim for git push over the propellor ssh channel. +-- Reads from stdin and sends it to hout; +-- reads from hin and sends it to stdout. +gitPushHelper :: Fd -> Fd -> IO () +gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout + where + fromstdin = do + h <- fdToHandle hout + connect stdin h + tostdout = do + h <- fdToHandle hin + connect h stdout + connect fromh toh = do + hSetBinaryMode fromh True + hSetBinaryMode toh True + b <- B.hGetSome fromh 40960 + if B.null b + then do + hClose fromh + hClose toh + else do + B.hPut toh b + hFlush toh + connect fromh toh + +mergeSpin :: IO () +mergeSpin = do + branch <- getCurrentBranch + branchref <- getCurrentBranchRef + old_head <- getCurrentGitSha1 branch + old_commit <- findLastNonSpinCommit + rungit "reset" [Param old_commit] + unlessM (gitCommit Nothing [Param "-a", Param "--allow-empty"]) $ + error "git commit failed" + rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head, Param "--no-edit"] + current_commit <- getCurrentGitSha1 branch + rungit "update-ref" [Param branchref, Param current_commit] + rungit "checkout" [Param branch] + where + rungit cmd ps = unlessM (boolSystem "git" (Param cmd:ps)) $ + error ("git " ++ cmd ++ " failed") + +findLastNonSpinCommit :: IO String +findLastNonSpinCommit = do + commits <- map (separate (== ' ')) . lines + <$> readProcess "git" ["log", "--oneline", "--no-abbrev-commit"] + case dropWhile (\(_, msg) -> msg == spinCommitMessage) commits of + ((sha, _):_) -> return sha + _ -> error $ "Did not find any previous commit that was not a " ++ show spinCommitMessage + +spinCommitMessage :: String +spinCommitMessage = "propellor spin" diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs new file mode 100644 index 00000000..a7a9452e --- /dev/null +++ b/src/Propellor/Ssh.hs @@ -0,0 +1,79 @@ +module Propellor.Ssh where + +import Propellor.Base +import Utility.UserInfo +import Utility.FileSystemEncoding + +import System.PosixCompat +import Data.Time.Clock.POSIX +import qualified Data.Hash.MD5 as MD5 + +-- Parameters can be passed to both ssh and scp, to enable a ssh connection +-- caching socket. +-- +-- If the socket already exists, check if its mtime is older than 10 +-- minutes, and if so stop that ssh process, in order to not try to +-- use an old stale connection. (atime would be nicer, but there's +-- a good chance a laptop uses noatime) +sshCachingParams :: HostName -> IO [CommandParam] +sshCachingParams hn = do + home <- myHomeDir + let socketfile = socketFile home hn + createDirectoryIfMissing False (takeDirectory socketfile) + let ps = + [ Param "-o" + , Param ("ControlPath=" ++ socketfile) + , Param "-o", Param "ControlMaster=auto" + , Param "-o", Param "ControlPersist=yes" + ] + + maybe noop (expireold ps socketfile) + =<< catchMaybeIO (getFileStatus socketfile) + + return ps + + where + expireold ps f s = do + now <- truncate <$> getPOSIXTime :: IO Integer + if modificationTime s > fromIntegral now - tenminutes + then touchFile f + else do + void $ boolSystem "ssh" $ + [ Param "-O", Param "stop" ] ++ ps ++ + [ Param "localhost" ] + nukeFile f + tenminutes = 600 + +-- Generate a socket filename inside the home directory. +-- +-- There's a limit in the size of unix domain sockets, of approximately +-- 100 bytes. Try to never construct a filename longer than that. +-- +-- When space allows, include the full hostname in the socket filename. +-- Otherwise, include at least a partial md5sum of it, +-- to avoid using the same socket file for multiple hosts. +socketFile :: FilePath -> HostName -> FilePath +socketFile home hn = selectSocketFile + [ sshdir </> hn ++ ".sock" + , sshdir </> hn + , sshdir </> take 10 hn ++ "-" ++ md5 + , sshdir </> md5 + , home </> ".propellor-" ++ md5 + ] + (".propellor-" ++ md5) + where + sshdir = home </> ".ssh" </> "propellor" + md5 = take 9 $ MD5.md5s $ MD5.Str hn + +selectSocketFile :: [FilePath] -> FilePath -> FilePath +selectSocketFile [] d = d +selectSocketFile [f] _ = f +selectSocketFile (f:fs) d + | valid_unix_socket_path f = f + | otherwise = selectSocketFile fs d + +valid_unix_socket_path :: FilePath -> Bool +valid_unix_socket_path f = length (decodeW8 f) < 100 - reservedbyssh + where + -- ssh tacks on 17 or so characters when making a socket + reservedbyssh = 18 diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index b606cef2..6d6b14ea 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -1,149 +1,197 @@ -{-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Propellor.Types - ( Host(..) - , Info - , getInfo - , Propellor(..) +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Propellor.Types ( + -- * Core data types + Host(..) , Property(..) - , RevertableProperty(..) - , IsProp - , describe - , toProp - , requires + , property , Desc - , Result(..) - , ActionResult(..) - , CmdLine(..) - , PrivDataField(..) - , PrivData - , Context(..) - , anyContext - , SshKeyType(..) + , RevertableProperty(..) + , (<!>) + , Propellor(..) + , LiftPropellor(..) + , Info + -- * Types of properties + , UnixLike + , Linux + , DebianLike + , Debian + , Buntish + , FreeBSD + , HasInfo + , type (+) + , TightenTargets(..) + -- * Combining and modifying properties + , Combines(..) + , CombinedType + , ResultCombiner + , adjustPropertySatisfy + -- * Other included types , module Propellor.Types.OS , module Propellor.Types.Dns + , module Propellor.Types.Result + , module Propellor.Types.ZFS ) where import Data.Monoid -import Control.Applicative -import System.Console.ANSI -import "mtl" Control.Monad.Reader -import "MonadCatchIO-transformers" Control.Monad.CatchIO +import Propellor.Types.Core import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns -import Propellor.Types.PrivData - --- | Everything Propellor knows about a system: Its hostname, --- properties and other info. -data Host = Host - { hostName :: HostName - , hostProperties :: [Property] - , hostInfo :: Info - } - deriving (Show) - --- | Propellor's monad provides read-only access to info about the host --- it's running on. -newtype Propellor p = Propellor { runWithHost :: ReaderT Host IO p } - deriving - ( Monad - , Functor - , Applicative - , MonadReader Host - , MonadIO - , MonadCatchIO - ) +import Propellor.Types.Result +import Propellor.Types.MetaTypes +import Propellor.Types.ZFS -- | The core data type of Propellor, this represents a property --- that the system should have, and an action to ensure it has the --- property. -data Property = Property - { propertyDesc :: Desc - , propertySatisfy :: Propellor Result - -- ^ must be idempotent; may run repeatedly - , propertyInfo :: Info - -- ^ a property can add info to the host. +-- that the system should have, with a descrition, and an action to ensure +-- it has the property. +-- that have the property. +-- +-- There are different types of properties that target different OS's, +-- and so have different metatypes. +-- For example: "Property DebianLike" and "Property FreeBSD". +-- +-- Also, some properties have associated `Info`, which is indicated in +-- their type: "Property (HasInfo + DebianLike)" +-- +-- There are many associated type families, which are mostly used +-- internally, so you needn't worry about them. +data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] + +instance Show (Property metatypes) where + show p = "property " ++ show (getDesc p) + +-- | Constructs a Property, from a description and an action to run to +-- ensure the Property is met. +-- +-- Due to the polymorphic return type of this function, most uses will need +-- to specify a type signature. This lets you specify what OS the property +-- targets, etc. +-- +-- For example: +-- +-- > foo :: Property Debian +-- > foo = property "foo" $ do +-- > ... +-- > return MadeChange +property + :: SingI metatypes + => Desc + -> Propellor Result + -> Property (MetaTypes metatypes) +property d a = Property sing d a mempty mempty + +-- | Changes the action that is performed to satisfy a property. +adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes +adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c + +-- | A property that can be reverted. The first Property is run +-- normally and the second is run when it's reverted. +data RevertableProperty setupmetatypes undometatypes = RevertableProperty + { setupRevertableProperty :: Property setupmetatypes + , undoRevertableProperty :: Property undometatypes } -instance Show Property where - show p = "property " ++ show (propertyDesc p) - --- | A property that can be reverted. -data RevertableProperty = RevertableProperty Property Property - -class IsProp p where - -- | Sets description. - describe :: p -> Desc -> p - toProp :: p -> Property - -- | Indicates that the first property can only be satisfied - -- once the second one is. - requires :: p -> Property -> p - getInfo :: p -> Info - -instance IsProp Property where - describe p d = p { propertyDesc = d } - toProp p = p - getInfo = propertyInfo - x `requires` y = Property (propertyDesc x) satisfy info - where - info = getInfo y <> getInfo x - satisfy = do - r <- propertySatisfy y - case r of - FailedChange -> return FailedChange - _ -> propertySatisfy x - - -instance IsProp RevertableProperty where +instance Show (RevertableProperty setupmetatypes undometatypes) where + show (RevertableProperty p _) = show p + +-- | Shorthand to construct a revertable property from any two Properties. +(<!>) + :: Property setupmetatypes + -> Property undometatypes + -> RevertableProperty setupmetatypes undometatypes +setup <!> undo = RevertableProperty setup undo + +instance IsProp (Property metatypes) where + setDesc (Property t _ a i c) d = Property t d a i c + getDesc (Property _ d _ _ _) = d + getChildren (Property _ _ _ _ c) = c + addChildren (Property t d a i c) c' = Property t d a i (c ++ c') + getInfoRecursive (Property _ _ _ i c) = + i <> mconcat (map getInfoRecursive c) + getInfo (Property _ _ _ i _) = i + toChildProperty (Property _ d a i c) = ChildProperty d a i c + getSatisfy (Property _ _ a _ _) = a + +instance IsProp (RevertableProperty setupmetatypes undometatypes) where -- | Sets the description of both sides. - describe (RevertableProperty p1 p2) d = - RevertableProperty (describe p1 d) (describe p2 ("not " ++ d)) - toProp (RevertableProperty p1 _) = p1 - (RevertableProperty p1 p2) `requires` y = - RevertableProperty (p1 `requires` y) p2 + setDesc (RevertableProperty p1 p2) d = + RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) + getDesc (RevertableProperty p1 _) = getDesc p1 + getChildren (RevertableProperty p1 _) = getChildren p1 + -- | Only add children to the active side. + addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2 -- | Return the Info of the currently active side. + getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 getInfo (RevertableProperty p1 _p2) = getInfo p1 - -type Desc = String - -data Result = NoChange | MadeChange | FailedChange - deriving (Read, Show, Eq) - -instance Monoid Result where - mempty = NoChange - - mappend FailedChange _ = FailedChange - mappend _ FailedChange = FailedChange - mappend MadeChange _ = MadeChange - mappend _ MadeChange = MadeChange - mappend NoChange NoChange = NoChange - --- | Results of actions, with color. -class ActionResult a where - getActionResult :: a -> (String, ColorIntensity, Color) - -instance ActionResult Bool where - getActionResult False = ("failed", Vivid, Red) - getActionResult True = ("done", Dull, Green) - -instance ActionResult Result where - getActionResult NoChange = ("ok", Dull, Green) - getActionResult MadeChange = ("done", Vivid, Green) - getActionResult FailedChange = ("failed", Vivid, Red) - -data CmdLine - = Run HostName - | Spin HostName - | Boot HostName - | Set PrivDataField Context - | Dump PrivDataField Context - | Edit PrivDataField Context - | ListFields - | AddKey String - | Continue CmdLine - | Chain HostName - | Docker HostName - deriving (Read, Show, Eq) + toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1 + getSatisfy (RevertableProperty p1 _) = getSatisfy p1 + +-- | Type level calculation of the type that results from combining two +-- types of properties. +type family CombinedType x y +type instance CombinedType (Property (MetaTypes x)) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y)) +type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) = RevertableProperty (MetaTypes (Combine x y)) (MetaTypes (Combine x' y')) +-- When only one of the properties is revertable, the combined property is +-- not fully revertable, so is not a RevertableProperty. +type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y)) +type instance CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) = Property (MetaTypes (Combine x y)) + +type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result + +class Combines x y where + -- | Combines together two properties, yielding a property that + -- has the description and info of the first, and that has the + -- second property as a child property. + combineWith + :: ResultCombiner + -- ^ How to combine the actions to satisfy the properties. + -> ResultCombiner + -- ^ Used when combining revertable properties, to combine + -- their reversion actions. + -> x + -> y + -> CombinedType x y + +instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where + combineWith f _ (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) = + Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1) +instance (CheckCombinable x y ~ 'CanCombine, CheckCombinable x' y' ~ 'CanCombine, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where + combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = + RevertableProperty + (combineWith sf tf s1 s2) + (combineWith tf sf t1 t2) +instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where + combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y +instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where + combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y + +class TightenTargets p where + -- | Tightens the MetaType list of a Property (or similar), + -- to contain fewer targets. + -- + -- For example, to make a property that uses apt-get, which is only + -- available on DebianLike systems: + -- + -- > upgraded :: Property DebianLike + -- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"] + tightenTargets + :: + -- Note that this uses PolyKinds + ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine + , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine + , SingI tightened + ) + => p (MetaTypes untightened) + -> p (MetaTypes tightened) + +instance TightenTargets Property where + tightenTargets (Property _ d a i c) = Property sing d a i c diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs new file mode 100644 index 00000000..fc049603 --- /dev/null +++ b/src/Propellor/Types/Chroot.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Propellor.Types.Chroot where + +import Propellor.Types +import Propellor.Types.Empty +import Propellor.Types.Info + +import Data.Monoid +import qualified Data.Map as M + +data ChrootInfo = ChrootInfo + { _chroots :: M.Map FilePath Host + , _chrootCfg :: ChrootCfg + } + deriving (Show, Typeable) + +instance IsInfo ChrootInfo where + propagateInfo _ = False + +instance Monoid ChrootInfo where + mempty = ChrootInfo mempty mempty + mappend old new = ChrootInfo + { _chroots = M.union (_chroots old) (_chroots new) + , _chrootCfg = _chrootCfg old <> _chrootCfg new + } + +instance Empty ChrootInfo where + isEmpty i = and + [ isEmpty (_chroots i) + , isEmpty (_chrootCfg i) + ] + +data ChrootCfg + = NoChrootCfg + | SystemdNspawnCfg [(String, Bool)] + deriving (Show, Eq) + +instance Monoid ChrootCfg where + mempty = NoChrootCfg + mappend v NoChrootCfg = v + mappend NoChrootCfg v = v + mappend (SystemdNspawnCfg l1) (SystemdNspawnCfg l2) = + SystemdNspawnCfg (l1 <> l2) + +instance Empty ChrootCfg where + isEmpty c= c == NoChrootCfg diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs new file mode 100644 index 00000000..558c6e8b --- /dev/null +++ b/src/Propellor/Types/CmdLine.hs @@ -0,0 +1,31 @@ +module Propellor.Types.CmdLine where + +import Propellor.Types.OS +import Propellor.Types.PrivData + +import System.Posix.Types + +-- | All the command line actions that propellor can perform. +data CmdLine + = Run HostName + | Spin [HostName] (Maybe HostName) + | SimpleRun HostName + | Set PrivDataField Context + | Unset PrivDataField Context + | UnsetUnused + | Dump PrivDataField Context + | Edit PrivDataField Context + | ListFields + | AddKey String + | RmKey String + | Merge + | Serialized CmdLine + | Continue CmdLine + | Update (Maybe HostName) + | Relay HostName + | DockerInit HostName + | DockerChain HostName String + | ChrootChain HostName FilePath Bool Bool + | GitPush Fd Fd + | Check + deriving (Read, Show, Eq) diff --git a/src/Propellor/Types/Container.hs b/src/Propellor/Types/Container.hs new file mode 100644 index 00000000..217d7df7 --- /dev/null +++ b/src/Propellor/Types/Container.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies #-} + +module Propellor.Types.Container where + +-- | A value that can be bound between the host and a container. +-- +-- For example, a Bound Port is a Port on the container that is bound to +-- a Port on the host. +data Bound v = Bound + { hostSide :: v + , containerSide :: v + } + +-- | Create a Bound value, from two different values for the host and +-- container. +-- +-- For example, @Port 8080 -<- Port 80@ means that port 8080 on the host +-- is bound to port 80 from the container. +(-<-) :: (hostv ~ v, containerv ~ v) => hostv -> containerv -> Bound v +(-<-) = Bound + +-- | Flipped version of -<- with the container value first and host value +-- second. +(->-) :: (containerv ~ v, hostv ~ v) => containerv -> hostv -> Bound v +(->-) = flip (-<-) + +-- | Create a Bound value, that is the same on both the host and container. +same :: v -> Bound v +same v = Bound v v + diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs new file mode 100644 index 00000000..6fedc47e --- /dev/null +++ b/src/Propellor/Types/Core.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +module Propellor.Types.Core where + +import Propellor.Types.Info +import Propellor.Types.OS +import Propellor.Types.Result + +import Data.Monoid +import "mtl" Control.Monad.RWS.Strict +import Control.Monad.Catch +import Control.Applicative +import Prelude + +-- | Everything Propellor knows about a system: Its hostname, +-- properties and their collected info. +data Host = Host + { hostName :: HostName + , hostProperties :: [ChildProperty] + , hostInfo :: Info + } + deriving (Show, Typeable) + +-- | Propellor's monad provides read-only access to info about the host +-- it's running on, and a writer to accumulate EndActions. +newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } + deriving + ( Monad + , Functor + , Applicative + , MonadReader Host + , MonadWriter [EndAction] + , MonadIO + , MonadCatch + , MonadThrow + , MonadMask + ) + +class LiftPropellor m where + liftPropellor :: m a -> Propellor a + +instance LiftPropellor Propellor where + liftPropellor = id + +instance LiftPropellor IO where + liftPropellor = liftIO + +instance Monoid (Propellor Result) where + mempty = return NoChange + -- | The second action is only run if the first action does not fail. + mappend x y = do + rx <- x + case rx of + FailedChange -> return FailedChange + _ -> do + ry <- y + return (rx <> ry) + +-- | An action that Propellor runs at the end, after trying to satisfy all +-- properties. It's passed the combined Result of the entire Propellor run. +data EndAction = EndAction Desc (Result -> Propellor Result) + +type Desc = String + +-- | Props is a combination of a list of properties, with their combined +-- metatypes. +data Props metatypes = Props [ChildProperty] + +-- | Since there are many different types of Properties, they cannot be put +-- into a list. The simplified ChildProperty can be put into a list. +data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] + +instance Show ChildProperty where + show p = "property " ++ show (getDesc p) + +class IsProp p where + setDesc :: p -> Desc -> p + getDesc :: p -> Desc + getChildren :: p -> [ChildProperty] + addChildren :: p -> [ChildProperty] -> p + -- | Gets the info of the property, combined with all info + -- of all children properties. + getInfoRecursive :: p -> Info + -- | Info, not including info from children. + getInfo :: p -> Info + -- | Gets a ChildProperty representing the Property. + -- You should not normally need to use this. + toChildProperty :: p -> ChildProperty + -- | Gets the action that can be run to satisfy a Property. + -- You should never run this action directly. Use + -- 'Propellor.EnsureProperty.ensureProperty` instead. + getSatisfy :: p -> Propellor Result + +instance IsProp ChildProperty where + setDesc (ChildProperty _ a i c) d = ChildProperty d a i c + getDesc (ChildProperty d _ _ _) = d + getChildren (ChildProperty _ _ _ c) = c + addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') + getInfoRecursive (ChildProperty _ _ i c) = + i <> mconcat (map getInfoRecursive c) + getInfo (ChildProperty _ _ i _) = i + toChildProperty = id + getSatisfy (ChildProperty _ a _ _) = a diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs index 66fbd1a4..8f15d156 100644 --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -1,10 +1,18 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + module Propellor.Types.Dns where import Propellor.Types.OS (HostName) +import Propellor.Types.Empty +import Propellor.Types.Info import Data.Word -import Data.Monoid import qualified Data.Map as M +import qualified Data.Set as S +import Data.List +import Data.String.Utils (split, replace) +import Data.Monoid +import Prelude type Domain = String @@ -15,6 +23,29 @@ fromIPAddr :: IPAddr -> String fromIPAddr (IPv4 addr) = addr fromIPAddr (IPv6 addr) = addr +newtype AliasesInfo = AliasesInfo (S.Set HostName) + deriving (Show, Eq, Ord, Monoid, Typeable) + +instance IsInfo AliasesInfo where + propagateInfo _ = False + +toAliasesInfo :: [HostName] -> AliasesInfo +toAliasesInfo l = AliasesInfo (S.fromList l) + +fromAliasesInfo :: AliasesInfo -> [HostName] +fromAliasesInfo (AliasesInfo s) = S.toList s + +newtype DnsInfo = DnsInfo { fromDnsInfo :: S.Set Record } + deriving (Show, Eq, Ord, Monoid, Typeable) + +toDnsInfo :: S.Set Record -> DnsInfo +toDnsInfo = DnsInfo + +-- | DNS Info is propagated, so that eg, aliases of a container +-- are reflected in the dns for the host where it runs. +instance IsInfo DnsInfo where + propagateInfo _ = True + -- | Represents a bind 9 named.conf file. data NamedConf = NamedConf { confDomain :: Domain @@ -61,7 +92,35 @@ data Record | NS BindDomain | TXT String | SRV Word16 Word16 Word16 BindDomain - deriving (Read, Show, Eq, Ord) + | SSHFP Int Int String + | INCLUDE FilePath + | PTR ReverseIP + deriving (Read, Show, Eq, Ord, Typeable) + +-- | An in-addr.arpa record corresponding to an IPAddr. +type ReverseIP = String + +reverseIP :: IPAddr -> ReverseIP +reverseIP (IPv4 addr) = intercalate "." (reverse $ split "." addr) ++ ".in-addr.arpa" +reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ fromIPAddr $ canonicalIP addr) ++ ".ip6.arpa" + +-- | Converts an IP address (particularly IPv6) to canonical, fully +-- expanded form. +canonicalIP :: IPAddr -> IPAddr +canonicalIP (IPv4 addr) = IPv4 addr +canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":" $ replaceImplicitGroups addr + where + canonicalGroup g + | l <= 4 = replicate (4 - l) '0' ++ g + | otherwise = error $ "IPv6 group " ++ g ++ "as more than 4 hex digits" + where + l = length g + emptyGroups n = iterate (++ ":") "" !! n + numberOfImplicitGroups a = 8 - length (split ":" $ replace "::" "" a) + replaceImplicitGroups a = concat $ aux $ split "::" a + where + aux [] = [] + aux (x : xs) = x : emptyGroups (numberOfImplicitGroups a) : xs getIPAddr :: Record -> Maybe IPAddr getIPAddr (Address addr) = Just addr @@ -94,7 +153,10 @@ domainHostName (AbsDomain d) = Just d domainHostName RootDomain = Nothing newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf) - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) + +instance IsInfo NamedConfMap where + propagateInfo _ = False -- | Adding a Master NamedConf stanza for a particulr domain always -- overrides an existing Secondary stanza for that domain, while a @@ -108,5 +170,8 @@ instance Monoid NamedConfMap where (Secondary, Master) -> o _ -> n +instance Empty NamedConfMap where + isEmpty (NamedConfMap m) = isEmpty m + fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf fromNamedConfMap (NamedConfMap m) = m diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs new file mode 100644 index 00000000..f3cc4a52 --- /dev/null +++ b/src/Propellor/Types/Docker.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Propellor.Types.Docker where + +import Propellor.Types +import Propellor.Types.Empty +import Propellor.Types.Info + +import Data.Monoid +import qualified Data.Map as M + +data DockerInfo = DockerInfo + { _dockerRunParams :: [DockerRunParam] + , _dockerContainers :: M.Map String Host + } + deriving (Show, Typeable) + +instance IsInfo DockerInfo where + propagateInfo _ = False + +instance Monoid DockerInfo where + mempty = DockerInfo mempty mempty + mappend old new = DockerInfo + { _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + , _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new) + } + +instance Empty DockerInfo where + isEmpty i = and + [ isEmpty (_dockerRunParams i) + , isEmpty (_dockerContainers i) + ] + +newtype DockerRunParam = DockerRunParam (HostName -> String) + +instance Show DockerRunParam where + show (DockerRunParam a) = a "" diff --git a/src/Propellor/Types/Empty.hs b/src/Propellor/Types/Empty.hs new file mode 100644 index 00000000..dcd2f4a0 --- /dev/null +++ b/src/Propellor/Types/Empty.hs @@ -0,0 +1,16 @@ +module Propellor.Types.Empty where + +import qualified Data.Map as M +import qualified Data.Set as S + +class Empty t where + isEmpty :: t -> Bool + +instance Empty [a] where + isEmpty = null + +instance Empty (M.Map k v) where + isEmpty = M.null + +instance Empty (S.Set v) where + isEmpty = S.null diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index de072aa0..2e188ae5 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -1,70 +1,92 @@ -module Propellor.Types.Info where +{-# LANGUAGE GADTs, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -import Propellor.Types.OS -import Propellor.Types.PrivData -import qualified Propellor.Types.Dns as Dns +module Propellor.Types.Info ( + Info, + IsInfo(..), + addInfo, + toInfo, + fromInfo, + mapInfo, + propagatableInfo, + InfoVal(..), + fromInfoVal, + Typeable, +) where -import qualified Data.Set as S +import Data.Dynamic +import Data.Maybe import Data.Monoid +import Prelude --- | Information about a host. -data Info = Info - { _os :: Val System - , _privDataFields :: S.Set (PrivDataField, Context) - , _sshPubKey :: Val String - , _aliases :: S.Set HostName - , _dns :: S.Set Dns.Record - , _namedconf :: Dns.NamedConfMap - , _dockerinfo :: DockerInfo - } - deriving (Eq, Show) - -instance Monoid Info where - mempty = Info mempty mempty mempty mempty mempty mempty mempty - mappend old new = Info - { _os = _os old <> _os new - , _privDataFields = _privDataFields old <> _privDataFields new - , _sshPubKey = _sshPubKey old <> _sshPubKey new - , _aliases = _aliases old <> _aliases new - , _dns = _dns old <> _dns new - , _namedconf = _namedconf old <> _namedconf new - , _dockerinfo = _dockerinfo old <> _dockerinfo new - } - -data Val a = Val a | NoVal - deriving (Eq, Show) - -instance Monoid (Val a) where - mempty = NoVal - mappend old new = case new of - NoVal -> old - _ -> new - -fromVal :: Val a -> Maybe a -fromVal (Val a) = Just a -fromVal NoVal = Nothing - -data DockerInfo = DockerInfo - { _dockerImage :: Val String - , _dockerRunParams :: [HostName -> String] - } - -instance Eq DockerInfo where - x == y = and - [ _dockerImage x == _dockerImage y - , let simpl v = map (\a -> a "") (_dockerRunParams v) - in simpl x == simpl y - ] - -instance Monoid DockerInfo where - mempty = DockerInfo mempty mempty - mappend old new = DockerInfo - { _dockerImage = _dockerImage old <> _dockerImage new - , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new - } - -instance Show DockerInfo where - show a = unlines - [ "docker image " ++ show (_dockerImage a) - , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) - ] +-- | Information about a Host, which can be provided by its properties. +-- +-- Many different types of data can be contained in the same Info value +-- at the same time. See `toInfo` and `fromInfo`. +newtype Info = Info [InfoEntry] + deriving (Monoid, Show) + +data InfoEntry where + InfoEntry :: (IsInfo v, Typeable v) => v -> InfoEntry + +instance Show InfoEntry where + show (InfoEntry v) = show v + +-- Extracts the value from an InfoEntry but only when +-- it's of the requested type. +extractInfoEntry :: Typeable v => InfoEntry -> Maybe v +extractInfoEntry (InfoEntry v) = cast v + +-- | Values stored in Info must be members of this class. +-- +-- This is used to avoid accidentially using other data types +-- as info, especially type aliases which coud easily lead to bugs. +-- We want a little bit of dynamic types here, but not too far.. +class (Typeable v, Monoid v, Show v) => IsInfo v where + -- | Should info of this type be propagated out of a + -- container to its Host? + propagateInfo :: v -> Bool + +-- | Any value in the `IsInfo` type class can be added to an Info. +addInfo :: IsInfo v => Info -> v -> Info +addInfo (Info l) v = Info (InfoEntry v:l) + +-- | Converts any value in the `IsInfo` type class into an Info, +-- which is otherwise empty. +toInfo :: IsInfo v => v -> Info +toInfo = addInfo mempty + +-- The list is reversed here because addInfo builds it up in reverse order. +fromInfo :: IsInfo v => Info -> v +fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) + +-- | Maps a function over all values stored in the Info that are of the +-- appropriate type. +mapInfo :: IsInfo v => (v -> v) -> Info -> Info +mapInfo f (Info l) = Info (map go l) + where + go i = case extractInfoEntry i of + Nothing -> i + Just v -> InfoEntry (f v) + +-- | Filters out parts of the Info that should not propagate out of a +-- container. +propagatableInfo :: Info -> Info +propagatableInfo (Info l) = Info (filter (\(InfoEntry a) -> propagateInfo a) l) + +-- | Use this to put a value in Info that is not a monoid. +-- The last value set will be used. This info does not propagate +-- out of a container. +data InfoVal v = NoInfoVal | InfoVal v + deriving (Typeable, Show) + +instance Monoid (InfoVal v) where + mempty = NoInfoVal + mappend _ v@(InfoVal _) = v + mappend v NoInfoVal = v + +instance (Typeable v, Show v) => IsInfo (InfoVal v) where + propagateInfo _ = False + +fromInfoVal :: InfoVal v -> Maybe v +fromInfoVal NoInfoVal = Nothing +fromInfoVal (InfoVal v) = Just v diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs new file mode 100644 index 00000000..e064d76f --- /dev/null +++ b/src/Propellor/Types/MetaTypes.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-} + +module Propellor.Types.MetaTypes ( + MetaType(..), + UnixLike, + Linux, + DebianLike, + Debian, + Buntish, + FreeBSD, + HasInfo, + MetaTypes, + type (+), + sing, + SingI, + IncludesInfo, + Targets, + NonTargets, + NotSuperset, + Combine, + CheckCombine(..), + CheckCombinable, + type (&&), + Not, + EqT, + Union, +) where + +import Propellor.Types.Singletons +import Propellor.Types.OS + +data MetaType + = Targeting TargetOS -- ^ A target OS of a Property + | WithInfo -- ^ Indicates that a Property has associated Info + deriving (Show, Eq, Ord) + +-- | Any unix-like system +type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ] +-- | Any linux system +type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] +-- | Debian and derivatives. +type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] +type Debian = MetaTypes '[ 'Targeting 'OSDebian ] +type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ] +type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ] + +-- | Used to indicate that a Property adds Info to the Host where it's used. +type HasInfo = MetaTypes '[ 'WithInfo ] + +type family IncludesInfo t :: Bool +type instance IncludesInfo (MetaTypes l) = Elem 'WithInfo l + +type MetaTypes = Sing + +-- This boilerplate would not be needed if the singletons library were +-- used. However, we're targeting too old a version of ghc to use it yet. +data instance Sing (x :: MetaType) where + OSDebianS :: Sing ('Targeting 'OSDebian) + OSBuntishS :: Sing ('Targeting 'OSBuntish) + OSFreeBSDS :: Sing ('Targeting 'OSFreeBSD) + WithInfoS :: Sing 'WithInfo +instance SingI ('Targeting 'OSDebian) where sing = OSDebianS +instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS +instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS +instance SingI 'WithInfo where sing = WithInfoS +instance SingKind ('KProxy :: KProxy MetaType) where + type DemoteRep ('KProxy :: KProxy MetaType) = MetaType + fromSing OSDebianS = Targeting OSDebian + fromSing OSBuntishS = Targeting OSBuntish + fromSing OSFreeBSDS = Targeting OSFreeBSD + fromSing WithInfoS = WithInfo + +-- | Convenience type operator to combine two `MetaTypes` lists. +-- +-- For example: +-- +-- > HasInfo + Debian +-- +-- Which is shorthand for this type: +-- +-- > MetaTypes '[WithInfo, Targeting OSDebian] +type family a + b :: ab +type instance (MetaTypes a) + (MetaTypes b) = MetaTypes (Concat a b) + +type family Concat (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Concat '[] bs = bs +type instance Concat (a ': as) bs = a ': (Concat as bs) + +-- | Combine two MetaTypes lists, yielding a list +-- that has targets present in both, and nontargets present in either. +type family Combine (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Combine (list1 :: [a]) (list2 :: [a]) = + (Concat + (NonTargets list1 `Union` NonTargets list2) + (Targets list1 `Intersect` Targets list2) + ) + +-- | Checks if two MetaTypes lists can be safely combined. +-- +-- This should be used anywhere Combine is used, as an additional +-- constraint. For example: +-- +-- > foo :: (CheckCombinable x y ~ 'CanCombine) => x -> y -> Combine x y +type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: CheckCombine +-- As a special case, if either list is empty, let it be combined with the +-- other. This relies on MetaTypes list always containing at least +-- one target, so can only happen if there's already been a type error. +-- This special case lets the type checker show only the original type +-- error, and not an extra error due to a later CheckCombinable constraint. +type instance CheckCombinable '[] list2 = 'CanCombine +type instance CheckCombinable list1 '[] = 'CanCombine +type instance CheckCombinable (l1 ': list1) (l2 ': list2) = + CheckCombinable' (Combine (l1 ': list1) (l2 ': list2)) +type family CheckCombinable' (combinedlist :: [a]) :: CheckCombine +type instance CheckCombinable' '[] = 'CannotCombineTargets +type instance CheckCombinable' (a ': rest) + = If (IsTarget a) + 'CanCombine + (CheckCombinable' rest) + +data CheckCombine = CannotCombineTargets | CanCombine + +-- | Every item in the subset must be in the superset. +-- +-- The name of this was chosen to make type errors more understandable. +type family NotSuperset (superset :: [a]) (subset :: [a]) :: CheckCombine +type instance NotSuperset superset '[] = 'CanCombine +type instance NotSuperset superset (s ': rest) = + If (Elem s superset) + (NotSuperset superset rest) + 'CannotCombineTargets + +type family IsTarget (a :: t) :: Bool +type instance IsTarget ('Targeting a) = 'True +type instance IsTarget 'WithInfo = 'False + +type family Targets (l :: [a]) :: [a] +type instance Targets '[] = '[] +type instance Targets (x ': xs) = + If (IsTarget x) + (x ': Targets xs) + (Targets xs) + +type family NonTargets (l :: [a]) :: [a] +type instance NonTargets '[] = '[] +type instance NonTargets (x ': xs) = + If (IsTarget x) + (NonTargets xs) + (x ': NonTargets xs) + +-- | Type level elem +type family Elem (a :: t) (list :: [t]) :: Bool +type instance Elem a '[] = 'False +type instance Elem a (b ': bs) = EqT a b || Elem a bs + +-- | Type level union. +type family Union (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Union '[] list2 = list2 +type instance Union (a ': rest) list2 = + If (Elem a list2 || Elem a rest) + (Union rest list2) + (a ': Union rest list2) + +-- | Type level intersection. Duplicate list items are eliminated. +type family Intersect (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Intersect '[] list2 = '[] +type instance Intersect (a ': rest) list2 = + If (Elem a list2 && Not (Elem a rest)) + (a ': Intersect rest list2) + (Intersect rest list2) + +-- | Type level equality +-- +-- This is a very clumsy implmentation, but it works back to ghc 7.6. +type family EqT (a :: t) (b :: t) :: Bool +type instance EqT ('Targeting a) ('Targeting b) = EqT a b +type instance EqT 'WithInfo 'WithInfo = 'True +type instance EqT 'WithInfo ('Targeting b) = 'False +type instance EqT ('Targeting a) 'WithInfo = 'False +type instance EqT 'OSDebian 'OSDebian = 'True +type instance EqT 'OSBuntish 'OSBuntish = 'True +type instance EqT 'OSFreeBSD 'OSFreeBSD = 'True +type instance EqT 'OSDebian 'OSBuntish = 'False +type instance EqT 'OSDebian 'OSFreeBSD = 'False +type instance EqT 'OSBuntish 'OSDebian = 'False +type instance EqT 'OSBuntish 'OSFreeBSD = 'False +type instance EqT 'OSFreeBSD 'OSDebian = 'False +type instance EqT 'OSFreeBSD 'OSBuntish = 'False +-- More modern version if the combinatiorial explosion gets too bad later: +-- +-- type family Eq (a :: MetaType) (b :: MetaType) where +-- Eq a a = True +-- Eq a b = False + +-- | An equivilant to the following is in Data.Type.Bool in +-- modern versions of ghc, but is included here to support ghc 7.6. +type family If (cond :: Bool) (tru :: a) (fls :: a) :: a +type instance If 'True tru fls = tru +type instance If 'False tru fls = fls +type family (a :: Bool) || (b :: Bool) :: Bool +type instance 'False || 'False = 'False +type instance 'True || 'True = 'True +type instance 'True || 'False = 'True +type instance 'False || 'True = 'True +type family (a :: Bool) && (b :: Bool) :: Bool +type instance 'False && 'False = 'False +type instance 'True && 'True = 'True +type instance 'True && 'False = 'False +type instance 'False && 'True = 'False +type family Not (a :: Bool) :: Bool +type instance Not 'False = 'True +type instance Not 'True = 'False + diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs index 2529e7d8..d7df5490 100644 --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -1,26 +1,96 @@ -module Propellor.Types.OS where +{-# LANGUAGE DeriveDataTypeable #-} -type HostName = String -type UserName = String -type GroupName = String +module Propellor.Types.OS ( + System(..), + Distribution(..), + TargetOS(..), + DebianSuite(..), + FreeBSDRelease(..), + FBSDVersion(..), + isStable, + Release, + Architecture, + HostName, + UserName, + User(..), + Group(..), + userGroup, + Port(..), + fromPort, + systemToTargetOS, +) where + +import Network.BSD (HostName) +import Data.Typeable +import Data.String --- | High level descritption of a operating system. +-- | High level description of a operating system. data System = System Distribution Architecture - deriving (Show, Eq) + deriving (Show, Eq, Typeable) data Distribution = Debian DebianSuite - | Ubuntu Release + | Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per <http://joeyh.name/blog/entry/trademark_nonsense/> + | FreeBSD FreeBSDRelease deriving (Show, Eq) +-- | Properties can target one or more OS's; the targets are part +-- of the type of the property, so need to be kept fairly simple. +data TargetOS + = OSDebian + | OSBuntish + | OSFreeBSD + deriving (Show, Eq, Ord) + +systemToTargetOS :: System -> TargetOS +systemToTargetOS (System (Debian _) _) = OSDebian +systemToTargetOS (System (Buntish _) _) = OSBuntish +systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD + -- | Debian has several rolling suites, and a number of stable releases, --- such as Stable "wheezy". +-- such as Stable "jessie". data DebianSuite = Experimental | Unstable | Testing | Stable Release deriving (Show, Eq) +-- | FreeBSD breaks their releases into "Production" and "Legacy". +data FreeBSDRelease = FBSDProduction FBSDVersion | FBSDLegacy FBSDVersion + deriving (Show, Eq) + +data FBSDVersion = FBSD101 | FBSD102 | FBSD093 + deriving (Eq) + +instance IsString FBSDVersion where + fromString "10.1-RELEASE" = FBSD101 + fromString "10.2-RELEASE" = FBSD102 + fromString "9.3-RELEASE" = FBSD093 + fromString _ = error "Invalid FreeBSD release" + +instance Show FBSDVersion where + show FBSD101 = "10.1-RELEASE" + show FBSD102 = "10.2-RELEASE" + show FBSD093 = "9.3-RELEASE" + isStable :: DebianSuite -> Bool isStable (Stable _) = True isStable _ = False type Release = String type Architecture = String + +type UserName = String + +newtype User = User UserName + deriving (Eq, Ord, Show) + +newtype Group = Group String + deriving (Eq, Ord, Show) + +-- | Makes a Group with the same name as the User. +userGroup :: User -> Group +userGroup (User u) = Group u + +newtype Port = Port Int + deriving (Eq, Show) + +fromPort :: Port -> String +fromPort (Port p) = show p diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs index 16d6cdb1..32b51c4b 100644 --- a/src/Propellor/Types/PrivData.hs +++ b/src/Propellor/Types/PrivData.hs @@ -1,34 +1,134 @@ module Propellor.Types.PrivData where import Propellor.Types.OS +import Utility.PartialPrelude +import Utility.FileSystemEncoding --- | 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. +import Data.Maybe +import qualified Data.ByteString.Lazy as L + +-- | Note that removing or changing constructors or changing types will +-- break the serialized privdata files, so don't do that! +-- It's fine to add new constructors. data PrivDataField = DockerAuthentication - | SshPubKey SshKeyType UserName - | SshPrivKey SshKeyType UserName + | SshPubKey SshKeyType UserName -- ^ Not used anymore, but retained to avoid breaking serialization of old files + | SshPrivKey SshKeyType UserName -- ^ For host key, use empty UserName | SshAuthorizedKeys UserName | Password UserName + | CryptPassword UserName | PrivFile FilePath | GpgKey + | DnsSec DnsSecKey deriving (Read, Show, Ord, Eq) --- | Context in which a PrivDataField is used. +-- | Combines a PrivDataField with a description of how to generate +-- its value. +data PrivDataSource + = PrivDataSourceFile PrivDataField FilePath + | PrivDataSourceFileFromCommand PrivDataField FilePath String + | PrivDataSource PrivDataField String + +type PrivDataSourceDesc = String + +class IsPrivDataSource s where + privDataField :: s -> PrivDataField + describePrivDataSource :: s -> Maybe PrivDataSourceDesc + +instance IsPrivDataSource PrivDataField where + privDataField = id + describePrivDataSource _ = Nothing + +instance IsPrivDataSource PrivDataSource where + privDataField s = case s of + PrivDataSourceFile f _ -> f + PrivDataSourceFileFromCommand f _ _ -> f + PrivDataSource f _ -> f + describePrivDataSource s = Just $ case s of + PrivDataSourceFile _ f -> "< " ++ f + PrivDataSourceFileFromCommand _ f c -> + "< " ++ f ++ " (created by running, for example, `" ++ c ++ "` )" + PrivDataSource _ d -> "< (" ++ d ++ ")" + +-- | A context in which a PrivDataField is used. -- -- Often this will be a domain name. For example, -- Context "www.example.com" could be used for the SSL cert -- for the web server serving that domain. Multiple hosts might -- use that privdata. +-- +-- This appears in serialized privdata files. newtype Context = Context String deriving (Read, Show, Ord, Eq) +-- | A context that may vary depending on the HostName where it's used. +newtype HostContext = HostContext { mkHostContext :: HostName -> Context } + +instance Show HostContext where + show hc = show $ mkHostContext hc "<hostname>" + +instance Ord HostContext where + a <= b = show a <= show b + +instance Eq HostContext where + a == b = show a == show b + +-- | Class of things that can be used as a Context. +class IsContext c where + asContext :: HostName -> c -> Context + asHostContext :: c -> HostContext + +instance IsContext HostContext where + asContext = flip mkHostContext + asHostContext = id + +instance IsContext Context where + asContext _ c = c + asHostContext = HostContext . const + -- | Use when a PrivDataField is not dependent on any paricular context. anyContext :: Context anyContext = Context "any" -type PrivData = String +-- | Makes a HostContext that consists just of the hostname. +hostContext :: HostContext +hostContext = HostContext Context + +-- | Contains the actual private data. +-- +-- Note that this may contain exta newlines at the end, or they may have +-- been stripped off, depending on how the user entered the privdata, +-- and which version of propellor stored it. Use the accessor functions +-- below to avoid newline problems. +newtype PrivData = PrivData String + +-- | When PrivData is the content of a file, this is the lines thereof. +privDataLines :: PrivData -> [String] +privDataLines (PrivData s) = lines s + +-- | When the PrivData is a single value, like a password, this extracts +-- it. Note that if multiple lines are present in the PrivData, only +-- the first is returned; there is never a newline in the String. +privDataVal :: PrivData -> String +privDataVal (PrivData s) = fromMaybe "" (headMaybe (lines s)) + +-- | Use to get ByteString out of PrivData. +privDataByteString :: PrivData -> L.ByteString +privDataByteString (PrivData s) = encodeBS s data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519 - deriving (Read, Show, Ord, Eq) + deriving (Read, Show, Ord, Eq, Enum, Bounded) + +-- | Parameter that would be passed to ssh-keygen to generate key of this type +sshKeyTypeParam :: SshKeyType -> String +sshKeyTypeParam SshRsa = "RSA" +sshKeyTypeParam SshDsa = "DSA" +sshKeyTypeParam SshEcdsa = "ECDSA" +sshKeyTypeParam SshEd25519 = "ED25519" + +data DnsSecKey + = PubZSK -- ^ DNSSEC Zone Signing Key (public) + | PrivZSK -- ^ DNSSEC Zone Signing Key (private) + | PubKSK -- ^ DNSSEC Key Signing Key (public) + | PrivKSK -- ^ DNSSEC Key Signing Key (private) + deriving (Read, Show, Ord, Eq, Bounded, Enum) diff --git a/src/Propellor/Types/Result.hs b/src/Propellor/Types/Result.hs new file mode 100644 index 00000000..e8510abf --- /dev/null +++ b/src/Propellor/Types/Result.hs @@ -0,0 +1,38 @@ +module Propellor.Types.Result where + +import System.Console.ANSI +import Data.Monoid +import Prelude + +-- | There can be three results of satisfying a Property. +data Result = NoChange | MadeChange | FailedChange + deriving (Read, Show, Eq) + +instance Monoid Result where + mempty = NoChange + + mappend FailedChange _ = FailedChange + mappend _ FailedChange = FailedChange + mappend MadeChange _ = MadeChange + mappend _ MadeChange = MadeChange + mappend NoChange NoChange = NoChange + +class ToResult t where + toResult :: t -> Result + +instance ToResult Bool where + toResult False = FailedChange + toResult True = MadeChange + +-- | Results of actions, with color. +class ActionResult a where + getActionResult :: a -> (String, ColorIntensity, Color) + +instance ActionResult Bool where + getActionResult False = ("failed", Vivid, Red) + getActionResult True = ("done", Dull, Green) + +instance ActionResult Result where + getActionResult NoChange = ("ok", Dull, Green) + getActionResult MadeChange = ("done", Vivid, Green) + getActionResult FailedChange = ("failed", Vivid, Red) diff --git a/src/Propellor/Types/ResultCheck.hs b/src/Propellor/Types/ResultCheck.hs new file mode 100644 index 00000000..f03c174f --- /dev/null +++ b/src/Propellor/Types/ResultCheck.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Propellor.Types.ResultCheck ( + UncheckedProperty, + unchecked, + checkResult, + check, + Checkable, + assume, +) where + +import Propellor.Types +import Propellor.Exception +import Utility.Monad + +import Data.Monoid + +-- | This is a `Property` but its `Result` is not accurate; in particular +-- it may return `NoChange` despite having made a change. +-- +-- However, when it returns `MadeChange`, it really did make a change, +-- and `FailedChange` is still an error. +data UncheckedProperty i = UncheckedProperty (Property i) + +instance TightenTargets UncheckedProperty where + tightenTargets (UncheckedProperty p) = UncheckedProperty (tightenTargets p) + +-- | Use to indicate that a Property is unchecked. +unchecked :: Property i -> UncheckedProperty i +unchecked = UncheckedProperty + +-- | Checks the result of a property. Mostly used to convert a +-- `UncheckedProperty` to a `Property`, but can also be used to further +-- check a `Property`. +checkResult + :: (Checkable p i, LiftPropellor m) + => m a + -- ^ Run before ensuring the property. + -> (a -> m Result) + -- ^ Run after ensuring the property. Return `MadeChange` if a + -- change was detected, or `NoChange` if no change was detected. + -> p i + -> Property i +checkResult precheck postcheck p = adjustPropertySatisfy (checkedProp p) $ \satisfy -> do + a <- liftPropellor precheck + r <- catchPropellor satisfy + -- Always run postcheck, even if the result is already MadeChange, + -- as it may need to clean up after precheck. + r' <- liftPropellor $ postcheck a + return (r <> r') + +-- | Makes a `Property` or an `UncheckedProperty` only run +-- when a test succeeds. +check :: (Checkable p i, LiftPropellor m) => m Bool -> p i -> Property i +check test p = adjustPropertySatisfy (preCheckedProp p) $ \satisfy -> + ifM (liftPropellor test) + ( satisfy + , return NoChange + ) + +class Checkable p i where + checkedProp :: p i -> Property i + preCheckedProp :: p i -> Property i + +instance Checkable Property i where + checkedProp = id + preCheckedProp = id + +instance Checkable UncheckedProperty i where + checkedProp (UncheckedProperty p) = p + -- Since it was pre-checked that the property needed to be run, + -- if the property succeeded, we can assume it made a change. + preCheckedProp (UncheckedProperty p) = p `assume` MadeChange + +-- | Sometimes it's not practical to test if a property made a change. +-- In such a case, it's often fine to say: +-- +-- > someprop `assume` MadeChange +-- +-- However, beware assuming `NoChange`, as that will make combinators +-- like `onChange` not work. +assume :: Checkable p i => p i -> Result -> Property i +assume p result = adjustPropertySatisfy (checkedProp p) $ \satisfy -> do + r <- satisfy + return (r <> result) diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs new file mode 100644 index 00000000..f2089ee8 --- /dev/null +++ b/src/Propellor/Types/Singletons.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, UndecidableInstances #-} + +-- | Simple implementation of singletons, portable back to ghc 7.6.3 + +module Propellor.Types.Singletons ( + module Propellor.Types.Singletons, + KProxy(..) +) where + +#if __GLASGOW_HASKELL__ > 707 +import Data.Proxy (KProxy(..)) +#else +data KProxy (a :: *) = KProxy +#endif + +-- | The data family of singleton types. +data family Sing (x :: k) + +-- | A class used to pass singleton values implicitly. +class SingI t where + sing :: Sing t + +-- Lists of singletons +data instance Sing (x :: [k]) where + Nil :: Sing '[] + Cons :: Sing x -> Sing xs -> Sing (x ': xs) +instance (SingI x, SingI xs) => SingI (x ': xs) where sing = Cons sing sing +instance SingI '[] where sing = Nil + +data instance Sing (x :: Bool) where + TrueS :: Sing 'True + FalseS :: Sing 'False +instance SingI 'True where sing = TrueS +instance SingI 'False where sing = FalseS + +class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where + type DemoteRep kparam :: * + -- | From singleton to value. + fromSing :: Sing (a :: k) -> DemoteRep kparam + +instance SingKind ('KProxy :: KProxy a) => SingKind ('KProxy :: KProxy [a]) where + type DemoteRep ('KProxy :: KProxy [a]) = [DemoteRep ('KProxy :: KProxy a)] + fromSing Nil = [] + fromSing (Cons x xs) = fromSing x : fromSing xs + +instance SingKind ('KProxy :: KProxy Bool) where + type DemoteRep ('KProxy :: KProxy Bool) = Bool + fromSing FalseS = False + fromSing TrueS = True diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs new file mode 100644 index 00000000..3ce4b22c --- /dev/null +++ b/src/Propellor/Types/ZFS.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +-- | Types for ZFS Properties. +-- +-- Copyright 2016 Evan Cofsky <evan@theunixman.com> +-- License: BSD 2-clause + +module Propellor.Types.ZFS where + +import Data.String +import qualified Data.Set as Set +import qualified Data.String.Utils as SU +import Data.List + +-- | A single ZFS filesystem. +data ZFS = ZFS ZPool ZDataset deriving (Show, Eq, Ord) + +-- | Represents a zpool. +data ZPool = ZPool String deriving (Show, Eq, Ord) + +-- | Represents a dataset in a zpool. +-- +-- Can be constructed from a / separated string. +data ZDataset = ZDataset [String] deriving (Eq, Ord) + +type ZFSProperties = Set.Set ZFSProperty + +fromList :: [ZFSProperty] -> ZFSProperties +fromList = Set.fromList + +toPropertyList :: ZFSProperties -> [(String, String)] +toPropertyList = Set.foldr (\p l -> l ++ [toPair p]) [] + +fromPropertyList :: [(String, String)] -> ZFSProperties +fromPropertyList props = + Set.fromList $ map fromPair props + +zfsName :: ZFS -> String +zfsName (ZFS (ZPool pool) dataset) = intercalate "/" [pool, show dataset] + +instance Show ZDataset where + show (ZDataset paths) = intercalate "/" paths + +instance IsString ZDataset where + fromString s = ZDataset $ SU.split "/" s + +instance IsString ZPool where + fromString p = ZPool p + +class Value a where + toValue :: a -> String + fromValue :: (IsString a) => String -> a + fromValue = fromString + +data ZFSYesNo = ZFSYesNo Bool deriving (Show, Eq, Ord) +data ZFSOnOff = ZFSOnOff Bool deriving (Show, Eq, Ord) +data ZFSSize = ZFSSize Integer deriving (Show, Eq, Ord) +data ZFSString = ZFSString String deriving (Show, Eq, Ord) + +instance Value ZFSYesNo where + toValue (ZFSYesNo True) = "yes" + toValue (ZFSYesNo False) = "no" + +instance Value ZFSOnOff where + toValue (ZFSOnOff True) = "on" + toValue (ZFSOnOff False) = "off" + +instance Value ZFSSize where + toValue (ZFSSize s) = show s + +instance Value ZFSString where + toValue (ZFSString s) = s + +instance IsString ZFSString where + fromString = ZFSString + +instance IsString ZFSYesNo where + fromString "yes" = ZFSYesNo True + fromString "no" = ZFSYesNo False + fromString _ = error "Not yes or no" + +instance IsString ZFSOnOff where + fromString "on" = ZFSOnOff True + fromString "off" = ZFSOnOff False + fromString _ = error "Not on or off" + +data ZFSACLInherit = AIDiscard | AINoAllow | AISecure | AIPassthrough deriving (Show, Eq, Ord) +instance IsString ZFSACLInherit where + fromString "discard" = AIDiscard + fromString "noallow" = AINoAllow + fromString "secure" = AISecure + fromString "passthrough" = AIPassthrough + fromString _ = error "Not valid aclpassthrough value" + +instance Value ZFSACLInherit where + toValue AIDiscard = "discard" + toValue AINoAllow = "noallow" + toValue AISecure = "secure" + toValue AIPassthrough = "passthrough" + +data ZFSACLMode = AMDiscard | AMGroupmask | AMPassthrough deriving (Show, Eq, Ord) +instance IsString ZFSACLMode where + fromString "discard" = AMDiscard + fromString "groupmask" = AMGroupmask + fromString "passthrough" = AMPassthrough + fromString _ = error "Invalid zfsaclmode" + +instance Value ZFSACLMode where + toValue AMDiscard = "discard" + toValue AMGroupmask = "groupmask" + toValue AMPassthrough = "passthrough" + +data ZFSProperty = Mounted ZFSYesNo + | Mountpoint ZFSString + | ReadOnly ZFSYesNo + | ACLInherit ZFSACLInherit + | ACLMode ZFSACLMode + | StringProperty String ZFSString + deriving (Show, Eq, Ord) + +toPair :: ZFSProperty -> (String, String) +toPair (Mounted v) = ("mounted", toValue v) +toPair (Mountpoint v) = ("mountpoint", toValue v) +toPair (ReadOnly v) = ("readonly", toValue v) +toPair (ACLInherit v) = ("aclinherit", toValue v) +toPair (ACLMode v) = ("aclmode", toValue v) +toPair (StringProperty s v) = (s, toValue v) + +fromPair :: (String, String) -> ZFSProperty +fromPair ("mounted", v) = Mounted (fromString v) +fromPair ("mountpoint", v) = Mountpoint (fromString v) +fromPair ("readonly", v) = ReadOnly (fromString v) +fromPair ("aclinherit", v) = ACLInherit (fromString v) +fromPair ("aclmode", v) = ACLMode (fromString v) +fromPair (s, v) = StringProperty s (fromString v) diff --git a/src/Propellor/Utilities.hs b/src/Propellor/Utilities.hs new file mode 100644 index 00000000..33af4eda --- /dev/null +++ b/src/Propellor/Utilities.hs @@ -0,0 +1,27 @@ +-- | Re-exports some of propellor's internal utility modules. +-- +-- These are used in the implementation of propellor, including some of its +-- properties. However, there is no API stability; any of these can change +-- or be removed without a major version number increase. +-- +-- Use outside propellor at your own risk. + +module Propellor.Utilities ( + module Utility.PartialPrelude + , module Utility.Process + , module Utility.Exception + , module Utility.Env + , module Utility.Directory + , module Utility.Tmp + , module Utility.Monad + , module Utility.Misc +) where + +import Utility.PartialPrelude +import Utility.Process +import Utility.Exception +import Utility.Env +import Utility.Directory +import Utility.Tmp +import Utility.Monad +import Utility.Misc diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs new file mode 100644 index 00000000..12447637 --- /dev/null +++ b/src/System/Console/Concurrent.hs @@ -0,0 +1,44 @@ +-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name> +-- License: BSD-2-clause +-- +-- Concurrent output handling. +-- +-- > import Control.Concurrent.Async +-- > import System.Console.Concurrent +-- > +-- > main = withConcurrentOutput $ +-- > outputConcurrent "washed the car\n" +-- > `concurrently` +-- > outputConcurrent "walked the dog\n" +-- > `concurrently` +-- > createProcessConcurrent (proc "ls" []) + +{-# LANGUAGE CPP #-} + +module System.Console.Concurrent ( + -- * Concurrent output + withConcurrentOutput, + Outputable(..), + outputConcurrent, + errorConcurrent, + ConcurrentProcessHandle, +#ifndef mingw32_HOST_OS + createProcessConcurrent, +#endif + waitForProcessConcurrent, + createProcessForeground, + flushConcurrentOutput, + lockOutput, + -- * Low level access to the output buffer + OutputBuffer, + StdHandle(..), + bufferOutputSTM, + outputBufferWaiterSTM, + waitAnyBuffer, + waitCompleteLines, + emitOutputBuffer, +) where + +import System.Console.Concurrent.Internal + diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs new file mode 100644 index 00000000..ffe6a9e8 --- /dev/null +++ b/src/System/Console/Concurrent/Internal.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -O2 #-} +{- Building this module with -O0 causes streams not to fuse and too much + - memory to be used. -} + +-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name> +-- License: BSD-2-clause +-- +-- Concurrent output handling, internals. +-- +-- May change at any time. + +module System.Console.Concurrent.Internal where + +import System.IO +#ifndef mingw32_HOST_OS +import System.Posix.IO +#endif +import System.Directory +import System.Exit +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.Async +import Data.Maybe +import Data.List +import Data.Monoid +import qualified System.Process as P +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Control.Applicative +import Prelude + +import Utility.Monad +import Utility.Exception + +data OutputHandle = OutputHandle + { outputLock :: TMVar Lock + , outputBuffer :: TMVar OutputBuffer + , errorBuffer :: TMVar OutputBuffer + , outputThreads :: TMVar Integer + , processWaiters :: TMVar [Async ()] + , waitForProcessLock :: TMVar () + } + +data Lock = Locked + +-- | A shared global variable for the OutputHandle. +{-# NOINLINE globalOutputHandle #-} +globalOutputHandle :: OutputHandle +globalOutputHandle = unsafePerformIO $ OutputHandle + <$> newEmptyTMVarIO + <*> newTMVarIO (OutputBuffer []) + <*> newTMVarIO (OutputBuffer []) + <*> newTMVarIO 0 + <*> newTMVarIO [] + <*> newEmptyTMVarIO + +-- | Holds a lock while performing an action. This allows the action to +-- perform its own output to the console, without using functions from this +-- module. +-- +-- While this is running, other threads that try to lockOutput will block. +-- Any calls to `outputConcurrent` and `createProcessConcurrent` will not +-- block, but the output will be buffered and displayed only once the +-- action is done. +lockOutput :: (MonadIO m, MonadMask m) => m a -> m a +lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) + +-- | Blocks until we have the output lock. +takeOutputLock :: IO () +takeOutputLock = void $ takeOutputLock' True + +-- | Tries to take the output lock, without blocking. +tryTakeOutputLock :: IO Bool +tryTakeOutputLock = takeOutputLock' False + +withLock :: (TMVar Lock -> STM a) -> IO a +withLock a = atomically $ a (outputLock globalOutputHandle) + +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = do + locked <- withLock $ \l -> do + v <- tryTakeTMVar l + case v of + Just Locked + | block -> retry + | otherwise -> do + -- Restore value we took. + putTMVar l Locked + return False + Nothing -> do + putTMVar l Locked + return True + when locked $ do + (outbuf, errbuf) <- atomically $ (,) + <$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer []) + <*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer []) + emitOutputBuffer StdOut outbuf + emitOutputBuffer StdErr errbuf + return locked + +-- | Only safe to call after taking the output lock. +dropOutputLock :: IO () +dropOutputLock = withLock $ void . takeTMVar + +-- | Use this around any actions that use `outputConcurrent` +-- or `createProcessConcurrent` +-- +-- This is necessary to ensure that buffered concurrent output actually +-- gets displayed before the program exits. +withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a +withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput + +-- | Blocks until any processes started by `createProcessConcurrent` have +-- finished, and any buffered output is displayed. Also blocks while +-- `lockOutput` is is use. +-- +-- `withConcurrentOutput` calls this at the end, so you do not normally +-- need to use this. +flushConcurrentOutput :: IO () +flushConcurrentOutput = do + atomically $ do + r <- takeTMVar (outputThreads globalOutputHandle) + if r <= 0 + then putTMVar (outputThreads globalOutputHandle) r + else retry + -- Take output lock to wait for anything else that might be + -- currently generating output. + lockOutput $ return () + +-- | Values that can be output. +class Outputable v where + toOutput :: v -> T.Text + +instance Outputable T.Text where + toOutput = id + +instance Outputable String where + toOutput = toOutput . T.pack + +-- | Displays a value to stdout. +-- +-- No newline is appended to the value, so if you want a newline, be sure +-- to include it yourself. +-- +-- Uses locking to ensure that the whole output occurs atomically +-- even when other threads are concurrently generating output. +-- +-- When something else is writing to the console at the same time, this does +-- not block. It buffers the value, so it will be displayed once the other +-- writer is done. +outputConcurrent :: Outputable v => v -> IO () +outputConcurrent = outputConcurrent' StdOut + +-- | Like `outputConcurrent`, but displays to stderr. +-- +-- (Does not throw an exception.) +errorConcurrent :: Outputable v => v -> IO () +errorConcurrent = outputConcurrent' StdErr + +outputConcurrent' :: Outputable v => StdHandle -> v -> IO () +outputConcurrent' stdh v = bracket setup cleanup go + where + setup = tryTakeOutputLock + cleanup False = return () + cleanup True = dropOutputLock + go True = do + T.hPutStr h (toOutput v) + hFlush h + go False = do + oldbuf <- atomically $ takeTMVar bv + newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf + atomically $ putTMVar bv newbuf + h = toHandle stdh + bv = bufferFor stdh + +newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle + +toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h) + +-- | Use this to wait for processes started with +-- `createProcessConcurrent` and `createProcessForeground`, and get their +-- exit status. +-- +-- Note that such processes are actually automatically waited for +-- internally, so not calling this explicitly will not result +-- in zombie processes. This behavior differs from `P.waitForProcess` +waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode +waitForProcessConcurrent (ConcurrentProcessHandle h) = + bracket lock unlock checkexit + where + lck = waitForProcessLock globalOutputHandle + lock = atomically $ tryPutTMVar lck () + unlock True = atomically $ takeTMVar lck + unlock False = return () + checkexit locked = maybe (waitsome locked) return + =<< P.getProcessExitCode h + waitsome True = do + let v = processWaiters globalOutputHandle + l <- atomically $ readTMVar v + if null l + -- Avoid waitAny [] which blocks forever + then P.waitForProcess h + else do + -- Wait for any of the running + -- processes to exit. It may or may not + -- be the one corresponding to the + -- ProcessHandle. If it is, + -- getProcessExitCode will succeed. + void $ tryIO $ waitAny l + checkexit True + waitsome False = do + -- Another thread took the lck first. Wait for that thread to + -- wait for one of the running processes to exit. + atomically $ do + putTMVar lck () + takeTMVar lck + checkexit False + +-- Registers an action that waits for a process to exit, +-- adding it to the processWaiters list, and removing it once the action +-- completes. +asyncProcessWaiter :: IO () -> IO () +asyncProcessWaiter waitaction = do + regdone <- newEmptyTMVarIO + waiter <- async $ do + self <- atomically (takeTMVar regdone) + waitaction `finally` unregister self + register waiter regdone + where + v = processWaiters globalOutputHandle + register waiter regdone = atomically $ do + l <- takeTMVar v + putTMVar v (waiter:l) + putTMVar regdone waiter + unregister waiter = atomically $ do + l <- takeTMVar v + putTMVar v (filter (/= waiter) l) + +-- | Wrapper around `System.Process.createProcess` that prevents +-- multiple processes that are running concurrently from writing +-- to stdout/stderr at the same time. +-- +-- If the process does not output to stdout or stderr, it's run +-- by createProcess entirely as usual. Only processes that can generate +-- output are handled specially: +-- +-- A process is allowed to write to stdout and stderr in the usual +-- way, assuming it can successfully take the output lock. +-- +-- When the output lock is held (ie, by another concurrent process, +-- or because `outputConcurrent` is being called at the same time), +-- the process is instead run with its stdout and stderr +-- redirected to a buffer. The buffered output will be displayed as soon +-- as the output lock becomes free. +-- +-- Currently only available on Unix systems, not Windows. +#ifndef mingw32_HOST_OS +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +createProcessConcurrent p + | willOutput (P.std_out p) || willOutput (P.std_err p) = + ifM tryTakeOutputLock + ( fgProcess p + , bgProcess p + ) + | otherwise = do + r@(_, _, _, h) <- P.createProcess p + asyncProcessWaiter $ + void $ tryIO $ P.waitForProcess h + return (toConcurrentProcessHandle r) +#endif + +-- | Wrapper around `System.Process.createProcess` that makes sure a process +-- is run in the foreground, with direct access to stdout and stderr. +-- Useful when eg, running an interactive process. +createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +createProcessForeground p = do + takeOutputLock + fgProcess p + +fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +fgProcess p = do + r@(_, _, _, h) <- P.createProcess p + `onException` dropOutputLock + registerOutputThread + -- Wait for the process to exit and drop the lock. + asyncProcessWaiter $ do + void $ tryIO $ P.waitForProcess h + unregisterOutputThread + dropOutputLock + return (toConcurrentProcessHandle r) + +#ifndef mingw32_HOST_OS +bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +bgProcess p = do + (toouth, fromouth) <- pipe + (toerrh, fromerrh) <- pipe + let p' = p + { P.std_out = rediroutput (P.std_out p) toouth + , P.std_err = rediroutput (P.std_err p) toerrh + } + registerOutputThread + r@(_, _, _, h) <- P.createProcess p' + `onException` unregisterOutputThread + asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h + outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth + errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh + void $ async $ bufferWriter [outbuf, errbuf] + return (toConcurrentProcessHandle r) + where + pipe = do + (from, to) <- createPipe + (,) <$> fdToHandle to <*> fdToHandle from + rediroutput ss h + | willOutput ss = P.UseHandle h + | otherwise = ss +#endif + +willOutput :: P.StdStream -> Bool +willOutput P.Inherit = True +willOutput _ = False + +-- | Buffered output. +data OutputBuffer = OutputBuffer [OutputBufferedActivity] + deriving (Eq) + +data StdHandle = StdOut | StdErr + +toHandle :: StdHandle -> Handle +toHandle StdOut = stdout +toHandle StdErr = stderr + +bufferFor :: StdHandle -> TMVar OutputBuffer +bufferFor StdOut = outputBuffer globalOutputHandle +bufferFor StdErr = errorBuffer globalOutputHandle + +data OutputBufferedActivity + = Output T.Text + | InTempFile + { tempFile :: FilePath + , endsInNewLine :: Bool + } + deriving (Eq) + +data AtEnd = AtEnd + deriving Eq + +data BufSig = BufSig + +setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) +setupOutputBuffer h toh ss fromh = do + hClose toh + buf <- newMVar (OutputBuffer []) + bufsig <- atomically newEmptyTMVar + bufend <- atomically newEmptyTMVar + void $ async $ outputDrainer ss fromh buf bufsig bufend + return (h, buf, bufsig, bufend) + +-- Drain output from the handle, and buffer it. +outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO () +outputDrainer ss fromh buf bufsig bufend + | willOutput ss = go + | otherwise = atend + where + go = do + t <- T.hGetChunk fromh + if T.null t + then atend + else do + modifyMVar_ buf $ addOutputBuffer (Output t) + changed + go + atend = do + atomically $ putTMVar bufend AtEnd + hClose fromh + changed = atomically $ do + void $ tryTakeTMVar bufsig + putTMVar bufsig BufSig + +registerOutputThread :: IO () +registerOutputThread = do + let v = outputThreads globalOutputHandle + atomically $ putTMVar v . succ =<< takeTMVar v + +unregisterOutputThread :: IO () +unregisterOutputThread = do + let v = outputThreads globalOutputHandle + atomically $ putTMVar v . pred =<< takeTMVar v + +-- Wait to lock output, and once we can, display everything +-- that's put into the buffers, until the end. +-- +-- If end is reached before lock is taken, instead add the command's +-- buffers to the global outputBuffer and errorBuffer. +bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () +bufferWriter ts = do + activitysig <- atomically newEmptyTMVar + worker1 <- async $ lockOutput $ + ifM (atomically $ tryPutTMVar activitysig ()) + ( void $ mapConcurrently displaybuf ts + , noop -- buffers already moved to global + ) + worker2 <- async $ void $ globalbuf activitysig worker1 + void $ async $ do + void $ waitCatch worker1 + void $ waitCatch worker2 + unregisterOutputThread + where + displaybuf v@(outh, buf, bufsig, bufend) = do + change <- atomically $ + (Right <$> takeTMVar bufsig) + `orElse` + (Left <$> takeTMVar bufend) + l <- takeMVar buf + putMVar buf (OutputBuffer []) + emitOutputBuffer outh l + case change of + Right BufSig -> displaybuf v + Left AtEnd -> return () + globalbuf activitysig worker1 = do + ok <- atomically $ do + -- signal we're going to handle it + -- (returns false if the displaybuf already did) + ok <- tryPutTMVar activitysig () + -- wait for end of all buffers + when ok $ + mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts + return ok + when ok $ do + -- add all of the command's buffered output to the + -- global output buffer, atomically + bs <- forM ts $ \(outh, buf, _bufsig, _bufend) -> + (outh,) <$> takeMVar buf + atomically $ + forM_ bs $ \(outh, b) -> + bufferOutputSTM' outh b + -- worker1 might be blocked waiting for the output + -- lock, and we've already done its job, so cancel it + cancel worker1 + +-- Adds a value to the OutputBuffer. When adding Output to a Handle, +-- it's cheaper to combine it with any already buffered Output to that +-- same Handle. +-- +-- When the total buffered Output exceeds 1 mb in size, it's moved out of +-- memory, to a temp file. This should only happen rarely, but is done to +-- avoid some verbose process unexpectedly causing excessive memory use. +addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer +addOutputBuffer (Output t) (OutputBuffer buf) + | T.length t' <= 1048576 = return $ OutputBuffer (Output t' : other) + | otherwise = do + tmpdir <- getTemporaryDirectory + (tmp, h) <- openTempFile tmpdir "output.tmp" + let !endnl = endsNewLine t' + let i = InTempFile + { tempFile = tmp + , endsInNewLine = endnl + } + T.hPutStr h t' + hClose h + return $ OutputBuffer (i : other) + where + !t' = T.concat (mapMaybe getOutput this) <> t + !(this, other) = partition isOutput buf + isOutput v = case v of + Output _ -> True + _ -> False + getOutput v = case v of + Output t'' -> Just t'' + _ -> Nothing +addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v:buf) + +-- | Adds a value to the output buffer for later display. +-- +-- Note that buffering large quantities of data this way will keep it +-- resident in memory until it can be displayed. While `outputConcurrent` +-- uses temp files if the buffer gets too big, this STM function cannot do +-- so. +bufferOutputSTM :: Outputable v => StdHandle -> v -> STM () +bufferOutputSTM h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)]) + +bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM () +bufferOutputSTM' h (OutputBuffer newbuf) = do + (OutputBuffer buf) <- takeTMVar bv + putTMVar bv (OutputBuffer (newbuf ++ buf)) + where + bv = bufferFor h + +-- | A STM action that waits for some buffered output to become +-- available, and returns it. +-- +-- The function can select a subset of output when only some is desired; +-- the fst part is returned and the snd is left in the buffer. +-- +-- This will prevent it from being displayed in the usual way, so you'll +-- need to use `emitOutputBuffer` to display it yourself. +outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer) +outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr + where + waitgetbuf h = do + let bv = bufferFor h + (selected, rest) <- selector <$> takeTMVar bv + when (selected == OutputBuffer []) + retry + putTMVar bv rest + return (h, selected) + +waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer) +waitAnyBuffer b = (b, OutputBuffer []) + +-- | Use with `outputBufferWaiterSTM` to make it only return buffered +-- output that ends with a newline. Anything buffered without a newline +-- is left in the buffer. +waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer) +waitCompleteLines (OutputBuffer l) = + let (selected, rest) = span completeline l + in (OutputBuffer selected, OutputBuffer rest) + where + completeline (v@(InTempFile {})) = endsInNewLine v + completeline (Output b) = endsNewLine b + +endsNewLine :: T.Text -> Bool +endsNewLine t = not (T.null t) && T.last t == '\n' + +-- | Emits the content of the OutputBuffer to the Handle +-- +-- If you use this, you should use `lockOutput` to ensure you're the only +-- thread writing to the console. +emitOutputBuffer :: StdHandle -> OutputBuffer -> IO () +emitOutputBuffer stdh (OutputBuffer l) = + forM_ (reverse l) $ \ba -> case ba of + Output t -> emit t + InTempFile tmp _ -> do + emit =<< T.readFile tmp + void $ tryWhenExists $ removeFile tmp + where + outh = toHandle stdh + emit t = void $ tryIO $ do + T.hPutStr outh t + hFlush outh diff --git a/src/System/Process/Concurrent.hs b/src/System/Process/Concurrent.hs new file mode 100644 index 00000000..0e00e4fd --- /dev/null +++ b/src/System/Process/Concurrent.hs @@ -0,0 +1,34 @@ +-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name> +-- License: BSD-2-clause +-- +-- The functions exported by this module are intended to be drop-in +-- replacements for those from System.Process, when converting a whole +-- program to use System.Console.Concurrent. + +module System.Process.Concurrent where + +import System.Console.Concurrent +import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) +import System.Process hiding (createProcess, waitForProcess) +import System.IO +import System.Exit + +-- | Calls `createProcessConcurrent` +-- +-- You should use the waitForProcess in this module on the resulting +-- ProcessHandle. Using System.Process.waitForProcess instead can have +-- mildly unexpected results. +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess p = do + (i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p + return (i, o, e, h) + +-- | Calls `waitForProcessConcurrent` +-- +-- You should only use this on a ProcessHandle obtained by calling +-- createProcess from this module. Using this with a ProcessHandle +-- obtained from System.Process.createProcess etc will have extremely +-- unexpected results; it can wait a very long time before returning. +waitForProcess :: ProcessHandle -> IO ExitCode +waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs index fd8944b2..fce3c048 100644 --- a/src/Utility/Applicative.hs +++ b/src/Utility/Applicative.hs @@ -1,6 +1,6 @@ {- applicative stuff - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs index 2df12b36..27c0a824 100644 --- a/src/Utility/Data.hs +++ b/src/Utility/Data.hs @@ -1,10 +1,12 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.Data where {- First item in the list that is not Nothing. -} diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs new file mode 100644 index 00000000..6e40932e --- /dev/null +++ b/src/Utility/DataUnits.hs @@ -0,0 +1,162 @@ +{- data size display and parsing + - + - Copyright 2011 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + - + - + - And now a rant: + - + - In the beginning, we had powers of two, and they were good. + - + - Disk drive manufacturers noticed that some powers of two were + - sorta close to some powers of ten, and that rounding down to the nearest + - power of ten allowed them to advertise their drives were bigger. This + - was sorta annoying. + - + - Then drives got big. Really, really big. This was good. + - + - Except that the small rounding error perpretrated by the drive + - manufacturers suffered the fate of a small error, and became a large + - error. This was bad. + - + - So, a committee was formed. And it arrived at a committee-like decision, + - which satisfied noone, confused everyone, and made the world an uglier + - place. As with all committees, this was meh. + - + - And the drive manufacturers happily continued selling drives that are + - increasingly smaller than you'd expect, if you don't count on your + - fingers. But that are increasingly too big for anyone to much notice. + - This caused me to need git-annex. + - + - Thus, I use units here that I loathe. Because if I didn't, people would + - be confused that their drives seem the wrong size, and other people would + - complain at me for not being standards compliant. And we call this + - progress? + -} + +module Utility.DataUnits ( + dataUnits, + storageUnits, + memoryUnits, + bandwidthUnits, + oldSchoolUnits, + Unit(..), + ByteSize, + + roughSize, + compareSizes, + readSize +) where + +import Data.List +import Data.Char + +import Utility.HumanNumber + +type ByteSize = Integer +type Name = String +type Abbrev = String +data Unit = Unit ByteSize Abbrev Name + deriving (Ord, Show, Eq) + +dataUnits :: [Unit] +dataUnits = storageUnits ++ memoryUnits + +{- Storage units are (stupidly) powers of ten. -} +storageUnits :: [Unit] +storageUnits = + [ Unit (p 8) "YB" "yottabyte" + , Unit (p 7) "ZB" "zettabyte" + , Unit (p 6) "EB" "exabyte" + , Unit (p 5) "PB" "petabyte" + , Unit (p 4) "TB" "terabyte" + , Unit (p 3) "GB" "gigabyte" + , Unit (p 2) "MB" "megabyte" + , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 1000^n + +{- Memory units are (stupidly named) powers of 2. -} +memoryUnits :: [Unit] +memoryUnits = + [ Unit (p 8) "YiB" "yobibyte" + , Unit (p 7) "ZiB" "zebibyte" + , Unit (p 6) "EiB" "exbibyte" + , Unit (p 5) "PiB" "pebibyte" + , Unit (p 4) "TiB" "tebibyte" + , Unit (p 3) "GiB" "gibibyte" + , Unit (p 2) "MiB" "mebibyte" + , Unit (p 1) "KiB" "kibibyte" + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 2^(n*10) + +{- Bandwidth units are only measured in bits if you're some crazy telco. -} +bandwidthUnits :: [Unit] +bandwidthUnits = error "stop trying to rip people off" + +{- Do you yearn for the days when men were men and megabytes were megabytes? -} +oldSchoolUnits :: [Unit] +oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits + where + mingle (Unit _ a n, Unit s' _ _) = Unit s' a n + +{- approximate display of a particular number of bytes -} +roughSize :: [Unit] -> Bool -> ByteSize -> String +roughSize units short i + | i < 0 = '-' : findUnit units' (negate i) + | otherwise = findUnit units' i + where + units' = sortBy (flip compare) units -- largest first + + findUnit (u@(Unit s _ _):us) i' + | i' >= s = showUnit i' u + | otherwise = findUnit us i' + findUnit [] i' = showUnit i' (last units') -- bytes + + showUnit x (Unit size abbrev name) = s ++ " " ++ unit + where + v = (fromInteger x :: Double) / fromInteger size + s = showImprecise 2 v + unit + | short = abbrev + | s == "1" = name + | otherwise = name ++ "s" + +{- displays comparison of two sizes -} +compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String +compareSizes units abbrev old new + | old > new = roughSize units abbrev (old - new) ++ " smaller" + | old < new = roughSize units abbrev (new - old) ++ " larger" + | otherwise = "same" + +{- Parses strings like "10 kilobytes" or "0.5tb". -} +readSize :: [Unit] -> String -> Maybe ByteSize +readSize units input + | null parsednum || null parsedunit = Nothing + | otherwise = Just $ round $ number * fromIntegral multiplier + where + (number, rest) = head parsednum + multiplier = head parsedunit + unitname = takeWhile isAlpha $ dropWhile isSpace rest + + parsednum = reads input :: [(Double, String)] + parsedunit = lookupUnit units unitname + + lookupUnit _ [] = [1] -- no unit given, assume bytes + lookupUnit [] _ = [] + lookupUnit (Unit s a n:us) v + | a ~~ v || n ~~ v = [s] + | plural n ~~ v || a ~~ byteabbrev v = [s] + | otherwise = lookupUnit us v + + a ~~ b = map toLower a == map toLower b + + plural n = n ++ "s" + byteabbrev a = a ++ "b" diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs index d92327c0..693e7713 100644 --- a/src/Utility/Directory.hs +++ b/src/Utility/Directory.hs @@ -1,25 +1,37 @@ -{- directory manipulation +{- directory traversal and manipulation - - - Copyright 2011-2014 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Directory where +module Utility.Directory ( + module Utility.Directory, + module Utility.SystemDirectory +) where import System.IO.Error -import System.Directory -import Control.Exception (throw) import Control.Monad -import Control.Monad.IfElse import System.FilePath import Control.Applicative +import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) +import Data.Maybe +import Prelude -import Utility.PosixFiles +#ifdef mingw32_HOST_OS +import qualified System.Win32 as Win32 +#else +import qualified System.Posix as Posix import Utility.SafeCommand +import Control.Monad.IfElse +#endif + +import Utility.SystemDirectory +import Utility.PosixFiles import Utility.Tmp import Utility.Exception import Utility.Monad @@ -49,7 +61,7 @@ dirContentsRecursive = dirContentsRecursiveSkipping (const False) True dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] where - go [] = return [] + go [] = return [] go (dir:dirs) | skipdir (takeFileName dir) = go dirs | otherwise = unsafeInterleaveIO $ do @@ -80,7 +92,7 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] where - go c [] = return c + go c [] = return c go c (dir:dirs) | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do @@ -98,27 +110,40 @@ moveFile src dest = tryIO (rename src dest) >>= onrename onrename (Left e) | isPermissionError e = rethrow | isDoesNotExistError e = rethrow - | otherwise = do - -- copyFile is likely not as optimised as - -- the mv command, so we'll use the latter. - -- But, mv will move into a directory if - -- dest is one, which is not desired. - whenM (isdir dest) rethrow - viaTmp mv dest undefined + | otherwise = viaTmp mv dest "" where - rethrow = throw e + rethrow = throwM e + mv tmp _ = do + -- copyFile is likely not as optimised as + -- the mv command, so we'll use the command. + -- + -- But, while Windows has a "mv", it does not seem very + -- reliable, so use copyFile there. +#ifndef mingw32_HOST_OS + -- If dest is a directory, mv would move the file + -- into it, which is not desired. + whenM (isdir dest) rethrow ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] + let e' = e +#else + r <- tryIO $ copyFile src tmp + let (ok, e') = case r of + Left err -> (False, err) + Right _ -> (True, e) +#endif unless ok $ do -- delete any partial _ <- tryIO $ removeFile tmp - rethrow + throwM e' +#ifndef mingw32_HOST_OS isdir f = do r <- tryIO $ getFileStatus f case r of (Left _) -> return False (Right s) -> return $ isDirectory s +#endif {- Removes a file, which may or may not exist, and does not have to - be a regular file. @@ -133,3 +158,90 @@ nukeFile file = void $ tryWhenExists go #else go = removeFile file #endif + +#ifndef mingw32_HOST_OS +data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream +#else +data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ()) +#endif + +type IsOpen = MVar () -- full when the handle is open + +openDirectory :: FilePath -> IO DirectoryHandle +openDirectory path = do +#ifndef mingw32_HOST_OS + dirp <- Posix.openDirStream path + isopen <- newMVar () + return (DirectoryHandle isopen dirp) +#else + (h, fdat) <- Win32.findFirstFile (path </> "*") + -- Indicate that the fdat contains a filename that readDirectory + -- has not yet returned, by making the MVar be full. + -- (There's always at least a "." entry.) + alreadyhave <- newMVar () + isopen <- newMVar () + return (DirectoryHandle isopen h fdat alreadyhave) +#endif + +closeDirectory :: DirectoryHandle -> IO () +#ifndef mingw32_HOST_OS +closeDirectory (DirectoryHandle isopen dirp) = + whenOpen isopen $ + Posix.closeDirStream dirp +#else +closeDirectory (DirectoryHandle isopen h _ alreadyhave) = + whenOpen isopen $ do + _ <- tryTakeMVar alreadyhave + Win32.findClose h +#endif + where + whenOpen :: IsOpen -> IO () -> IO () + whenOpen mv f = do + v <- tryTakeMVar mv + when (isJust v) f + +{- |Reads the next entry from the handle. Once the end of the directory +is reached, returns Nothing and automatically closes the handle. +-} +readDirectory :: DirectoryHandle -> IO (Maybe FilePath) +#ifndef mingw32_HOST_OS +readDirectory hdl@(DirectoryHandle _ dirp) = do + e <- Posix.readDirStream dirp + if null e + then do + closeDirectory hdl + return Nothing + else return (Just e) +#else +readDirectory hdl@(DirectoryHandle _ h fdat mv) = do + -- If the MVar is full, then the filename in fdat has + -- not yet been returned. Otherwise, need to find the next + -- file. + r <- tryTakeMVar mv + case r of + Just () -> getfn + Nothing -> do + more <- Win32.findNextFile h fdat + if more + then getfn + else do + closeDirectory hdl + return Nothing + where + getfn = do + filename <- Win32.getFindDataFileName fdat + return (Just filename) +#endif + +-- True only when directory exists and contains nothing. +-- Throws exception if directory does not exist. +isDirectoryEmpty :: FilePath -> IO Bool +isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check + where + check h = do + v <- readDirectory h + case v of + Nothing -> return True + Just f + | not (dirCruft f) -> return False + | otherwise -> check h diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs index 6763c24e..c56f4ec2 100644 --- a/src/Utility/Env.hs +++ b/src/Utility/Env.hs @@ -1,11 +1,12 @@ {- portable environment variables - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Env where @@ -13,7 +14,9 @@ module Utility.Env where import Utility.Exception import Control.Applicative import Data.Maybe +import Prelude import qualified System.Environment as E +import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -39,27 +42,27 @@ getEnvironment = PE.getEnvironment getEnvironment = E.getEnvironment #endif -{- Returns True if it could successfully set the environment variable. +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. - - - There is, apparently, no way to do this in Windows. Instead, - - environment varuables must be provided when running a new process. -} -setEnv :: String -> String -> Bool -> IO Bool + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () #ifndef mingw32_HOST_OS -setEnv var val overwrite = do - PE.setEnv var val overwrite - return True +setEnv var val overwrite = PE.setEnv var val overwrite #else -setEnv _ _ _ = return False +setEnv var val True = System.SetEnv.setEnv var val +setEnv var val False = do + r <- getEnv var + case r of + Nothing -> setEnv var val True + Just _ -> return () #endif -{- Returns True if it could successfully unset the environment variable. -} -unsetEnv :: String -> IO Bool +unsetEnv :: String -> IO () #ifndef mingw32_HOST_OS -unsetEnv var = do - PE.unsetEnv var - return True +unsetEnv = PE.unsetEnv #else -unsetEnv _ = return False +unsetEnv = System.SetEnv.unsetEnv #endif {- Adds the environment variable to the input environment. If already diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs index 1fecf65d..e691f13b 100644 --- a/src/Utility/Exception.hs +++ b/src/Utility/Exception.hs @@ -1,59 +1,103 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2012 Joey Hess <joey@kitenet.net> + - Copyright 2011-2015 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Exception where +module Utility.Exception ( + module X, + catchBoolIO, + catchMaybeIO, + catchDefaultIO, + catchMsgIO, + catchIO, + tryIO, + bracketIO, + catchNonAsync, + tryNonAsync, + tryWhenExists, + catchIOErrorType, + IOErrorType(..), + catchPermissionDenied, +) where -import Control.Exception -import qualified Control.Exception as E -import Control.Applicative +import Control.Monad.Catch as X hiding (Handler) +import qualified Control.Monad.Catch as M +import Control.Exception (IOException, AsyncException) import Control.Monad -import System.IO.Error (isDoesNotExistError) +import Control.Monad.IO.Class (liftIO, MonadIO) +import System.IO.Error (isDoesNotExistError, ioeGetErrorType) +import GHC.IO.Exception (IOErrorType(..)) + import Utility.Data {- Catches IO errors and returns a Bool -} -catchBoolIO :: IO Bool -> IO Bool +catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False {- Catches IO errors and returns a Maybe -} -catchMaybeIO :: IO a -> IO (Maybe a) -catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a +catchMaybeIO :: MonadCatch m => m a -> m (Maybe a) +catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just) {- Catches IO errors and returns a default value. -} -catchDefaultIO :: a -> IO a -> IO a +catchDefaultIO :: MonadCatch m => a -> m a -> m a catchDefaultIO def a = catchIO a (const $ return def) {- Catches IO errors and returns the error message. -} -catchMsgIO :: IO a -> IO (Either String a) -catchMsgIO a = either (Left . show) Right <$> tryIO a +catchMsgIO :: MonadCatch m => m a -> m (Either String a) +catchMsgIO a = do + v <- tryIO a + return $ either (Left . show) Right v {- catch specialized for IO errors only -} -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = E.catch +catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a +catchIO = M.catch {- try specialized for IO errors only -} -tryIO :: IO a -> IO (Either IOException a) -tryIO = try +tryIO :: MonadCatch m => m a -> m (Either IOException a) +tryIO = M.try + +{- bracket with setup and cleanup actions lifted to IO. + - + - Note that unlike catchIO and tryIO, this catches all exceptions. -} +bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a +bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) {- Catches all exceptions except for async exceptions. - This is often better to use than catching them all, so that - ThreadKilled and UserInterrupt get through. -} -catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a +catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` - [ Handler (\ (e :: AsyncException) -> throw e) - , Handler (\ (e :: SomeException) -> onerr e) + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (e :: SomeException) -> onerr e) ] -tryNonAsync :: IO a -> IO (Either SomeException a) -tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left) +tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) +tryNonAsync a = go `catchNonAsync` (return . Left) + where + go = do + v <- a + return (Right v) {- Catches only DoesNotExist exceptions, and lets all others through. -} -tryWhenExists :: IO a -> IO (Maybe a) -tryWhenExists a = eitherToMaybe <$> - tryJust (guard . isDoesNotExistError) a +tryWhenExists :: MonadCatch m => m a -> m (Maybe a) +tryWhenExists a = do + v <- tryJust (guard . isDoesNotExistError) a + return (eitherToMaybe v) + +{- Catches only IO exceptions of a particular type. + - Ie, use HardwareFault to catch disk IO errors. -} +catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a +catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching + where + onlymatching e + | ioeGetErrorType e == errtype = onmatchingerr e + | otherwise = throwM e + +catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a +catchPermissionDenied = catchIOErrorType PermissionDenied diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs index c2ef683a..bb3780c6 100644 --- a/src/Utility/FileMode.hs +++ b/src/Utility/FileMode.hs @@ -1,29 +1,35 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} -module Utility.FileMode where +module Utility.FileMode ( + module Utility.FileMode, + FileMode, +) where import System.IO import Control.Monad -import Control.Exception (bracket) import System.PosixCompat.Types import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files +import Control.Monad.IO.Class (liftIO) #endif +import Control.Monad.IO.Class (MonadIO) import Foreign (complement) +import Control.Monad.Catch import Utility.Exception {- Applies a conversion function to a file's mode. -} modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert + modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode modifyFileMode' f convert = do s <- getFileStatus f @@ -33,6 +39,14 @@ modifyFileMode' f convert = do setFileMode f new return old +{- Runs an action after changing a file's mode, then restores the old mode. -} +withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a +withModifiedFileMode file convert a = bracket setup cleanup go + where + setup = modifyFileMode' file convert + cleanup oldmode = modifyFileMode file (const oldmode) + go _ = a + {- Adds the specified FileModes to the input mode, leaving the rest - unchanged. -} addModes :: [FileMode] -> FileMode -> FileMode @@ -42,14 +56,6 @@ addModes ms m = combineModes (m:ms) removeModes :: [FileMode] -> FileMode -> FileMode removeModes ms m = m `intersectFileModes` complement (combineModes ms) -{- Runs an action after changing a file's mode, then restores the old mode. -} -withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a -withModifiedFileMode file convert a = bracket setup cleanup go - where - setup = modifyFileMode' file convert - cleanup oldmode = modifyFileMode file (const oldmode) - go _ = a - writeModes :: [FileMode] writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode] @@ -104,7 +110,7 @@ isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 {- Runs an action without that pesky umask influencing it, unless the - passed FileMode is the standard one. -} -noUmask :: FileMode -> IO a -> IO a +noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS noUmask mode a | mode == stdFileMode = a @@ -113,19 +119,19 @@ noUmask mode a noUmask _ a = a #endif -withUmask :: FileMode -> IO a -> IO a +withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS withUmask umask a = bracket setup cleanup go where - setup = setFileCreationMask umask - cleanup = setFileCreationMask + setup = liftIO $ setFileCreationMask umask + cleanup = liftIO . setFileCreationMask go _ = a #else withUmask _ a = a #endif combineModes :: [FileMode] -> FileMode -combineModes [] = undefined +combineModes [] = 0 combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms @@ -152,7 +158,11 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - as writeFile. -} writeFileProtected :: FilePath -> String -> IO () -writeFileProtected file content = withUmask 0o0077 $ +writeFileProtected file content = writeFileProtected' file + (\h -> hPutStr h content) + +writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' file writer = withUmask 0o0077 $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes - hPutStr h content + writer h diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs index b81fdc53..eab98337 100644 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -1,20 +1,25 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( fileEncoding, withFilePath, md5FilePath, decodeBS, + encodeBS, decodeW8, encodeW8, + encodeW8NUL, + decodeW8NUL, truncateFilePath, + setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -25,11 +30,15 @@ import System.IO.Unsafe import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils +import Data.List +import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 #endif +import Utility.Exception + {- Sets a Handle to use the filesystem encoding. This causes data - written or read from it to be encoded/decoded the same - as ghc 7.4 does to filenames etc. This special encoding @@ -63,12 +72,16 @@ withFilePath fp f = Encoding.getFileSystemEncoding - only allows doing this conversion with CStrings, and the CString buffer - is allocated, used, and deallocated within the call, with no side - effects. + - + - If the FilePath contains a value that is not legal in the filesystem + - encoding, rather than thowing an exception, it will be returned as-is. -} {-# NOINLINE _encodeFilePath #-} _encodeFilePath :: FilePath -> String _encodeFilePath fp = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding - GHC.withCString enc fp $ GHC.peekCString Encoding.char8 + GHC.withCString enc fp (GHC.peekCString Encoding.char8) + `catchNonAsync` (\_ -> return fp) {- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} md5FilePath :: FilePath -> MD5.Str @@ -77,18 +90,29 @@ md5FilePath = MD5.Str . _encodeFilePath {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBS :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBS = encodeW8 . L.unpack +decodeBS = encodeW8NUL . L.unpack #else {- On Windows, we assume that the ByteString is utf-8, since Windows - only uses unicode for filenames. -} decodeBS = L8.toString #endif +{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} +encodeBS :: FilePath -> L.ByteString +#ifndef mingw32_HOST_OS +encodeBS = L.pack . decodeW8NUL +#else +encodeBS = L8.fromString +#endif + {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - w82c produces a String, which may contain Chars that are invalid - unicode. From there, this is really a simple matter of applying the - file system encoding, only complicated by GHC's interface to doing so. + - + - Note that the encoding stops at any NUL in the input. FilePaths + - do not normally contain embedded NUL, but Haskell Strings may. -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath @@ -101,6 +125,17 @@ encodeW8 w8 = unsafePerformIO $ do decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath +{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} +encodeW8NUL :: [Word8] -> FilePath +encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) + where + nul = ['\NUL'] + +decodeW8NUL :: FilePath -> [Word8] +decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul + where + nul = ['\NUL'] + {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. - @@ -111,7 +146,7 @@ truncateFilePath :: Int -> FilePath -> FilePath #ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where - go f = + go f = let bytes = decodeW8 f in if length bytes <= n then reverse f @@ -130,3 +165,10 @@ truncateFilePath n = reverse . go [] n . L8.fromString else go (c:coll) (cnt - x') (L8.drop 1 bs) _ -> coll #endif + +{- This avoids ghc's output layer crashing on invalid encoded characters in + - filenames when printing them out. -} +setConsoleEncoding :: IO () +setConsoleEncoding = do + fileEncoding stdout + fileEncoding stderr diff --git a/src/Utility/HumanNumber.hs b/src/Utility/HumanNumber.hs new file mode 100644 index 00000000..c3fede95 --- /dev/null +++ b/src/Utility/HumanNumber.hs @@ -0,0 +1,21 @@ +{- numbers for humans + - + - Copyright 2012-2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.HumanNumber where + +{- Displays a fractional value as a string with a limited number + - of decimal digits. -} +showImprecise :: RealFrac a => Int -> a -> String +showImprecise precision n + | precision == 0 || remainder == 0 = show (round n :: Integer) + | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder) + where + int :: Integer + (int, frac) = properFraction n + remainder = round (frac * 10 ^ precision) :: Integer + pad0s s = replicate (precision - length s) '0' ++ s + striptrailing0s = reverse . dropWhile (== '0') . reverse diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs index 1dc4e1ea..122f3964 100644 --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -1,26 +1,27 @@ {- Linux library copier and binary shimmer - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} module Utility.LinuxMkLibs where -import Control.Applicative -import Data.Maybe -import System.Directory -import Data.List.Utils -import System.Posix.Files -import Data.Char -import Control.Monad.IfElse - import Utility.PartialPrelude import Utility.Directory import Utility.Process import Utility.Monad import Utility.Path +import Data.Maybe +import System.FilePath +import Data.List.Utils +import System.Posix.Files +import Data.Char +import Control.Monad.IfElse +import Control.Applicative +import Prelude + {- Installs a library. If the library is a symlink to another file, - install the file it links to, and update the symlink to be relative. -} installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath) @@ -35,7 +36,7 @@ installLib installfile top lib = ifM (doesFileExist lib) checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do l <- readSymbolicLink (inTop top f) let absl = absPathFrom (parentDir f) l - let target = relPathDirToFile (parentDir f) absl + target <- relPathDirToFile (takeDirectory f) absl installfile top absl nukeFile (top ++ f) createSymbolicLink target (inTop top f) diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs index 949f41e7..ebb42576 100644 --- a/src/Utility/Misc.hs +++ b/src/Utility/Misc.hs @@ -1,28 +1,30 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2011 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Misc where +import Utility.FileSystemEncoding +import Utility.Monad + import System.IO import Control.Monad import Foreign import Data.Char import Data.List -import Control.Applicative import System.Exit #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif - -import Utility.FileSystemEncoding -import Utility.Monad +import Control.Applicative +import Prelude {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} @@ -134,7 +136,7 @@ hGetSomeString h sz = do - if this reap gets there first. -} reapZombies :: IO () #ifndef mingw32_HOST_OS -reapZombies = do +reapZombies = -- throws an exception when there are no child processes catchDefaultIO Nothing (getAnyProcessStatus False True) >>= maybe (return ()) (const reapZombies) diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs index eba3c428..ac751043 100644 --- a/src/Utility/Monad.hs +++ b/src/Utility/Monad.hs @@ -1,10 +1,12 @@ {- monadic stuff - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.Monad where import Data.Maybe diff --git a/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs index 6efa093f..55795563 100644 --- a/src/Utility/PartialPrelude.hs +++ b/src/Utility/PartialPrelude.hs @@ -5,6 +5,8 @@ - them being accidentially used. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.PartialPrelude where import qualified Data.Maybe diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs index 99c9438b..3ee5ff39 100644 --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -1,34 +1,37 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess <joey@kitenet.net> + - Copyright 2010-2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE PackageImports, CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path where import Data.String.Utils import System.FilePath -import System.Directory import Data.List import Data.Maybe import Data.Char import Control.Applicative +import Prelude #ifdef mingw32_HOST_OS import qualified System.FilePath.Posix as Posix #else import System.Posix.Files +import Utility.Exception #endif import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo +import Utility.Directory -{- Simplifies a path, removing any ".." or ".", and removing the trailing - - path separator. +{- Simplifies a path, removing any "." component, collapsing "dir/..", + - and removing the trailing path separator. - - On Windows, preserves whichever style of path separator might be used in - the input FilePaths. This is done because some programs in Windows @@ -47,7 +50,8 @@ simplifyPath path = dropTrailingPathSeparator $ norm c [] = reverse c norm c (p:ps) - | p' == ".." = norm (drop 1 c) ps + | p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." = + norm (drop 1 c) ps | p' == "." = norm c ps | otherwise = norm (p:c) ps where @@ -56,7 +60,7 @@ simplifyPath path = dropTrailingPathSeparator $ {- Makes a path absolute. - - The first parameter is a base directory (ie, the cwd) to use if the path - - is not already absolute. + - is not already absolute, and should itsef be absolute. - - Does not attempt to deal with edge cases or ensure security with - untrusted inputs. @@ -65,7 +69,7 @@ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) {- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. Resulting path will use / separators. -} + - MissingH's absNormPath on them. -} absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS absNormPathUnix dir path = MissingH.absNormPath dir path @@ -76,27 +80,29 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos todos = replace "/" "\\" #endif -{- Returns the parent directory of a path. - - - - To allow this to be easily used in loops, which terminate upon reaching the - - top, the parent of / is "" -} +{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath -parentDir dir - | null dirs = "" - | otherwise = joinDrive drive (join s $ init dirs) +parentDir = takeDirectory . dropTrailingPathSeparator + +{- Just the parent directory of a path, or Nothing if the path has no +- parent (ie for "/" or ".") -} +upFrom :: FilePath -> Maybe FilePath +upFrom dir + | length dirs < 2 = Nothing + | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" (drive, path) = splitDrive dir dirs = filter (not . null) $ split s path s = [pathSeparator] -prop_parentDir_basics :: FilePath -> Bool -prop_parentDir_basics dir +prop_upFrom_basics :: FilePath -> Bool +prop_upFrom_basics dir | null dir = True - | dir == "/" = parentDir dir == "" - | otherwise = p /= dir + | dir == "/" = p == Nothing + | otherwise = p /= Just dir where - p = parentDir dir + p = upFrom dir {- Checks if the first FilePath is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc @@ -125,14 +131,25 @@ absPath file = do - relPathCwdToFile "/tmp/foo/bar" == "" -} relPathCwdToFile :: FilePath -> IO FilePath -relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f +relPathCwdToFile f = do + c <- getCurrentDirectory + relPathDirToFile c f -{- Constructs a relative path from a directory to a file. +{- Constructs a relative path from a directory to a file. -} +relPathDirToFile :: FilePath -> FilePath -> IO FilePath +relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ - - - Both must be absolute, and cannot contain .. etc. (eg use absPath first). + - On Windows, if the paths are on different drives, + - a relative path is not possible and the path is simply + - returned as-is. -} -relPathDirToFile :: FilePath -> FilePath -> FilePath -relPathDirToFile from to = join s $ dotdots ++ uncommon +relPathDirToFileAbs :: FilePath -> FilePath -> FilePath +relPathDirToFileAbs from to + | takeDrive from /= takeDrive to = to + | otherwise = intercalate s $ dotdots ++ uncommon where s = [pathSeparator] pfrom = split s from @@ -145,10 +162,11 @@ relPathDirToFile from to = join s $ dotdots ++ uncommon prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to + | null from || null to = True | from == to = null r | otherwise = not (null r) where - r = relPathDirToFile from to + r = relPathDirToFileAbs from to prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference @@ -157,22 +175,31 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - location, but it's not really the same directory. - Code used to get this wrong. -} same_dir_shortcurcuits_at_difference = - relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) + relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] {- Given an original list of paths, and an expanded list derived from it, - - generates a list of lists, where each sublist corresponds to one of the - - original paths. When the original path is a directory, any items - - in the expanded list that are contained in that directory will appear in - - its segment. + - which may be arbitrarily reordered, generates a list of lists, where + - each sublist corresponds to one of the original paths. + - + - When the original path is a directory, any items in the expanded list + - that are contained in that directory will appear in its segment. + - + - The order of the original list of paths is attempted to be preserved in + - the order of the returned segments. However, doing so has a O^NM + - growth factor. So, if the original list has more than 100 paths on it, + - we stop preserving ordering at that point. Presumably a user passing + - that many paths in doesn't care too much about order of the later ones. -} segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation -segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest +segmentPaths (l:ls) new = found : segmentPaths ls rest where - (found, rest)=partition (l `dirContains`) new + (found, rest) = if length ls < 100 + then partition (l `dirContains`) new + else break (\p -> not (l `dirContains` p)) new {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In @@ -186,7 +213,7 @@ relHome :: FilePath -> IO String relHome path = do home <- myHomeDir return $ if dirContains home path - then "~/" ++ relPathDirToFile home path + then "~/" ++ relPathDirToFileAbs home path else path {- Checks if a command is available in PATH. @@ -225,21 +252,27 @@ dotfile file where f = takeFileName file -{- Converts a DOS style path to a Cygwin style path. Only on Windows. - - Any trailing '\' is preserved as a trailing '/' -} -toCygPath :: FilePath -> FilePath +{- Converts a DOS style path to a msys2 style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' + - + - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i + - + - The virtual filesystem contains: + - /c, /d, ... mount points for Windows drives + -} +toMSYS2Path :: FilePath -> FilePath #ifndef mingw32_HOST_OS -toCygPath = id +toMSYS2Path = id #else -toCygPath p +toMSYS2Path p | null drive = recombine parts - | otherwise = recombine $ "/cygdrive" : driveletter drive : parts + | otherwise = recombine $ "/" : driveletter drive : parts where - (drive, p') = splitDrive p + (drive, p') = splitDrive p parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') + driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath - fixtrailing s + fixtrailing s | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s | otherwise = s #endif @@ -255,11 +288,12 @@ fileNameLengthLimit :: FilePath -> IO Int fileNameLengthLimit _ = return 255 #else fileNameLengthLimit dir = do - l <- fromIntegral <$> getPathVar dir FileNameLimit + -- getPathVar can fail due to statfs(2) overflow + l <- catchDefaultIO 0 $ + fromIntegral <$> getPathVar dir FileNameLimit if l <= 0 then return 255 else return $ minimum [l, 255] - where #endif {- Given a string that we'd like to use as the basis for FilePath, but that @@ -267,12 +301,13 @@ fileNameLengthLimit dir = do - sane FilePath. - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' "../" will thus turn into ".._", which is safe. + - with '_', except for '.' + - "../" will thus turn into ".._", which is safe. -} sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize where - sanitize c + sanitize c | c == '.' = c | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' | otherwise = c diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs index 5abbb578..37253da2 100644 --- a/src/Utility/PosixFiles.hs +++ b/src/Utility/PosixFiles.hs @@ -1,13 +1,14 @@ {- POSIX files (and compatablity wrappers). - - - This is like System.PosixCompat.Files, except with a fixed rename. + - This is like System.PosixCompat.Files, but with a few fixes. - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.PosixFiles ( module X, @@ -20,6 +21,7 @@ import System.PosixCompat.Files as X hiding (rename) import System.Posix.Files (rename) #else import qualified System.Win32.File as Win32 +import qualified System.Win32.HardLink as Win32 #endif {- System.PosixCompat.Files.rename on Windows calls renameFile, @@ -31,3 +33,10 @@ import qualified System.Win32.File as Win32 rename :: FilePath -> FilePath -> IO () rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING #endif + +{- System.PosixCompat.Files.createLink throws an error, but windows + - does support hard links. -} +#ifdef mingw32_HOST_OS +createLink :: FilePath -> FilePath -> IO () +createLink = Win32.createHardLink +#endif diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index cd3826d7..ed02f49e 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -1,21 +1,24 @@ {- System.Process enhancements, including additional ways of running - processes, and logging. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012-2015 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( module X, - CreateProcess, + CreateProcess(..), StdHandle(..), readProcess, + readProcess', readProcessEnv, writeReadProcessEnv, forceSuccessProcess, + forceSuccessProcess', checkSuccessProcess, ignoreFailureProcess, createProcessSuccess, @@ -24,20 +27,27 @@ module Utility.Process ( processTranscript, processTranscript', withHandle, - withBothHandles, + withIOHandles, + withOEHandles, withQuietOutput, + feedWithQuietOutput, createProcess, + waitForProcess, startInteractiveProcess, stdinHandle, stdoutHandle, stderrHandle, + ioHandles, processHandle, devNull, ) where -import qualified System.Process -import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) -import System.Process hiding (createProcess, readProcess) +import qualified Utility.Process.Shim +import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) +import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess) +import Utility.Misc +import Utility.Exception + import System.Exit import System.IO import System.Log.Logger @@ -45,40 +55,39 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad #ifndef mingw32_HOST_OS -import System.Posix.IO +import qualified System.Posix.IO #else import Control.Applicative #endif import Data.Maybe - -import Utility.Misc -import Utility.Exception +import Prelude type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a data StdHandle = StdinHandle | StdoutHandle | StderrHandle deriving (Eq) -{- Normally, when reading from a process, it does not need to be fed any - - standard input. -} +-- | Normally, when reading from a process, it does not need to be fed any +-- standard input. readProcess :: FilePath -> [String] -> IO String readProcess cmd args = readProcessEnv cmd args Nothing readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String -readProcessEnv cmd args environ = - withHandle StdoutHandle createProcessSuccess p $ \h -> do - output <- hGetContentsStrict h - hClose h - return output +readProcessEnv cmd args environ = readProcess' p where p = (proc cmd args) { std_out = CreatePipe , env = environ } -{- Runs an action to write to a process on its stdin, - - returns its output, and also allows specifying the environment. - -} +readProcess' :: CreateProcess -> IO String +readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do + output <- hGetContentsStrict h + hClose h + return output + +-- | Runs an action to write to a process on its stdin, +-- returns its output, and also allows specifying the environment. writeReadProcessEnv :: FilePath -> [String] @@ -118,19 +127,20 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do , env = environ } -{- Waits for a ProcessHandle, and throws an IOError if the process - - did not exit successfully. -} +-- | Waits for a ProcessHandle, and throws an IOError if the process +-- did not exit successfully. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () -forceSuccessProcess p pid = do - code <- waitForProcess pid - case code of - ExitSuccess -> return () - ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n - -{- Waits for a ProcessHandle and returns True if it exited successfully. - - Note that using this with createProcessChecked will throw away - - the Bool, and is only useful to ignore the exit code of a process, - - while still waiting for it. -} +forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p + +forceSuccessProcess' :: CreateProcess -> ExitCode -> IO () +forceSuccessProcess' _ ExitSuccess = return () +forceSuccessProcess' p (ExitFailure n) = fail $ + showCmd p ++ " exited " ++ show n + +-- | Waits for a ProcessHandle and returns True if it exited successfully. +-- Note that using this with createProcessChecked will throw away +-- the Bool, and is only useful to ignore the exit code of a process, +-- while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do code <- waitForProcess pid @@ -141,13 +151,13 @@ ignoreFailureProcess pid = do void $ waitForProcess pid return True -{- Runs createProcess, then an action on its handles, and then - - forceSuccessProcess. -} +-- | Runs createProcess, then an action on its handles, and then +-- forceSuccessProcess. createProcessSuccess :: CreateProcessRunner createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a -{- Runs createProcess, then an action on its handles, and then - - a checker action on its exit code, which must wait for the process. -} +-- | Runs createProcess, then an action on its handles, and then +-- a checker action on its exit code, which must wait for the process. createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner createProcessChecked checker p a = do t@(_, _, _, pid) <- createProcess p @@ -155,31 +165,30 @@ createProcessChecked checker p a = do _ <- checker pid either E.throw return r -{- Leaves the process running, suitable for lazy streaming. - - Note: Zombies will result, and must be waited on. -} +-- | Leaves the process running, suitable for lazy streaming. +-- Note: Zombies will result, and must be waited on. createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p -{- Runs a process, optionally feeding it some input, and - - returns a transcript combining its stdout and stderr, and - - whether it succeeded or failed. -} +-- | Runs a process, optionally feeding it some input, and +-- returns a transcript combining its stdout and stderr, and +-- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript cmd opts input = processTranscript' cmd opts Nothing input +processTranscript = processTranscript' id -processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool) -processTranscript' cmd opts environ input = do +processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) +processTranscript' modproc cmd opts input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} - (readf, writef) <- createPipe - readh <- fdToHandle readf - writeh <- fdToHandle writef - p@(_, _, _, pid) <- createProcess $ + (readf, writef) <- System.Posix.IO.createPipe + readh <- System.Posix.IO.fdToHandle readf + writeh <- System.Posix.IO.fdToHandle writef + p@(_, _, _, pid) <- createProcess $ modproc $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = UseHandle writeh , std_err = UseHandle writeh - , env = environ } hClose writeh @@ -191,12 +200,11 @@ processTranscript' cmd opts environ input = do return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ + p@(_, _, _, pid) <- createProcess $ modproc $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = CreatePipe , std_err = CreatePipe - , env = environ } getout <- mkreader (stdoutHandle p) @@ -226,9 +234,9 @@ processTranscript' cmd opts environ input = do hClose inh writeinput Nothing _ = return () -{- Runs a CreateProcessRunner, on a CreateProcess structure, that - - is adjusted to pipe only from/to a single StdHandle, and passes - - the resulting Handle to an action. -} +-- | Runs a CreateProcessRunner, on a CreateProcess structure, that +-- is adjusted to pipe only from/to a single StdHandle, and passes +-- the resulting Handle to an action. withHandle :: StdHandle -> CreateProcessRunner @@ -250,13 +258,13 @@ withHandle h creator p a = creator p' $ a . select | h == StderrHandle = (stderrHandle, base { std_err = CreatePipe }) -{- Like withHandle, but passes (stdin, stdout) handles to the action. -} -withBothHandles +-- | Like withHandle, but passes (stdin, stdout) handles to the action. +withIOHandles :: CreateProcessRunner -> CreateProcess -> ((Handle, Handle) -> IO a) -> IO a -withBothHandles creator p a = creator p' $ a . bothHandles +withIOHandles creator p a = creator p' $ a . ioHandles where p' = p { std_in = CreatePipe @@ -264,8 +272,22 @@ withBothHandles creator p a = creator p' $ a . bothHandles , std_err = Inherit } -{- Forces the CreateProcessRunner to run quietly; - - both stdout and stderr are discarded. -} +-- | Like withHandle, but passes (stdout, stderr) handles to the action. +withOEHandles + :: CreateProcessRunner + -> CreateProcess + -> ((Handle, Handle) -> IO a) + -> IO a +withOEHandles creator p a = creator p' $ a . oeHandles + where + p' = p + { std_in = Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } + +-- | Forces the CreateProcessRunner to run quietly; +-- both stdout and stderr are discarded. withQuietOutput :: CreateProcessRunner -> CreateProcess @@ -277,6 +299,21 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do } creator p' $ const $ return () +-- | Stdout and stderr are discarded, while the process is fed stdin +-- from the handle. +feedWithQuietOutput + :: CreateProcessRunner + -> CreateProcess + -> (Handle -> IO a) + -> IO a +feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do + let p' = p + { std_in = CreatePipe + , std_out = UseHandle nullh + , std_err = UseHandle nullh + } + creator p' $ a . stdinHandle + devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null" @@ -284,11 +321,11 @@ devNull = "/dev/null" devNull = "NUL" #endif -{- Extract a desired handle from createProcess's tuple. - - These partial functions are safe as long as createProcess is run - - with appropriate parameters to set up the desired handle. - - Get it wrong and the runtime crash will always happen, so should be - - easily noticed. -} +-- | Extract a desired handle from createProcess's tuple. +-- These partial functions are safe as long as createProcess is run +-- with appropriate parameters to set up the desired handle. +-- Get it wrong and the runtime crash will always happen, so should be +-- easily noticed. type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle stdinHandle :: HandleExtractor stdinHandle (Just h, _, _, _) = h @@ -299,38 +336,25 @@ stdoutHandle _ = error "expected stdoutHandle" stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle" -bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) -bothHandles (Just hin, Just hout, _, _) = (hin, hout) -bothHandles _ = error "expected bothHandles" +ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +ioHandles (Just hin, Just hout, _, _) = (hin, hout) +ioHandles _ = error "expected ioHandles" +oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +oeHandles (_, Just hout, Just herr, _) = (hout, herr) +oeHandles _ = error "expected oeHandles" processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid -{- Debugging trace for a CreateProcess. -} -debugProcess :: CreateProcess -> IO () -debugProcess p = do - debugM "Utility.Process" $ unwords - [ action ++ ":" - , showCmd p - ] - where - action - | piped (std_in p) && piped (std_out p) = "chat" - | piped (std_in p) = "feed" - | piped (std_out p) = "read" - | otherwise = "call" - piped Inherit = False - piped _ = True - -{- Shows the command that a CreateProcess will run. -} +-- | Shows the command that a CreateProcess will run. showCmd :: CreateProcess -> String showCmd = go . cmdspec where go (ShellCommand s) = s go (RawCommand c ps) = c ++ " " ++ show ps -{- Starts an interactive process. Unlike runInteractiveProcess in - - System.Process, stderr is inherited. -} +-- | Starts an interactive process. Unlike runInteractiveProcess in +-- System.Process, stderr is inherited. startInteractiveProcess :: FilePath -> [String] @@ -346,8 +370,30 @@ startInteractiveProcess cmd args environ = do (Just from, Just to, _, pid) <- createProcess p return (pid, to, from) -{- Wrapper around System.Process function that does debug logging. -} +-- | Wrapper around 'System.Process.createProcess' that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p - System.Process.createProcess p + Utility.Process.Shim.createProcess p + +-- | Debugging trace for a CreateProcess. +debugProcess :: CreateProcess -> IO () +debugProcess p = debugM "Utility.Process" $ unwords + [ action ++ ":" + , showCmd p + ] + where + action + | piped (std_in p) && piped (std_out p) = "chat" + | piped (std_in p) = "feed" + | piped (std_out p) = "read" + | otherwise = "call" + piped Inherit = False + piped _ = True + +-- | Wrapper around 'System.Process.waitForProcess' that does debug logging. +waitForProcess :: ProcessHandle -> IO ExitCode +waitForProcess h = do + r <- Utility.Process.Shim.waitForProcess h + debugM "Utility.Process" ("process done " ++ show r) + return r diff --git a/src/Utility/Process/NonConcurrent.hs b/src/Utility/Process/NonConcurrent.hs new file mode 100644 index 00000000..d25d2a24 --- /dev/null +++ b/src/Utility/Process/NonConcurrent.hs @@ -0,0 +1,35 @@ +{- Running processes in the foreground, not via the concurrent-output + - layer. + - + - Avoid using this in propellor properties! + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Process.NonConcurrent where + +import System.Process +import System.Exit +import System.IO +import Utility.SafeCommand +import Control.Applicative +import Prelude + +boolSystemNonConcurrent :: String -> [CommandParam] -> IO Bool +boolSystemNonConcurrent cmd params = do + (Nothing, Nothing, Nothing, p) <- createProcessNonConcurrent $ + proc cmd (toCommand params) + dispatch <$> waitForProcessNonConcurrent p + where + dispatch ExitSuccess = True + dispatch _ = False + +createProcessNonConcurrent :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcessNonConcurrent = createProcess + +waitForProcessNonConcurrent :: ProcessHandle -> IO ExitCode +waitForProcessNonConcurrent = waitForProcess diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs new file mode 100644 index 00000000..8c9d41d0 --- /dev/null +++ b/src/Utility/Process/Shim.hs @@ -0,0 +1,4 @@ +module Utility.Process.Shim (module X, createProcess, waitForProcess) where + +import System.Process as X hiding (createProcess, waitForProcess) +import System.Process.Concurrent diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs deleted file mode 100644 index a498ee61..00000000 --- a/src/Utility/QuickCheck.hs +++ /dev/null @@ -1,52 +0,0 @@ -{- QuickCheck with additional instances - - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> - - - - License: BSD-2-clause - -} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Utility.QuickCheck - ( module X - , module Utility.QuickCheck - ) where - -import Test.QuickCheck as X -import Data.Time.Clock.POSIX -import System.Posix.Types -import qualified Data.Map as M -import qualified Data.Set as S -import Control.Applicative - -instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where - arbitrary = M.fromList <$> arbitrary - -instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where - arbitrary = S.fromList <$> arbitrary - -{- Times before the epoch are excluded. -} -instance Arbitrary POSIXTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - -instance Arbitrary EpochTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - -{- Pids are never negative, or 0. -} -instance Arbitrary ProcessID where - arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) - -{- Inodes are never negative. -} -instance Arbitrary FileID where - arbitrary = nonNegative arbitrarySizedIntegral - -{- File sizes are never negative. -} -instance Arbitrary FileOffset where - arbitrary = nonNegative arbitrarySizedIntegral - -nonNegative :: (Num a, Ord a) => Gen a -> Gen a -nonNegative g = g `suchThat` (>= 0) - -positive :: (Num a, Ord a) => Gen a -> Gen a -positive g = g `suchThat` (> 0) diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs index 04fcf390..5ce17a84 100644 --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -1,85 +1,94 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.SafeCommand where import System.Exit import Utility.Process -import System.Process (env) import Data.String.Utils -import Control.Applicative import System.FilePath import Data.Char +import Data.List +import Control.Applicative +import Prelude -{- A type for parameters passed to a shell command. A command can - - be passed either some Params (multiple parameters can be included, - - whitespace-separated, or a single Param (for when parameters contain - - whitespace), or a File. - -} -data CommandParam = Params String | Param String | File FilePath +-- | Parameters that can be passed to a shell command. +data CommandParam + = Param String -- ^ A parameter + | File FilePath -- ^ The name of a file deriving (Eq, Show, Ord) -{- Used to pass a list of CommandParams to a function that runs - - a command and expects Strings. -} +-- | Used to pass a list of CommandParams to a function that runs +-- a command and expects Strings. -} toCommand :: [CommandParam] -> [String] -toCommand = concatMap unwrap +toCommand = map unwrap where - unwrap (Param s) = [s] - unwrap (Params s) = filter (not . null) (split " " s) + unwrap (Param s) = s -- Files that start with a non-alphanumeric that is not a path -- separator are modified to avoid the command interpreting them as -- options or other special constructs. unwrap (File s@(h:_)) - | isAlphaNum h || h `elem` pathseps = [s] - | otherwise = ["./" ++ s] - unwrap (File s) = [s] + | isAlphaNum h || h `elem` pathseps = s + | otherwise = "./" ++ s + unwrap (File s) = s -- '/' is explicitly included because it's an alternative -- path separator on Windows. pathseps = pathSeparator:"./" -{- Run a system command, and returns True or False - - if it succeeded or failed. - -} +-- | Run a system command, and returns True or False if it succeeded or failed. +-- +-- This and other command running functions in this module log the commands +-- run at debug level, using System.Log.Logger. boolSystem :: FilePath -> [CommandParam] -> IO Bool -boolSystem command params = boolSystemEnv command params Nothing +boolSystem command params = boolSystem' command params id -boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ +boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool +boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess where dispatch ExitSuccess = True dispatch _ = False -{- Runs a system command, returning the exit status. -} +boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +boolSystemEnv command params environ = boolSystem' command params $ + \p -> p { env = environ } + +-- | Runs a system command, returning the exit status. safeSystem :: FilePath -> [CommandParam] -> IO ExitCode -safeSystem command params = safeSystemEnv command params Nothing +safeSystem command params = safeSystem' command params id -safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode -safeSystemEnv command params environ = do - (_, _, _, pid) <- createProcess (proc command $ toCommand params) - { env = environ } +safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode +safeSystem' command params mkprocess = do + (_, _, _, pid) <- createProcess p waitForProcess pid + where + p = mkprocess $ proc command (toCommand params) + +safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode +safeSystemEnv command params environ = safeSystem' command params $ + \p -> p { env = environ } -{- Wraps a shell command line inside sh -c, allowing it to be run in a - - login shell that may not support POSIX shell, eg csh. -} +-- | Wraps a shell command line inside sh -c, allowing it to be run in a +-- login shell that may not support POSIX shell, eg csh. shellWrap :: String -> String shellWrap cmdline = "sh -c " ++ shellEscape cmdline -{- Escapes a filename or other parameter to be safely able to be exposed to - - the shell. - - - - This method works for POSIX shells, as well as other shells like csh. - -} +-- | Escapes a filename or other parameter to be safely able to be exposed to +-- the shell. +-- +-- This method works for POSIX shells, as well as other shells like csh. shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' - escaped = join "'\"'\"'" $ split "'" f + escaped = intercalate "'\"'\"'" $ split "'" f -{- Unescapes a set of shellEscaped words or filenames. -} +-- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] shellUnEscape [] = [] shellUnEscape s = word : shellUnEscape rest @@ -96,25 +105,32 @@ shellUnEscape s = word : shellUnEscape rest | c == q = findword w cs | otherwise = inquote q (w++[c]) cs -{- For quickcheck. -} -prop_idempotent_shellEscape :: String -> Bool -prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s -prop_idempotent_shellEscape_multiword :: [String] -> Bool -prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s +-- | For quickcheck. +prop_isomorphic_shellEscape :: String -> Bool +prop_isomorphic_shellEscape s = [s] == (shellUnEscape . shellEscape) s +prop_isomorphic_shellEscape_multiword :: [String] -> Bool +prop_isomorphic_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s + +-- | Segments a list of filenames into groups that are all below the maximum +-- command-line length limit. +segmentXargsOrdered :: [FilePath] -> [[FilePath]] +segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered -{- Segements a list of filenames into groups that are all below the manximum - - command-line length limit. Does not preserve order. -} -segmentXargs :: [FilePath] -> [[FilePath]] -segmentXargs l = go l [] 0 [] +-- | Not preserving order is a little faster, and streams better when +-- there are a great many filenames. +segmentXargsUnordered :: [FilePath] -> [[FilePath]] +segmentXargsUnordered l = go l [] 0 [] where - go [] c _ r = c:r + go [] c _ r = (c:r) go (f:fs) c accumlen r - | len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r) + | newlen > maxlen && len < maxlen = go (f:fs) [] 0 (c:r) | otherwise = go fs (f:c) newlen r where len = length f newlen = accumlen + len - {- 10k of filenames per command, well under Linux's 20k limit; - - allows room for other parameters etc. -} + {- 10k of filenames per command, well under 100k limit + - of Linux (and OSX has a similar limit); + - allows room for other parameters etc. Also allows for + - eg, multibyte characters. -} maxlen = 10240 diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs index 305410c5..d23aaf03 100644 --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -1,6 +1,6 @@ {- scheduled activities - - - Copyright 2013-2014 Joey Hess <joey@kitenet.net> + - Copyright 2013-2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -23,28 +23,28 @@ module Utility.Scheduled ( toRecurrance, toSchedule, parseSchedule, - prop_schedule_roundtrips, prop_past_sane, ) where import Utility.Data -import Utility.QuickCheck import Utility.PartialPrelude import Utility.Misc -import Control.Applicative import Data.List import Data.Time.Clock import Data.Time.LocalTime import Data.Time.Calendar import Data.Time.Calendar.WeekDate import Data.Time.Calendar.OrdinalDate +import Data.Time.Format () import Data.Tuple.Utils import Data.Char +import Control.Applicative +import Prelude {- Some sort of scheduled event. -} data Schedule = Schedule Recurrance ScheduledTime - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) data Recurrance = Daily @@ -54,7 +54,7 @@ data Recurrance | Divisible Int Recurrance -- ^ Days, Weeks, or Months of the year evenly divisible by a number. -- (Divisible Year is years evenly divisible by a number.) - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) type WeekDay = Int type MonthDay = Int @@ -63,7 +63,7 @@ type YearDay = Int data ScheduledTime = AnyTime | SpecificTime Hour Minute - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) type Hour = Int type Minute = Int @@ -73,7 +73,7 @@ type Minute = Int data NextTime = NextTimeExactly LocalTime | NextTimeWindow LocalTime LocalTime - deriving (Eq, Read, Show) + deriving (Eq, Read, Show) startTime :: NextTime -> LocalTime startTime (NextTimeExactly t) = t @@ -96,9 +96,9 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime NextTimeExactly t -> window (localDay t) (localDay t) | otherwise = NextTimeExactly . startTime <$> findfromtoday False where - findfromtoday anytime = findfrom recurrance afterday today + findfromtoday anytime = findfrom recurrance afterday today where - today = localDay currenttime + today = localDay currenttime afterday = sameaslastrun || toolatetoday toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime sameaslastrun = lastrun == Just today @@ -163,8 +163,8 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate where - skip n = findfrom r False (addDays n candidate) - handlediv n r' getval mmax + skip n = findfrom r False (addDays n candidate) + handlediv n r' getval mmax | n > 0 && maybe True (n <=) mmax = findfromwhere r' (divisible n . getval) afterday candidate | otherwise = Nothing @@ -267,7 +267,7 @@ toRecurrance s = case words s of constructor u | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u | otherwise = Nothing - withday sd u = do + withday sd u = do c <- constructor u d <- readish sd Just $ c (Just d) @@ -285,7 +285,7 @@ fromScheduledTime AnyTime = "any time" fromScheduledTime (SpecificTime h m) = show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm where - pad n s = take (n - length s) (repeat '0') ++ s + pad n s = replicate (n - length s) '0' ++ s (h', ampm) | h == 0 = (12, "AM") | h < 12 = (h, "AM") @@ -304,10 +304,10 @@ toScheduledTime v = case words v of (s:[]) -> go s id _ -> Nothing where - h0 h + h0 h | h == 12 = 0 | otherwise = h - go :: String -> (Int -> Int) -> Maybe ScheduledTime + go :: String -> (Int -> Int) -> Maybe ScheduledTime go s adjust = let (h, m) = separate (== ':') s in SpecificTime @@ -336,41 +336,6 @@ parseSchedule s = do recurrance = unwords rws scheduledtime = unwords tws -instance Arbitrary Schedule where - arbitrary = Schedule <$> arbitrary <*> arbitrary - -instance Arbitrary ScheduledTime where - arbitrary = oneof - [ pure AnyTime - , SpecificTime - <$> choose (0, 23) - <*> choose (1, 59) - ] - -instance Arbitrary Recurrance where - arbitrary = oneof - [ pure Daily - , Weekly <$> arbday - , Monthly <$> arbday - , Yearly <$> arbday - , Divisible - <$> positive arbitrary - <*> oneof -- no nested Divisibles - [ pure Daily - , Weekly <$> arbday - , Monthly <$> arbday - , Yearly <$> arbday - ] - ] - where - arbday = oneof - [ Just <$> nonNegative arbitrary - , pure Nothing - ] - -prop_schedule_roundtrips :: Schedule -> Bool -prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s - prop_past_sane :: Bool prop_past_sane = and [ all (checksout oneMonthPast) (mplus1 ++ yplus1) diff --git a/src/Utility/SystemDirectory.hs b/src/Utility/SystemDirectory.hs new file mode 100644 index 00000000..3dd44d19 --- /dev/null +++ b/src/Utility/SystemDirectory.hs @@ -0,0 +1,16 @@ +{- System.Directory without its conflicting isSymbolicLink + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +-- Disable warnings because only some versions of System.Directory export +-- isSymbolicLink. +{-# OPTIONS_GHC -fno-warn-tabs -w #-} + +module Utility.SystemDirectory ( + module System.Directory +) where + +import System.Directory hiding (isSymbolicLink) diff --git a/src/Utility/Table.hs b/src/Utility/Table.hs index 910038e8..6d4c045b 100644 --- a/src/Utility/Table.hs +++ b/src/Utility/Table.hs @@ -1,6 +1,6 @@ {- text based table generation - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} @@ -16,13 +16,14 @@ tableWithHeader header rows = header : map linesep header : rows where linesep = map (const '-') --- | Formats a table to lines, automatically padding rows to the same size. +-- | Formats a table to lines, automatically padding columns to the same size. formatTable :: Table -> [String] -formatTable table = map (\r -> unwords (map pad (zip r rowsizes))) table +formatTable table = map (\r -> unwords (map pad (zip r colsizes))) table where pad (cell, size) = cell ++ take (size - length cell) padding padding = repeat ' ' - rowsizes = sumrows (map (map length) table) - sumrows [] = repeat 0 - sumrows [r] = r - sumrows (r1:r2:rs) = sumrows $ map (uncurry max) (zip r1 r2) : rs + colsizes = reverse $ (0:) $ drop 1 $ reverse $ + sumcols (map (map length) table) + sumcols [] = repeat 0 + sumcols [r] = r + sumcols (r1:r2:rs) = sumcols $ zipWith max r1 r2 : rs diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs index fc026d7e..da05e996 100644 --- a/src/Utility/ThreadScheduler.hs +++ b/src/Utility/ThreadScheduler.hs @@ -1,6 +1,6 @@ {- thread scheduling - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2013 Joey Hess <id@joeyh.name> - Copyright 2011 Bas van Dijk & Roel van Dijk - - License: BSD-2-clause @@ -57,8 +57,7 @@ unboundDelay time = do waitForTermination :: IO () waitForTermination = do #ifdef mingw32_HOST_OS - runEvery (Seconds 600) $ - void getLine + forever $ threadDelaySeconds (Seconds 6000) #else lock <- newEmptyMVar let check sig = void $ diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs index 0dc9f2c0..6a541cfe 100644 --- a/src/Utility/Tmp.hs +++ b/src/Utility/Tmp.hs @@ -1,19 +1,23 @@ {- Temporary files and directories. - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Tmp where -import Control.Exception (bracket) import System.IO -import System.Directory import Control.Monad.IfElse import System.FilePath +import System.Directory +import Control.Monad.IO.Class +#ifndef mingw32_HOST_OS +import System.Posix.Temp (mkdtemp) +#endif import Utility.Exception import Utility.FileSystemEncoding @@ -24,64 +28,84 @@ type Template = String {- Runs an action like writeFile, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. -} -viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () -viaTmp a file content = do - let (dir, base) = splitFileName file - createDirectoryIfMissing True dir - (tmpfile, handle) <- openTempFile dir (base ++ ".tmp") - hClose handle - a tmpfile content - rename tmpfile file +viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m () +viaTmp a file content = bracketIO setup cleanup use + where + (dir, base) = splitFileName file + template = base ++ ".tmp" + setup = do + createDirectoryIfMissing True dir + openTempFile dir template + cleanup (tmpfile, h) = do + _ <- tryIO $ hClose h + tryIO $ removeFile tmpfile + use (tmpfile, h) = do + liftIO $ hClose h + a tmpfile content + liftIO $ rename tmpfile file {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} -withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a withTmpFile template a = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory + tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - then removes the file. -} -withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where - create = openTempFile tmpdir template - remove (name, handle) = do - hClose handle + create = liftIO $ openTempFile tmpdir template + remove (name, h) = liftIO $ do + hClose h catchBoolIO (removeFile name >> return True) - use (name, handle) = a name handle + use (name, h) = a name h {- Runs an action with a tmp directory located within the system's tmp - directory (or within "." if there is none), then removes the tmp - directory and all its contents. -} -withTmpDir :: Template -> (FilePath -> IO a) -> IO a +withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a withTmpDir template a = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory - withTmpDirIn tmpdir template a + topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory +#ifndef mingw32_HOST_OS + -- Use mkdtemp to create a temp directory securely in /tmp. + bracket + (liftIO $ mkdtemp $ topleveltmpdir </> template) + removeTmpDir + a +#else + withTmpDirIn topleveltmpdir template a +#endif {- Runs an action with a tmp directory located within a specified directory, - then removes the tmp directory and all its contents. -} -withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a -withTmpDirIn tmpdir template = bracket create remove +withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a +withTmpDirIn tmpdir template = bracketIO create removeTmpDir where - remove d = whenM (doesDirectoryExist d) $ do -#if mingw32_HOST_OS - -- Windows will often refuse to delete a file - -- after a process has just written to it and exited. - -- Because it's crap, presumably. So, ignore failure - -- to delete the temp directory. - _ <- tryIO $ removeDirectoryRecursive d - return () -#else - removeDirectoryRecursive d -#endif create = do createDirectoryIfMissing True tmpdir makenewdir (tmpdir </> template) (0 :: Int) makenewdir t n = do let dir = t ++ "." ++ show n - either (const $ makenewdir t $ n + 1) (const $ return dir) - =<< tryIO (createDirectory dir) + catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do + createDirectory dir + return dir + +{- Deletes the entire contents of the the temporary directory, if it + - exists. -} +removeTmpDir :: MonadIO m => FilePath -> m () +removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do +#if mingw32_HOST_OS + -- Windows will often refuse to delete a file + -- after a process has just written to it and exited. + -- Because it's crap, presumably. So, ignore failure + -- to delete the temp directory. + _ <- tryIO $ removeDirectoryRecursive tmpdir + return () +#else + removeDirectoryRecursive tmpdir +#endif {- It's not safe to use a FilePath of an existing file as the template - for openTempFile, because if the FilePath is really long, the tmpfile diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs index 617c3e94..c6010116 100644 --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -1,11 +1,12 @@ {- user info - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.UserInfo ( myHomeDir, @@ -13,11 +14,12 @@ module Utility.UserInfo ( myUserGecos, ) where -import Control.Applicative -import System.PosixCompat - import Utility.Env +import System.PosixCompat +import Control.Applicative +import Prelude + {- Current user's home directory. - - getpwent will fail on LDAP or NIS, so use HOME if set. -} @@ -40,16 +42,20 @@ myUserName = myVal env userName env = ["USERNAME", "USER", "LOGNAME"] #endif -myUserGecos :: IO String -#ifdef __ANDROID__ -myUserGecos = return "" -- userGecos crashes on Android +myUserGecos :: IO (Maybe String) +-- userGecos crashes on Android and is not available on Windows. +#if defined(__ANDROID__) || defined(mingw32_HOST_OS) +myUserGecos = return Nothing #else -myUserGecos = myVal [] userGecos +myUserGecos = Just <$> myVal [] userGecos #endif myVal :: [String] -> (UserEntry -> String) -> IO String -myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars +myVal envvars extract = go envvars where - check [] = return Nothing - check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v - getpwent = getUserEntryForID =<< getEffectiveUserID +#ifndef mingw32_HOST_OS + go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) +#else + go [] = extract <$> error ("environment not set: " ++ show envvars) +#endif + go (v:vs) = maybe (go vs) return =<< getEnv v diff --git a/src/wrapper.hs b/src/wrapper.hs index 304e833d..dab77358 100644 --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -3,164 +3,42 @@ -- Distributions should install this program into PATH. -- (Cabal builds it as dist/build/propellor/propellor). -- --- This is not the propellor main program (that's config.hs) --- --- This installs propellor's source into ~/.propellor, --- uses it to build the real propellor program (if not already built), --- and runs it. --- --- The source is cloned from /usr/src/propellor when available, --- or is cloned from git over the network. +-- This is not the propellor main program (that's config.hs). +-- This bootstraps ~/.propellor/config.hs, builds it if +-- it's not already built, and runs it. module Main where +import Propellor.DotDir import Propellor.Message -import Utility.UserInfo +import Propellor.Bootstrap import Utility.Monad +import Utility.Directory import Utility.Process -import Utility.SafeCommand -import Utility.Exception +import Utility.Process.NonConcurrent -import Control.Monad -import Control.Monad.IfElse -import Control.Applicative -import System.Directory -import System.FilePath import System.Environment (getArgs) import System.Exit import System.Posix.Directory -import System.IO - -distdir :: FilePath -distdir = "/usr/src/propellor" - -distrepo :: FilePath -distrepo = distdir </> "propellor.git" - -disthead :: FilePath -disthead = distdir </> "head" - -upstreambranch :: String -upstreambranch = "upstream/master" - --- Using the github mirror of the main propellor repo because --- it is accessible over https for better security. -netrepo :: String -netrepo = "https://github.com/joeyh/propellor.git" +import Control.Monad.IfElse main :: IO () -main = do - args <- getArgs - home <- myHomeDir - let propellordir = home </> ".propellor" - let propellorbin = propellordir </> "propellor" - wrapper args propellordir propellorbin - -wrapper :: [String] -> FilePath -> FilePath -> IO () -wrapper args propellordir propellorbin = do - ifM (doesDirectoryExist propellordir) - ( checkRepo - , makeRepo - ) - buildruncfg +main = withConcurrentOutput $ go =<< getArgs where - makeRepo = do - putStrLn $ "Setting up your propellor repo in " ++ propellordir - putStrLn "" - ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo) - ( do - void $ boolSystem "git" [Param "clone", File distrepo, File propellordir] - fetchUpstreamBranch propellordir distrepo - changeWorkingDirectory propellordir - void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"] - , void $ boolSystem "git" [Param "clone", Param netrepo, File propellordir] - ) - - checkRepo = whenM (doesFileExist disthead) $ do - headrev <- takeWhile (/= '\n') <$> readFile disthead - changeWorkingDirectory propellordir - headknown <- catchMaybeIO $ - withQuietOutput createProcessSuccess $ - proc "git" ["log", headrev] - if (headknown == Nothing) - then setupupstreammaster headrev propellordir - else do - merged <- not . null <$> - readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"] - unless merged $ - warnoutofdate propellordir True - buildruncfg = do - changeWorkingDirectory propellordir - ifM (boolSystem "make" [Param "build"]) - ( do - putStrLn "" - putStrLn "" - chain - , error "Propellor build failed." - ) - chain = do - (_, _, _, pid) <- createProcess (proc propellorbin args) - exitWith =<< waitForProcess pid - --- Passed the user's propellordir repository, makes upstream/master --- be a usefully mergeable branch. --- --- We cannot just use origin/master, because in the case of a distrepo, --- it only contains 1 commit. So, trying to merge with it will result --- in lots of merge conflicts, since git cannot find a common parent --- commit. --- --- Instead, the upstream/master branch is created by taking the --- upstream/master branch (which must be an old version of propellor, --- as distributed), and diffing from it to the current origin/master, --- and committing the result. This is done in a temporary clone of the --- repository, giving it a new master branch. That new branch is fetched --- into the user's repository, as if fetching from a upstream remote, --- yielding a new upstream/master branch. -setupupstreammaster :: String -> FilePath -> IO () -setupupstreammaster newref propellordir = do - changeWorkingDirectory propellordir - go =<< catchMaybeIO getoldrev - where - go Nothing = warnoutofdate propellordir False - go (Just oldref) = do - let tmprepo = ".git/propellordisttmp" - let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo - cleantmprepo - git ["clone", "--quiet", ".", tmprepo] - - changeWorkingDirectory tmprepo - git ["fetch", distrepo, "--quiet"] - git ["reset", "--hard", oldref, "--quiet"] - git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"] - - fetchUpstreamBranch propellordir tmprepo - cleantmprepo - warnoutofdate propellordir True - - getoldrev = takeWhile (/= '\n') - <$> readProcess "git" ["show-ref", upstreambranch, "--hash"] - - git = run "git" - run cmd ps = unlessM (boolSystem cmd (map Param ps)) $ - error $ "Failed to run " ++ cmd ++ " " ++ show ps - -warnoutofdate :: FilePath -> Bool -> IO () -warnoutofdate propellordir havebranch = do - warningMessage ("** Your " ++ propellordir ++ " is out of date..") - let also s = hPutStrLn stderr (" " ++ s) - also ("A newer upstream version is available in " ++ distrepo) - if havebranch - then also ("To merge it, run: git merge " ++ upstreambranch) - else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.") - also "" + go ["--init"] = interactiveInit + go args = ifM (doesDirectoryExist =<< dotPropellor) + ( do + checkRepoUpToDate + buildRunConfig args + , error "Seems that ~/.propellor/ does not exist. To set it up, run: propellor --init" + ) -fetchUpstreamBranch :: FilePath -> FilePath -> IO () -fetchUpstreamBranch propellordir repo = do - changeWorkingDirectory propellordir - void $ boolSystem "git" - [ Param "fetch" - , File repo - , Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch) - , Param "--quiet" - ] +buildRunConfig :: [String] -> IO () +buildRunConfig args = do + changeWorkingDirectory =<< dotPropellor + unlessM (doesFileExist "propellor") $ do + buildPropellor Nothing + putStrLn "" + putStrLn "" + (_, _, _, pid) <- createProcessNonConcurrent (proc "./propellor" args) + exitWith =<< waitForProcessNonConcurrent pid |