Merge branch 'joeyconfig'

This commit is contained in:
Joey Hess 2014-04-11 01:09:01 -04:00
commit 856ce97995
39 changed files with 1420 additions and 414 deletions

View File

@ -10,7 +10,8 @@ build: dist/setup-config
ln -sf dist/build/config/config propellor ln -sf dist/build/config/config propellor
deps: deps:
@if [ $$(whoami) = root ]; then apt-get -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-async-dev; fi || true @if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-quickcheck2-dev libghc-mtl-dev libghc-monadcatchio-transformers-dev; fi || true
@if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install libghc-async-dev || cabal update; cabal install async; fi || true
dist/setup-config: propellor.cabal dist/setup-config: propellor.cabal
if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi

View File

@ -1,7 +1,10 @@
{-# LANGUAGE PackageImports #-}
-- | Pulls in lots of useful modules for building and using Properties. -- | Pulls in lots of useful modules for building and using Properties.
-- --
-- Propellor enures that the system it's run in satisfies a list of -- When propellor runs on a Host, it ensures that its list of Properties
-- properties, taking action as necessary when a property is not yet met. -- is satisfied, taking action as necessary when a Property is not
-- currently satisfied.
-- --
-- A simple propellor program example: -- A simple propellor program example:
-- --
@ -11,15 +14,16 @@
-- > import qualified Propellor.Property.Apt as Apt -- > import qualified Propellor.Property.Apt as Apt
-- > -- >
-- > main :: IO () -- > main :: IO ()
-- > main = defaultMain getProperties -- > main = defaultMain hosts
-- > -- >
-- > getProperties :: HostName -> Maybe [Property] -- > hosts :: [Host]
-- > getProperties "example.com" = Just -- > hosts =
-- > [ Apt.installed ["mydaemon"] -- > [ host "example.com"
-- > , "/etc/mydaemon.conf" `File.containsLine` "secure=1" -- > & Apt.installed ["mydaemon"]
-- > & "/etc/mydaemon.conf" `File.containsLine` "secure=1"
-- > `onChange` cmdProperty "service" ["mydaemon", "restart"] -- > `onChange` cmdProperty "service" ["mydaemon", "restart"]
-- > ! Apt.installed ["unwantedpackage"]
-- > ] -- > ]
-- > getProperties _ = Nothing
-- --
-- See config.hs for a more complete example, and clone Propellor's -- See config.hs for a more complete example, and clone Propellor's
-- git repository for a deployable system using Propellor: -- git repository for a deployable system using Propellor:
@ -29,8 +33,10 @@ module Propellor (
module Propellor.Types module Propellor.Types
, module Propellor.Property , module Propellor.Property
, module Propellor.Property.Cmd , module Propellor.Property.Cmd
, module Propellor.Attr
, module Propellor.PrivData , module Propellor.PrivData
, module Propellor.Engine , module Propellor.Engine
, module Propellor.Exception
, module Propellor.Message , module Propellor.Message
, localdir , localdir
@ -43,6 +49,8 @@ import Propellor.Engine
import Propellor.Property.Cmd import Propellor.Property.Cmd
import Propellor.PrivData import Propellor.PrivData
import Propellor.Message import Propellor.Message
import Propellor.Exception
import Propellor.Attr
import Utility.PartialPrelude as X import Utility.PartialPrelude as X
import Utility.Process as X import Utility.Process as X
@ -62,6 +70,7 @@ import Control.Applicative as X
import Control.Monad as X import Control.Monad as X
import Data.Monoid as X import Data.Monoid as X
import Control.Monad.IfElse 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. -- | This is where propellor installs itself when deploying a host.
localdir :: FilePath localdir :: FilePath

47
Propellor/Attr.hs Normal file
View File

@ -0,0 +1,47 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Attr where
import Propellor.Types
import Propellor.Types.Attr
import "mtl" Control.Monad.Reader
import qualified Data.Set as S
import qualified Data.Map as M
pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty
pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
(return NoChange)
hostname :: HostName -> AttrProperty
hostname name = pureAttrProperty ("hostname " ++ name) $
\d -> d { _hostname = name }
getHostName :: Propellor HostName
getHostName = asks _hostname
cname :: Domain -> AttrProperty
cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty
cnameFor domain mkp =
let p = mkp domain
in AttrProperty p (addCName domain)
addCName :: HostName -> Attr -> Attr
addCName domain d = d { _cnames = S.insert domain (_cnames d) }
hostnameless :: Attr
hostnameless = newAttr (error "hostname Attr not specified")
hostAttr :: Host -> Attr
hostAttr (Host _ mkattrs) = mkattrs hostnameless
hostProperties :: Host -> [Property]
hostProperties (Host ps _) = ps
hostMap :: [Host] -> M.Map HostName Host
hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l
findHost :: [Host] -> HostName -> Maybe Host
findHost l hn = M.lookup hn (hostMap l)

View File

@ -16,6 +16,7 @@ import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Docker.Shim as DockerShim import qualified Propellor.Property.Docker.Shim as DockerShim
import Utility.FileMode import Utility.FileMode
import Utility.SafeCommand import Utility.SafeCommand
import Utility.UserInfo
usage :: IO a usage :: IO a
usage = do usage = do
@ -54,8 +55,8 @@ processCmdLine = go =<< getArgs
else return $ Run s else return $ Run s
go _ = usage go _ = usage
defaultMain :: [HostName -> Maybe [Property]] -> IO () defaultMain :: [Host] -> IO ()
defaultMain getprops = do defaultMain hostlist = do
DockerShim.cleanEnv DockerShim.cleanEnv
checkDebugMode checkDebugMode
cmdline <- processCmdLine cmdline <- processCmdLine
@ -63,23 +64,26 @@ defaultMain getprops = do
go True cmdline go True cmdline
where where
go _ (Continue cmdline) = go False cmdline go _ (Continue cmdline) = go False cmdline
go _ (Set host field) = setPrivData host field go _ (Set hn field) = setPrivData hn field
go _ (AddKey keyid) = addKey keyid go _ (AddKey keyid) = addKey keyid
go _ (Chain host) = withprops host $ \ps -> do go _ (Chain hn) = withprops hn $ \attr ps -> do
r <- ensureProperties' ps r <- runPropellor attr $ ensureProperties ps
putStrLn $ "\n" ++ show r putStrLn $ "\n" ++ show r
go _ (Docker host) = Docker.chain host go _ (Docker hn) = Docker.chain hn
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin host) = withprops host $ const $ spin host go False (Spin hn) = withprops hn $ const . const $ spin hn
go False (Run host) = ifM ((==) 0 <$> getRealUserID) go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyProcess $ withprops host ensureProperties ( onlyProcess $ withprops hn mainProperties
, go True (Spin host) , go True (Spin hn)
) )
go False (Boot host) = onlyProcess $ withprops host $ boot go False (Boot hn) = onlyProcess $ withprops hn boot
withprops host a = maybe (unknownhost host) a $ withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
headMaybe $ catMaybes $ map (\get -> get host) getprops withprops hn a = maybe
(unknownhost hn)
(\h -> a (hostAttr h) (hostProperties h))
(findHost hostlist hn)
onlyProcess :: IO a -> IO a onlyProcess :: IO a -> IO a
onlyProcess a = bracket lock unlock (const a) onlyProcess a = bracket lock unlock (const a)
@ -95,7 +99,7 @@ onlyProcess a = bracket lock unlock (const a)
unknownhost :: HostName -> IO a unknownhost :: HostName -> IO a
unknownhost h = errorMessage $ unlines unknownhost h = errorMessage $ unlines
[ "Unknown host: " ++ h [ "Propellor does not know about host: " ++ h
, "(Perhaps you should specify the real hostname on the command line?)" , "(Perhaps you should specify the real hostname on the command line?)"
, "(Or, edit propellor's config.hs to configure this host)" , "(Or, edit propellor's config.hs to configure this host)"
] ]
@ -163,15 +167,16 @@ getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref] getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
spin :: HostName -> IO () spin :: HostName -> IO ()
spin host = do spin hn = do
url <- getUrl url <- getUrl
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
void $ boolSystem "git" [Param "push"] void $ boolSystem "git" [Param "push"]
go url =<< gpgDecrypt (privDataFile host) cacheparams <- toCommand <$> sshCachingParams hn
go cacheparams url =<< gpgDecrypt (privDataFile hn)
where where
go url privdata = withBothHandles createProcessSuccess (proc "ssh" [user, bootstrapcmd]) $ \(toh, fromh) -> do go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
let finish = do let finish = do
senddata toh (privDataFile host) privDataMarker privdata senddata toh (privDataFile hn) privDataMarker privdata
hClose toh hClose toh
-- Display remaining output. -- Display remaining output.
@ -184,21 +189,21 @@ spin host = do
NeedGitClone -> do NeedGitClone -> do
hClose toh hClose toh
hClose fromh hClose fromh
sendGitClone host url sendGitClone hn url
go url privdata go cacheparams url privdata
user = "root@"++host user = "root@"++hn
bootstrapcmd = shellWrap $ intercalate " ; " bootstrapcmd = shellWrap $ intercalate " ; "
[ "if [ ! -d " ++ localdir ++ " ]" [ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && " , "then " ++ intercalate " && "
[ "apt-get -y install git" [ "apt-get --no-install-recommends --no-upgrade -y install git make"
, "echo " ++ toMarked statusMarker (show NeedGitClone) , "echo " ++ toMarked statusMarker (show NeedGitClone)
] ]
, "else " ++ intercalate " && " , "else " ++ intercalate " && "
[ "cd " ++ localdir [ "cd " ++ localdir
, "if ! test -x ./propellor; then make build; fi" , "if ! test -x ./propellor; then make deps build; fi"
, "./propellor --boot " ++ host , "./propellor --boot " ++ hn
] ]
, "fi" , "fi"
] ]
@ -214,19 +219,18 @@ spin host = do
showremote s = putStrLn s showremote s = putStrLn s
senddata toh f marker s = void $ senddata toh f marker s = void $
actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
sendMarked toh marker s sendMarked toh marker s
return True return True
sendGitClone :: HostName -> String -> IO () sendGitClone :: HostName -> String -> IO ()
sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ do sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
branch <- getCurrentBranch branch <- getCurrentBranch
cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id withTmpFile "propellor.git" $ \tmp _ -> allM id
-- TODO: ssh connection caching, or better push method
-- with less connections.
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
, boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)] , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
, boolSystem "ssh" [Param ("root@"++host), Param $ unpackcmd branch] , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
] ]
where where
remotebundle = "/usr/local/propellor.git" remotebundle = "/usr/local/propellor.git"
@ -274,15 +278,15 @@ fromMarked marker s
len = length marker len = length marker
matches = filter (marker `isPrefixOf`) $ lines s matches = filter (marker `isPrefixOf`) $ lines s
boot :: [Property] -> IO () boot :: Attr -> [Property] -> IO ()
boot ps = do boot attr ps = do
sendMarked stdout statusMarker $ show Ready sendMarked stdout statusMarker $ show Ready
reply <- hGetContentsStrict stdin reply <- hGetContentsStrict stdin
makePrivDataDir makePrivDataDir
maybe noop (writeFileProtected privDataLocal) $ maybe noop (writeFileProtected privDataLocal) $
fromMarked privDataMarker reply fromMarked privDataMarker reply
ensureProperties ps mainProperties attr ps
addKey :: String -> IO () addKey :: String -> IO ()
addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ] addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
@ -341,3 +345,15 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
updateGlobalLogger rootLoggerName $ updateGlobalLogger rootLoggerName $
setLevel DEBUG . setHandlers [f] setLevel DEBUG . setHandlers [f]
go _ = noop go _ = noop
-- Parameters can be passed to both ssh and scp.
sshCachingParams :: HostName -> IO [CommandParam]
sshCachingParams hn = do
home <- myHomeDir
let cachedir = home </> ".ssh" </> "propellor"
createDirectoryIfMissing False cachedir
let socketfile = cachedir </> hn ++ ".sock"
return
[ Param "-o", Param ("ControlPath=" ++ socketfile)
, Params "-o ControlMaster=auto -o ControlPersist=yes"
]

View File

