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

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 Utility.FileMode
import Utility.SafeCommand
import Utility.UserInfo
usage :: IO a
usage = do
@ -54,8 +55,8 @@ processCmdLine = go =<< getArgs
else return $ Run s
go _ = usage
defaultMain :: [HostName -> Maybe [Property]] -> IO ()
defaultMain getprops = do
defaultMain :: [Host] -> IO ()
defaultMain hostlist = do
DockerShim.cleanEnv
checkDebugMode
cmdline <- processCmdLine
@ -63,23 +64,26 @@ defaultMain getprops = do
go True cmdline
where
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 _ (Chain host) = withprops host $ \ps -> do
r <- ensureProperties' ps
go _ (Chain hn) = withprops hn $ \attr ps -> do
r <- runPropellor attr $ ensureProperties ps
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 = updateFirst cmdline $ go False cmdline
go False (Spin host) = withprops host $ const $ spin host
go False (Run host) = ifM ((==) 0 <$> getRealUserID)
( onlyProcess $ withprops host ensureProperties
, go True (Spin host)
go False (Spin hn) = withprops hn $ const . const $ spin hn
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyProcess $ withprops hn mainProperties
, 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 $
headMaybe $ catMaybes $ map (\get -> get host) getprops
withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
withprops hn a = maybe
(unknownhost hn)
(\h -> a (hostAttr h) (hostProperties h))
(findHost hostlist hn)
onlyProcess :: IO a -> IO a
onlyProcess a = bracket lock unlock (const a)
@ -95,7 +99,7 @@ onlyProcess a = bracket lock unlock (const a)
unknownhost :: HostName -> IO a
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?)"
, "(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]
spin :: HostName -> IO ()
spin host = do
spin hn = do
url <- getUrl
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
void $ boolSystem "git" [Param "push"]
go url =<< gpgDecrypt (privDataFile host)
cacheparams <- toCommand <$> sshCachingParams hn
go cacheparams url =<< gpgDecrypt (privDataFile hn)
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
senddata toh (privDataFile host) privDataMarker privdata
senddata toh (privDataFile hn) privDataMarker privdata
hClose toh
-- Display remaining output.
@ -184,21 +189,21 @@ spin host = do
NeedGitClone -> do
hClose toh
hClose fromh
sendGitClone host url
go url privdata
sendGitClone hn url
go cacheparams url privdata
user = "root@"++host
user = "root@"++hn
bootstrapcmd = shellWrap $ intercalate " ; "
[ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && "
[ "apt-get -y install git"
[ "apt-get --no-install-recommends --no-upgrade -y install git make"
, "echo " ++ toMarked statusMarker (show NeedGitClone)
]
, "else " ++ intercalate " && "
[ "cd " ++ localdir
, "if ! test -x ./propellor; then make build; fi"
, "./propellor --boot " ++ host
, "if ! test -x ./propellor; then make deps build; fi"
, "./propellor --boot " ++ hn
]
, "fi"
]
@ -214,19 +219,18 @@ spin host = do
showremote s = putStrLn s
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
return True
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
cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id
-- TODO: ssh connection caching, or better push method
-- with less connections.
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
, boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)]
, boolSystem "ssh" [Param ("root@"++host), Param $ unpackcmd branch]
, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
]
where
remotebundle = "/usr/local/propellor.git"
@ -274,15 +278,15 @@ fromMarked marker s
len = length marker
matches = filter (marker `isPrefixOf`) $ lines s
boot :: [Property] -> IO ()
boot ps = do
boot :: Attr -> [Property] -> IO ()
boot attr ps = do
sendMarked stdout statusMarker $ show Ready
reply <- hGetContentsStrict stdin
makePrivDataDir
maybe noop (writeFileProtected privDataLocal) $
fromMarked privDataMarker reply
ensureProperties ps
mainProperties attr ps
addKey :: String -> IO ()
addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
@ -341,3 +345,15 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
updateGlobalLogger rootLoggerName $
setLevel DEBUG . setHandlers [f]
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
import System.Exit
import System.IO
import Data.Monoid
import System.Console.ANSI
import "mtl" Control.Monad.Reader
import Propellor.Types
import Propellor.Message
import Utility.Exception
import Propellor.Exception
ensureProperty :: Property -> IO Result
ensureProperty = catchDefaultIO FailedChange . propertySatisfy
runPropellor :: Attr -> Propellor a -> IO a
runPropellor attr a = runReaderT (runWithAttr a) attr
ensureProperties :: [Property] -> IO ()
ensureProperties ps = do
r <- ensureProperties' [Property "overall" $ ensureProperties' ps]
mainProperties :: Attr -> [Property] -> IO ()
mainProperties attr ps = do
r <- runPropellor attr $
ensureProperties [Property "overall" $ ensureProperties ps]
setTitle "propellor: done"
hFlush stdout
case r of
FailedChange -> exitWith (ExitFailure 1)
_ -> exitWith ExitSuccess
ensureProperties' :: [Property] -> IO Result
ensureProperties' ps = ensure ps NoChange
ensureProperties :: [Property] -> Propellor Result
ensureProperties ps = ensure ps NoChange
where
ensure [] rs = return rs
ensure (l:ls) rs = do
r <- actionMessage (propertyDesc l) (ensureProperty l)
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
import System.Console.ANSI
import System.IO
import System.Log.Logger
import "mtl" Control.Monad.Reader
import Propellor.Types
-- | Shows a message while performing an action, with a colored status
-- display.
actionMessage :: ActionResult r => Desc -> IO r -> IO r
actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r
actionMessage desc a = do
liftIO $ do
setTitle $ "propellor: " ++ desc
hFlush stdout
r <- a
liftIO $ do
setTitle "propellor: running"
let (msg, intensity, color) = getActionResult r
putStr $ desc ++ " ... "
@ -23,8 +28,8 @@ actionMessage desc a = do
return r
warningMessage :: String -> IO ()
warningMessage s = colorLine Vivid Red $ "** warning: " ++ s
warningMessage :: MonadIO m => String -> m ()
warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s
colorLine :: ColorIntensity -> Color -> String -> IO ()
colorLine intensity color msg = do