@ -1,30 +1,37 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Engine where module Propellor.Engine where
import System.Exit import System.Exit
import System.IO import System.IO
import Data.Monoid import Data.Monoid
import System.Console.ANSI import System.Console.ANSI
import "mtl" Control.Monad.Reader
import Propellor.Types import Propellor.Types
import Propellor.Message import Propellor.Message
import Utility.Exception import Propellor.Exception
ensureProperty :: Property -> IO Result runPropellor :: Attr -> Propellor a -> IO a
ensureProperty = catchDefaultIO FailedChange . propertySatisfy runPropellor attr a = runReaderT (runWithAttr a) attr
ensureProperties :: [Property] -> IO () mainProperties :: Attr -> [Property] -> IO ()
ensureProperties ps = do mainProperties attr ps = do
r <- ensureProperties' [Property "overall" $ ensureProperties' ps] r <- runPropellor attr $
ensureProperties [Property "overall" $ ensureProperties ps]
setTitle "propellor: done" setTitle "propellor: done"
hFlush stdout hFlush stdout
case r of case r of
FailedChange -> exitWith (ExitFailure 1) FailedChange -> exitWith (ExitFailure 1)
_ -> exitWith ExitSuccess _ -> exitWith ExitSuccess
ensureProperties' :: [Property] -> IO Result ensureProperties :: [Property] -> Propellor Result
ensureProperties' ps = ensure ps NoChange ensureProperties ps = ensure ps NoChange
where where
ensure [] rs = return rs ensure [] rs = return rs
ensure (l:ls) rs = do ensure (l:ls) rs = do
r <- actionMessage (propertyDesc l) (ensureProperty l) r <- actionMessage (propertyDesc l) (ensureProperty l)
ensure ls (r <> rs) ensure ls (r <> rs)
ensureProperty :: Property -> Propellor Result
ensureProperty = catchPropellor . propertySatisfy

16
Propellor/Exception.hs Normal file
View File

@ -0,0 +1,16 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Exception where
import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
import Control.Exception
import Control.Applicative
import Propellor.Types
-- | Catches IO exceptions and returns FailedChange.
catchPropellor :: Propellor Result -> Propellor Result
catchPropellor a = either (\_ -> FailedChange) id <$> tryPropellor a
tryPropellor :: Propellor a -> Propellor (Either IOException a)
tryPropellor = M.try

View File

@ -1,20 +1,25 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Message where module Propellor.Message where
import System.Console.ANSI import System.Console.ANSI
import System.IO import System.IO
import System.Log.Logger import System.Log.Logger
import "mtl" Control.Monad.Reader
import Propellor.Types import Propellor.Types
-- | Shows a message while performing an action, with a colored status -- | Shows a message while performing an action, with a colored status
-- display. -- display.
actionMessage :: ActionResult r => Desc -> IO r -> IO r actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r
actionMessage desc a = do actionMessage desc a = do
liftIO $ do
setTitle $ "propellor: " ++ desc setTitle $ "propellor: " ++ desc
hFlush stdout hFlush stdout
r <- a r <- a
liftIO $ do
setTitle "propellor: running" setTitle "propellor: running"
let (msg, intensity, color) = getActionResult r let (msg, intensity, color) = getActionResult r
putStr $ desc ++ " ... " putStr $ desc ++ " ... "
@ -23,8 +28,8 @@ actionMessage desc a = do
return r return r
warningMessage :: String -> IO () warningMessage :: MonadIO m => String -> m ()
warningMessage s = colorLine Vivid Red $ "** warning: " ++ s warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s
colorLine :: ColorIntensity -> Color -> String -> IO () colorLine :: ColorIntensity -> Color -> String -> IO ()
colorLine intensity color msg = do colorLine intensity color msg = do

View File

@ -1,3 +1,5 @@
{-# LANGUAGE PackageImports #-}
module Propellor.PrivData where module Propellor.PrivData where
import qualified Data.Map as M import qualified Data.Map as M
@ -7,8 +9,10 @@ import System.IO
import System.Directory import System.Directory
import Data.Maybe import Data.Maybe
import Control.Monad import Control.Monad
import "mtl" Control.Monad.Reader
import Propellor.Types import Propellor.Types
import Propellor.Attr
import Propellor.Message import Propellor.Message
import Utility.Monad import Utility.Monad
import Utility.PartialPrelude import Utility.PartialPrelude
@ -18,11 +22,14 @@ import Utility.Tmp
import Utility.SafeCommand import Utility.SafeCommand
import Utility.Misc import Utility.Misc
withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result
withPrivData field a = maybe missing a =<< getPrivData field withPrivData field a = maybe missing a =<< liftIO (getPrivData field)
where where
missing = do missing = do
host <- getHostName
liftIO $ do
warningMessage $ "Missing privdata " ++ show field warningMessage $ "Missing privdata " ++ show field
putStrLn $ "Fix this by running: propellor --set "++host++" '" ++ show field ++ "'"
return FailedChange return FailedChange
getPrivData :: PrivDataField -> IO (Maybe String) getPrivData :: PrivDataField -> IO (Maybe String)

View File

@ -1,17 +1,22 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Property where module Propellor.Property where
import System.Directory import System.Directory
import Control.Monad import Control.Monad
import Data.Monoid import Data.Monoid
import Control.Monad.IfElse
import "mtl" Control.Monad.Reader
import Propellor.Types import Propellor.Types
import Propellor.Types.Attr
import Propellor.Engine import Propellor.Engine
import Utility.Monad import Utility.Monad
makeChange :: IO () -> IO Result makeChange :: IO () -> Propellor Result
makeChange a = a >> return MadeChange makeChange a = liftIO a >> return MadeChange
noChange :: IO Result noChange :: Propellor Result
noChange = return NoChange noChange = return NoChange
-- | Combines a list of properties, resulting in a single property -- | Combines a list of properties, resulting in a single property
@ -19,7 +24,7 @@ noChange = return NoChange
-- and print out the description of each as it's run. Does not stop -- and print out the description of each as it's run. Does not stop
-- on failure; does propigate overall success/failure. -- on failure; does propigate overall success/failure.
propertyList :: Desc -> [Property] -> Property propertyList :: Desc -> [Property] -> Property
propertyList desc ps = Property desc $ ensureProperties' ps propertyList desc ps = Property desc $ ensureProperties ps
-- | Combines a list of properties, resulting in one property that -- | Combines a list of properties, resulting in one property that
-- ensures each in turn, stopping on failure. -- ensures each in turn, stopping on failure.
@ -33,17 +38,28 @@ combineProperties desc ps = Property desc $ go ps NoChange
FailedChange -> return FailedChange FailedChange -> return FailedChange
_ -> go ls (r <> rs) _ -> 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 = Property (propertyDesc p1) $ do
r <- ensureProperty p1
case r of
FailedChange -> return FailedChange
_ -> ensureProperty p2
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag -- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before. -- file to indicate whether it has run before.
-- Use with caution. -- Use with caution.
flagFile :: Property -> FilePath -> Property flagFile :: Property -> FilePath -> Property
flagFile property flagfile = Property (propertyDesc property) $ flagFile property flagfile = Property (propertyDesc property) $
go =<< doesFileExist flagfile go =<< liftIO (doesFileExist flagfile)
where where
go True = return NoChange go True = return NoChange
go False = do go False = do
r <- ensureProperty property r <- ensureProperty property
when (r == MadeChange) $ when (r == MadeChange) $ liftIO $
unlessM (doesFileExist flagfile) $
writeFile flagfile "" writeFile flagfile ""
return r return r
@ -64,13 +80,13 @@ infixl 1 ==>
-- | Makes a Property only be performed when a test succeeds. -- | Makes a Property only be performed when a test succeeds.
check :: IO Bool -> Property -> Property check :: IO Bool -> Property -> Property
check c property = Property (propertyDesc property) $ ifM c check c property = Property (propertyDesc property) $ ifM (liftIO c)
( ensureProperty property ( ensureProperty property
, return NoChange , return NoChange
) )
boolProperty :: Desc -> IO Bool -> Property boolProperty :: Desc -> IO Bool -> Property
boolProperty desc a = Property desc $ ifM a boolProperty desc a = Property desc $ ifM (liftIO a)
( return MadeChange ( return MadeChange
, return FailedChange , return FailedChange
) )
@ -79,17 +95,26 @@ boolProperty desc a = Property desc $ ifM a
revert :: RevertableProperty -> RevertableProperty revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
-- | Starts a list of Properties -- | Starts accumulating the properties of a Host.
props :: [Property] --
props = [] -- > host "example.com"
-- > & someproperty
-- > ! oldproperty
-- > & otherproperty
host :: HostName -> Host
host hn = Host [] (\_ -> newAttr hn)
-- | Adds a property to a Host
-- Can add Properties, RevertableProperties, and AttrProperties
(&) :: IsProp p => Host -> p -> Host
(Host ps as) & p = Host (ps ++ [toProp p]) (getAttr p . as)
-- | Adds a property to the list.
-- Can add both Properties and RevertableProperties.
(&) :: IsProp p => [Property] -> p -> [Property]
ps & p = ps ++ [toProp p]
infixl 1 & infixl 1 &
-- | Adds a property to the list in reverted form. -- | Adds a property to the Host in reverted form.
(!) :: [Property] -> RevertableProperty -> [Property] (!) :: Host -> RevertableProperty -> Host
ps ! p = ps ++ [toProp $ revert p] (Host ps as) ! p = Host (ps ++ [toProp q]) (getAttr q . as)
where
q = revert p
infixl 1 ! infixl 1 !

View File

@ -8,6 +8,7 @@ import Control.Monad
import Propellor import Propellor
import qualified Propellor.Property.File as File import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import Propellor.Property.File (Line) import Propellor.Property.File (Line)
sourcesList :: FilePath sourcesList :: FilePath
@ -46,13 +47,22 @@ debCdn = binandsrc "http://cdn.debian.net/debian"
kernelOrg :: DebianSuite -> [Line] kernelOrg :: DebianSuite -> [Line]
kernelOrg = binandsrc "http://mirrors.kernel.org/debian" kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
-- | Only available for Stable and Testing
securityUpdates :: DebianSuite -> [Line]
securityUpdates suite
| suite == Stable || suite == Testing =
let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections
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 mirror CDN,
-- with a particular DebianSuite. -- with a particular DebianSuite.
-- --
-- Since the CDN is sometimes unreliable, also adds backup lines using -- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org. -- kernel.org.
stdSourcesList :: DebianSuite -> Property stdSourcesList :: DebianSuite -> Property
stdSourcesList suite = setSourcesList (debCdn suite ++ kernelOrg suite) stdSourcesList suite = setSourcesList
(debCdn suite ++ kernelOrg suite ++ securityUpdates suite)
`describe` ("standard sources.list for " ++ show suite) `describe` ("standard sources.list for " ++ show suite)
setSourcesList :: [Line] -> Property setSourcesList :: [Line] -> Property
@ -147,9 +157,12 @@ autoRemove = runApt ["-y", "autoremove"]
-- | Enables unattended upgrades. Revert to disable. -- | Enables unattended upgrades. Revert to disable.
unattendedUpgrades :: RevertableProperty unattendedUpgrades :: RevertableProperty
unattendedUpgrades = RevertableProperty (go True) (go False) unattendedUpgrades = RevertableProperty enable disable
where where
go enabled = (if enabled then installed else removed) ["unattended-upgrades"] enable = setup True `before` Service.running "cron"
disable = setup False
setup enabled = (if enabled then installed else removed) ["unattended-upgrades"]
`onChange` reConfigure "unattended-upgrades" `onChange` reConfigure "unattended-upgrades"
[("unattended-upgrades/enable_auto_updates" , "boolean", v)] [("unattended-upgrades/enable_auto_updates" , "boolean", v)]
`describe` ("unattended upgrades " ++ v) `describe` ("unattended upgrades " ++ v)
@ -167,7 +180,14 @@ reConfigure package vals = reconfigure `requires` setselections
setselections = Property "preseed" $ makeChange $ setselections = Property "preseed" $ makeChange $
withHandle StdinHandle createProcessSuccess withHandle StdinHandle createProcessSuccess
(proc "debconf-set-selections" []) $ \h -> do (proc "debconf-set-selections" []) $ \h -> do
forM_ vals $ \(template, tmpltype, value) -> forM_ vals $ \(tmpl, tmpltype, value) ->
hPutStrLn h $ unwords [package, template, tmpltype, value] hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
hClose h hClose h
reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package] reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]
-- | 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 svc = Service.running svc `requires` installed [svc]

View File

@ -1,17 +1,17 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Property.Cmd ( module Propellor.Property.Cmd (
cmdProperty, cmdProperty,
cmdProperty', cmdProperty',
scriptProperty, scriptProperty,
userScriptProperty, userScriptProperty,
serviceRunning,
) where ) where
import Control.Monad
import Control.Applicative import Control.Applicative
import Data.List import Data.List
import "mtl" Control.Monad.Reader
import Propellor.Types import Propellor.Types
import Propellor.Engine
import Utility.Monad import Utility.Monad
import Utility.SafeCommand import Utility.SafeCommand
import Utility.Env import Utility.Env
@ -25,7 +25,7 @@ cmdProperty cmd params = cmdProperty' cmd params []
-- | A property that can be satisfied by running a command, -- | A property that can be satisfied by running a command,
-- with added environment. -- with added environment.
cmdProperty' :: String -> [String] -> [(String, String)] -> Property cmdProperty' :: String -> [String] -> [(String, String)] -> Property
cmdProperty' cmd params env = Property desc $ do cmdProperty' cmd params env = Property desc $ liftIO $ do
env' <- addEntries env <$> getEnvironment env' <- addEntries env <$> getEnvironment
ifM (boolSystemEnv cmd (map Param params) (Just env')) ifM (boolSystemEnv cmd (map Param params) (Just env'))
( return MadeChange ( return MadeChange
@ -46,14 +46,3 @@ userScriptProperty :: UserName -> [String] -> Property
userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user] userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]
where where
shellcmd = intercalate " ; " ("set -e" : "cd" : script) shellcmd = intercalate " ; " ("set -e" : "cd" : script)
-- | Ensures that a service is running.
--
-- Note that due to the general poor state of init scripts, the best
-- we can do is try to start the service, and if it fails, assume
-- this means it's already running.
serviceRunning :: String -> Property
serviceRunning svc = Property ("running " ++ svc) $ do
void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]
return NoChange

View File

@ -18,8 +18,7 @@ job desc times user cddir command = ("/etc/cron.d/" ++ desc) `File.hasContent`
, "" , ""
, times ++ "\t" ++ user ++ "\t" ++ "cd " ++ cddir ++ " && " ++ command , times ++ "\t" ++ user ++ "\t" ++ "cd " ++ cddir ++ " && " ++ command
] ]
`requires` Apt.installed ["cron"] `requires` Apt.serviceInstalledRunning "cron"
`requires` serviceRunning "cron"
`describe` ("cronned " ++ desc) `describe` ("cronned " ++ desc)
-- | Installs a cron job, and runs it niced and ioniced. -- | Installs a cron job, and runs it niced and ioniced.

63
Propellor/Property/Dns.hs Normal file
View File

@ -0,0 +1,63 @@
module Propellor.Property.Dns where
import Propellor
import Propellor.Property.File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
namedconf :: FilePath
namedconf = "/etc/bind/named.conf.local"
data Zone = Zone
{ zdomain :: Domain
, ztype :: Type
, zfile :: FilePath
, zmasters :: [IPAddr]
, zconfiglines :: [String]
}
zoneDesc :: Zone -> String
zoneDesc z = zdomain z ++ " (" ++ show (ztype z) ++ ")"
type IPAddr = String
type Domain = String
data Type = Master | Secondary
deriving (Show, Eq)
secondary :: Domain -> [IPAddr] -> Zone
secondary domain masters = Zone
{ zdomain = domain
, ztype = Secondary
, zfile = "db." ++ domain
, zmasters = masters
, zconfiglines = ["allow-transfer { }"]
}
zoneStanza :: Zone -> [Line]
zoneStanza z =
[ "// automatically generated by propellor"
, "zone \"" ++ zdomain z ++ "\" {"
, cfgline "type" (if ztype z == Master then "master" else "slave")
, cfgline "file" ("\"" ++ zfile z ++ "\"")
] ++
(if null (zmasters z) then [] else mastersblock) ++
(map (\l -> "\t" ++ l ++ ";") (zconfiglines z)) ++
[ "};"
, ""
]
where
cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
mastersblock =
[ "\tmasters {" ] ++
(map (\ip -> "\t\t" ++ ip ++ ";") (zmasters z)) ++
[ "\t};" ]
-- | Rewrites the whole named.conf.local file to serve the specificed
-- zones.
zones :: [Zone] -> Property
zones zs = hasContent namedconf (concatMap zoneStanza zs)
`describe` ("dns server for zones: " ++ unwords (map zoneDesc zs))
`requires` Apt.serviceInstalledRunning "bind9"
`onChange` Service.reloaded "bind9"

View File

@ -1,4 +1,4 @@
{-# LANGUAGE RankNTypes, BangPatterns #-} {-# LANGUAGE BangPatterns #-}
-- | Docker support for propellor -- | Docker support for propellor
-- --
@ -9,6 +9,7 @@ module Propellor.Property.Docker where
import Propellor import Propellor
import Propellor.SimpleSh import Propellor.SimpleSh
import Propellor.Types.Attr
import qualified Propellor.Property.File as File import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Docker.Shim as Shim import qualified Propellor.Property.Docker.Shim as Shim
@ -32,6 +33,25 @@ configured = Property "docker configured" go `requires` installed
installed :: Property installed :: Property
installed = Apt.installed ["docker.io"] installed = Apt.installed ["docker.io"]
-- | 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.
--
-- > container "web-server" "debian"
-- > & publish "80:80"
-- > & Apt.installed {"apache2"]
-- > & ...
container :: ContainerName -> Image -> Host
container cn image = Host [] (\_ -> attr)
where
attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }
cn2hn :: ContainerName -> HostName
cn2hn cn = cn ++ ".docker"
-- | Ensures that a docker container is set up and running. The container -- | Ensures that a docker container is set up and running. The container
-- has its own Properties which are handled by running propellor -- has its own Properties which are handled by running propellor
-- inside the container. -- inside the container.
@ -39,44 +59,61 @@ installed = Apt.installed ["docker.io"]
-- Reverting this property ensures that the container is stopped and -- Reverting this property ensures that the container is stopped and
-- removed. -- removed.
docked docked
:: (HostName -> ContainerName -> Maybe (Container)) :: [Host]
-> HostName
-> ContainerName -> ContainerName
-> RevertableProperty -> RevertableProperty
docked findc hn cn = findContainer findc hn cn $ docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
\(Container image containerprops) -> where
let setup = provisionContainer cid go desc a = Property (desc ++ " " ++ cn) $ do
hn <- getHostName
let cid = ContainerId hn cn
ensureProperties [findContainer hosts cid cn $ a cid]
setup cid (Container image runparams) =
provisionContainer cid
`requires` `requires`
runningContainer cid image containerprops runningContainer cid image runparams
`requires` `requires`
installed installed
teardown = combineProperties ("undocked " ++ fromContainerId cid)
teardown cid (Container image _runparams) =
combineProperties ("undocked " ++ fromContainerId cid)
[ stoppedContainer cid [ stoppedContainer cid
, Property ("cleaned up " ++ fromContainerId cid) $ , Property ("cleaned up " ++ fromContainerId cid) $
report <$> mapM id liftIO $ report <$> mapM id
[ removeContainer cid [ removeContainer cid
, removeImage image , removeImage image
] ]
] ]
in RevertableProperty setup teardown
where
cid = ContainerId hn cn
findContainer findContainer
:: (HostName -> ContainerName -> Maybe (Container)) :: [Host]
-> HostName -> ContainerId
-> ContainerName -> ContainerName
-> (Container -> RevertableProperty) -> (Container -> Property)
-> RevertableProperty -> Property
findContainer findc hn cn mk = case findc hn cn of findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
Nothing -> RevertableProperty cantfind cantfind Nothing -> cantfind
Just container -> mk container Just h -> maybe cantfind mk (mkContainer cid h)
where where
cid = ContainerId hn cn cantfind = containerDesc cid $ Property "" $ do
cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do liftIO $ warningMessage $
warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid "missing definition for docker container \"" ++ cn2hn cn
return FailedChange return FailedChange
mkContainer :: ContainerId -> Host -> Maybe Container
mkContainer cid@(ContainerId hn _cn) h = Container
<$> _dockerImage attr
<*> pure (map (\a -> a hn) (_dockerRunParams attr))
where
attr = hostAttr h'
h' = h
-- expose propellor directory inside the container
& volume (localdir++":"++localdir)
-- name the container in a predictable way so we
-- and the user can easily find it later
& name (fromContainerId cid)
-- | Causes *any* docker images that are not in use by running containers to -- | Causes *any* docker images that are not in use by running containers to
-- be deleted. And deletes any containers that propellor has set up -- be deleted. And deletes any containers that propellor has set up
-- before that are not currently running. Does not delete any containers -- before that are not currently running. Does not delete any containers
@ -90,34 +127,11 @@ garbageCollected = propertyList "docker garbage collected"
] ]
where where
gccontainers = Property "docker containers garbage collected" $ gccontainers = Property "docker containers garbage collected" $
report <$> (mapM removeContainer =<< listContainers AllContainers) liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
gcimages = Property "docker images garbage collected" $ do gcimages = Property "docker images garbage collected" $ do
report <$> (mapM removeImage =<< listImages) liftIO $ report <$> (mapM removeImage =<< listImages)
-- | Pass to defaultMain to add docker containers. data Container = Container Image [RunParam]
-- You need to provide the function mapping from
-- HostName and ContainerName to the Container to use.
containerProperties
:: (HostName -> ContainerName -> Maybe (Container))
-> (HostName -> Maybe [Property])
containerProperties findcontainer = \h -> case toContainerId h of
Nothing -> Nothing
Just cid@(ContainerId hn cn) ->
case findcontainer hn cn of
Nothing -> Nothing
Just (Container _ cprops) ->
Just $ map (containerDesc cid) $
fromContainerized cprops
-- | This type is used to configure a docker container.
-- It has an image, and a list of Properties, but these
-- properties are Containerized; they can specify
-- things about the container's configuration, in
-- addition to properties of the system inside the
-- container.
data Container = Container Image [Containerized Property]
data Containerized a = Containerized [HostName -> RunParam] a
-- | Parameters to pass to `docker run` when creating a container. -- | Parameters to pass to `docker run` when creating a container.
type RunParam = String type RunParam = String
@ -125,62 +139,50 @@ type RunParam = String
-- | A docker image, that can be used to run a container. -- | A docker image, that can be used to run a container.
type Image = String type Image = String
-- | A short descriptive name for a container.
-- Should not contain whitespace or other unusual characters,
-- only [a-zA-Z0-9_.-] are allowed
type ContainerName = String
-- | Lift a Property to apply inside a container.
inside1 :: Property -> Containerized Property
inside1 = Containerized []
inside :: [Property] -> Containerized Property
inside = Containerized [] . combineProperties "provision"
-- | Set custom dns server for container. -- | Set custom dns server for container.
dns :: String -> Containerized Property dns :: String -> AttrProperty
dns = runProp "dns" dns = runProp "dns"
-- | Set container host name. -- | Set container host name.
hostname :: String -> Containerized Property hostname :: String -> AttrProperty
hostname = runProp "hostname" hostname = runProp "hostname"
-- | Set name for container. (Normally done automatically.) -- | Set name for container. (Normally done automatically.)
name :: String -> Containerized Property name :: String -> AttrProperty
name = runProp "name" name = runProp "name"
-- | Publish a container's port to the host -- | Publish a container's port to the host
-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) -- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
publish :: String -> Containerized Property publish :: String -> AttrProperty
publish = runProp "publish" publish = runProp "publish"
-- | Username or UID for container. -- | Username or UID for container.
user :: String -> Containerized Property user :: String -> AttrProperty
user = runProp "user" user = runProp "user"
-- | Mount a volume -- | Mount a volume
-- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] -- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
-- With just a directory, creates a volume in the container. -- With just a directory, creates a volume in the container.
volume :: String -> Containerized Property volume :: String -> AttrProperty
volume = runProp "volume" volume = runProp "volume"
-- | Mount a volume from the specified container into the current -- | Mount a volume from the specified container into the current
-- container. -- container.
volumes_from :: ContainerName -> Containerized Property volumes_from :: ContainerName -> AttrProperty
volumes_from cn = genProp "volumes-from" $ \hn -> volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn) fromContainerId (ContainerId hn cn)
-- | Work dir inside the container. -- | Work dir inside the container.
workdir :: String -> Containerized Property workdir :: String -> AttrProperty
workdir = runProp "workdir" workdir = runProp "workdir"
-- | Memory limit for container. -- | Memory limit for container.
--Format: <number><optional unit>, where unit = b, k, m or g --Format: <number><optional unit>, where unit = b, k, m or g
memory :: String -> Containerized Property memory :: String -> AttrProperty
memory = runProp "memory" memory = runProp "memory"
-- | Link with another container on the same host. -- | Link with another container on the same host.
link :: ContainerName -> ContainerAlias -> Containerized Property link :: ContainerName -> ContainerAlias -> AttrProperty
link linkwith alias = genProp "link" $ \hn -> link linkwith alias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias
@ -199,16 +201,6 @@ data ContainerId = ContainerId HostName ContainerName
data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
deriving (Read, Show, Eq) deriving (Read, Show, Eq)
getRunParams :: HostName -> [Containerized a] -> [RunParam]
getRunParams hn l = concatMap get l
where
get (Containerized ps _) = map (\a -> a hn ) ps
fromContainerized :: forall a. [Containerized a] -> [a]
fromContainerized l = map get l
where
get (Containerized _ a) = a
ident2id :: ContainerIdent -> ContainerId ident2id :: ContainerIdent -> ContainerId
ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn
@ -226,32 +218,32 @@ toContainerId s
fromContainerId :: ContainerId -> String fromContainerId :: ContainerId -> String
fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
containerHostName :: ContainerId -> HostName
containerHostName (ContainerId _ cn) = cn2hn cn
myContainerSuffix :: String myContainerSuffix :: String
myContainerSuffix = ".propellor" myContainerSuffix = ".propellor"
containerFrom :: Image -> [Containerized Property] -> Container
containerFrom = Container
containerDesc :: ContainerId -> Property -> Property containerDesc :: ContainerId -> Property -> Property
containerDesc cid p = p `describe` desc containerDesc cid p = p `describe` desc
where where
desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property runningContainer :: ContainerId -> Image -> [RunParam] -> Property
runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ Property "running" $ do
l <- listContainers RunningContainers l <- liftIO $ listContainers RunningContainers
if cid `elem` l if cid `elem` l
then do then do
-- Check if the ident has changed; if so the -- Check if the ident has changed; if so the
-- parameters of the container differ and it must -- parameters of the container differ and it must
-- be restarted. -- be restarted.
runningident <- getrunningident runningident <- liftIO $ getrunningident
if runningident == Just ident if runningident == Just ident
then return NoChange then noChange
else do else do
void $ stopContainer cid void $ liftIO $ stopContainer cid
restartcontainer restartcontainer
else ifM (elem cid <$> listContainers AllContainers) else ifM (liftIO $ elem cid <$> listContainers AllContainers)
( restartcontainer ( restartcontainer
, go image , go image
) )
@ -259,8 +251,8 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
ident = ContainerIdent image hn cn runps ident = ContainerIdent image hn cn runps
restartcontainer = do restartcontainer = do
oldimage <- fromMaybe image <$> commitContainer cid oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
void $ removeContainer cid void $ liftIO $ removeContainer cid
go oldimage go oldimage
getrunningident :: IO (Maybe ContainerIdent) getrunningident :: IO (Maybe ContainerIdent)
@ -271,19 +263,12 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
extractident :: [Resp] -> Maybe ContainerIdent extractident :: [Resp] -> Maybe ContainerIdent
extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
runps = getRunParams hn $ containerprops ++
-- expose propellor directory inside the container
[ volume (localdir++":"++localdir)
-- name the container in a predictable way so we
-- and the user can easily find it later
, name (fromContainerId cid)
]
go img = do go img = do
liftIO $ do
clearProvisionedFlag cid clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid) createDirectoryIfMissing True (takeDirectory $ identFile cid)
shim <- Shim.setup (localdir </> "propellor") (localdir </> shimdir cid) shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
writeFile (identFile cid) (show ident) liftIO $ writeFile (identFile cid) (show ident)
ensureProperty $ boolProperty "run" $ runContainer img ensureProperty $ boolProperty "run" $ runContainer img
(runps ++ ["-i", "-d", "-t"]) (runps ++ ["-i", "-d", "-t"])
[shim, "--docker", fromContainerId cid] [shim, "--docker", fromContainerId cid]
@ -317,7 +302,7 @@ chain s = case toContainerId s of
-- to avoid ever provisioning twice at the same time. -- to avoid ever provisioning twice at the same time.
whenM (checkProvisionedFlag cid) $ do whenM (checkProvisionedFlag cid) $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ fromContainerId cid]) $ unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $
warningMessage "Boot provision failed!" warningMessage "Boot provision failed!"
void $ async $ job reapzombies void $ async $ job reapzombies
void $ async $ job $ simpleSh $ namedPipe cid void $ async $ job $ simpleSh $ namedPipe cid
@ -339,14 +324,14 @@ chain s = case toContainerId s of
-- being run. So, retry connections to the client for up to -- being run. So, retry connections to the client for up to
-- 1 minute. -- 1 minute.
provisionContainer :: ContainerId -> Property provisionContainer :: ContainerId -> Property
provisionContainer cid = containerDesc cid $ Property "provision" $ do provisionContainer cid = containerDesc cid $ Property "provision" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing) r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
when (r /= FailedChange) $ when (r /= FailedChange) $
setProvisionedFlag cid setProvisionedFlag cid
return r return r
where where
params = ["--continue", show $ Chain $ fromContainerId cid] params = ["--continue", show $ Chain $ containerHostName cid]
go lastline (v:rest) = case v of go lastline (v:rest) = case v of
StdoutLine s -> do StdoutLine s -> do
@ -372,8 +357,8 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
stoppedContainer :: ContainerId -> Property stoppedContainer :: ContainerId -> Property
stoppedContainer cid = containerDesc cid $ Property desc $ stoppedContainer cid = containerDesc cid $ Property desc $
ifM (elem cid <$> listContainers RunningContainers) ifM (liftIO $ elem cid <$> listContainers RunningContainers)
( cleanup `after` ensureProperty ( liftIO cleanup `after` ensureProperty
(boolProperty desc $ stopContainer cid) (boolProperty desc $ stopContainer cid)
, return NoChange , return NoChange
) )
@ -420,17 +405,18 @@ listContainers status =
listImages :: IO [Image] listImages :: IO [Image]
listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Containerized Property runProp :: String -> RunParam -> AttrProperty
runProp field val = Containerized runProp field val = AttrProperty prop $ \attr ->
[\_ -> "--" ++ param] attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
(Property (param) (return NoChange))
where where
param = field++"="++val param = field++"="++val
prop = Property (param) (return NoChange)
genProp :: String -> (HostName -> RunParam) -> Containerized Property genProp :: String -> (HostName -> RunParam) -> AttrProperty
genProp field mkval = Containerized genProp field mkval = AttrProperty prop $ \attr ->
[\h -> "--" ++ field ++ "=" ++ mkval h] attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
(Property field (return NoChange)) where
prop = Property field (return NoChange)
-- | The ContainerIdent of a container is written to -- | 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