View File

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

View File

@ -1,17 +1,22 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Property where
import System.Directory
import Control.Monad
import Data.Monoid
import Control.Monad.IfElse
import "mtl" Control.Monad.Reader
import Propellor.Types
import Propellor.Types.Attr
import Propellor.Engine
import Utility.Monad
makeChange :: IO () -> IO Result
makeChange a = a >> return MadeChange
makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange
noChange :: IO Result
noChange :: Propellor Result
noChange = return NoChange
-- | 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
-- on failure; does propigate overall success/failure.
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
-- ensures each in turn, stopping on failure.
@ -33,17 +38,28 @@ combineProperties desc ps = Property desc $ go ps NoChange
FailedChange -> return FailedChange
_ -> go ls (r <> rs)
-- | Combines together two properties, resulting in one property
-- that ensures the first, and if the first succeeds, ensures the second.
-- The property uses the description of the first property.
before :: Property -> Property -> Property
p1 `before` p2 = 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
-- file to indicate whether it has run before.
-- Use with caution.
flagFile :: Property -> FilePath -> Property
flagFile property flagfile = Property (propertyDesc property) $
go =<< doesFileExist flagfile
go =<< liftIO (doesFileExist flagfile)
where
go True = return NoChange
go False = do
r <- ensureProperty property
when (r == MadeChange) $
when (r == MadeChange) $ liftIO $
unlessM (doesFileExist flagfile) $
writeFile flagfile ""
return r
@ -64,13 +80,13 @@ infixl 1 ==>
-- | Makes a Property only be performed when a test succeeds.
check :: IO Bool -> Property -> Property
check c property = Property (propertyDesc property) $ ifM c
check c property = Property (propertyDesc property) $ ifM (liftIO c)
( ensureProperty property
, return NoChange
)
boolProperty :: Desc -> IO Bool -> Property
boolProperty desc a = Property desc $ ifM a
boolProperty desc a = Property desc $ ifM (liftIO a)
( return MadeChange
, return FailedChange
)
@ -79,17 +95,26 @@ boolProperty desc a = Property desc $ ifM a
revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
-- | Starts a list of Properties
props :: [Property]
props = []
-- | Starts accumulating the properties of a Host.
--
-- > 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 &
-- | Adds a property to the list in reverted form.
(!) :: [Property] -> RevertableProperty -> [Property]
ps ! p = ps ++ [toProp $ revert p]
-- | Adds a property to the Host in reverted form.
(!) :: Host -> RevertableProperty -> Host
(Host ps as) ! p = Host (ps ++ [toProp q]) (getAttr q . as)
where
q = revert p
infixl 1 !