View File

@ -11,6 +11,13 @@ hasContent :: FilePath -> [Line] -> Property
f `hasContent` newcontent = fileProperty ("replace " ++ f) f `hasContent` newcontent = fileProperty ("replace " ++ f)
(\_oldcontent -> newcontent) f (\_oldcontent -> newcontent) f
-- | Ensures a file has contents that comes from PrivData.
-- Note: Does not do anything with the permissions of the file to prevent
-- it from being seen.
hasPrivContent :: FilePath -> Property
hasPrivContent f = Property ("privcontent " ++ f) $
withPrivData (PrivFile f) (\v -> ensureProperty $ f `hasContent` lines v)
-- | Ensures that a line is present in a file, adding it to the end if not. -- | Ensures that a line is present in a file, adding it to the end if not.
containsLine :: FilePath -> Line -> Property containsLine :: FilePath -> Line -> Property
f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f
@ -31,10 +38,10 @@ notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $
makeChange $ nukeFile f makeChange $ nukeFile f
fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
fileProperty desc a f = Property desc $ go =<< doesFileExist f fileProperty desc a f = Property desc $ go =<< liftIO (doesFileExist f)
where where
go True = do go True = do
ls <- lines <$> readFile f ls <- liftIO $ lines <$> readFile f
let ls' = a ls let ls' = a ls
if ls' == ls if ls' == ls
then noChange then noChange
@ -51,3 +58,13 @@ fileProperty desc a f = Property desc $ go =<< doesFileExist f
dirExists :: FilePath -> Property dirExists :: FilePath -> Property
dirExists d = check (not <$> doesDirectoryExist d) $ Property (d ++ " exists") $ dirExists d = check (not <$> doesDirectoryExist d) $ Property (d ++ " exists") $
makeChange $ createDirectoryIfMissing True d makeChange $ createDirectoryIfMissing True d
-- | 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
where
og = owner ++ ":" ++ group

48
Propellor/Property/Git.hs Normal file
View File

@ -0,0 +1,48 @@
module Propellor.Property.Git where
import Propellor
import Propellor.Property.File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Data.List
-- | Exports all git repos in a directory (that user nobody can read)
-- 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
where
setup = containsLine conf (mkl "tcp4")
`requires`
containsLine conf (mkl "tcp6")
`requires`
dirExists exportdir
`requires`
Apt.serviceInstalledRunning "openbsd-inetd"
`onChange`
Service.running "openbsd-inetd"
`describe` ("git-daemon exporting " ++ exportdir)
unsetup = lacksLine conf (mkl "tcp4")
`requires`
lacksLine conf (mkl "tcp6")
`onChange`
Service.reloaded "openbsd-inetd"
conf = "/etc/inetd.conf"
mkl tcpv = intercalate "\t"
[ "git"
, "stream"
, tcpv
, "nowait"
, "nobody"
, "/usr/bin/git"
, "git"
, "daemon"
, "--inetd"
, "--export-all"
, "--base-path=" ++ exportdir
, exportdir
]

View File

@ -3,21 +3,24 @@ module Propellor.Property.Hostname where
import Propellor import Propellor
import qualified Propellor.Property.File as File import qualified Propellor.Property.File as File
-- | Sets the hostname. Configures both /etc/hostname and the current -- | Ensures that the hostname is set to the HostAttr value.
-- hostname. -- Configures both /etc/hostname and the current hostname.
-- --
-- When provided with a FQDN, also configures /etc/hosts, -- When the hostname is a FQDN, also configures /etc/hosts,
-- with an entry for 127.0.1.1, which is standard at least on Debian -- with an entry for 127.0.1.1, which is standard at least on Debian
-- to set the FDQN (127.0.0.1 is localhost). -- to set the FDQN (127.0.0.1 is localhost).
set :: HostName -> Property sane :: Property
set hostname = combineProperties desc go sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName)
`onChange` cmdProperty "hostname" [host]
setTo :: HostName -> Property
setTo hn = combineProperties desc go
`onChange` cmdProperty "hostname" [basehost]
where where
desc = "hostname " ++ hostname desc = "hostname " ++ hn
(host, domain) = separate (== '.') hostname (basehost, domain) = separate (== '.') hn
go = catMaybes go = catMaybes
[ Just $ "/etc/hostname" `File.hasContent` [host] [ Just $ "/etc/hostname" `File.hasContent` [basehost]
, if null domain , if null domain
then Nothing then Nothing
else Just $ File.fileProperty desc else Just $ File.fileProperty desc
@ -25,7 +28,7 @@ set hostname = combineProperties desc go
] ]
hostip = "127.0.1.1" hostip = "127.0.1.1"
hostline = hostip ++ "\t" ++ hostname ++ " " ++ host hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost
addhostline ls = hostline : filter (not . hashostip) ls addhostline ls = hostline : filter (not . hashostip) ls
hashostip l = headMaybe (words l) == Just hostip hashostip l = headMaybe (words l) == Just hostip

View File

@ -20,6 +20,7 @@ ipv6to4 = fileProperty "ipv6to4" go interfaces
, "\taddress 2002:5044:5531::1" , "\taddress 2002:5044:5531::1"
, "\tnetmask 64" , "\tnetmask 64"
, "\tgateway ::192.88.99.1" , "\tgateway ::192.88.99.1"
, "auto sit0"
, "# End automatically added by propeller" , "# End automatically added by propeller"
] ]

View File

@ -0,0 +1,26 @@
module Propellor.Property.OpenId where
import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
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
(map setbaseurl) "/etc/simpleid/config.inc"
] ++ map identfile users
where
identfile u = File.hasPrivContent $ concat
[ "/var/lib/simpleid/identities/", u, ".identity" ]
url = "http://"++baseurl++"/simpleid"
desc = "openid provider " ++ url
setbaseurl l
| "SIMPLEID_BASE_URL" `isInfixOf` l =
"define('SIMPLEID_BASE_URL', '"++url++"');"
| otherwise = l

View File

@ -0,0 +1,67 @@
module Propellor.Property.Scheduled
( period
, periodParse
, Recurrance(..)
, WeekDay
, MonthDay
, YearDay
) where
import Propellor
import Utility.Scheduled
import Data.Time.Clock
import Data.Time.LocalTime
import qualified Data.Map as M
-- | Makes a Property only be checked every so often.
--
-- This uses the description of the Property to keep track of when it was
-- last run.
period :: Property -> Recurrance -> Property
period prop recurrance = Property desc $ do
lasttime <- liftIO $ getLastChecked (propertyDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow
if Just t >= nexttime
then do
r <- ensureProperty prop
liftIO $ setLastChecked t (propertyDesc prop)
return r
else noChange
where
schedule = Schedule recurrance AnyTime
desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
-- | Like period, but parse a human-friendly string.
periodParse :: Property -> String -> Property
periodParse prop s = case toRecurrance s of
Just recurrance -> period prop recurrance
Nothing -> Property "periodParse" $ do
liftIO $ warningMessage $ "failed periodParse: " ++ s
noChange
lastCheckedFile :: FilePath
lastCheckedFile = localdir </> ".lastchecked"
getLastChecked :: Desc -> IO (Maybe LocalTime)
getLastChecked desc = M.lookup desc <$> readLastChecked
localNow :: IO LocalTime
localNow = do
now <- getCurrentTime
tz <- getTimeZone now
return $ utcToLocalTime tz now
setLastChecked :: LocalTime -> Desc -> IO ()
setLastChecked time desc = do
m <- readLastChecked
writeLastChecked (M.insert desc time m)
readLastChecked :: IO (M.Map Desc LocalTime)
readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go
where
go = readish <$> readFile lastCheckedFile
writeLastChecked :: M.Map Desc LocalTime -> IO ()
writeLastChecked = writeFile lastCheckedFile . show

View File

@ -0,0 +1,31 @@
module Propellor.Property.Service where
import Propellor
import Utility.SafeCommand
type ServiceName = String
-- | Ensures that a service is running. Does not ensure that
-- any package providing that service is installed. See
-- Apt.serviceInstalledRunning
--
-- 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
restarted :: ServiceName -> Property
restarted svc = Property ("restarted " ++ svc) $ do
void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"]
return NoChange
reloaded :: ServiceName -> Property
reloaded svc = Property ("reloaded " ++ svc) $ do
void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"]
return NoChange

View File

@ -24,7 +24,7 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
, Apt.buildDep ["git-annex"] , Apt.buildDep ["git-annex"]
, Apt.installed ["git", "rsync", "moreutils", "ca-certificates", , Apt.installed ["git", "rsync", "moreutils", "ca-certificates",
"liblockfile-simple-perl", "cabal-install", "vim", "less"] "liblockfile-simple-perl", "cabal-install", "vim", "less"]
, serviceRunning "cron" `requires` Apt.installed ["cron"] , Apt.serviceInstalledRunning "cron"
, User.accountFor builduser , User.accountFor builduser
, check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser , check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser
[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
@ -44,12 +44,13 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
let f = homedir </> "rsyncpassword" let f = homedir </> "rsyncpassword"
if rsyncupload if rsyncupload
then withPrivData (Password builduser) $ \p -> do then withPrivData (Password builduser) $ \p -> do
oldp <- catchDefaultIO "" $ readFileStrict f oldp <- liftIO $ catchDefaultIO "" $
readFileStrict f
if p /= oldp if p /= oldp
then makeChange $ writeFile f p then makeChange $ writeFile f p
else noChange else noChange
else do else do
ifM (doesFileExist f) ifM (liftIO $ doesFileExist f)
( noChange ( noChange
, makeChange $ writeFile f "no password configured" , makeChange $ writeFile f "no password configured"
) )

View File

@ -8,8 +8,8 @@ import Utility.SafeCommand
-- | Clones Joey Hess's git home directory, and runs its fixups script. -- | Clones Joey Hess's git home directory, and runs its fixups script.
installedFor :: UserName -> Property installedFor :: UserName -> Property
installedFor user = check (not <$> hasGitDir user) $ installedFor user = check (not <$> hasGitDir user) $
Property ("githome " ++ user) (go =<< homedir user) Property ("githome " ++ user) (go =<< liftIO (homedir user))
`requires` Apt.installed ["git", "myrepos"] `requires` Apt.installed ["git"]
where where
go Nothing = noChange go Nothing = noChange
go (Just home) = do go (Just home) = do
@ -20,7 +20,7 @@ installedFor user = check (not <$> hasGitDir user) $
moveout tmpdir home moveout tmpdir home
, Property "rmdir" $ makeChange $ void $ , Property "rmdir" $ makeChange $ void $
catchMaybeIO $ removeDirectory tmpdir catchMaybeIO $ removeDirectory tmpdir
, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; mr checkout; bin/fixups"] , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]
] ]
moveout tmpdir home = do moveout tmpdir home = do
fs <- dirContents tmpdir fs <- dirContents tmpdir

View File