View File

@ -8,6 +8,7 @@ import Control.Monad
import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import Propellor.Property.File (Line)
sourcesList :: FilePath
@ -46,13 +47,22 @@ debCdn = binandsrc "http://cdn.debian.net/debian"
kernelOrg :: DebianSuite -> [Line]
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,
-- with a particular DebianSuite.
--
-- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org.
stdSourcesList :: DebianSuite -> Property
stdSourcesList suite = setSourcesList (debCdn suite ++ kernelOrg suite)
stdSourcesList suite = setSourcesList
(debCdn suite ++ kernelOrg suite ++ securityUpdates suite)
`describe` ("standard sources.list for " ++ show suite)
setSourcesList :: [Line] -> Property
@ -147,9 +157,12 @@ autoRemove = runApt ["-y", "autoremove"]
-- | Enables unattended upgrades. Revert to disable.
unattendedUpgrades :: RevertableProperty
unattendedUpgrades = RevertableProperty (go True) (go False)
unattendedUpgrades = RevertableProperty enable disable
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"
[("unattended-upgrades/enable_auto_updates" , "boolean", v)]
`describe` ("unattended upgrades " ++ v)
@ -167,7 +180,14 @@ reConfigure package vals = reconfigure `requires` setselections
setselections = Property "preseed" $ makeChange $
withHandle StdinHandle createProcessSuccess
(proc "debconf-set-selections" []) $ \h -> do
forM_ vals $ \(template, tmpltype, value) ->
hPutStrLn h $ unwords [package, template, tmpltype, value]
forM_ vals $ \(tmpl, tmpltype, value) ->
hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
hClose h
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 (
cmdProperty,
cmdProperty',
scriptProperty,
userScriptProperty,
serviceRunning,
) where
import Control.Monad
import Control.Applicative
import Data.List
import "mtl" Control.Monad.Reader
import Propellor.Types
import Propellor.Engine
import Utility.Monad
import Utility.SafeCommand
import Utility.Env
@ -25,7 +25,7 @@ cmdProperty cmd params = cmdProperty' cmd params []
-- | A property that can be satisfied by running a command,
-- with added environment.
cmdProperty' :: String -> [String] -> [(String, String)] -> Property
cmdProperty' cmd params env = Property desc $ do
cmdProperty' cmd params env = Property desc $ liftIO $ do
env' <- addEntries env <$> getEnvironment
ifM (boolSystemEnv cmd (map Param params) (Just env'))
( return MadeChange
@ -46,14 +46,3 @@ userScriptProperty :: UserName -> [String] -> Property
userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]
where
shellcmd = intercalate " ; " ("set -e" : "cd" : script)
-- | Ensures that a service is running.
--
-- Note that due to the general poor state of init scripts, the best
-- we can do is try to start the service, and if it fails, assume
-- this means it's already running.
serviceRunning :: String -> Property
serviceRunning svc = Property ("running " ++ svc) $ do
void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]
return NoChange

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

View File

@ -20,6 +20,7 @@ ipv6to4 = fileProperty "ipv6to4" go interfaces
, "\taddress 2002:5044:5531::1"
, "\tnetmask 64"
, "\tgateway ::192.88.99.1"
, "auto sit0"
, "# 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.installed ["git", "rsync", "moreutils", "ca-certificates",
"liblockfile-simple-perl", "cabal-install", "vim", "less"]
, serviceRunning "cron" `requires` Apt.installed ["cron"]
, Apt.serviceInstalledRunning "cron"
, User.accountFor builduser
, check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser
[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
@ -44,12 +44,13 @@ builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"
let f = homedir </> "rsyncpassword"
if rsyncupload
then withPrivData (Password builduser) $ \p -> do
oldp <- catchDefaultIO "" $ readFileStrict f
oldp <- liftIO $ catchDefaultIO "" $
readFileStrict f
if p /= oldp
then makeChange $ writeFile f p
else noChange
else do
ifM (doesFileExist f)
ifM (liftIO $ doesFileExist f)
( noChange
, 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.
installedFor :: UserName -> Property
installedFor user = check (not <$> hasGitDir user) $
Property ("githome " ++ user) (go =<< homedir user)
`requires` Apt.installed ["git", "myrepos"]
Property ("githome " ++ user) (go =<< liftIO (homedir user))
`requires` Apt.installed ["git"]
where
go Nothing = noChange
go (Just home) = do
@ -20,7 +20,7 @@ installedFor user = check (not <$> hasGitDir user) $
moveout tmpdir home
, Property "rmdir" $ makeChange $ void $
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
fs <- dirContents tmpdir

View File

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

View File

@ -53,7 +53,7 @@ uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restartSshd
where
prop = Property "ssh unique host keys" $ do
void $ boolSystem "sh"
void $ liftIO $ boolSystem "sh"
[ Param "-c"
, 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"]
where
go = do
locked <- isLockedPassword user
locked <- liftIO $ isLockedPassword user
ensureProperty $
fileProperty desc
(modify locked . filter (wanted locked))

View File

@ -27,7 +27,7 @@ simpleSh namedpipe = do
createDirectoryIfMissing True dir
modifyFileMode dir (removeModes otherGroupModes)
s <- socket AF_UNIX Stream defaultProtocol
bind s (SockAddrUnix namedpipe)
bindSocket s (SockAddrUnix namedpipe)
listen s 2
forever $ do
(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 Control.Applicative
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 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
{ propertyDesc :: Desc
-- | must be idempotent; may run repeatedly
, propertySatisfy :: IO Result
, propertySatisfy :: Propellor Result
}
-- | A property that can be reverted.
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
-- | Sets description.
describe :: p -> Desc -> p
@ -21,6 +76,7 @@ class IsProp p where
-- | Indicates that the first property can only be satisfied
-- once the second one is.
requires :: p -> Property -> p
getAttr :: p -> (Attr -> Attr)
instance IsProp Property where
describe p d = p { propertyDesc = d }
@ -30,6 +86,7 @@ instance IsProp Property where
case r of
FailedChange -> return FailedChange
_ -> propertySatisfy x
getAttr _ = id
instance IsProp RevertableProperty where
-- | Sets the description of both sides.
@ -38,6 +95,13 @@ instance IsProp RevertableProperty where
toProp (RevertableProperty p1 _) = p1
(RevertableProperty p1 p2) `requires` y =
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
@ -63,7 +127,7 @@ data Distribution
deriving (Show)
data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release
deriving (Show)
deriving (Show, Eq)
type Release = String
@ -100,6 +164,7 @@ data PrivDataField
= DockerAuthentication
| SshPrivKey UserName
| Password UserName
| PrivFile FilePath
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,
but only once despite many config changes being made to satisfy
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.
One way to improve that would be to parameterize Properties with a
Distribution witness.
This could be improved by making the Distribution of the system part
of its HostAttr.
* Display of docker container properties is a bit wonky. It always
says they are unchanged even when they changed and triggered a
reprovision.
* Should properties be a tree rather than a list?
* Only make docker garbage collection run once a day or something
to avoid GC after a temp fail.
* Need a way for a dns server host to look at the properties of
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.CmdLine
import Propellor.Property.Scheduled
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
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.Reboot as Reboot
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.Git as Git
import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
import Data.List
main :: IO ()
main = defaultMain [host, Docker.containerProperties container]
hosts :: [Host]
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
-- or one specified on the command line, is converted into a list of
-- Properties for that system.
--
-- Edit this to configure propellor!
host :: HostName -> Maybe [Property]
-- Clam is a tor bridge, and an olduse.net shellbox and other fun stuff.
host hostname@"clam.kitenet.net" = standardSystem Unstable $ props
& cleanCloudAtCost hostname
-- Nothing super-important lives here.
, standardSystem "clam.kitenet.net" Unstable
& cleanCloudAtCost
& Apt.unattendedUpgrades
& Network.ipv6to4
& Apt.installed ["git-annex", "mtr"]
& Tor.isBridge
& JoeySites.oldUseNetshellBox
& Docker.configured
& Docker.garbageCollected
-- Orca is the main git-annex build box.
host hostname@"orca.kitenet.net" = standardSystem Unstable $ props
& Hostname.set hostname
& cname "shell.olduse.net"
& JoeySites.oldUseNetShellBox
& 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
& Docker.configured
& Apt.buildDep ["git-annex"]
& Docker.docked container hostname "amd64-git-annex-builder"
& Docker.docked container hostname "i386-git-annex-builder"
& Docker.docked container hostname "armel-git-annex-builder-companion"
& Docker.docked container hostname "armel-git-annex-builder"
& Docker.garbageCollected
-- My laptop
host _hostname@"darkstar.kitenet.net" = Just $ props
& Docker.configured
& Docker.docked hosts "amd64-git-annex-builder"
& Docker.docked hosts "i386-git-annex-builder"
! Docker.docked hosts "armel-git-annex-builder-companion"
! Docker.docked hosts "armel-git-annex-builder"
& Docker.garbageCollected `period` Daily
& Apt.buildDep ["git-annex"] `period` Daily
-- add more hosts here...
--host "foo.example.com" =
host _ = Nothing
-- Important stuff that needs not too much memory or CPU.
, standardSystem "diatom.kitenet.net" Stable
& 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.
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"]
]
--------------------------------------------------------------------
-- Docker Containers ----------------------------------- \o/ -----
--------------------------------------------------------------------
-- 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
-- runs the build first to get TH splices. They share a home
-- directory, and need to have the same versions of all haskell
-- libraries installed.
| name == "armel-git-annex-builder-companion" = Just $ Docker.containerFrom
, Docker.container "armel-git-annex-builder-companion"
(image $ System (Debian Unstable) "amd64")
[ Docker.volume GitAnnexBuilder.homedir
]
| name == "armel-git-annex-builder" = Just $ Docker.containerFrom
& Docker.volume GitAnnexBuilder.homedir
& Apt.unattendedUpgrades
, Docker.container "armel-git-annex-builder"
(image $ System (Debian Unstable) "armel")
[ Docker.link (name ++ "-companion") "companion"
, Docker.volumes_from (name ++ "-companion")
, Docker.inside $ props
& Docker.link "armel-git-annex-builder-companion" "companion"
& Docker.volumes_from "armel-git-annex-builder-companion"
-- & GitAnnexBuilder.builder "armel" "15 * * * *" True
& Apt.unattendedUpgrades
]
| "-git-annex-builder" `isSuffixOf` name =
let arch = takeWhile (/= '-') name
in Just $ Docker.containerFrom
gitAnnexBuilder :: Architecture -> Int -> Host
gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder")
(image $ System (Debian Unstable) arch)
[ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" True ]
& GitAnnexBuilder.builder arch (show buildminute ++ " * * * *") True
& Apt.unattendedUpgrades
| otherwise = Nothing
-- | Docker images I prefer to use.
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
-- This is my standard system setup.
standardSystem :: HostName -> DebianSuite -> Host
standardSystem hn suite = host hn
& Apt.stdSourcesList suite `onChange` Apt.upgrade
& Apt.installed ["etckeeper"]
& Apt.installed ["ssh"]
@ -122,14 +155,25 @@ standardSystem suite customprops = Just $
-- I use postfix, or no MTA.
& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
`onChange` Apt.autoRemove
-- May reboot, so comes last
-- Currently not enable due to #726375
endprops = [] -- [Apt.installed ["systemd-sysv"] `onChange` Reboot.now]
-- This is my standard container setup, featuring automatic upgrades.
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
cleanCloudAtCost :: HostName -> Property
cleanCloudAtCost hostname = propertyList "cloudatcost cleanup"
[ Hostname.set hostname
cleanCloudAtCost :: Property
cleanCloudAtCost = propertyList "cloudatcost cleanup"
[ Hostname.sane
, Ssh.uniqueHostKeys
, "worked around grub/lvm boot bug #743126" ==>
"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
@ -141,3 +185,18 @@ cleanCloudAtCost hostname = propertyList "cloudatcost cleanup"
, 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.CmdLine
import Propellor.Property.Scheduled
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
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.Docker as Docker
main :: IO ()
main = defaultMain [host, Docker.containerProperties container]
-- | This is where the system's HostName, either as returned by uname
-- or one specified on the command line, is converted into a list of
-- Properties for that system.
--
-- The hosts propellor knows about.
-- Edit this to configure propellor!
host :: HostName -> Maybe [Property]
host hostname@"mybox.example.com" = Just $ props
hosts :: [Host]
hosts =
[ host "mybox.example.com"
& Apt.stdSourcesList Unstable
`onChange` Apt.upgrade
& Apt.unattendedUpgrades
@ -33,21 +29,19 @@ host hostname@"mybox.example.com" = Just $ props
& User.hasSomePassword "root"
& Network.ipv6to4
& File.dirExists "/var/www"
& Docker.docked container hostname "webserver"
& Docker.garbageCollected
& Docker.docked hosts "webserver"
& Docker.garbageCollected `period` Daily
& Cron.runPropellor "30 * * * *"
-- add more hosts here...
--host "foo.example.com" =
host _ = Nothing
-- | This is where Docker containers are set up. A container
-- can vary by hostname where it's used, or be the same everywhere.
container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"
[ Docker.publish "80:80"
, Docker.volume "/var/www:/var/www"
, Docker.inside $ props
& serviceRunning "apache2"
`requires` Apt.installed ["apache2"]
-- A generic webserver in a Docker container.
, Docker.container "webserver" "joeyh/debian-unstable"
& Docker.publish "80:80"
& Docker.volume "/var/www:/var/www"
& Apt.serviceInstalledRunning "apache2"
-- add more hosts here...
--, host "foo.example.com" = ...
]
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
* 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-ansi-terminal-dev,
libghc-ifelse-dev,
libghc-mtl-dev,
libghc-monadcatchio-transformers-dev,
Maintainer: Joey Hess <joeyh@debian.org>
Standards-Version: 3.9.5
Vcs-Git: git://git.kitenet.net/propellor
@ -28,6 +30,8 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-unix-compat-dev,
libghc-ansi-terminal-dev,
libghc-ifelse-dev,
libghc-mtl-dev,
libghc-monadcatchio-transformers-dev,
git,
Description: property-based host configuration management in haskell
Propellor enures that the system it's run in satisfies a list of

View File

@ -1,22 +1,25 @@
-----BEGIN PGP MESSAGE-----
Version: GnuPG v1
hQIMA7ODiaEXBlRZAQ//fmOcGRNxe/ooyFebOl54oFJtUvmWclBN8ycWb+1FEiED
4293/YYL13OXStSDCMc1o0Rq6SxRpkD/xavcc2wqBa4rTEvOzU/YdhXRLOCr2QwQ
Mhn4vtLmQqaQwYz5tzPkfRwtB/Wx/R4dJBfNF5vp+nl788fF+cdgLLSihY+TEPSk
+Wo2PZ0jNvCSpVR99Rh3o3ut57shsVGGa4Z4uaXfLVOu118Z00iyKZ9pHFa7gLH4
nU1Y8N8JPg0Z+zJvTbJGU66k5LMZx9a/cu/+dwk2KPm3uldld4dwFk9zkmnzsIzS
UhWWsuea4OGanjDsPZzECkLY/AOWxRL7+4qC6c9vsFagktJezRNqNImeSkYi9fR5
xw4VnhL5JwC2RF3gMC8XHYSx5C1ByGIq0gaklJjdPRn3Kj7/zSOefgNZC/O+wSfG
V5W7kW7x6vvMv9og3k4BBpD4p2s94O8xtztLE+wOXxJclFen37FNhwuJyp7PiBN6
T4PgekpqPfX9Xp4M1tgyUVV9m8Jeof0TtS/YsKeYqaGk1ZKPOJvqXnZTL5LOkaqE
KTWYnWdBROwNXhsaIUnu8YHqf2mRA5VlCl1Uspd3SIyU1Xh0LL9stPnxdyJGghrG
RTmTJsEkzPAxnjSop72sEkKjqwkHxNbEkXg690QEPon+m/FAg083yTtKH/whbQ7S
wFIBtEWDmBQyFmc1fvi1IouM9fUij6AwtJx2JrWE2d68BqE1moFGGiRSnf7itNc0
YFashaGMSRZAzlx6quMJtg3sE/Xw4zra1b8SkvmH6FoQnQ2rXriG5U4Hc6bW0jIX
48O96/NbIwabZiwC5BKGmSPpQBDnyzruWR/Qsnw6uar5/ZKsIOvPhICCvChO03So
6C6WLHFb9trLqpB+r8BOMjUG/FPqZ4lRanQ3Xn///lLD2uuhH27Pmt/XDpwRJgsz
V+uM6TVQMBe5XyE3LOk7Yn0oosohYF0LFFzQH0mO5cykx+Ctjt1muxKoUmcN99ms
j99fwMhrk1qlzlu2Yoe5caph4M44TXbQRGhPX7jXDJzYbRdS
=GYf9
hQIMA7ODiaEXBlRZARAAuRttWmrr3tFgQnbnaQpWxiAQToL94e0SctFiYqiEGRNa
D63/ZaBhBkvKSx57+SyOloqfBaeWM63vd4Yacocypl2zOjC4aEN7/MKyQRl+xhmk
EwQ4kFfJ3dmYrgXt7NAdIarjHsK5/Bv7PGVIrcwD3zqV+FUyuxt2L2ETG61kYo+m
xNWl1NCvHDZ1QOfvw4ldBo7+LO2odzoZAxBF0ZgQFqo/r/6RZaqFNJRLdVTLERTq
E4igjtgfq6blrpyeupKpFu6oy8/7WeBXthnyoduftk+aBTkXWzb+i30zIzNNsc4+
GE68a5tM0XE8nGwKp4yz0AZHhEYzv+BZXI7HQMAZ+m0srVn637SDHeAgOBU8NjrA
SbZt0ubQ28Qaux7C7awLJ5SjvlQyLT61jLaN6SMcpeLmgkjRVN+eiVOE/qmXzhHv
AobUwJgBOktiN6+WtRcxq7WduNf6Jtxw8UB5gVWiEeg6o+29ZBfIKVMT/Jly4rTO
M13HbmSVzwdGcUL1D7Gf3oY2R7eS4VR8ShCQmF8aB8TXdsw4mo71HnUa7u5N4hCP
jLtJG24+f39TWWRjMQjtFXi5hkep4OG5CBViWdCWOjlfn4Kmr5zCXaunkO9cgDAd
s8UZdmALu2MPoVdcVm+KLq2JQi1jBWEqRu5krx/nSi+eRRX2/y95CKPEPqZoU+rS
wM0BzlW+pEDc7aFlcYCrWTiwO0BWT2iBmbse9/r2NyJPpuFf7GOMI2v65jXQ+avy
1r69zPdAXNgJ19Gid/q1CXCYnYLLVHqigd8XNs12ANaVvkOnBi3gAf309SIPJtCa
uFVBxNasLTMQ3Ta7v7TLa0PopdBuFqfcy9d3BBiOKqokvhWFJobaG/WhF85ercRJ
F8lse9fgo5xfrDoCFk7u9rzhHl8xKLl24thKFTDzwm+yuzXOoLq8+Km/xYuzQXZK
JCjPvIUDaCCc1E/Yeoc3RafAiOuNwnjHW15TRdlohmgXzYlTCYF491WVKQfpL2Sd
VO8Uar094M1d52Rv8/1HCTBKJ0hnK259l4dguzw4sl2BcrFPBz9SJ0f6V/eAHE0h
la5QtLdwDDRI2giMXKfmzRiRA/5kBW01YaK7tt0om6L7Ri4Rs3JAhVgjcWDtH6fI
w807PpsIHaK8r3yDJoeqUnDYOsImuNgdctQkeroPsFYmV3fu5Hb5tYDkKzm5lE0z
C6mz09PD0M5hsnqmZXaw
=UFa1
-----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
Version: 0.2.3
Version: 0.3.0
Cabal-Version: >= 1.6
License: GPL
Maintainer: Joey Hess <joey@kitenet.net>
@ -38,7 +38,8 @@ Executable propellor
GHC-Options: -Wall
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async
containers, network, async, time, QuickCheck, mtl,
MonadCatchIO-transformers
if (! os(windows))
Build-Depends: unix
@ -48,7 +49,8 @@ Executable config
GHC-Options: -Wall -threaded
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async
containers, network, async, time, QuickCheck, mtl,
MonadCatchIO-transformers
if (! os(windows))
Build-Depends: unix
@ -57,7 +59,8 @@ Library
GHC-Options: -Wall
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async
containers, network, async, time, QuickCheck, mtl,
MonadCatchIO-transformers
if (! os(windows))
Build-Depends: unix
@ -69,10 +72,15 @@ Library
Propellor.Property.Cmd
Propellor.Property.Hostname
Propellor.Property.Cron
Propellor.Property.Dns
Propellor.Property.Docker
Propellor.Property.File
Propellor.Property.Git
Propellor.Property.Network
Propellor.Property.OpenId
Propellor.Property.Reboot
Propellor.Property.Scheduled
Propellor.Property.Service
Propellor.Property.Ssh
Propellor.Property.Sudo
Propellor.Property.Tor
@ -80,11 +88,14 @@ Library
Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites
Propellor.Property.SiteSpecific.GitAnnexBuilder
Propellor.Attr
Propellor.Message
Propellor.PrivData
Propellor.Engine
Propellor.Exception
Propellor.Types
Other-Modules:
Propellor.Types.Attr
Propellor.CmdLine
Propellor.SimpleSh
Propellor.Property.Docker.Shim
@ -103,9 +114,11 @@ Library
Utility.PosixFiles
Utility.Process
Utility.SafeCommand
Utility.Scheduled
Utility.ThreadScheduler
Utility.Tmp
Utility.UserInfo
Utility.QuickCheck
source-repository head
type: git