@ -6,8 +6,8 @@ module Propellor.Property.SiteSpecific.JoeySites where
import Propellor import Propellor
import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Apt as Apt
oldUseNetshellBox :: Property oldUseNetShellBox :: Property
oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $ oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $
propertyList ("olduse.net shellbox") propertyList ("olduse.net shellbox")
[ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") [ 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" `describe` "olduse.net build deps"

View File

@ -53,7 +53,7 @@ uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restartSshd `onChange` restartSshd
where where
prop = Property "ssh unique host keys" $ do prop = Property "ssh unique host keys" $ do
void $ boolSystem "sh" void $ liftIO $ boolSystem "sh"
[ Param "-c" [ Param "-c"
, Param "rm -f /etc/ssh/ssh_host_*" , Param "rm -f /etc/ssh/ssh_host_*"
] ]

View File

@ -13,7 +13,7 @@ enabledFor :: UserName -> Property
enabledFor user = Property desc go `requires` Apt.installed ["sudo"] enabledFor user = Property desc go `requires` Apt.installed ["sudo"]
where where
go = do go = do
locked <- isLockedPassword user locked <- liftIO $ isLockedPassword user
ensureProperty $ ensureProperty $
fileProperty desc fileProperty desc
(modify locked . filter (wanted locked)) (modify locked . filter (wanted locked))

View File

@ -27,7 +27,7 @@ simpleSh namedpipe = do
createDirectoryIfMissing True dir createDirectoryIfMissing True dir
modifyFileMode dir (removeModes otherGroupModes) modifyFileMode dir (removeModes otherGroupModes)
s <- socket AF_UNIX Stream defaultProtocol s <- socket AF_UNIX Stream defaultProtocol
bind s (SockAddrUnix namedpipe) bindSocket s (SockAddrUnix namedpipe)
listen s 2 listen s 2
forever $ do forever $ do
(client, _addr) <- accept s (client, _addr) <- accept s

View File

@ -1,19 +1,74 @@
module Propellor.Types where {-# LANGUAGE PackageImports #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
module Propellor.Types
( Host(..)
, Attr
, HostName
, UserName
, GroupName
, Propellor(..)
, Property(..)
, RevertableProperty(..)
, AttrProperty(..)
, IsProp
, describe
, toProp
, getAttr
, requires
, Desc
, Result(..)
, System(..)
, Distribution(..)
, DebianSuite(..)
, Release
, Architecture
, ActionResult(..)
, CmdLine(..)
, PrivDataField(..)
) where
import Data.Monoid import Data.Monoid
import Control.Applicative
import System.Console.ANSI import System.Console.ANSI
import "mtl" Control.Monad.Reader
import "MonadCatchIO-transformers" Control.Monad.CatchIO
import Propellor.Types.Attr
data Host = Host [Property] (Attr -> Attr)
type HostName = String
type UserName = String type UserName = String
type GroupName = String
-- | Propellor's monad provides read-only access to attributes of the
-- system.
newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
deriving
( Monad
, Functor
, Applicative
, MonadReader Attr
, MonadIO
, MonadCatchIO
)
-- | 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 data Property = Property
{ propertyDesc :: Desc { propertyDesc :: Desc
-- | must be idempotent; may run repeatedly -- | must be idempotent; may run repeatedly
, propertySatisfy :: IO Result , propertySatisfy :: Propellor Result
} }
-- | A property that can be reverted.
data RevertableProperty = RevertableProperty Property Property data RevertableProperty = RevertableProperty Property Property
-- | A property that affects the Attr.
data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
class IsProp p where class IsProp p where
-- | Sets description. -- | Sets description.
describe :: p -> Desc -> p describe :: p -> Desc -> p
@ -21,6 +76,7 @@ class IsProp p where
-- | Indicates that the first property can only be satisfied -- | Indicates that the first property can only be satisfied
-- once the second one is. -- once the second one is.
requires :: p -> Property -> p requires :: p -> Property -> p
getAttr :: p -> (Attr -> Attr)
instance IsProp Property where instance IsProp Property where
describe p d = p { propertyDesc = d } describe p d = p { propertyDesc = d }
@ -30,6 +86,7 @@ instance IsProp Property where
case r of case r of
FailedChange -> return FailedChange FailedChange -> return FailedChange
_ -> propertySatisfy x _ -> propertySatisfy x
getAttr _ = id
instance IsProp RevertableProperty where instance IsProp RevertableProperty where
-- | Sets the description of both sides. -- | Sets the description of both sides.
@ -38,6 +95,13 @@ instance IsProp RevertableProperty where
toProp (RevertableProperty p1 _) = p1 toProp (RevertableProperty p1 _) = p1
(RevertableProperty p1 p2) `requires` y = (RevertableProperty p1 p2) `requires` y =
RevertableProperty (p1 `requires` y) p2 RevertableProperty (p1 `requires` y) p2
getAttr _ = id
instance IsProp AttrProperty where
describe (AttrProperty p a) d = AttrProperty (describe p d) a
toProp (AttrProperty p _) = toProp p
(AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a
getAttr (AttrProperty _ a) = a
type Desc = String type Desc = String
@ -63,7 +127,7 @@ data Distribution
deriving (Show) deriving (Show)
data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release
deriving (Show) deriving (Show, Eq)
type Release = String type Release = String
@ -100,6 +164,7 @@ data PrivDataField
= DockerAuthentication = DockerAuthentication
| SshPrivKey UserName | SshPrivKey UserName
| Password UserName | Password UserName
| PrivFile FilePath
deriving (Read, Show, Ord, Eq) deriving (Read, Show, Ord, Eq)

36
Propellor/Types/Attr.hs Normal file
View File

@ -0,0 +1,36 @@
module Propellor.Types.Attr where
import qualified Data.Set as S
-- | The attributes of a host. For example, its hostname.
data Attr = Attr
{ _hostname :: HostName
, _cnames :: S.Set Domain
, _dockerImage :: Maybe String
, _dockerRunParams :: [HostName -> String]
}
instance Eq Attr where
x == y = and
[ _hostname x == _hostname y
, _cnames x == _cnames y
, _dockerImage x == _dockerImage y
, let simpl v = map (\a -> a "") (_dockerRunParams v)
in simpl x == simpl y
]
instance Show Attr where
show a = unlines
[ "hostname " ++ _hostname a
, "cnames " ++ show (_cnames a)
, "docker image " ++ show (_dockerImage a)
, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
]
newAttr :: HostName -> Attr
newAttr hn = Attr hn S.empty Nothing []
type HostName = String
type Domain = String

18
TODO
View File

@ -2,15 +2,19 @@
run it once for the whole. For example, may want to restart apache, run it once for the whole. For example, may want to restart apache,
but only once despite many config changes being made to satisfy but only once despite many config changes being made to satisfy
properties. onChange is a poor substitute. properties. onChange is a poor substitute.
* --spin needs 4 ssh connections when bootstrapping a new host
that does not have the git repo yet. Should be possible to get that
down to 1.
* Currently only Debian and derivatives are supported by most Properties. * Currently only Debian and derivatives are supported by most Properties.
One way to improve that would be to parameterize Properties with a This could be improved by making the Distribution of the system part
Distribution witness. of its HostAttr.
* Display of docker container properties is a bit wonky. It always * Display of docker container properties is a bit wonky. It always
says they are unchanged even when they changed and triggered a says they are unchanged even when they changed and triggered a
reprovision. reprovision.
* Should properties be a tree rather than a list? * Should properties be a tree rather than a list?
* Only make docker garbage collection run once a day or something * Need a way for a dns server host to look at the properties of
to avoid GC after a temp fail. the other hosts and generate a zone file. For example, mapping
openid.kitenet.net to a CNAME to clam.kitenet.net, which is where
the docker container for that service is located. Moving containers
to a different host, or duplicating a container on multiple hosts
would then update DNS too
* There is no way for a property of a docker container to require
some property be met outside the container. For example, some servers
need ntp installed for a good date source.

52
Utility/QuickCheck.hs Normal file
View File

@ -0,0 +1,52 @@
{- QuickCheck with additional instances
-
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# 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)

358
Utility/Scheduled.hs Normal file
View File

@ -0,0 +1,358 @@
{- scheduled activities
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.Scheduled (
Schedule(..),
Recurrance(..),
ScheduledTime(..),
NextTime(..),
WeekDay,
MonthDay,
YearDay,
nextTime,
startTime,
fromSchedule,
fromScheduledTime,
toScheduledTime,
fromRecurrance,
toRecurrance,
toSchedule,
parseSchedule,
prop_schedule_roundtrips
) 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.Tuple.Utils
import Data.Char
{- Some sort of scheduled event. -}
data Schedule = Schedule Recurrance ScheduledTime
deriving (Eq, Read, Show, Ord)
data Recurrance
= Daily
| Weekly (Maybe WeekDay)
| Monthly (Maybe MonthDay)
| Yearly (Maybe YearDay)
| 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)
type WeekDay = Int
type MonthDay = Int
type YearDay = Int
data ScheduledTime
= AnyTime
| SpecificTime Hour Minute
deriving (Eq, Read, Show, Ord)
type Hour = Int
type Minute = Int
{- Next time a Schedule should take effect. The NextTimeWindow is used
- when a Schedule is allowed to start at some point within the window. -}
data NextTime
= NextTimeExactly LocalTime
| NextTimeWindow LocalTime LocalTime
deriving (Eq, Read, Show)
startTime :: NextTime -> LocalTime
startTime (NextTimeExactly t) = t
startTime (NextTimeWindow t _) = t
nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
nextTime schedule lasttime = do
now <- getCurrentTime
tz <- getTimeZone now
return $ calcNextTime schedule lasttime $ utcToLocalTime tz now
{- Calculate the next time that fits a Schedule, based on the
- last time it occurred, and the current time. -}
calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime
| scheduledtime == AnyTime = do
next <- findfromtoday True
return $ case next of
NextTimeWindow _ _ -> next
NextTimeExactly t -> window (localDay t) (localDay t)
| otherwise = NextTimeExactly . startTime <$> findfromtoday False
where
findfromtoday anytime = findfrom recurrance afterday today
where
today = localDay currenttime
afterday = sameaslastday || toolatetoday
toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
sameaslastday = lastday == Just today
lastday = localDay <$> lasttime
nexttime = case scheduledtime of
AnyTime -> TimeOfDay 0 0 0
SpecificTime h m -> TimeOfDay h m 0
exactly d = NextTimeExactly $ LocalTime d nexttime
window startd endd = NextTimeWindow
(LocalTime startd nexttime)
(LocalTime endd (TimeOfDay 23 59 0))
findfrom r afterday day = case r of
Daily
| afterday -> Just $ exactly $ addDays 1 day
| otherwise -> Just $ exactly day
Weekly Nothing
| afterday -> skip 1
| otherwise -> case (wday <$> lastday, wday day) of
(Nothing, _) -> Just $ window day (addDays 6 day)
(Just old, curr)
| old == curr -> Just $ window day (addDays 6 day)
| otherwise -> skip 1
Monthly Nothing
| afterday -> skip 1
| maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday ->
-- Window only covers current month,
-- in case there is a Divisible requirement.
Just $ window day (endOfMonth day)
| otherwise -> skip 1
Yearly Nothing
| afterday -> skip 1
| maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday ->
Just $ window day (endOfYear day)
| otherwise -> skip 1
Weekly (Just w)
| w < 0 || w > maxwday -> Nothing
| w == wday day -> if afterday
then Just $ exactly $ addDays 7 day
else Just $ exactly day
| otherwise -> Just $ exactly $
addDays (fromIntegral $ (w - wday day) `mod` 7) day
Monthly (Just m)
| m < 0 || m > maxmday -> Nothing
-- TODO can be done more efficiently than recursing
| m == mday day -> if afterday
then skip 1
else Just $ exactly day
| otherwise -> skip 1
Yearly (Just y)
| y < 0 || y > maxyday -> Nothing
| y == yday day -> if afterday
then skip 365
else Just $ exactly day
| otherwise -> skip 1
Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
Divisible _ r'@(Divisible _ _) -> findfrom r' afterday day
where
skip n = findfrom r False (addDays n day)
handlediv n r' getval mmax
| n > 0 && maybe True (n <=) mmax =
findfromwhere r' (divisible n . getval) afterday day
| otherwise = Nothing
findfromwhere r p afterday day
| maybe True (p . getday) next = next
| otherwise = maybe Nothing (findfromwhere r p True . getday) next
where
next = findfrom r afterday day
getday = localDay . startTime
divisible n v = v `rem` n == 0
endOfMonth :: Day -> Day
endOfMonth day =
let (y,m,_d) = toGregorian day
in fromGregorian y m (gregorianMonthLength y m)
endOfYear :: Day -> Day
endOfYear day =
let (y,_m,_d) = toGregorian day
in endOfMonth (fromGregorian y maxmnum 1)
-- extracting various quantities from a Day
wday :: Day -> Int
wday = thd3 . toWeekDate
wnum :: Day -> Int
wnum = snd3 . toWeekDate
mday :: Day -> Int
mday = thd3 . toGregorian
mnum :: Day -> Int
mnum = snd3 . toGregorian
yday :: Day -> Int
yday = snd . toOrdinalDate
ynum :: Day -> Int
ynum = fromIntegral . fst . toOrdinalDate
{- Calendar max and mins. -}
maxyday :: Int
maxyday = 366 -- with leap days
minyday :: Int
minyday = 365
maxwnum :: Int
maxwnum = 53 -- some years have more than 52
maxmday :: Int
maxmday = 31
minmday :: Int
minmday = 28
maxmnum :: Int
maxmnum = 12
maxwday :: Int
maxwday = 7
fromRecurrance :: Recurrance -> String
fromRecurrance (Divisible n r) =
fromRecurrance' (++ "s divisible by " ++ show n) r
fromRecurrance r = fromRecurrance' ("every " ++) r
fromRecurrance' :: (String -> String) -> Recurrance -> String
fromRecurrance' a Daily = a "day"
fromRecurrance' a (Weekly n) = onday n (a "week")
fromRecurrance' a (Monthly n) = onday n (a "month")
fromRecurrance' a (Yearly n) = onday n (a "year")
fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used
onday :: Maybe Int -> String -> String
onday (Just n) s = "on day " ++ show n ++ " of " ++ s
onday Nothing s = s
toRecurrance :: String -> Maybe Recurrance
toRecurrance s = case words s of
("every":"day":[]) -> Just Daily
("on":"day":sd:"of":"every":something:[]) -> withday sd something
("every":something:[]) -> noday something
("days":"divisible":"by":sn:[]) ->
Divisible <$> getdivisor sn <*> pure Daily
("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
Divisible
<$> getdivisor sn
<*> withday sd something
("every":something:"divisible":"by":sn:[]) ->
Divisible
<$> getdivisor sn
<*> noday something
(something:"divisible":"by":sn:[]) ->
Divisible
<$> getdivisor sn
<*> noday something
_ -> Nothing
where
constructor "week" = Just Weekly
constructor "month" = Just Monthly
constructor "year" = Just Yearly
constructor u
| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
| otherwise = Nothing
withday sd u = do
c <- constructor u
d <- readish sd
Just $ c (Just d)
noday u = do
c <- constructor u
Just $ c Nothing
getdivisor sn = do
n <- readish sn
if n > 0
then Just n
else Nothing
fromScheduledTime :: ScheduledTime -> String
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
(h', ampm)
| h == 0 = (12, "AM")
| h < 12 = (h, "AM")
| h == 12 = (h, "PM")
| otherwise = (h - 12, "PM")
toScheduledTime :: String -> Maybe ScheduledTime
toScheduledTime "any time" = Just AnyTime
toScheduledTime v = case words v of
(s:ampm:[])
| map toUpper ampm == "AM" ->
go s h0
| map toUpper ampm == "PM" ->
go s (\h -> (h0 h) + 12)
| otherwise -> Nothing
(s:[]) -> go s id
_ -> Nothing
where
h0 h
| h == 12 = 0
| otherwise = h
go :: String -> (Int -> Int) -> Maybe ScheduledTime
go s adjust =
let (h, m) = separate (== ':') s
in SpecificTime
<$> (adjust <$> readish h)
<*> if null m then Just 0 else readish m
fromSchedule :: Schedule -> String
fromSchedule (Schedule recurrance scheduledtime) = unwords
[ fromRecurrance recurrance
, "at"
, fromScheduledTime scheduledtime
]
toSchedule :: String -> Maybe Schedule
toSchedule = eitherToMaybe . parseSchedule
parseSchedule :: String -> Either String Schedule
parseSchedule s = do
r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
(toRecurrance recurrance)
t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right
(toScheduledTime scheduledtime)
Right $ Schedule r t
where
(rws, tws) = separate (== "at") (words s)
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

View File

@ -2,6 +2,7 @@
import Propellor import Propellor
import Propellor.CmdLine import Propellor.CmdLine
import Propellor.Property.Scheduled
import qualified Propellor.Property.File as File import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network import qualified Propellor.Property.Network as Network
@ -12,98 +13,130 @@ import qualified Propellor.Property.User as User
import qualified Propellor.Property.Hostname as Hostname import qualified Propellor.Property.Hostname as Hostname
--import qualified Propellor.Property.Reboot as Reboot --import qualified Propellor.Property.Reboot as Reboot
import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Tor as Tor
import qualified Propellor.Property.Dns as Dns
import qualified Propellor.Property.OpenId as OpenId
import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Git as Git
import qualified Propellor.Property.SiteSpecific.GitHome as GitHome import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
import Data.List
main :: IO () hosts :: [Host]
main = defaultMain [host, Docker.containerProperties container] hosts =
-- My laptop
[ host "darkstar.kitenet.net"
& Docker.configured
& Apt.buildDep ["git-annex"] `period` Daily
-- | This is where the system's HostName, either as returned by uname -- Nothing super-important lives here.
-- or one specified on the command line, is converted into a list of , standardSystem "clam.kitenet.net" Unstable
-- Properties for that system. & cleanCloudAtCost
--
-- Edit this to configure propellor!
host :: HostName -> Maybe [Property]
-- Clam is a tor bridge, and an olduse.net shellbox and other fun stuff.
host hostname@"clam.kitenet.net" = standardSystem Unstable $ props
& cleanCloudAtCost hostname
& Apt.unattendedUpgrades & Apt.unattendedUpgrades
& Network.ipv6to4 & Network.ipv6to4
& Apt.installed ["git-annex", "mtr"]
& Tor.isBridge & Tor.isBridge
& JoeySites.oldUseNetshellBox
& Docker.configured & Docker.configured
& Docker.garbageCollected & cname "shell.olduse.net"
-- Orca is the main git-annex build box. & JoeySites.oldUseNetShellBox
host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
& Hostname.set hostname & cname "openid.kitenet.net"
& Docker.docked hosts "openid-provider"
`requires` Apt.installed ["ntp"]
& cname "ancient.kitenet.net"
& Docker.docked hosts "ancient-kitenet"
& Docker.garbageCollected `period` Daily
& Apt.installed ["git-annex", "mtr", "screen"]
-- Orca is the main git-annex build box.
, standardSystem "orca.kitenet.net" Unstable
& Hostname.sane
& Apt.unattendedUpgrades & Apt.unattendedUpgrades
& Docker.configured & Docker.configured
& Apt.buildDep ["git-annex"] & Docker.docked hosts "amd64-git-annex-builder"
& Docker.docked container hostname "amd64-git-annex-builder" & Docker.docked hosts "i386-git-annex-builder"
& Docker.docked container hostname "i386-git-annex-builder" ! Docker.docked hosts "armel-git-annex-builder-companion"
& Docker.docked container hostname "armel-git-annex-builder-companion" ! Docker.docked hosts "armel-git-annex-builder"
& Docker.docked container hostname "armel-git-annex-builder" & Docker.garbageCollected `period` Daily
& Docker.garbageCollected & Apt.buildDep ["git-annex"] `period` Daily
-- My laptop
host _hostname@"darkstar.kitenet.net" = Just $ props
& Docker.configured
-- add more hosts here... -- Important stuff that needs not too much memory or CPU.
--host "foo.example.com" = , standardSystem "diatom.kitenet.net" Stable
host _ = Nothing & Hostname.sane
& Apt.unattendedUpgrades
& Apt.serviceInstalledRunning "ntp"
& Dns.zones myDnsSecondary
& Apt.serviceInstalledRunning "apache2"
& Apt.installed ["git", "git-annex", "rsync"]
& Apt.buildDep ["git-annex"] `period` Daily
& Git.daemonRunning "/srv/git"
& File.ownerGroup "/srv/git" "joey" "joey"
-- git repos restore (how?)
-- family annex needs family members to have accounts,
-- ssh host key etc.. finesse?
-- (also should upgrade git-annex-shell for it..)
-- kgb installation and setup
-- ssh keys for branchable and github repo hooks
-- gitweb
-- downloads.kitenet.net setup (including ssh key to turtle)
-- | This is where Docker containers are set up. A container --------------------------------------------------------------------
-- can vary by hostname where it's used, or be the same everywhere. -- Docker Containers ----------------------------------- \o/ -----
container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container) --------------------------------------------------------------------
container _host name
| name == "webserver" = Just $ Docker.containerFrom
(image $ System (Debian Unstable) "amd64")
[ Docker.publish "8080:80"
, Docker.volume "/var/www:/var/www"
, Docker.inside $ props
& serviceRunning "apache2"
`requires` Apt.installed ["apache2"]
]
-- Simple web server, publishing the outside host's /var/www
, standardContainer "webserver" Stable "amd64"
& Docker.publish "8080:80"
& Docker.volume "/var/www:/var/www"
& Apt.serviceInstalledRunning "apache2"
-- My own openid provider. Uses php, so containerized for security
-- and administrative sanity.
, standardContainer "openid-provider" Stable "amd64"
& Docker.publish "8081:80"
& OpenId.providerFor ["joey", "liw"]
"openid.kitenet.net:8081"
, standardContainer "ancient-kitenet" Stable "amd64"
& Docker.publish "1994:80"
& Apt.serviceInstalledRunning "apache2"
& Apt.installed ["git"]
& scriptProperty
[ "cd /var/"
, "rm -rf www"
, "git clone git://git.kitenet.net/kitewiki www"
, "cd www"
, "git checkout remotes/origin/old-kitenet.net"
] `flagFile` "/var/www/blastfromthepast.html"
-- git-annex autobuilder containers
, gitAnnexBuilder "amd64" 15
, gitAnnexBuilder "i386" 45
-- armel builder has a companion container that run amd64 and -- armel builder has a companion container that run amd64 and
-- runs the build first to get TH splices. They share a home -- runs the build first to get TH splices. They share a home
-- directory, and need to have the same versions of all haskell -- directory, and need to have the same versions of all haskell
-- libraries installed. -- libraries installed.
| name == "armel-git-annex-builder-companion" = Just $ Docker.containerFrom , Docker.container "armel-git-annex-builder-companion"
(image $ System (Debian Unstable) "amd64") (image $ System (Debian Unstable) "amd64")
[ Docker.volume GitAnnexBuilder.homedir & Docker.volume GitAnnexBuilder.homedir
] & Apt.unattendedUpgrades
| name == "armel-git-annex-builder" = Just $ Docker.containerFrom , Docker.container "armel-git-annex-builder"
(image $ System (Debian Unstable) "armel") (image $ System (Debian Unstable) "armel")
[ Docker.link (name ++ "-companion") "companion" & Docker.link "armel-git-annex-builder-companion" "companion"
, Docker.volumes_from (name ++ "-companion") & Docker.volumes_from "armel-git-annex-builder-companion"
, Docker.inside $ props
-- & GitAnnexBuilder.builder "armel" "15 * * * *" True -- & GitAnnexBuilder.builder "armel" "15 * * * *" True
& Apt.unattendedUpgrades
] ]
| "-git-annex-builder" `isSuffixOf` name = gitAnnexBuilder :: Architecture -> Int -> Host
let arch = takeWhile (/= '-') name gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder")
in Just $ Docker.containerFrom
(image $ System (Debian Unstable) arch) (image $ System (Debian Unstable) arch)
[ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" True ] & GitAnnexBuilder.builder arch (show buildminute ++ " * * * *") True
& Apt.unattendedUpgrades
| otherwise = Nothing -- This is my standard system setup.
standardSystem :: HostName -> DebianSuite -> Host
-- | Docker images I prefer to use. standardSystem hn suite = host hn
image :: System -> Docker.Image
image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
image _ = "debian-stable-official" -- does not currently exist!
-- This is my standard system setup
standardSystem :: DebianSuite -> [Property] -> Maybe [Property]
standardSystem suite customprops = Just $
standardprops : customprops ++ endprops
where
standardprops = propertyList "standard system" $ props
& Apt.stdSourcesList suite `onChange` Apt.upgrade & Apt.stdSourcesList suite `onChange` Apt.upgrade
& Apt.installed ["etckeeper"] & Apt.installed ["etckeeper"]
& Apt.installed ["ssh"] & Apt.installed ["ssh"]
@ -122,14 +155,25 @@ standardSystem suite customprops = Just $
-- I use postfix, or no MTA. -- I use postfix, or no MTA.
& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"] & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
`onChange` Apt.autoRemove `onChange` Apt.autoRemove
-- May reboot, so comes last
-- Currently not enable due to #726375 -- This is my standard container setup, featuring automatic upgrades.
endprops = [] -- [Apt.installed ["systemd-sysv"] `onChange` Reboot.now] standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host
standardContainer name suite arch = Docker.container name (image system)
& Apt.stdSourcesList suite
& Apt.unattendedUpgrades
where
system = System (Debian suite) arch
-- | Docker images I prefer to use.
image :: System -> Docker.Image
image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
image (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch
image _ = "debian-stable-official" -- does not currently exist!
-- Clean up a system as installed by cloudatcost.com -- Clean up a system as installed by cloudatcost.com
cleanCloudAtCost :: HostName -> Property cleanCloudAtCost :: Property
cleanCloudAtCost hostname = propertyList "cloudatcost cleanup" cleanCloudAtCost = propertyList "cloudatcost cleanup"
[ Hostname.set hostname [ Hostname.sane
, Ssh.uniqueHostKeys , Ssh.uniqueHostKeys
, "worked around grub/lvm boot bug #743126" ==> , "worked around grub/lvm boot bug #743126" ==>
"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
@ -141,3 +185,18 @@ cleanCloudAtCost hostname = propertyList "cloudatcost cleanup"
, User.nuked "user" User.YesReallyDeleteHome , User.nuked "user" User.YesReallyDeleteHome
] ]
] ]
myDnsSecondary :: [Dns.Zone]
myDnsSecondary =
[ Dns.secondary "kitenet.net" master
, Dns.secondary "joeyh.name" master
, Dns.secondary "ikiwiki.info" master
, Dns.secondary "olduse.net" master
, Dns.secondary "branchable.com" branchablemaster
]
where
master = ["80.68.85.49", "2001:41c8:125:49::10"] -- wren
branchablemaster = ["66.228.46.55", "2600:3c03::f03c:91ff:fedf:c0e5"]
main :: IO ()
main = defaultMain hosts --, Docker.containerProperties container]

View File

@ -3,6 +3,7 @@
import Propellor import Propellor
import Propellor.CmdLine import Propellor.CmdLine
import Propellor.Property.Scheduled
import qualified Propellor.Property.File as File import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network import qualified Propellor.Property.Network as Network
@ -15,16 +16,11 @@ import qualified Propellor.Property.User as User
--import qualified Propellor.Property.Tor as Tor --import qualified Propellor.Property.Tor as Tor
import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Docker as Docker
main :: IO () -- The hosts propellor knows about.
main = defaultMain [host, Docker.containerProperties container]
-- | This is where the system's HostName, either as returned by uname
-- or one specified on the command line, is converted into a list of
-- Properties for that system.
--
-- Edit this to configure propellor! -- Edit this to configure propellor!
host :: HostName -> Maybe [Property] hosts :: [Host]
host hostname@"mybox.example.com" = Just $ props hosts =
[ host "mybox.example.com"
& Apt.stdSourcesList Unstable & Apt.stdSourcesList Unstable
`onChange` Apt.upgrade `onChange` Apt.upgrade
& Apt.unattendedUpgrades & Apt.unattendedUpgrades
@ -33,21 +29,19 @@ host hostname@"mybox.example.com" = Just $ props
& User.hasSomePassword "root" & User.hasSomePassword "root"
& Network.ipv6to4 & Network.ipv6to4
& File.dirExists "/var/www" & File.dirExists "/var/www"
& Docker.docked container hostname "webserver" & Docker.docked hosts "webserver"
& Docker.garbageCollected & Docker.garbageCollected `period` Daily
& Cron.runPropellor "30 * * * *" & Cron.runPropellor "30 * * * *"
-- add more hosts here...
--host "foo.example.com" =
host _ = Nothing
-- | This is where Docker containers are set up. A container -- A generic webserver in a Docker container.
-- can vary by hostname where it's used, or be the same everywhere. , Docker.container "webserver" "joeyh/debian-unstable"
container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container) & Docker.publish "80:80"
container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable" & Docker.volume "/var/www:/var/www"
[ Docker.publish "80:80" & Apt.serviceInstalledRunning "apache2"
, Docker.volume "/var/www:/var/www"
, Docker.inside $ props -- add more hosts here...
& serviceRunning "apache2" --, host "foo.example.com" = ...
`requires` Apt.installed ["apache2"]
] ]
container _ _ = Nothing
main :: IO ()
main = defaultMain hosts

15
debian/changelog vendored
View File

@ -1,3 +1,18 @@
propellor (0.3.0) UNRELEASED; urgency=medium
* ipv6to4: Ensure interface is brought up automatically on boot.
* Enabling unattended upgrades now ensures that cron is installed and
running to perform them.
* Properties can be scheduled to only be checked after a given time period.
* Fix bootstrapping of dependencies.
* Fix compilation on Debian stable.
* Include security updates in sources.list for stable and testing.
* Use ssh connection caching, especially when bootstrapping.
* Properties now run in a Propellor monad, which provides access to
attributes of the host.
-- Joey Hess <joeyh@debian.org> Tue, 08 Apr 2014 18:07:12 -0400
propellor (0.2.3) unstable; urgency=medium propellor (0.2.3) unstable; urgency=medium
* docker: Fix laziness bug that caused running containers to be * docker: Fix laziness bug that caused running containers to be

4
debian/control vendored
View File

@ -11,6 +11,8 @@ Build-Depends:
libghc-unix-compat-dev, libghc-unix-compat-dev,
libghc-ansi-terminal-dev, libghc-ansi-terminal-dev,
libghc-ifelse-dev, libghc-ifelse-dev,
libghc-mtl-dev,
libghc-monadcatchio-transformers-dev,
Maintainer: Joey Hess <joeyh@debian.org> Maintainer: Joey Hess <joeyh@debian.org>
Standards-Version: 3.9.5 Standards-Version: 3.9.5
Vcs-Git: git://git.kitenet.net/propellor Vcs-Git: git://git.kitenet.net/propellor
@ -28,6 +30,8 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-unix-compat-dev, libghc-unix-compat-dev,
libghc-ansi-terminal-dev, libghc-ansi-terminal-dev,
libghc-ifelse-dev, libghc-ifelse-dev,
libghc-mtl-dev,
libghc-monadcatchio-transformers-dev,
git, git,
Description: property-based host configuration management in haskell Description: property-based host configuration management in haskell
Propellor enures that the system it's run in satisfies a list of Propellor enures that the system it's run in satisfies a list of

View File

@ -1,22 +1,25 @@
-----BEGIN PGP MESSAGE----- -----BEGIN PGP MESSAGE-----
Version: GnuPG v1 Version: GnuPG v1
hQIMA7ODiaEXBlRZAQ//fmOcGRNxe/ooyFebOl54oFJtUvmWclBN8ycWb+1FEiED hQIMA7ODiaEXBlRZARAAuRttWmrr3tFgQnbnaQpWxiAQToL94e0SctFiYqiEGRNa
4293/YYL13OXStSDCMc1o0Rq6SxRpkD/xavcc2wqBa4rTEvOzU/YdhXRLOCr2QwQ D63/ZaBhBkvKSx57+SyOloqfBaeWM63vd4Yacocypl2zOjC4aEN7/MKyQRl+xhmk
Mhn4vtLmQqaQwYz5tzPkfRwtB/Wx/R4dJBfNF5vp+nl788fF+cdgLLSihY+TEPSk EwQ4kFfJ3dmYrgXt7NAdIarjHsK5/Bv7PGVIrcwD3zqV+FUyuxt2L2ETG61kYo+m
+Wo2PZ0jNvCSpVR99Rh3o3ut57shsVGGa4Z4uaXfLVOu118Z00iyKZ9pHFa7gLH4 xNWl1NCvHDZ1QOfvw4ldBo7+LO2odzoZAxBF0ZgQFqo/r/6RZaqFNJRLdVTLERTq
nU1Y8N8JPg0Z+zJvTbJGU66k5LMZx9a/cu/+dwk2KPm3uldld4dwFk9zkmnzsIzS E4igjtgfq6blrpyeupKpFu6oy8/7WeBXthnyoduftk+aBTkXWzb+i30zIzNNsc4+
UhWWsuea4OGanjDsPZzECkLY/AOWxRL7+4qC6c9vsFagktJezRNqNImeSkYi9fR5 GE68a5tM0XE8nGwKp4yz0AZHhEYzv+BZXI7HQMAZ+m0srVn637SDHeAgOBU8NjrA
xw4VnhL5JwC2RF3gMC8XHYSx5C1ByGIq0gaklJjdPRn3Kj7/zSOefgNZC/O+wSfG SbZt0ubQ28Qaux7C7awLJ5SjvlQyLT61jLaN6SMcpeLmgkjRVN+eiVOE/qmXzhHv
V5W7kW7x6vvMv9og3k4BBpD4p2s94O8xtztLE+wOXxJclFen37FNhwuJyp7PiBN6 AobUwJgBOktiN6+WtRcxq7WduNf6Jtxw8UB5gVWiEeg6o+29ZBfIKVMT/Jly4rTO
T4PgekpqPfX9Xp4M1tgyUVV9m8Jeof0TtS/YsKeYqaGk1ZKPOJvqXnZTL5LOkaqE M13HbmSVzwdGcUL1D7Gf3oY2R7eS4VR8ShCQmF8aB8TXdsw4mo71HnUa7u5N4hCP
KTWYnWdBROwNXhsaIUnu8YHqf2mRA5VlCl1Uspd3SIyU1Xh0LL9stPnxdyJGghrG jLtJG24+f39TWWRjMQjtFXi5hkep4OG5CBViWdCWOjlfn4Kmr5zCXaunkO9cgDAd
RTmTJsEkzPAxnjSop72sEkKjqwkHxNbEkXg690QEPon+m/FAg083yTtKH/whbQ7S s8UZdmALu2MPoVdcVm+KLq2JQi1jBWEqRu5krx/nSi+eRRX2/y95CKPEPqZoU+rS
wFIBtEWDmBQyFmc1fvi1IouM9fUij6AwtJx2JrWE2d68BqE1moFGGiRSnf7itNc0 wM0BzlW+pEDc7aFlcYCrWTiwO0BWT2iBmbse9/r2NyJPpuFf7GOMI2v65jXQ+avy
YFashaGMSRZAzlx6quMJtg3sE/Xw4zra1b8SkvmH6FoQnQ2rXriG5U4Hc6bW0jIX 1r69zPdAXNgJ19Gid/q1CXCYnYLLVHqigd8XNs12ANaVvkOnBi3gAf309SIPJtCa
48O96/NbIwabZiwC5BKGmSPpQBDnyzruWR/Qsnw6uar5/ZKsIOvPhICCvChO03So uFVBxNasLTMQ3Ta7v7TLa0PopdBuFqfcy9d3BBiOKqokvhWFJobaG/WhF85ercRJ
6C6WLHFb9trLqpB+r8BOMjUG/FPqZ4lRanQ3Xn///lLD2uuhH27Pmt/XDpwRJgsz F8lse9fgo5xfrDoCFk7u9rzhHl8xKLl24thKFTDzwm+yuzXOoLq8+Km/xYuzQXZK
V+uM6TVQMBe5XyE3LOk7Yn0oosohYF0LFFzQH0mO5cykx+Ctjt1muxKoUmcN99ms JCjPvIUDaCCc1E/Yeoc3RafAiOuNwnjHW15TRdlohmgXzYlTCYF491WVKQfpL2Sd
j99fwMhrk1qlzlu2Yoe5caph4M44TXbQRGhPX7jXDJzYbRdS VO8Uar094M1d52Rv8/1HCTBKJ0hnK259l4dguzw4sl2BcrFPBz9SJ0f6V/eAHE0h
=GYf9 la5QtLdwDDRI2giMXKfmzRiRA/5kBW01YaK7tt0om6L7Ri4Rs3JAhVgjcWDtH6fI
w807PpsIHaK8r3yDJoeqUnDYOsImuNgdctQkeroPsFYmV3fu5Hb5tYDkKzm5lE0z
C6mz09PD0M5hsnqmZXaw
=UFa1
-----END PGP MESSAGE----- -----END PGP MESSAGE-----

View File

@ -0,0 +1,19 @@
-----BEGIN PGP MESSAGE-----
Version: GnuPG v1
hQIMA7ODiaEXBlRZAQ//Qsi46/S4X9qWNSCqFUuUOdoKnuOro0SIKfR19Z0SlseL
AH5cPWUX2eIFA3tzku5Psm8enxGc2jyMhfS5KQkVMLoV/SdgLTEfbsF2TkOGUIFf
AMEt+HOPercftwzU+KnwyNJ6kfCinlgmehLwAHLvD8HfzsL9lD59dJGkYQ61cDZ8
NQSOJwbLVzlXGoMjUcQ6ihmg7gOEGptO7F+p4oamOYwpzibaFGX2BsczMRDcjlGY
B+ufxINqj2bV17lHchNs/Je8uF5Owe+5zoK2cf6TTCdtlIcWjuw6YIMUPWHhIx3C
DCrEFS/rOJCyY+M8CwIfqS0JTJVNIKJfhP8LbbaoyRyXB2XF2eLM1bQ25p//fpav
+MRQ/0SqnGXYV7ZQE/a+/dESi8/u2yua1m1DBwXzAp468pCTaZCm9gwV+D9Ggsbr
uCU5K/cTa7wPyzfYtki0jkM+R1uk1HqWuHHt0/CD1VnDM3Zrj2JVkoE+pR1LhiSH
qKj8/zF935QmGrCUUjo+1bBn20BDiiFPiiPo4KN3At2uK4qQo1F0c+JUQUHGKV9r
O/c4v0dhPj/Qq5kSp5higO8n2Afv68wAfCWBkBo6SpCS7nuR7xvLWD7pWBTS/0BG
BcL4recUTckQHPo+VUNMYlSNeUhnlv/2TK7/qsfPMYTi0Xu/Fr+bnKn3QOPbgITS
cgHrplzueGhsVhhy+Cpn31FptA7txwcAWuWcZmT7ych0APt/PdkZ1CdeQ3gQop0p
BXaUlY7N4PacFyrC8Jha4p8THbbmfg6zTwaPggH8HonOIL5iA2yZz78uvZwqUd5i
QD0LMQZ3ZgNiqlwLxA8e6heSNA==
=V6He
-----END PGP MESSAGE-----

View File

@ -1,5 +1,5 @@
Name: propellor Name: propellor
Version: 0.2.3 Version: 0.3.0
Cabal-Version: >= 1.6 Cabal-Version: >= 1.6
License: GPL License: GPL
Maintainer: Joey Hess <joey@kitenet.net> Maintainer: Joey Hess <joey@kitenet.net>
@ -38,7 +38,8 @@ Executable propellor
GHC-Options: -Wall GHC-Options: -Wall
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async containers, network, async, time, QuickCheck, mtl,
MonadCatchIO-transformers
if (! os(windows)) if (! os(windows))
Build-Depends: unix Build-Depends: unix
@ -48,7 +49,8 @@ Executable config
GHC-Options: -Wall -threaded GHC-Options: -Wall -threaded
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async containers, network, async, time, QuickCheck, mtl,
MonadCatchIO-transformers
if (! os(windows)) if (! os(windows))
Build-Depends: unix Build-Depends: unix
@ -57,7 +59,8 @@ Library
GHC-Options: -Wall GHC-Options: -Wall
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async containers, network, async, time, QuickCheck, mtl,
MonadCatchIO-transformers
if (! os(windows)) if (! os(windows))
Build-Depends: unix Build-Depends: unix
@ -69,10 +72,15 @@ Library
Propellor.Property.Cmd Propellor.Property.Cmd
Propellor.Property.Hostname Propellor.Property.Hostname
Propellor.Property.Cron Propellor.Property.Cron
Propellor.Property.Dns
Propellor.Property.Docker Propellor.Property.Docker
Propellor.Property.File Propellor.Property.File
Propellor.Property.Git
Propellor.Property.Network Propellor.Property.Network
Propellor.Property.OpenId
Propellor.Property.Reboot Propellor.Property.Reboot
Propellor.Property.Scheduled
Propellor.Property.Service
Propellor.Property.Ssh Propellor.Property.Ssh
Propellor.Property.Sudo Propellor.Property.Sudo
Propellor.Property.Tor Propellor.Property.Tor
@ -80,11 +88,14 @@ Library
Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.JoeySites
Propellor.Property.SiteSpecific.GitAnnexBuilder Propellor.Property.SiteSpecific.GitAnnexBuilder
Propellor.Attr
Propellor.Message Propellor.Message
Propellor.PrivData Propellor.PrivData
Propellor.Engine Propellor.Engine
Propellor.Exception
Propellor.Types Propellor.Types
Other-Modules: Other-Modules:
Propellor.Types.Attr
Propellor.CmdLine Propellor.CmdLine
Propellor.SimpleSh Propellor.SimpleSh
Propellor.Property.Docker.Shim Propellor.Property.Docker.Shim
@ -103,9 +114,11 @@ Library
Utility.PosixFiles Utility.PosixFiles
Utility.Process Utility.Process
Utility.SafeCommand Utility.SafeCommand
Utility.Scheduled
Utility.ThreadScheduler Utility.ThreadScheduler
Utility.Tmp Utility.Tmp
Utility.UserInfo Utility.UserInfo
Utility.QuickCheck
source-repository head source-repository head
type: git type: git