GADT properties seem to work (untested)

* Property has been converted to a GADT, and will be Property NoInfo
  or Property HasInfo.
  This was done to make sure that ensureProperty is only used on
  properties that do not have Info.
  Transition guide:
  - Change all "Property" to "Property NoInfo" or "Property WithInfo"
    (The compiler can tell you if you got it wrong!)
  - To construct a RevertableProperty, it is useful to use the new
    (<!>) operator
  - Constructing a list of properties can be problimatic, since
    Property NoInto and Property WithInfo are different types and cannot
    appear in the same list. To deal with this, "props" has been added,
    and can built up a list of properties of different types,
    using the same (&) and (!) operators that are used to build
    up a host's properties.
This commit is contained in:
Joey Hess 2015-01-24 22:38:10 -04:00
parent 141a7c028b
commit 0ee04ecc43
51 changed files with 726 additions and 628 deletions

View File

@ -438,13 +438,12 @@ dockerImage (System (Debian Testing) arch) = "joeyh/debian-unstable-" ++ arch
dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch
dockerImage _ = "debian-stable-official" -- does not currently exist! dockerImage _ = "debian-stable-official" -- does not currently exist!
myDnsSecondary :: Property myDnsSecondary :: Property HasInfo
myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp myDnsSecondary = propertyList "dns secondary for all my domains" $ props
[ Dns.secondary hosts "kitenet.net" & Dns.secondary hosts "kitenet.net"
, Dns.secondary hosts "joeyh.name" & Dns.secondary hosts "joeyh.name"
, Dns.secondary hosts "ikiwiki.info" & Dns.secondary hosts "ikiwiki.info"
, Dns.secondary hosts "olduse.net" & Dns.secondary hosts "olduse.net"
]
branchableSecondary :: RevertableProperty branchableSecondary :: RevertableProperty
branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com" branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com"

18
debian/changelog vendored
View File

@ -1,9 +1,23 @@
propellor (1.4.0) UNRELEASED; urgency=medium propellor (2.0.0) UNRELEASED; urgency=medium
* Property has been converted to a GADT, and will be Property NoInfo
or Property HasInfo.
This was done to make sure that ensureProperty is only used on
properties that do not have Info.
Transition guide:
- Change all "Property" to "Property NoInfo" or "Property WithInfo"
(The compiler can tell you if you got it wrong!)
- To construct a RevertableProperty, it is useful to use the new
(<!>) operator
- Constructing a list of properties can be problimatic, since
Property NoInto and Property WithInfo are different types and cannot
appear in the same list. To deal with this, "props" has been added,
and can built up a list of properties of different types,
using the same (&) and (!) operators that are used to build
up a host's properties.
* Add descriptions of how to set missing fields to --list-fields output. * Add descriptions of how to set missing fields to --list-fields output.
* Properties now form a tree, instead of the flat list used before. * Properties now form a tree, instead of the flat list used before.
This includes the properties used inside a container. This includes the properties used inside a container.
(API change)
* Fix info propigation from fallback combinator's second Property. * Fix info propigation from fallback combinator's second Property.
* Added systemd configuration properties. * Added systemd configuration properties.
* Added journald configuration properties. * Added journald configuration properties.

View File

@ -1,3 +1,5 @@
> Now [[fixed|done]]!! --[[Joey]]
Currently, Info about a Host's Properties is manually gathered and Currently, Info about a Host's Properties is manually gathered and
propigated. propertyList combines the Info of the Properties in the list. propigated. propertyList combines the Info of the Properties in the list.
Docker.docked extracts relevant Info from the Properties of the container Docker.docked extracts relevant Info from the Properties of the container

View File

@ -95,6 +95,7 @@ Library
Propellor.Property.Postfix Propellor.Property.Postfix
Propellor.Property.Prosody Propellor.Property.Prosody
Propellor.Property.Reboot Propellor.Property.Reboot
Propellor.Property.List
Propellor.Property.Scheduled Propellor.Property.Scheduled
Propellor.Property.Service Propellor.Property.Service
Propellor.Property.Ssh Propellor.Property.Ssh

View File

@ -32,6 +32,7 @@
module Propellor ( module Propellor (
module Propellor.Types module Propellor.Types
, module Propellor.Property , module Propellor.Property
, module Propellor.Property.List
, module Propellor.Property.Cmd , module Propellor.Property.Cmd
, module Propellor.PropAccum , module Propellor.PropAccum
, module Propellor.Info , module Propellor.Info
@ -48,6 +49,7 @@ module Propellor (
import Propellor.Types import Propellor.Types
import Propellor.Property import Propellor.Property
import Propellor.Engine import Propellor.Engine
import Propellor.Property.List
import Propellor.Property.Cmd import Propellor.Property.Cmd
import Propellor.PrivData import Propellor.PrivData
import Propellor.Types.PrivData import Propellor.Types.PrivData

View File

@ -36,7 +36,7 @@ import Utility.Monad
mainProperties :: Host -> IO () mainProperties :: Host -> IO ()
mainProperties host = do mainProperties host = do
ret <- runPropellor host $ ret <- runPropellor host $
ensureProperties [mkProperty "overall" (ensureProperties ps) mempty mempty] ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
h <- mkMessageHandle h <- mkMessageHandle
whenConsole h $ whenConsole h $
setTitle "propellor: done" setTitle "propellor: done"

View File

@ -13,7 +13,7 @@ import Data.Monoid
import Control.Applicative import Control.Applicative
pureInfoProperty :: Desc -> Info -> Property HasInfo pureInfoProperty :: Desc -> Info -> Property HasInfo
pureInfoProperty desc i = mkProperty ("has " ++ desc) (return NoChange) i mempty pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
askInfo :: (Info -> Val a) -> Propellor (Maybe a) askInfo :: (Info -> Val a) -> Propellor (Maybe a)
askInfo f = asks (fromVal . f . hostInfo) askInfo f = asks (fromVal . f . hostInfo)

View File

@ -1,4 +1,5 @@
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
module Propellor.PrivData ( module Propellor.PrivData (
withPrivData, withPrivData,
@ -60,29 +61,29 @@ import Utility.Table
-- being used, which is necessary to ensure that the privdata is sent to -- being used, which is necessary to ensure that the privdata is sent to
-- the remote host by propellor. -- the remote host by propellor.
withPrivData withPrivData
:: (IsContext c, IsPrivDataSource s) :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> s => s
-> c -> c
-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property) -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i)
-> Property -> Property HasInfo
withPrivData s = withPrivData' snd [s] withPrivData s = withPrivData' snd [s]
-- Like withPrivData, but here any one of a list of PrivDataFields can be used. -- Like withPrivData, but here any one of a list of PrivDataFields can be used.
withSomePrivData withSomePrivData
:: (IsContext c, IsPrivDataSource s) :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> [s] => [s]
-> c -> c
-> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property) -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i)
-> Property -> Property HasInfo
withSomePrivData = withPrivData' id withSomePrivData = withPrivData' id
withPrivData' withPrivData'
:: (IsContext c, IsPrivDataSource s) :: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> ((PrivDataField, PrivData) -> v) => ((PrivDataField, PrivData) -> v)
-> [s] -> [s]
-> c -> c
-> (((v -> Propellor Result) -> Propellor Result) -> Property) -> (((v -> Propellor Result) -> Propellor Result) -> Property i)
-> Property -> Property HasInfo
withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
maybe missing (a . feed) =<< getM get fieldlist maybe missing (a . feed) =<< getM get fieldlist
where where
@ -97,7 +98,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
liftIO $ showSet $ liftIO $ showSet $
map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist
return FailedChange return FailedChange
addinfo p = mkProperty addinfo p = infoProperty
(propertyDesc p) (propertyDesc p)
(propertySatisfy p) (propertySatisfy p)
(propertyInfo p <> mempty { _privData = privset }) (propertyInfo p <> mempty { _privData = privset })
@ -113,7 +114,7 @@ showSet l = forM_ l $ \(f, Context c, md) -> do
maybe noop (\d -> putStrLn $ " " ++ d) md maybe noop (\d -> putStrLn $ " " ++ d) md
putStrLn "" putStrLn ""
addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo
addPrivData v = pureInfoProperty (show v) $ addPrivData v = pureInfoProperty (show v) $
mempty { _privData = S.singleton v } mempty { _privData = S.singleton v }

View File

@ -16,6 +16,15 @@ import Propellor.Property
host :: HostName -> Host host :: HostName -> Host
host hn = Host hn [] mempty host hn = Host hn [] mempty
-- | Starts accumulating a list of properties.
--
-- > propertyList "foo" $ props
-- > & someproperty
-- > ! oldproperty
-- > & otherproperty
props :: PropList
props = PropList []
-- | Something that can accumulate properties. -- | Something that can accumulate properties.
class PropAccum h where class PropAccum h where
-- | Adds a property. -- | Adds a property.
@ -23,13 +32,10 @@ class PropAccum h where
-- Can add Properties and RevertableProperties -- Can add Properties and RevertableProperties
(&) :: IsProp p => h -> p -> h (&) :: IsProp p => h -> p -> h
-- | Like (&), but adds the property as the -- | Like (&), but adds the property at the front of the list.
-- first property of the host. Normally, property
-- order should not matter, but this is useful
-- when it does.
(&^) :: IsProp p => h -> p -> h (&^) :: IsProp p => h -> p -> h
getProperties :: h -> [Property] getProperties :: h -> [Property HasInfo]
instance PropAccum Host where instance PropAccum Host where
(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (Host hn ps is) & p = Host hn (ps ++ [toProp p])
@ -38,6 +44,13 @@ instance PropAccum Host where
(getInfoRecursive p <> is) (getInfoRecursive p <> is)
getProperties = hostProperties getProperties = hostProperties
data PropList = PropList [Property HasInfo]
instance PropAccum PropList where
PropList l & p = PropList (l ++ [toProp p])
PropList l &^ p = PropList ([toProp p] ++ l)
getProperties (PropList l) = l
-- | Adds a property in reverted form. -- | Adds a property in reverted form.
(!) :: PropAccum h => h -> RevertableProperty -> h (!) :: PropAccum h => h -> RevertableProperty -> h
h ! p = h & revert p h ! p = h & revert p
@ -57,8 +70,12 @@ infixl 1 !
-- --
-- PrivData Info is propigated, so that properties used inside a -- PrivData Info is propigated, so that properties used inside a
-- PropAccum will have the necessary PrivData available. -- PropAccum will have the necessary PrivData available.
propigateContainer :: PropAccum container => container -> Property -> Property propigateContainer
propigateContainer c prop = mkProperty :: (PropAccum container)
=> container
-> Property HasInfo
-> Property HasInfo
propigateContainer c prop = infoProperty
(propertyDesc prop) (propertyDesc prop)
(propertySatisfy prop) (propertySatisfy prop)
(propertyInfo prop) (propertyInfo prop)
@ -72,4 +89,4 @@ propigateContainer c prop = mkProperty
, _privData = _privData i , _privData = _privData i
} }
cs = map go (propertyChildren p) cs = map go (propertyChildren p)
in mkProperty (propertyDesc p) (propertySatisfy p) i' cs in infoProperty (propertyDesc p) (propertySatisfy p) i' cs

View File

@ -1,4 +1,5 @@
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property where module Propellor.Property where
@ -11,47 +12,20 @@ import "mtl" Control.Monad.RWS.Strict
import Propellor.Types import Propellor.Types
import Propellor.Info import Propellor.Info
import Propellor.Engine
import Utility.Monad import Utility.Monad
-- Constructs a Property. -- Constructs a Property.
property :: Desc -> Propellor Result -> Property property :: Desc -> Propellor Result -> Property NoInfo
property d s = mkProperty d s mempty mempty property d s = simpleProperty d s mempty
-- | Combines a list of properties, resulting in a single property
-- that when run will run each property in the list in turn,
-- and print out the description of each as it's run. Does not stop
-- on failure; does propigate overall success/failure.
propertyList :: Desc -> [Property] -> Property
propertyList desc ps = mkProperty desc (ensureProperties ps) mempty ps
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn. Stops if a property fails.
combineProperties :: Desc -> [Property] -> Property
combineProperties desc ps = mkProperty desc (go ps NoChange) mempty ps
where
go [] rs = return rs
go (l:ls) rs = do
r <- ensureProperty l
case r of
FailedChange -> return FailedChange
_ -> go ls (r <> rs)
-- | Combines together two properties, resulting in one property
-- that ensures the first, and if the first succeeds, ensures the second.
-- The property uses the description of the first property.
before :: Property -> Property -> Property
p1 `before` p2 = p2 `requires` p1
`describe` (propertyDesc p1)
-- | 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 i -> FilePath -> Property i
flagFile p = flagFile' p . return flagFile p = flagFile' p . return
flagFile' :: Property -> IO FilePath -> Property flagFile' :: Property i -> IO FilePath -> Property i
flagFile' p getflagfile = adjustProperty p $ \satisfy -> do flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do
flagfile <- liftIO getflagfile flagfile <- liftIO getflagfile
go satisfy flagfile =<< liftIO (doesFileExist flagfile) go satisfy flagfile =<< liftIO (doesFileExist flagfile)
where where
@ -66,39 +40,37 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
--- | Whenever a change has to be made for a Property, causes a hook --- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise. -- Property to also be run, but not otherwise.
onChange :: Property -> Property -> Property onChange
p `onChange` hook = mkProperty (propertyDesc p) satisfy (propertyInfo p) cs :: (Combines (Property x) (Property y))
where => Property x
satisfy = do => Property y
r <- ensureProperty p => CombinedType (Property x) (Property y)
onChange = combineWith $ \p hook -> do
r <- p
case r of case r of
MadeChange -> do MadeChange -> do
r' <- ensureProperty hook r' <- hook
return $ r <> r' return $ r <> r'
_ -> return r _ -> return r
cs = propertyChildren p ++ [hook]
(==>) :: Desc -> Property -> Property (==>) :: IsProp (Property i) => Desc -> Property i -> Property i
(==>) = flip describe (==>) = flip describe
infixl 1 ==> infixl 1 ==>
-- | Makes a Property only need to do anything when a test succeeds. -- | Makes a Property only need to do anything when a test succeeds.
check :: IO Bool -> Property -> Property check :: IO Bool -> Property i -> Property i
check c p = adjustProperty p $ \satisfy -> ifM (liftIO c) check c p = adjustPropertySatisfy p $ \satisfy -> ifM (liftIO c)
( satisfy ( satisfy
, return NoChange , return NoChange
) )
-- | Tries the first property, but if it fails to work, instead uses -- | Tries the first property, but if it fails to work, instead uses
-- the second. -- the second.
fallback :: Property -> Property -> Property fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2)
fallback p1 p2 = mkProperty (propertyDesc p1) satisfy (propertyInfo p1) cs fallback = combineWith $ \a1 a2 -> do
where r <- a1
cs = p2 : propertyChildren p1
satisfy = do
r <- propertySatisfy p1
if r == FailedChange if r == FailedChange
then propertySatisfy p2 then a2
else return r else return r
-- | Marks a Property as trivial. It can only return FailedChange or -- | Marks a Property as trivial. It can only return FailedChange or
@ -107,35 +79,27 @@ fallback p1 p2 = mkProperty (propertyDesc p1) satisfy (propertyInfo p1) cs
-- Useful when it's just as expensive to check if a change needs -- Useful when it's just as expensive to check if a change needs
-- to be made as it is to just idempotently assure the property is -- to be made as it is to just idempotently assure the property is
-- satisfied. For example, chmodding a file. -- satisfied. For example, chmodding a file.
trivial :: Property -> Property trivial :: Property i -> Property i
trivial p = adjustProperty p $ \satisfy -> do trivial p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy r <- satisfy
if r == MadeChange if r == MadeChange
then return NoChange then return NoChange
else return r else return r
doNothing :: Property doNothing :: Property NoInfo
doNothing = property "noop property" noChange doNothing = property "noop property" noChange
-- | Makes a property that is satisfied differently depending on the host's -- | Makes a property that is satisfied differently depending on the host's
-- operating system. -- operating system.
-- --
-- Note that the operating system may not be declared for some hosts. -- Note that the operating system may not be declared for some hosts.
withOS :: Desc -> (Maybe System -> Propellor Result) -> Property withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo
withOS desc a = property desc $ a =<< getOS withOS desc a = property desc $ a =<< getOS
-- | Undoes the effect of a property. -- | Undoes the effect of a property.
revert :: RevertableProperty -> RevertableProperty revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
-- | Changes the action that is performed to satisfy a property.
adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
adjustProperty p f = mkProperty
(propertyDesc p)
(f (propertySatisfy p))
(propertyInfo p)
(propertyChildren p)
makeChange :: IO () -> Propellor Result makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange makeChange a = liftIO a >> return MadeChange

View File

@ -9,7 +9,7 @@ import Utility.SafeCommand
type ConfigFile = [String] type ConfigFile = [String]
siteEnabled :: HostName -> ConfigFile -> RevertableProperty siteEnabled :: HostName -> ConfigFile -> RevertableProperty
siteEnabled hn cf = RevertableProperty enable disable siteEnabled hn cf = enable <!> disable
where where
enable = combineProperties ("apache site enabled " ++ hn) enable = combineProperties ("apache site enabled " ++ hn)
[ siteAvailable hn cf [ siteAvailable hn cf
@ -28,14 +28,14 @@ siteEnabled hn cf = RevertableProperty enable disable
`onChange` reloaded `onChange` reloaded
isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn] isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn]
siteAvailable :: HostName -> ConfigFile -> Property siteAvailable :: HostName -> ConfigFile -> Property NoInfo
siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $ siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $
map (`File.hasContent` (comment:cf)) (siteCfg hn) map (`File.hasContent` (comment:cf)) (siteCfg hn)
where where
comment = "# deployed with propellor, do not modify" comment = "# deployed with propellor, do not modify"
modEnabled :: String -> RevertableProperty modEnabled :: String -> RevertableProperty
modEnabled modname = RevertableProperty enable disable modEnabled modname = enable <!> disable
where where
enable = check (not <$> isenabled) $ enable = check (not <$> isenabled) $
cmdProperty "a2enmod" ["--quiet", modname] cmdProperty "a2enmod" ["--quiet", modname]
@ -59,18 +59,18 @@ siteCfg hn =
, "/etc/apache2/sites-available/" ++ hn ++ ".conf" , "/etc/apache2/sites-available/" ++ hn ++ ".conf"
] ]
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["apache2"] installed = Apt.installed ["apache2"]
restarted :: Property restarted :: Property NoInfo
restarted = Service.restarted "apache2" restarted = Service.restarted "apache2"
reloaded :: Property reloaded :: Property NoInfo
reloaded = Service.reloaded "apache2" reloaded = Service.reloaded "apache2"
-- | Configure apache to use SNI to differentiate between -- | Configure apache to use SNI to differentiate between
-- https hosts. -- https hosts.
multiSSL :: Property multiSSL :: Property NoInfo
multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent` multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent`
[ "NameVirtualHost *:443" [ "NameVirtualHost *:443"
, "SSLStrictSNIVHostCheck off" , "SSLStrictSNIVHostCheck off"

View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Apt where module Propellor.Property.Apt where
import Data.Maybe import Data.Maybe
@ -77,36 +79,36 @@ securityUpdates suite
-- --
-- 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 :: Property stdSourcesList :: Property NoInfo
stdSourcesList = withOS ("standard sources.list") $ \o -> stdSourcesList = withOS ("standard sources.list") $ \o ->
case o of case o of
(Just (System (Debian suite) _)) -> (Just (System (Debian suite) _)) ->
ensureProperty $ stdSourcesListFor suite ensureProperty $ stdSourcesListFor suite
_ -> error "os is not declared to be Debian" _ -> error "os is not declared to be Debian"
stdSourcesListFor :: DebianSuite -> Property stdSourcesListFor :: DebianSuite -> Property NoInfo
stdSourcesListFor suite = stdSourcesList' suite [] stdSourcesListFor suite = stdSourcesList' suite []
-- | Adds additional sources.list generators. -- | Adds additional sources.list generators.
-- --
-- Note that if a Property needs to enable an apt source, it's better -- Note that if a Property needs to enable an apt source, it's better
-- to do so via a separate file in </etc/apt/sources.list.d/> -- to do so via a separate file in </etc/apt/sources.list.d/>
stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo
stdSourcesList' suite more = setSourcesList stdSourcesList' suite more = setSourcesList
(concatMap (\gen -> gen suite) generators) (concatMap (\gen -> gen suite) generators)
`describe` ("standard sources.list for " ++ show suite) `describe` ("standard sources.list for " ++ show suite)
where where
generators = [debCdn, kernelOrg, securityUpdates] ++ more generators = [debCdn, kernelOrg, securityUpdates] ++ more
setSourcesList :: [Line] -> Property setSourcesList :: [Line] -> Property NoInfo
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
setSourcesListD :: [Line] -> FilePath -> Property setSourcesListD :: [Line] -> FilePath -> Property NoInfo
setSourcesListD ls basename = f `File.hasContent` ls `onChange` update setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
where where
f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
runApt :: [String] -> Property runApt :: [String] -> Property NoInfo
runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)] noninteractiveEnv :: [(String, String)]
@ -115,26 +117,26 @@ noninteractiveEnv =
, ("APT_LISTCHANGES_FRONTEND", "none") , ("APT_LISTCHANGES_FRONTEND", "none")
] ]
update :: Property update :: Property NoInfo
update = runApt ["update"] update = runApt ["update"]
`describe` "apt update" `describe` "apt update"
upgrade :: Property upgrade :: Property NoInfo
upgrade = runApt ["-y", "dist-upgrade"] upgrade = runApt ["-y", "dist-upgrade"]
`describe` "apt dist-upgrade" `describe` "apt dist-upgrade"
type Package = String type Package = String
installed :: [Package] -> Property installed :: [Package] -> Property NoInfo
installed = installed' ["-y"] installed = installed' ["-y"]
installed' :: [String] -> [Package] -> Property installed' :: [String] -> [Package] -> Property NoInfo
installed' params ps = robustly $ check (isInstallable ps) go installed' params ps = robustly $ check (isInstallable ps) go
`describe` (unwords $ "apt installed":ps) `describe` (unwords $ "apt installed":ps)
where where
go = runApt $ params ++ ["install"] ++ ps go = runApt $ params ++ ["install"] ++ ps
installedBackport :: [Package] -> Property installedBackport :: [Package] -> Property NoInfo
installedBackport ps = trivial $ withOS desc $ \o -> case o of installedBackport ps = trivial $ withOS desc $ \o -> case o of
Nothing -> error "cannot install backports; os not declared" Nothing -> error "cannot install backports; os not declared"
(Just (System (Debian suite) _)) -> case backportSuite suite of (Just (System (Debian suite) _)) -> case backportSuite suite of
@ -147,16 +149,16 @@ installedBackport ps = trivial $ withOS desc $ \o -> case o of
notsupported o = error $ "backports not supported on " ++ show o notsupported o = error $ "backports not supported on " ++ show o
-- | Minimal install of package, without recommends. -- | Minimal install of package, without recommends.
installedMin :: [Package] -> Property installedMin :: [Package] -> Property NoInfo
installedMin = installed' ["--no-install-recommends", "-y"] installedMin = installed' ["--no-install-recommends", "-y"]
removed :: [Package] -> Property removed :: [Package] -> Property NoInfo
removed ps = check (or <$> isInstalled' ps) go removed ps = check (or <$> isInstalled' ps) go
`describe` (unwords $ "apt removed":ps) `describe` (unwords $ "apt removed":ps)
where where
go = runApt $ ["-y", "remove"] ++ ps go = runApt $ ["-y", "remove"] ++ ps
buildDep :: [Package] -> Property buildDep :: [Package] -> Property NoInfo
buildDep ps = robustly go buildDep ps = robustly go
`describe` (unwords $ "apt build-dep":ps) `describe` (unwords $ "apt build-dep":ps)
where where
@ -165,7 +167,7 @@ buildDep ps = robustly go
-- | Installs the build deps for the source package unpacked -- | Installs the build deps for the source package unpacked
-- in the specifed directory, with a dummy package also -- in the specifed directory, with a dummy package also
-- installed so that autoRemove won't remove them. -- installed so that autoRemove won't remove them.
buildDepIn :: FilePath -> Property buildDepIn :: FilePath -> Property NoInfo
buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
where where
go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"] go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]
@ -173,11 +175,13 @@ buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
-- | Package installation may fail becuse the archive has changed. -- | Package installation may fail becuse the archive has changed.
-- Run an update in that case and retry. -- Run an update in that case and retry.
robustly :: Property -> Property robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i
robustly p = adjustProperty p $ \satisfy -> do robustly p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy r <- satisfy
if r == FailedChange if r == FailedChange
then ensureProperty $ p `requires` update -- Safe to use ignoreInfo because we're re-running
-- the same property.
then ensureProperty $ ignoreInfo $ p `requires` update
else return r else return r
isInstallable :: [Package] -> IO Bool isInstallable :: [Package] -> IO Bool
@ -203,13 +207,13 @@ isInstalled' ps = catMaybes . map parse . lines <$> policy
environ <- addEntry "LANG" "C" <$> getEnvironment environ <- addEntry "LANG" "C" <$> getEnvironment
readProcessEnv "apt-cache" ("policy":ps) (Just environ) readProcessEnv "apt-cache" ("policy":ps) (Just environ)
autoRemove :: Property autoRemove :: Property NoInfo
autoRemove = runApt ["-y", "autoremove"] autoRemove = runApt ["-y", "autoremove"]
`describe` "apt autoremove" `describe` "apt autoremove"
-- | Enables unattended upgrades. Revert to disable. -- | Enables unattended upgrades. Revert to disable.
unattendedUpgrades :: RevertableProperty unattendedUpgrades :: RevertableProperty
unattendedUpgrades = RevertableProperty enable disable unattendedUpgrades = enable <!> disable
where where
enable = setup True enable = setup True
`before` Service.running "cron" `before` Service.running "cron"
@ -237,7 +241,7 @@ unattendedUpgrades = RevertableProperty enable disable
-- | Preseeds debconf values and reconfigures the package so it takes -- | Preseeds debconf values and reconfigures the package so it takes
-- effect. -- effect.
reConfigure :: Package -> [(String, String, String)] -> Property reConfigure :: Package -> [(String, String, String)] -> Property NoInfo
reConfigure package vals = reconfigure `requires` setselections reConfigure package vals = reconfigure `requires` setselections
`describe` ("reconfigure " ++ package) `describe` ("reconfigure " ++ package)
where where
@ -253,7 +257,7 @@ reConfigure package vals = reconfigure `requires` setselections
-- --
-- Assumes that there is a 1:1 mapping between service names and apt -- Assumes that there is a 1:1 mapping between service names and apt
-- package names. -- package names.
serviceInstalledRunning :: Package -> Property serviceInstalledRunning :: Package -> Property NoInfo
serviceInstalledRunning svc = Service.running svc `requires` installed [svc] serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
data AptKey = AptKey data AptKey = AptKey
@ -262,7 +266,7 @@ data AptKey = AptKey
} }
trustsKey :: AptKey -> RevertableProperty trustsKey :: AptKey -> RevertableProperty
trustsKey k = RevertableProperty trust untrust trustsKey k = trust <!> untrust
where where
desc = "apt trusts key " ++ keyname k desc = "apt trusts key " ++ keyname k
f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg" f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
@ -276,6 +280,6 @@ trustsKey k = RevertableProperty trust untrust
-- | Cleans apt's cache of downloaded packages to avoid using up disk -- | Cleans apt's cache of downloaded packages to avoid using up disk
-- space. -- space.
cacheCleaned :: Property cacheCleaned :: Property NoInfo
cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"] cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"]
`describe` "apt cache cleaned" `describe` "apt cache cleaned"

View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Chroot ( module Propellor.Property.Chroot (
Chroot(..), Chroot(..),
BuilderConf(..), BuilderConf(..),
@ -59,12 +61,13 @@ debootstrapped system conf location = case system of
provisioned :: Chroot -> RevertableProperty provisioned :: Chroot -> RevertableProperty
provisioned c = provisioned' (propigateChrootInfo c) c False provisioned c = provisioned' (propigateChrootInfo c) c False
provisioned' :: (Property -> Property) -> Chroot -> Bool -> RevertableProperty provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = RevertableProperty provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
(propigator $ go "exists" setup) (propigator $ go "exists" setup)
<!>
(go "removed" teardown) (go "removed" teardown)
where where
go desc a = property (chrootDesc c desc) $ ensureProperties [a] go desc a = propertyList (chrootDesc c desc) [a]
setup = propellChroot c (inChrootProcess c) systemdonly setup = propellChroot c (inChrootProcess c) systemdonly
`requires` toProp built `requires` toProp built
@ -77,10 +80,10 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert
teardown = toProp (revert built) teardown = toProp (revert built)
propigateChrootInfo :: Chroot -> Property -> Property propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
propigateChrootInfo c p = propigateContainer c p' propigateChrootInfo c p = propigateContainer c p'
where where
p' = mkProperty p' = infoProperty
(propertyDesc p) (propertyDesc p)
(propertySatisfy p) (propertySatisfy p)
(propertyInfo p <> chrootInfo c) (propertyInfo p <> chrootInfo c)
@ -91,7 +94,7 @@ chrootInfo (Chroot loc _ _ h) =
mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } } mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }
-- | Propellor is run inside the chroot to provision it. -- | Propellor is run inside the chroot to provision it.
propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property NoInfo
propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c let d = localdir </> shimdir c
let me = localdir </> "propellor" let me = localdir </> "propellor"
@ -148,7 +151,8 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
r <- runPropellor h $ ensureProperties $ r <- runPropellor h $ ensureProperties $
if systemdonly if systemdonly
then [Systemd.installed] then [Systemd.installed]
else hostProperties h else map ignoreInfo $
hostProperties h
putStrLn $ "\n" ++ show r putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command" chain _ _ = errorMessage "bad chain command"

View File

@ -19,12 +19,12 @@ import Utility.Env
-- | A property that can be satisfied by running a command. -- | A property that can be satisfied by running a command.
-- --
-- The command must exit 0 on success. -- The command must exit 0 on success.
cmdProperty :: String -> [String] -> Property cmdProperty :: String -> [String] -> Property NoInfo
cmdProperty cmd params = cmdProperty' cmd params [] 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 NoInfo
cmdProperty' cmd params env = property desc $ liftIO $ do cmdProperty' cmd params env = property desc $ liftIO $ do
env' <- addEntries env <$> getEnvironment env' <- addEntries env <$> getEnvironment
toResult <$> boolSystemEnv cmd (map Param params) (Just env') toResult <$> boolSystemEnv cmd (map Param params) (Just env')
@ -32,14 +32,14 @@ cmdProperty' cmd params env = property desc $ liftIO $ do
desc = unwords $ cmd : params desc = unwords $ cmd : params
-- | A property that can be satisfied by running a series of shell commands. -- | A property that can be satisfied by running a series of shell commands.
scriptProperty :: [String] -> Property scriptProperty :: [String] -> Property NoInfo
scriptProperty script = cmdProperty "sh" ["-c", shellcmd] scriptProperty script = cmdProperty "sh" ["-c", shellcmd]
where where
shellcmd = intercalate " ; " ("set -e" : script) shellcmd = intercalate " ; " ("set -e" : script)
-- | A property that can satisfied by running a series of shell commands, -- | A property that can satisfied by running a series of shell commands,
-- as user (cd'd to their home directory). -- as user (cd'd to their home directory).
userScriptProperty :: UserName -> [String] -> Property userScriptProperty :: UserName -> [String] -> Property NoInfo
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)

View File

@ -19,7 +19,7 @@ type CronTimes = String
-- job file. -- job file.
-- --
-- The cron job's output will only be emailed if it exits nonzero. -- The cron job's output will only be emailed if it exits nonzero.
job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property NoInfo
job desc times user cddir command = combineProperties ("cronned " ++ desc) job desc times user cddir command = combineProperties ("cronned " ++ desc)
[ cronjobfile `File.hasContent` [ cronjobfile `File.hasContent`
[ "# Generated by propellor" [ "# Generated by propellor"
@ -52,10 +52,10 @@ job desc times user cddir command = combineProperties ("cronned " ++ desc)
| otherwise = '_' | otherwise = '_'
-- | Installs a cron job, and runs it niced and ioniced. -- | Installs a cron job, and runs it niced and ioniced.
niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property NoInfo
niceJob desc times user cddir command = job desc times user cddir niceJob desc times user cddir command = job desc times user cddir
("nice ionice -c 3 sh -c " ++ shellEscape command) ("nice ionice -c 3 sh -c " ++ shellEscape command)
-- | Installs a cron job to run propellor. -- | Installs a cron job to run propellor.
runPropellor :: CronTimes -> Property runPropellor :: CronTimes -> Property NoInfo
runPropellor times = niceJob "propellor" times "root" localdir "./propellor" runPropellor times = niceJob "propellor" times "root" localdir "./propellor"

View File

@ -58,9 +58,8 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2
built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty
built = built' (toProp installed) built = built' (toProp installed)
built' :: Property -> FilePath -> System -> DebootstrapConfig -> RevertableProperty built' :: Property HasInfo -> FilePath -> System -> DebootstrapConfig -> RevertableProperty
built' installprop target system@(System _ arch) config = built' installprop target system@(System _ arch) config = setup <!> teardown
RevertableProperty setup teardown
where where
setup = check (unpopulated target <||> ispartial) setupprop setup = check (unpopulated target <||> ispartial) setupprop
`requires` installprop `requires` installprop
@ -122,7 +121,7 @@ extractSuite (System (Ubuntu r) _) = Just r
-- Note that installation from source is done by downloading the tarball -- Note that installation from source is done by downloading the tarball
-- from a Debian mirror, with no cryptographic verification. -- from a Debian mirror, with no cryptographic verification.
installed :: RevertableProperty installed :: RevertableProperty
installed = RevertableProperty install remove installed = install <!> remove
where where
install = withOS "debootstrap installed" $ \o -> install = withOS "debootstrap installed" $ \o ->
ifM (liftIO $ isJust <$> programPath) ifM (liftIO $ isJust <$> programPath)
@ -142,18 +141,18 @@ installed = RevertableProperty install remove
aptinstall = Apt.installed ["debootstrap"] aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"] aptremove = Apt.removed ["debootstrap"]
sourceInstall :: Property sourceInstall :: Property NoInfo
sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall') sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')
`requires` perlInstalled `requires` perlInstalled
`requires` arInstalled `requires` arInstalled
perlInstalled :: Property perlInstalled :: Property NoInfo
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
liftIO $ toResult . isJust <$> firstM id liftIO $ toResult . isJust <$> firstM id
[ yumInstall "perl" [ yumInstall "perl"
] ]
arInstalled :: Property arInstalled :: Property NoInfo
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
liftIO $ toResult . isJust <$> firstM id liftIO $ toResult . isJust <$> firstM id
[ yumInstall "binutils" [ yumInstall "binutils"
@ -197,7 +196,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
return MadeChange return MadeChange
_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory" _ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
sourceRemove :: Property sourceRemove :: Property NoInfo
sourceRemove = property "debootstrap not installed from source" $ liftIO $ sourceRemove = property "debootstrap not installed from source" $ liftIO $
ifM (doesDirectoryExist sourceInstallDir) ifM (doesDirectoryExist sourceInstallDir)
( do ( do

View File

@ -58,7 +58,7 @@ import Data.List
-- In either case, the secondary dns server Host should have an ipv4 and/or -- In either case, the secondary dns server Host should have an ipv4 and/or
-- ipv6 property defined. -- ipv6 property defined.
primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
primary hosts domain soa rs = RevertableProperty setup cleanup primary hosts domain soa rs = setup <!> cleanup
where where
setup = setupPrimary zonefile id hosts domain soa rs setup = setupPrimary zonefile id hosts domain soa rs
`onChange` Service.reloaded "bind9" `onChange` Service.reloaded "bind9"
@ -67,7 +67,7 @@ primary hosts domain soa rs = RevertableProperty setup cleanup
zonefile = "/etc/bind/propellor/db." ++ domain zonefile = "/etc/bind/propellor/db." ++ domain
setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo
setupPrimary zonefile mknamedconffile hosts domain soa rs = setupPrimary zonefile mknamedconffile hosts domain soa rs =
withwarnings baseprop withwarnings baseprop
`requires` servingZones `requires` servingZones
@ -77,7 +77,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap
(partialzone, zonewarnings) = genZone indomain hostmap domain soa (partialzone, zonewarnings) = genZone indomain hostmap domain soa
baseprop = mkProperty ("dns primary for " ++ domain) satisfy baseprop = infoProperty ("dns primary for " ++ domain) satisfy
(addNamedConf conf) [] (addNamedConf conf) []
satisfy = do satisfy = do
sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
@ -87,7 +87,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
( makeChange $ writeZoneFile zone zonefile ( makeChange $ writeZoneFile zone zonefile
, noChange , noChange
) )
withwarnings p = adjustProperty p $ \a -> do withwarnings p = adjustPropertySatisfy p $ \a -> do
mapM_ warningMessage $ zonewarnings ++ secondarywarnings mapM_ warningMessage $ zonewarnings ++ secondarywarnings
a a
conf = NamedConf conf = NamedConf
@ -117,7 +117,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
in z /= oldzone || oldserial < sSerial (zSOA zone) in z /= oldzone || oldserial < sSerial (zSOA zone)
cleanupPrimary :: FilePath -> Domain -> Property cleanupPrimary :: FilePath -> Domain -> Property NoInfo
cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
property ("removed dns primary for " ++ domain) property ("removed dns primary for " ++ domain)
(makeChange $ removeZoneFile zonefile) (makeChange $ removeZoneFile zonefile)
@ -150,13 +150,14 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
-- want to later disable DNSSEC you will need to adjust the serial number -- want to later disable DNSSEC you will need to adjust the serial number
-- passed to mkSOA to ensure it is larger. -- passed to mkSOA to ensure it is larger.
signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty
signedPrimary recurrance hosts domain soa rs = RevertableProperty setup cleanup signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
where where
setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")
[ setupPrimary zonefile signedZoneFile hosts domain soa rs' (props
, toProp (zoneSigned domain zonefile) & setupPrimary zonefile signedZoneFile hosts domain soa rs'
, forceZoneSigned domain zonefile `period` recurrance & zoneSigned domain zonefile
] & forceZoneSigned domain zonefile `period` recurrance
)
`onChange` Service.reloaded "bind9" `onChange` Service.reloaded "bind9"
cleanup = cleanupPrimary zonefile domain cleanup = cleanupPrimary zonefile domain
@ -186,7 +187,7 @@ secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts d
-- | This variant is useful if the primary server does not have its DNS -- | This variant is useful if the primary server does not have its DNS
-- configured via propellor. -- configured via propellor.
secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty
secondaryFor masters hosts domain = RevertableProperty setup cleanup secondaryFor masters hosts domain = setup <!> cleanup
where where
setup = pureInfoProperty desc (addNamedConf conf) setup = pureInfoProperty desc (addNamedConf conf)
`requires` servingZones `requires` servingZones
@ -214,12 +215,12 @@ otherServers wantedtype hosts domain =
-- | Rewrites the whole named.conf.local file to serve the zones -- | Rewrites the whole named.conf.local file to serve the zones
-- configured by `primary` and `secondary`, and ensures that bind9 is -- configured by `primary` and `secondary`, and ensures that bind9 is
-- running. -- running.
servingZones :: Property servingZones :: Property NoInfo
servingZones = namedConfWritten servingZones = namedConfWritten
`onChange` Service.reloaded "bind9" `onChange` Service.reloaded "bind9"
`requires` Apt.serviceInstalledRunning "bind9" `requires` Apt.serviceInstalledRunning "bind9"
namedConfWritten :: Property namedConfWritten :: Property NoInfo
namedConfWritten = property "named.conf configured" $ do namedConfWritten = property "named.conf configured" $ do
zs <- getNamedConf zs <- getNamedConf
ensureProperty $ ensureProperty $

View File

@ -8,7 +8,7 @@ import qualified Propellor.Property.File as File
-- signedPrimary uses this, so this property does not normally need to be -- signedPrimary uses this, so this property does not normally need to be
-- used directly. -- used directly.
keysInstalled :: Domain -> RevertableProperty keysInstalled :: Domain -> RevertableProperty
keysInstalled domain = RevertableProperty setup cleanup keysInstalled domain = setup <!> cleanup
where where
setup = propertyList "DNSSEC keys installed" $ setup = propertyList "DNSSEC keys installed" $
map installkey keys map installkey keys
@ -38,16 +38,14 @@ keysInstalled domain = RevertableProperty setup cleanup
-- signedPrimary uses this, so this property does not normally need to be -- signedPrimary uses this, so this property does not normally need to be
-- used directly. -- used directly.
zoneSigned :: Domain -> FilePath -> RevertableProperty zoneSigned :: Domain -> FilePath -> RevertableProperty
zoneSigned domain zonefile = RevertableProperty setup cleanup zoneSigned domain zonefile = setup <!> cleanup
where where
setup = check needupdate (forceZoneSigned domain zonefile) setup = check needupdate (forceZoneSigned domain zonefile)
`requires` toProp (keysInstalled domain) `requires` toProp (keysInstalled domain)
cleanup = combineProperties ("removed signed zone for " ++ domain) cleanup = File.notPresent (signedZoneFile zonefile)
[ File.notPresent (signedZoneFile zonefile) `before` File.notPresent dssetfile
, File.notPresent dssetfile `before` toProp (revert (keysInstalled domain))
, toProp (revert (keysInstalled domain))
]
dssetfile = dir </> "-" ++ domain ++ "." dssetfile = dir </> "-" ++ domain ++ "."
dir = takeDirectory zonefile dir = takeDirectory zonefile
@ -65,7 +63,7 @@ zoneSigned domain zonefile = RevertableProperty setup cleanup
t2 <- getModificationTime f t2 <- getModificationTime f
return (t2 >= t1) return (t2 >= t1)
forceZoneSigned :: Domain -> FilePath -> Property forceZoneSigned :: Domain -> FilePath -> Property NoInfo
forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do
salt <- take 16 <$> saltSha1 salt <- take 16 <$> saltSha1
let p = proc "dnssec-signzone" let p = proc "dnssec-signzone"

View File

@ -1,4 +1,4 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}
-- | Docker support for propellor -- | Docker support for propellor
-- --
@ -56,12 +56,12 @@ import Data.List hiding (init)
import Data.List.Utils import Data.List.Utils
import qualified Data.Map as M import qualified Data.Map as M
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["docker.io"] installed = Apt.installed ["docker.io"]
-- | Configures docker with an authentication file, so that images can be -- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional. -- pushed to index.docker.io. Optional.
configured :: Property configured :: Property HasInfo
configured = prop `requires` installed configured = prop `requires` installed
where where
prop = withPrivData src anyContext $ \getcfg -> prop = withPrivData src anyContext $ \getcfg ->
@ -106,8 +106,9 @@ container cn image = Container image (Host cn [] info)
-- Reverting this property ensures that the container is stopped and -- Reverting this property ensures that the container is stopped and
-- removed. -- removed.
docked :: Container -> RevertableProperty docked :: Container -> RevertableProperty
docked ctr@(Container _ h) = RevertableProperty docked ctr@(Container _ h) =
(propigateContainerInfo ctr (go "docked" setup)) (propigateContainerInfo ctr (go "docked" setup))
<!>
(go "undocked" teardown) (go "undocked" teardown)
where where
cn = hostName h cn = hostName h
@ -134,10 +135,10 @@ docked ctr@(Container _ h) = RevertableProperty
] ]
] ]
propigateContainerInfo :: Container -> Property -> Property propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo
propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p' propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p'
where where
p' = mkProperty p' = infoProperty
(propertyDesc p) (propertyDesc p)
(propertySatisfy p) (propertySatisfy p)
(propertyInfo p <> dockerinfo) (propertyInfo p <> dockerinfo)
@ -169,7 +170,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
-- that were not set up using propellor. -- that were not set up using propellor.
-- --
-- Generally, should come after the properties for the desired containers. -- Generally, should come after the properties for the desired containers.
garbageCollected :: Property garbageCollected :: Property NoInfo
garbageCollected = propertyList "docker garbage collected" garbageCollected = propertyList "docker garbage collected"
[ gccontainers [ gccontainers
, gcimages , gcimages
@ -185,7 +186,7 @@ garbageCollected = propertyList "docker garbage collected"
-- Currently, this consists of making pam_loginuid lines optional in -- Currently, this consists of making pam_loginuid lines optional in
-- the pam config, to work around <https://github.com/docker/docker/issues/5663> -- the pam config, to work around <https://github.com/docker/docker/issues/5663>
-- which affects docker 1.2.0. -- which affects docker 1.2.0.
tweaked :: Property tweaked :: Property NoInfo
tweaked = trivial $ tweaked = trivial $
cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"] cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"]
`describe` "tweaked for docker" `describe` "tweaked for docker"
@ -196,7 +197,7 @@ tweaked = trivial $
-- other GRUB_CMDLINE_LINUX_DEFAULT settings. -- other GRUB_CMDLINE_LINUX_DEFAULT settings.
-- --
-- Only takes effect after reboot. (Not automated.) -- Only takes effect after reboot. (Not automated.)
memoryLimited :: Property memoryLimited :: Property NoInfo
memoryLimited = "/etc/default/grub" `File.containsLine` cfg memoryLimited = "/etc/default/grub" `File.containsLine` cfg
`describe` "docker memory limited" `describe` "docker memory limited"
`onChange` cmdProperty "update-grub" [] `onChange` cmdProperty "update-grub" []
@ -213,44 +214,44 @@ type RunParam = String
type Image = String type Image = String
-- | Set custom dns server for container. -- | Set custom dns server for container.
dns :: String -> Property dns :: String -> Property HasInfo
dns = runProp "dns" dns = runProp "dns"
-- | Set container host name. -- | Set container host name.
hostname :: String -> Property hostname :: String -> Property HasInfo
hostname = runProp "hostname" hostname = runProp "hostname"
-- | Set name of container. -- | Set name of container.
name :: String -> Property name :: String -> Property HasInfo
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 -> Property publish :: String -> Property HasInfo
publish = runProp "publish" publish = runProp "publish"
-- | Expose a container's port without publishing it. -- | Expose a container's port without publishing it.
expose :: String -> Property expose :: String -> Property HasInfo
expose = runProp "expose" expose = runProp "expose"
-- | Username or UID for container. -- | Username or UID for container.
user :: String -> Property user :: String -> Property HasInfo
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 -> Property volume :: String -> Property HasInfo
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 -> Property volumes_from :: ContainerName -> Property HasInfo
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 -> Property workdir :: String -> Property HasInfo
workdir = runProp "workdir" workdir = runProp "workdir"
-- | Memory limit for container. -- | Memory limit for container.
@ -258,18 +259,18 @@ workdir = runProp "workdir"
-- --
-- Note: Only takes effect when the host has the memoryLimited property -- Note: Only takes effect when the host has the memoryLimited property
-- enabled. -- enabled.
memory :: String -> Property memory :: String -> Property HasInfo
memory = runProp "memory" memory = runProp "memory"
-- | CPU shares (relative weight). -- | CPU shares (relative weight).
-- --
-- By default, all containers run at the same priority, but you can tell -- By default, all containers run at the same priority, but you can tell
-- the kernel to give more CPU time to a container using this property. -- the kernel to give more CPU time to a container using this property.
cpuShares :: Int -> Property cpuShares :: Int -> Property HasInfo
cpuShares = runProp "cpu-shares" . show cpuShares = runProp "cpu-shares" . show
-- | Link with another container on the same host. -- | Link with another container on the same host.
link :: ContainerName -> ContainerAlias -> Property link :: ContainerName -> ContainerAlias -> Property HasInfo
link linkwith calias = genProp "link" $ \hn -> link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
@ -281,19 +282,19 @@ type ContainerAlias = String
-- propellor; as well as keeping badly behaved containers running, -- propellor; as well as keeping badly behaved containers running,
-- it ensures that containers get started back up after reboot or -- it ensures that containers get started back up after reboot or
-- after docker is upgraded. -- after docker is upgraded.
restartAlways :: Property restartAlways :: Property HasInfo
restartAlways = runProp "restart" "always" restartAlways = runProp "restart" "always"
-- | Docker will restart the container if it exits nonzero. -- | Docker will restart the container if it exits nonzero.
-- If a number is provided, it will be restarted only up to that many -- If a number is provided, it will be restarted only up to that many
-- times. -- times.
restartOnFailure :: Maybe Int -> Property restartOnFailure :: Maybe Int -> Property HasInfo
restartOnFailure Nothing = runProp "restart" "on-failure" restartOnFailure Nothing = runProp "restart" "on-failure"
restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n) restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
-- | Makes docker not restart a container when it exits -- | Makes docker not restart a container when it exits
-- Note that this includes not restarting it on boot! -- Note that this includes not restarting it on boot!
restartNever :: Property restartNever :: Property HasInfo
restartNever = runProp "restart" "no" restartNever = runProp "restart" "no"
-- | A container is identified by its name, and the host -- | A container is identified by its name, and the host
@ -327,12 +328,12 @@ fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
myContainerSuffix :: String myContainerSuffix :: String
myContainerSuffix = ".propellor" myContainerSuffix = ".propellor"
containerDesc :: ContainerId -> Property -> Property containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
containerDesc cid p = p `describe` desc containerDesc cid p = p `describe` desc
where where
desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
runningContainer :: ContainerId -> Image -> [RunParam] -> Property runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers l <- liftIO $ listContainers RunningContainers
if cid `elem` l if cid `elem` l
@ -447,7 +448,7 @@ init s = case toContainerId s of
-- | Once a container is running, propellor can be run inside -- | Once a container is running, propellor can be run inside
-- it to provision it. -- it to provision it.
provisionContainer :: ContainerId -> Property provisionContainer :: ContainerId -> Property NoInfo
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
let params = ["--continue", show $ toChain cid] let params = ["--continue", show $ toChain cid]
@ -477,6 +478,7 @@ chain hostlist hn s = case toContainerId s of
changeWorkingDirectory localdir changeWorkingDirectory localdir
onlyProcess (provisioningLock cid) $ do onlyProcess (provisioningLock cid) $ do
r <- runPropellor h $ ensureProperties $ r <- runPropellor h $ ensureProperties $
map ignoreInfo $
hostProperties h hostProperties h
putStrLn $ "\n" ++ show r putStrLn $ "\n" ++ show r
@ -486,7 +488,7 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
startContainer :: ContainerId -> IO Bool startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
stoppedContainer :: ContainerId -> Property stoppedContainer :: ContainerId -> Property NoInfo
stoppedContainer cid = containerDesc cid $ property desc $ stoppedContainer cid = containerDesc cid $ property desc $
ifM (liftIO $ elem cid <$> listContainers RunningContainers) ifM (liftIO $ elem cid <$> listContainers RunningContainers)
( liftIO cleanup `after` ensureProperty ( liftIO cleanup `after` ensureProperty
@ -538,13 +540,13 @@ 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 -> Property runProp :: String -> RunParam -> Property HasInfo
runProp field val = pureInfoProperty (param) $ dockerInfo $ runProp field val = pureInfoProperty (param) $ dockerInfo $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where where
param = field++"="++val param = field++"="++val
genProp :: String -> (HostName -> RunParam) -> Property genProp :: String -> (HostName -> RunParam) -> Property HasInfo
genProp field mkval = pureInfoProperty field $ dockerInfo $ genProp field mkval = pureInfoProperty field $ dockerInfo $
mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] } mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }

View File

@ -9,7 +9,7 @@ import System.PosixCompat.Types
type Line = String type Line = String
-- | Replaces all the content of a file. -- | Replaces all the content of a file.
hasContent :: FilePath -> [Line] -> Property hasContent :: FilePath -> [Line] -> Property NoInfo
f `hasContent` newcontent = fileProperty ("replace " ++ f) f `hasContent` newcontent = fileProperty ("replace " ++ f)
(\_oldcontent -> newcontent) f (\_oldcontent -> newcontent) f
@ -17,25 +17,25 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f)
-- --
-- The file's permissions are preserved if the file already existed. -- The file's permissions are preserved if the file already existed.
-- Otherwise, they're set to 600. -- Otherwise, they're set to 600.
hasPrivContent :: IsContext c => FilePath -> c -> Property hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo
hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f
-- | Like hasPrivContent, but allows specifying a source -- | Like hasPrivContent, but allows specifying a source
-- for PrivData, rather than using PrivDataSourceFile. -- for PrivData, rather than using PrivDataSourceFile.
hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
hasPrivContentFrom = hasPrivContent' writeFileProtected hasPrivContentFrom = hasPrivContent' writeFileProtected
-- | Leaves the file at its default or current mode, -- | Leaves the file at its default or current mode,
-- allowing "private" data to be read. -- allowing "private" data to be read.
-- --
-- Use with caution! -- Use with caution!
hasPrivContentExposed :: IsContext c => FilePath -> c -> Property hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo
hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f
hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
hasPrivContentExposedFrom = hasPrivContent' writeFile hasPrivContentExposedFrom = hasPrivContent' writeFile
hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property HasInfo
hasPrivContent' writer source f context = hasPrivContent' writer source f context =
withPrivData source context $ \getcontent -> withPrivData source context $ \getcontent ->
property desc $ getcontent $ \privcontent -> property desc $ getcontent $ \privcontent ->
@ -45,10 +45,10 @@ hasPrivContent' writer source f context =
desc = "privcontent " ++ f desc = "privcontent " ++ f
-- | 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 NoInfo
f `containsLine` l = f `containsLines` [l] f `containsLine` l = f `containsLines` [l]
containsLines :: FilePath -> [Line] -> Property containsLines :: FilePath -> [Line] -> Property NoInfo
f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
where where
go content = content ++ filter (`notElem` content) ls go content = content ++ filter (`notElem` content) ls
@ -56,17 +56,17 @@ f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
-- | Ensures that a line is not present in a file. -- | Ensures that a line is not present in a file.
-- Note that the file is ensured to exist, so if it doesn't, an empty -- Note that the file is ensured to exist, so if it doesn't, an empty
-- file will be written. -- file will be written.
lacksLine :: FilePath -> Line -> Property lacksLine :: FilePath -> Line -> Property NoInfo
f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-- | Removes a file. Does not remove symlinks or non-plain-files. -- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property notPresent :: FilePath -> Property NoInfo
notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ 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 NoInfo
fileProperty = fileProperty' writeFile fileProperty = fileProperty' writeFile
fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
where where
go True = do go True = do
@ -86,12 +86,12 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
setOwnerAndGroup f' (fileOwner s) (fileGroup s) setOwnerAndGroup f' (fileOwner s) (fileGroup s)
-- | Ensures a directory exists. -- | Ensures a directory exists.
dirExists :: FilePath -> Property dirExists :: FilePath -> Property NoInfo
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. -- | Ensures that a file/dir has the specified owner and group.
ownerGroup :: FilePath -> UserName -> GroupName -> Property ownerGroup :: FilePath -> UserName -> GroupName -> Property NoInfo
ownerGroup f owner group = property (f ++ " owner " ++ og) $ do ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
r <- ensureProperty $ cmdProperty "chown" [og, f] r <- ensureProperty $ cmdProperty "chown" [og, f]
if r == FailedChange if r == FailedChange
@ -101,7 +101,7 @@ ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
og = owner ++ ":" ++ group og = owner ++ ":" ++ group
-- | Ensures that a file/dir has the specfied mode. -- | Ensures that a file/dir has the specfied mode.
mode :: FilePath -> FileMode -> Property mode :: FilePath -> FileMode -> Property NoInfo
mode f v = property (f ++ " mode " ++ show v) $ do mode f v = property (f ++ " mode " ++ show v) $ do
liftIO $ modifyFileMode f (\_old -> v) liftIO $ modifyFileMode f (\_old -> v)
noChange noChange

View File

@ -22,10 +22,10 @@ import Utility.SafeCommand
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
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["iptables"] installed = Apt.installed ["iptables"]
rule :: Chain -> Target -> Rules -> Property rule :: Chain -> Target -> Rules -> Property NoInfo
rule c t rs = property ("firewall rule: " <> show r) addIpTable rule c t rs = property ("firewall rule: " <> show r) addIpTable
where where
r = Rule c t rs r = Rule c t rs

View File

@ -13,7 +13,7 @@ import Data.List
-- --
-- Note that reverting this property does not remove or stop inetd. -- Note that reverting this property does not remove or stop inetd.
daemonRunning :: FilePath -> RevertableProperty daemonRunning :: FilePath -> RevertableProperty
daemonRunning exportdir = RevertableProperty setup unsetup daemonRunning exportdir = setup <!> unsetup
where where
setup = containsLine conf (mkl "tcp4") setup = containsLine conf (mkl "tcp4")
`requires` `requires`
@ -48,7 +48,7 @@ daemonRunning exportdir = RevertableProperty setup unsetup
, exportdir , exportdir
] ]
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["git"] installed = Apt.installed ["git"]
type RepoUrl = String type RepoUrl = String
@ -62,7 +62,7 @@ type Branch = String
-- it will be recursively deleted first. -- it will be recursively deleted first.
-- --
-- A branch can be specified, to check out. -- A branch can be specified, to check out.
cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo
cloned owner url dir mbranch = check originurl (property desc checkout) cloned owner url dir mbranch = check originurl (property desc checkout)
`requires` installed `requires` installed
where where
@ -98,7 +98,7 @@ isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--re
data GitShared = Shared GroupName | SharedAll | NotShared data GitShared = Shared GroupName | SharedAll | NotShared
bareRepo :: FilePath -> UserName -> GitShared -> Property bareRepo :: FilePath -> UserName -> GitShared -> Property NoInfo
bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $
dirExists repo : case gitshared of dirExists repo : case gitshared of
NotShared -> NotShared ->

View File

@ -6,7 +6,7 @@ import Utility.FileSystemEncoding
import System.PosixCompat import System.PosixCompat
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["gnupg"] installed = Apt.installed ["gnupg"]
-- A numeric id, or a description of the key, in a form understood by gpg. -- A numeric id, or a description of the key, in a form understood by gpg.
@ -20,7 +20,7 @@ newtype GpgKeyId = GpgKeyId { getGpgKeyId :: String }
-- --
-- Recommend only using this for low-value dedicated role keys. -- Recommend only using this for low-value dedicated role keys.
-- No attempt has been made to scrub the key out of memory once it's used. -- No attempt has been made to scrub the key out of memory once it's used.
keyImported :: GpgKeyId -> UserName -> Property keyImported :: GpgKeyId -> UserName -> Property HasInfo
keyImported (GpgKeyId keyid) user = flagFile' prop genflag keyImported (GpgKeyId keyid) user = flagFile' prop genflag
`requires` installed `requires` installed
where where

View File

@ -4,7 +4,7 @@ import Propellor
type GID = Int type GID = Int
exists :: GroupName -> Maybe GID -> Property exists :: GroupName -> Maybe GID -> Property NoInfo
exists group' mgid = check test (cmdProperty "addgroup" $ args mgid) exists group' mgid = check test (cmdProperty "addgroup" $ args mgid)
`describe` unwords ["group", group'] `describe` unwords ["group", group']
where where

View File

@ -21,7 +21,7 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- This includes running update-grub, so that the grub boot menu is -- This includes running update-grub, so that the grub boot menu is
-- created. It will be automatically updated when kernel packages are -- created. It will be automatically updated when kernel packages are
-- installed. -- installed.
installed :: BIOS -> Property installed :: BIOS -> Property NoInfo
installed bios = installed bios =
Apt.installed [pkg] `describe` "grub package installed" Apt.installed [pkg] `describe` "grub package installed"
`before` `before`
@ -43,7 +43,7 @@ installed bios =
-- on the device; it always does the work to reinstall it. It's a good idea -- on the device; it always does the work to reinstall it. It's a good idea
-- to arrange for this property to only run once, by eg making it be run -- to arrange for this property to only run once, by eg making it be run
-- onChange after OS.cleanInstallOnce. -- onChange after OS.cleanInstallOnce.
boots :: OSDevice -> Property boots :: OSDevice -> Property NoInfo
boots dev = cmdProperty "grub-install" [dev] boots dev = cmdProperty "grub-install" [dev]
`describe` ("grub boots " ++ dev) `describe` ("grub boots " ++ dev)
@ -55,7 +55,7 @@ boots dev = cmdProperty "grub-install" [dev]
-- --
-- The rootdev should be in the form "hd0", while the bootdev is in the form -- The rootdev should be in the form "hd0", while the bootdev is in the form
-- "xen/xvda". -- "xen/xvda".
chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo
chainPVGrub rootdev bootdev timeout = combineProperties desc chainPVGrub rootdev bootdev timeout = combineProperties desc
[ File.dirExists "/boot/grub" [ File.dirExists "/boot/grub"
, "/boot/grub/menu.lst" `File.hasContent` , "/boot/grub/menu.lst" `File.hasContent`

View File

@ -6,7 +6,7 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Property.User as User import qualified Propellor.Property.User as User
-- Clean up a system as installed by cloudatcost.com -- Clean up a system as installed by cloudatcost.com
decruft :: Property decruft :: Property NoInfo
decruft = propertyList "cloudatcost cleanup" decruft = propertyList "cloudatcost cleanup"
[ Hostname.sane [ Hostname.sane
, "worked around grub/lvm boot bug #743126" ==> , "worked around grub/lvm boot bug #743126" ==>

View File

@ -18,7 +18,7 @@ import Data.List
-- If the power is cycled, the non-distro kernel still boots up. -- If the power is cycled, the non-distro kernel still boots up.
-- So, this property also checks if the running kernel is present in /boot, -- So, this property also checks if the running kernel is present in /boot,
-- and if not, reboots immediately into a distro kernel. -- and if not, reboots immediately into a distro kernel.
distroKernel :: Property distroKernel :: Property NoInfo
distroKernel = propertyList "digital ocean distro kernel hack" distroKernel = propertyList "digital ocean distro kernel hack"
[ Apt.installed ["grub-pc", "kexec-tools", "file"] [ Apt.installed ["grub-pc", "kexec-tools", "file"]
, "/etc/default/kexec" `File.containsLines` , "/etc/default/kexec" `File.containsLines`

View File

@ -6,5 +6,5 @@ import qualified Propellor.Property.Grub as Grub
-- | Linode's pv-grub-x86_64 does not currently support booting recent -- | Linode's pv-grub-x86_64 does not currently support booting recent
-- Debian kernels compressed with xz. This sets up pv-grub chaing to enable -- Debian kernels compressed with xz. This sets up pv-grub chaing to enable
-- it. -- it.
chainPVGrub :: Grub.TimeoutSecs -> Property chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo
chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda" chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"

View File

@ -17,10 +17,10 @@ import Data.List
-- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any -- Also, the </etc/hosts> 127.0.0.1 line is set to localhost. Putting any
-- other hostnames there is not best practices and can lead to annoying -- other hostnames there is not best practices and can lead to annoying
-- messages from eg, apache. -- messages from eg, apache.
sane :: Property sane :: Property NoInfo
sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName) sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName)
setTo :: HostName -> Property setTo :: HostName -> Property NoInfo
setTo hn = combineProperties desc go setTo hn = combineProperties desc go
where where
desc = "hostname " ++ hn desc = "hostname " ++ hn
@ -46,7 +46,7 @@ setTo hn = combineProperties desc go
-- | Makes </etc/resolv.conf> contain search and domain lines for -- | Makes </etc/resolv.conf> contain search and domain lines for
-- the domain that the hostname is in. -- the domain that the hostname is in.
searchDomain :: Property searchDomain :: Property NoInfo
searchDomain = property desc (ensureProperty . go =<< asks hostName) searchDomain = property desc (ensureProperty . go =<< asks hostName)
where where
desc = "resolv.conf search and domain configured" desc = "resolv.conf search and domain configured"

View File

@ -4,7 +4,7 @@ import qualified Propellor.Property.Systemd as Systemd
import Utility.DataUnits import Utility.DataUnits
-- | Configures journald, restarting it so the changes take effect. -- | Configures journald, restarting it so the changes take effect.
configured :: Systemd.Option -> String -> Property configured :: Systemd.Option -> String -> Property NoInfo
configured option value = configured option value =
Systemd.configured "/etc/systemd/journald.conf" option value Systemd.configured "/etc/systemd/journald.conf" option value
`onChange` Systemd.restarted "systemd-journald" `onChange` Systemd.restarted "systemd-journald"
@ -13,27 +13,27 @@ configured option value =
-- Examples: "100 megabytes" or "0.5tb" -- Examples: "100 megabytes" or "0.5tb"
type DataSize = String type DataSize = String
configuredSize :: Systemd.Option -> DataSize -> Property configuredSize :: Systemd.Option -> DataSize -> Property NoInfo
configuredSize option s = case readSize dataUnits s of configuredSize option s = case readSize dataUnits s of
Just sz -> configured option (systemdSizeUnits sz) Just sz -> configured option (systemdSizeUnits sz)
Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange
systemMaxUse :: DataSize -> Property systemMaxUse :: DataSize -> Property NoInfo
systemMaxUse = configuredSize "SystemMaxUse" systemMaxUse = configuredSize "SystemMaxUse"
runtimeMaxUse :: DataSize -> Property runtimeMaxUse :: DataSize -> Property NoInfo
runtimeMaxUse = configuredSize "RuntimeMaxUse" runtimeMaxUse = configuredSize "RuntimeMaxUse"
systemKeepFree :: DataSize -> Property systemKeepFree :: DataSize -> Property NoInfo
systemKeepFree = configuredSize "SystemKeepFree" systemKeepFree = configuredSize "SystemKeepFree"
runtimeKeepFree :: DataSize -> Property runtimeKeepFree :: DataSize -> Property NoInfo
runtimeKeepFree = configuredSize "RuntimeKeepFree" runtimeKeepFree = configuredSize "RuntimeKeepFree"
systemMaxFileSize :: DataSize -> Property systemMaxFileSize :: DataSize -> Property NoInfo
systemMaxFileSize = configuredSize "SystemMaxFileSize" systemMaxFileSize = configuredSize "SystemMaxFileSize"
runtimeMaxFileSize :: DataSize -> Property runtimeMaxFileSize :: DataSize -> Property NoInfo
runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize" runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize"
-- Generates size units as used in journald.conf. -- Generates size units as used in journald.conf.

View File

@ -0,0 +1,63 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Propellor.Property.List (
PropertyList(..),
PropertyListType,
) where
import Propellor.Types
import Propellor.Engine
import Propellor.PropAccum
import Data.Monoid
class PropertyList l where
-- | Combines a list of properties, resulting in a single property
-- that when run will run each property in the list in turn,
-- and print out the description of each as it's run. Does not stop
-- on failure; does propigate overall success/failure.
--
-- Note that Property HasInfo and Property NoInfo are not the same
-- type, and so cannot be mixed in a list. To make a list of
-- mixed types, which can also include RevertableProperty,
-- use `props`:
--
-- > propertyList "foo" $ props
-- > & someproperty
-- > ! oldproperty
-- > & otherproperty
propertyList :: Desc -> l -> Property (PropertyListType l)
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn. Stops if a property fails.
combineProperties :: Desc -> l -> Property (PropertyListType l)
-- | Type level function to calculate whether a PropertyList has Info.
type family PropertyListType t
type instance PropertyListType [Property HasInfo] = HasInfo
type instance PropertyListType [Property NoInfo] = NoInfo
type instance PropertyListType PropList = HasInfo
instance PropertyList [Property NoInfo] where
propertyList desc ps = simpleProperty desc (ensureProperties ps) ps
combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps
instance PropertyList [Property HasInfo] where
-- It's ok to use ignoreInfo here, because the ps are made the
-- child properties of the property, and so their info is visible
-- that way.
propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps
combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps
instance PropertyList PropList where
propertyList desc = propertyList desc . getProperties
combineProperties desc = combineProperties desc . getProperties
combineSatisfy :: [Property i] -> Result -> Propellor Result
combineSatisfy [] rs = return rs
combineSatisfy (l:ls) rs = do
r <- ensureProperty $ ignoreInfo l
case r of
FailedChange -> return FailedChange
_ -> combineSatisfy ls (r <> rs)

View File

@ -5,7 +5,7 @@ import Propellor.Property.File
type Interface = String type Interface = String
ifUp :: Interface -> Property ifUp :: Interface -> Property NoInfo
ifUp iface = cmdProperty "ifup" [iface] ifUp iface = cmdProperty "ifup" [iface]
-- | Resets /etc/network/interfaces to a clean and empty state, -- | Resets /etc/network/interfaces to a clean and empty state,
@ -15,7 +15,7 @@ ifUp iface = cmdProperty "ifup" [iface]
-- This can be used as a starting point to defining other interfaces. -- This can be used as a starting point to defining other interfaces.
-- --
-- No interfaces are brought up or down by this property. -- No interfaces are brought up or down by this property.
cleanInterfacesFile :: Property cleanInterfacesFile :: Property NoInfo
cleanInterfacesFile = hasContent interfacesFile cleanInterfacesFile = hasContent interfacesFile
[ "# Deployed by propellor, do not edit." [ "# Deployed by propellor, do not edit."
, "" , ""
@ -38,7 +38,7 @@ cleanInterfacesFile = hasContent interfacesFile
-- --
-- (ipv6 addresses are not included because it's assumed they come up -- (ipv6 addresses are not included because it's assumed they come up
-- automatically in most situations.) -- automatically in most situations.)
static :: Interface -> Property static :: Interface -> Property NoInfo
static iface = check (not <$> doesFileExist f) setup static iface = check (not <$> doesFileExist f) setup
`describe` desc `describe` desc
`requires` interfacesDEnabled `requires` interfacesDEnabled
@ -69,7 +69,7 @@ static iface = check (not <$> doesFileExist f) setup
_ -> Nothing _ -> Nothing
-- | 6to4 ipv6 connection, should work anywhere -- | 6to4 ipv6 connection, should work anywhere
ipv6to4 :: Property ipv6to4 :: Property NoInfo
ipv6to4 = hasContent (interfaceDFile "sit0") ipv6to4 = hasContent (interfaceDFile "sit0")
[ "# Deployed by propellor, do not edit." [ "# Deployed by propellor, do not edit."
, "iface sit0 inet6 static" , "iface sit0 inet6 static"
@ -90,6 +90,6 @@ interfaceDFile :: Interface -> FilePath
interfaceDFile iface = "/etc/network/interfaces.d" </> iface interfaceDFile iface = "/etc/network/interfaces.d" </> iface
-- | Ensures that files in the the interfaces.d directory are used. -- | Ensures that files in the the interfaces.d directory are used.
interfacesDEnabled :: Property interfacesDEnabled :: Property NoInfo
interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d" interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d"
`describe` "interfaces.d directory enabled" `describe` "interfaces.d directory enabled"

View File

@ -9,7 +9,7 @@ import System.Posix.Files
type ConfigFile = [String] type ConfigFile = [String]
siteEnabled :: HostName -> ConfigFile -> RevertableProperty siteEnabled :: HostName -> ConfigFile -> RevertableProperty
siteEnabled hn cf = RevertableProperty enable disable siteEnabled hn cf = enable <!> disable
where where
enable = check test prop enable = check test prop
`describe` ("nginx site enabled " ++ hn) `describe` ("nginx site enabled " ++ hn)
@ -27,7 +27,7 @@ siteEnabled hn cf = RevertableProperty enable disable
`requires` installed `requires` installed
`onChange` reloaded `onChange` reloaded
siteAvailable :: HostName -> ConfigFile -> Property siteAvailable :: HostName -> ConfigFile -> Property NoInfo
siteAvailable hn cf = ("nginx site available " ++ hn) ==> siteAvailable hn cf = ("nginx site available " ++ hn) ==>
siteCfg hn `File.hasContent` (comment : cf) siteCfg hn `File.hasContent` (comment : cf)
where where
@ -42,11 +42,11 @@ siteVal hn = "/etc/nginx/sites-enabled/" ++ hn
siteValRelativeCfg :: HostName -> FilePath siteValRelativeCfg :: HostName -> FilePath
siteValRelativeCfg hn = "../sites-available/" ++ hn siteValRelativeCfg hn = "../sites-available/" ++ hn
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["nginx"] installed = Apt.installed ["nginx"]
restarted :: Property restarted :: Property NoInfo
restarted = Service.restarted "nginx" restarted = Service.restarted "nginx"
reloaded :: Property reloaded :: Property NoInfo
reloaded = Service.reloaded "nginx" reloaded = Service.reloaded "nginx"

View File

@ -65,7 +65,7 @@ import Control.Exception (throw)
-- > & User.accountFor "joey" -- > & User.accountFor "joey"
-- > & User.hasSomePassword "joey" -- > & User.hasSomePassword "joey"
-- > -- rest of system properties here -- > -- rest of system properties here
cleanInstallOnce :: Confirmation -> Property cleanInstallOnce :: Confirmation -> Property NoInfo
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation go `requires` confirmed "clean install confirmed" confirmation
where where
@ -89,10 +89,10 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
(Just u@(System (Ubuntu _) _)) -> debootstrap u (Just u@(System (Ubuntu _) _)) -> debootstrap u
_ -> error "os is not declared to be Debian or Ubuntu" _ -> error "os is not declared to be Debian or Ubuntu"
debootstrap targetos = ensureProperty $ toProp $ debootstrap targetos = ensureProperty $ fromJust $ toSimpleProp $
-- Ignore the os setting, and install debootstrap from -- Ignore the os setting, and install debootstrap from
-- source, since we don't know what OS we're running in yet. -- source, since we don't know what OS we're running in yet.
Debootstrap.built' Debootstrap.sourceInstall Debootstrap.built' (toProp Debootstrap.sourceInstall)
newOSDir targetos Debootstrap.DefaultConfig newOSDir targetos Debootstrap.DefaultConfig
-- debootstrap, I wish it was faster.. -- debootstrap, I wish it was faster..
-- TODO eatmydata to speed it up -- TODO eatmydata to speed it up
@ -180,7 +180,7 @@ massRename = go []
data Confirmation = Confirmed HostName data Confirmation = Confirmed HostName
confirmed :: Desc -> Confirmation -> Property confirmed :: Desc -> Confirmation -> Property NoInfo
confirmed desc (Confirmed c) = property desc $ do confirmed desc (Confirmed c) = property desc $ do
hostname <- asks hostName hostname <- asks hostName
if hostname /= c if hostname /= c
@ -192,7 +192,7 @@ confirmed desc (Confirmed c) = property desc $ do
-- | </etc/network/interfaces> is configured to bring up the network -- | </etc/network/interfaces> is configured to bring up the network
-- interface that currently has a default route configured, using -- interface that currently has a default route configured, using
-- the same (static) IP address. -- the same (static) IP address.
preserveNetwork :: Property preserveNetwork :: Property NoInfo
preserveNetwork = go `requires` Network.cleanInterfacesFile preserveNetwork = go `requires` Network.cleanInterfacesFile
where where
go = property "preserve network configuration" $ do go = property "preserve network configuration" $ do
@ -206,7 +206,7 @@ preserveNetwork = go `requires` Network.cleanInterfacesFile
return FailedChange return FailedChange
-- | </etc/resolv.conf> is copied from the old OS -- | </etc/resolv.conf> is copied from the old OS
preserveResolvConf :: Property preserveResolvConf :: Property NoInfo
preserveResolvConf = check (fileExist oldloc) $ preserveResolvConf = check (fileExist oldloc) $
property (newloc ++ " copied from old OS") $ do property (newloc ++ " copied from old OS") $ do
ls <- liftIO $ lines <$> readFile oldloc ls <- liftIO $ lines <$> readFile oldloc
@ -218,7 +218,7 @@ preserveResolvConf = check (fileExist oldloc) $
-- | </root/.ssh/authorized_keys> has added to it any ssh keys that -- | </root/.ssh/authorized_keys> has added to it any ssh keys that
-- were authorized in the old OS. Any other contents of the file are -- were authorized in the old OS. Any other contents of the file are
-- retained. -- retained.
preserveRootSshAuthorized :: Property preserveRootSshAuthorized :: Property NoInfo
preserveRootSshAuthorized = check (fileExist oldloc) $ preserveRootSshAuthorized = check (fileExist oldloc) $
property (newloc ++ " copied from old OS") $ do property (newloc ++ " copied from old OS") $ do
ks <- liftIO $ lines <$> readFile oldloc ks <- liftIO $ lines <$> readFile oldloc
@ -228,7 +228,7 @@ preserveRootSshAuthorized = check (fileExist oldloc) $
oldloc = oldOSDir ++ newloc oldloc = oldOSDir ++ newloc
-- Removes the old OS's backup from </old-os> -- Removes the old OS's backup from </old-os>
oldOSRemoved :: Confirmation -> Property oldOSRemoved :: Confirmation -> Property NoInfo
oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $ oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
go `requires` confirmed "old OS backup removal confirmed" confirmation go `requires` confirmed "old OS backup removal confirmed" confirmation
where where

View File

@ -36,7 +36,7 @@ data NumClients = OnlyClient | MultipleClients
-- > `requires` Ssh.keyImported SshRsa "root" (Context hostname) -- > `requires` Ssh.keyImported SshRsa "root" (Context hostname)
-- --
-- How awesome is that? -- How awesome is that?
backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo
backup dir crontimes params numclients = backup dir crontimes params numclients =
backup' dir crontimes params numclients backup' dir crontimes params numclients
`requires` restored dir params `requires` restored dir params
@ -46,7 +46,7 @@ backup dir crontimes params numclients =
-- --
-- The gpg secret key will be automatically imported -- The gpg secret key will be automatically imported
-- into root's keyring using Propellor.Property.Gpg.keyImported -- into root's keyring using Propellor.Property.Gpg.keyImported
backupEncrypted :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property backupEncrypted :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo
backupEncrypted dir crontimes params numclients keyid = backupEncrypted dir crontimes params numclients keyid =
backup dir crontimes params' numclients backup dir crontimes params' numclients
`requires` Gpg.keyImported keyid "root" `requires` Gpg.keyImported keyid "root"
@ -54,7 +54,7 @@ backupEncrypted dir crontimes params numclients keyid =
params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params
-- | Does a backup, but does not automatically restore. -- | Does a backup, but does not automatically restore.
backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo
backup' dir crontimes params numclients = cronjob `describe` desc backup' dir crontimes params numclients = cronjob `describe` desc
where where
desc = dir ++ " backed up by obnam" desc = dir ++ " backed up by obnam"
@ -80,7 +80,7 @@ backup' dir crontimes params numclients = cronjob `describe` desc
-- --
-- The restore is performed atomically; restoring to a temp directory -- The restore is performed atomically; restoring to a temp directory
-- and then moving it to the directory. -- and then moving it to the directory.
restored :: FilePath -> [ObnamParam] -> Property restored :: FilePath -> [ObnamParam] -> Property NoInfo
restored dir params = property (dir ++ " restored by obnam") go restored dir params = property (dir ++ " restored by obnam") go
`requires` installed `requires` installed
where where
@ -108,17 +108,17 @@ restored dir params = property (dir ++ " restored by obnam") go
, return FailedChange , return FailedChange
) )
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["obnam"] installed = Apt.installed ["obnam"]
-- | Ensures that a recent version of obnam gets installed. -- | Ensures that a recent version of obnam gets installed.
-- --
-- Only does anything for Debian Stable. -- Only does anything for Debian Stable.
latestVersion :: Property latestVersion :: Property NoInfo
latestVersion = withOS "obnam latest version" $ \o -> case o of latestVersion = withOS "obnam latest version" $ \o -> case o of
(Just (System (Debian suite) _)) | isStable suite -> ensureProperty $ (Just (System (Debian suite) _)) | isStable suite -> ensureProperty $
Apt.setSourcesListD (stablesources suite) "obnam" Apt.setSourcesListD (stablesources suite) "obnam"
`requires` toProp (Apt.trustsKey key) `requires` (fromJust (toSimpleProp (Apt.trustsKey key)))
_ -> noChange _ -> noChange
where where
stablesources suite = stablesources suite =

View File

@ -7,8 +7,8 @@ import qualified Propellor.Property.Service as Service
import Data.List import Data.List
providerFor :: [UserName] -> String -> Property providerFor :: [UserName] -> String -> Property HasInfo
providerFor users baseurl = propertyList desc $ providerFor users baseurl = propertyList desc $ map toProp
[ Apt.serviceInstalledRunning "apache2" [ Apt.serviceInstalledRunning "apache2"
, Apt.installed ["simpleid"] , Apt.installed ["simpleid"]
`onChange` Service.restarted "apache2" `onChange` Service.restarted "apache2"

View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Postfix where module Propellor.Property.Postfix where
import Propellor import Propellor
@ -9,13 +11,13 @@ import qualified Data.Map as M
import Data.List import Data.List
import Data.Char import Data.Char
installed :: Property installed :: Property NoInfo
installed = Apt.serviceInstalledRunning "postfix" installed = Apt.serviceInstalledRunning "postfix"
restarted :: Property restarted :: Property NoInfo
restarted = Service.restarted "postfix" restarted = Service.restarted "postfix"
reloaded :: Property reloaded :: Property NoInfo
reloaded = Service.reloaded "postfix" reloaded = Service.reloaded "postfix"
-- | Configures postfix as a satellite system, which -- | Configures postfix as a satellite system, which
@ -24,7 +26,7 @@ reloaded = Service.reloaded "postfix"
-- The smarthost may refuse to relay mail on to other domains, without -- The smarthost may refuse to relay mail on to other domains, without
-- futher coniguration/keys. But this should be enough to get cron job -- futher coniguration/keys. But this should be enough to get cron job
-- mail flowing to a place where it will be seen. -- mail flowing to a place where it will be seen.
satellite :: Property satellite :: Property NoInfo
satellite = check (not <$> mainCfIsSet "relayhost") setup satellite = check (not <$> mainCfIsSet "relayhost") setup
`requires` installed `requires` installed
where where
@ -45,13 +47,17 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup
-- | Sets up a file by running a property (which the filename is passed -- | Sets up a file by running a property (which the filename is passed
-- to). If the setup property makes a change, postmap will be run on the -- to). If the setup property makes a change, postmap will be run on the
-- file, and postfix will be reloaded. -- file, and postfix will be reloaded.
mappedFile :: FilePath -> (FilePath -> Property) -> Property mappedFile
:: Combines (Property x) (Property NoInfo)
=> FilePath
-> (FilePath -> Property x)
-> Property (CInfo x NoInfo)
mappedFile f setup = setup f mappedFile f setup = setup f
`onChange` cmdProperty "postmap" [f] `onChange` cmdProperty "postmap" [f]
-- | Run newaliases command, which should be done after changing -- | Run newaliases command, which should be done after changing
-- </etc/aliases>. -- </etc/aliases>.
newaliases :: Property newaliases :: Property NoInfo
newaliases = trivial $ cmdProperty "newaliases" [] newaliases = trivial $ cmdProperty "newaliases" []
-- | The main config file for postfix. -- | The main config file for postfix.
@ -59,7 +65,7 @@ mainCfFile :: FilePath
mainCfFile = "/etc/postfix/main.cf" mainCfFile = "/etc/postfix/main.cf"
-- | Sets a main.cf name=value pair. Does not reload postfix immediately. -- | Sets a main.cf name=value pair. Does not reload postfix immediately.
mainCf :: (String, String) -> Property mainCf :: (String, String) -> Property NoInfo
mainCf (name, value) = check notset set mainCf (name, value) = check notset set
`describe` ("postfix main.cf " ++ setting) `describe` ("postfix main.cf " ++ setting)
where where
@ -96,7 +102,7 @@ mainCfIsSet name = do
-- --
-- Note that multiline configurations that continue onto the next line -- Note that multiline configurations that continue onto the next line
-- are not currently supported. -- are not currently supported.
dedupMainCf :: Property dedupMainCf :: Property NoInfo
dedupMainCf = fileProperty "postfix main.cf dedupped" dedupCf mainCfFile dedupMainCf = fileProperty "postfix main.cf dedupped" dedupCf mainCfFile
dedupCf :: [String] -> [String] dedupCf :: [String] -> [String]

View File

@ -11,7 +11,7 @@ type ConfigFile = [String]
type Conf = String type Conf = String
confEnabled :: Conf -> ConfigFile -> RevertableProperty confEnabled :: Conf -> ConfigFile -> RevertableProperty
confEnabled conf cf = RevertableProperty enable disable confEnabled conf cf = enable <!> disable
where where
enable = check test prop enable = check test prop
`describe` ("prosody conf enabled " ++ conf) `describe` ("prosody conf enabled " ++ conf)
@ -30,7 +30,7 @@ confEnabled conf cf = RevertableProperty enable disable
`requires` installed `requires` installed
`onChange` reloaded `onChange` reloaded
confAvailable :: Conf -> ConfigFile -> Property confAvailable :: Conf -> ConfigFile -> Property NoInfo
confAvailable conf cf = ("prosody conf available " ++ conf) ==> confAvailable conf cf = ("prosody conf available " ++ conf) ==>
confAvailPath conf `File.hasContent` (comment : cf) confAvailPath conf `File.hasContent` (comment : cf)
where where
@ -42,11 +42,11 @@ confAvailPath conf = "/etc/prosody/conf.avail" </> conf <.> "cfg.lua"
confValPath :: Conf -> FilePath confValPath :: Conf -> FilePath
confValPath conf = "/etc/prosody/conf.d" </> conf <.> "cfg.lua" confValPath conf = "/etc/prosody/conf.d" </> conf <.> "cfg.lua"
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["prosody"] installed = Apt.installed ["prosody"]
restarted :: Property restarted :: Property NoInfo
restarted = Service.restarted "prosody" restarted = Service.restarted "prosody"
reloaded :: Property reloaded :: Property NoInfo
reloaded = Service.reloaded "prosody" reloaded = Service.reloaded "prosody"

View File

@ -3,7 +3,7 @@ module Propellor.Property.Reboot where
import Propellor import Propellor
import Utility.SafeCommand import Utility.SafeCommand
now :: Property now :: Property NoInfo
now = cmdProperty "reboot" [] now = cmdProperty "reboot" []
`describe` "reboot now" `describe` "reboot now"
@ -14,7 +14,7 @@ now = cmdProperty "reboot" []
-- --
-- The reboot can be forced to run, which bypasses the init system. Useful -- The reboot can be forced to run, which bypasses the init system. Useful
-- if the init system might not be running for some reason. -- if the init system might not be running for some reason.
atEnd :: Bool -> (Result -> Bool) -> Property atEnd :: Bool -> (Result -> Bool) -> Property NoInfo
atEnd force resultok = property "scheduled reboot at end of propellor run" $ do atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
endAction "rebooting" atend endAction "rebooting" atend
return NoChange return NoChange

View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Scheduled module Propellor.Property.Scheduled
( period ( period
, periodParse , periodParse
@ -18,8 +20,8 @@ import qualified Data.Map as M
-- --
-- This uses the description of the Property to keep track of when it was -- This uses the description of the Property to keep track of when it was
-- last run. -- last run.
period :: Property -> Recurrance -> Property period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i
period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do
lasttime <- liftIO $ getLastChecked (propertyDesc prop) lasttime <- liftIO $ getLastChecked (propertyDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow t <- liftIO localNow
@ -34,7 +36,7 @@ period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy ->
desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
-- | Like period, but parse a human-friendly string. -- | Like period, but parse a human-friendly string.
periodParse :: Property -> String -> Property periodParse :: Property NoInfo -> String -> Property NoInfo
periodParse prop s = case toRecurrance s of periodParse prop s = case toRecurrance s of
Just recurrance -> period prop recurrance Just recurrance -> period prop recurrance
Nothing -> property "periodParse" $ do Nothing -> property "periodParse" $ do

View File

@ -12,16 +12,16 @@ type ServiceName = String
-- Note that due to the general poor state of init scripts, the best -- 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 -- we can do is try to start the service, and if it fails, assume
-- this means it's already running. -- this means it's already running.
running :: ServiceName -> Property running :: ServiceName -> Property NoInfo
running = signaled "start" "running" running = signaled "start" "running"
restarted :: ServiceName -> Property restarted :: ServiceName -> Property NoInfo
restarted = signaled "restart" "restarted" restarted = signaled "restart" "restarted"
reloaded :: ServiceName -> Property reloaded :: ServiceName -> Property NoInfo
reloaded = signaled "reload" "reloaded" reloaded = signaled "reload" "reloaded"
signaled :: String -> Desc -> ServiceName -> Property signaled :: String -> Desc -> ServiceName -> Property NoInfo
signaled cmd desc svc = property (desc ++ " " ++ svc) $ do signaled cmd desc svc = property (desc ++ " " ++ svc) $ do
void $ ensureProperty $ void $ ensureProperty $
scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]

View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.SiteSpecific.GitAnnexBuilder where module Propellor.Property.SiteSpecific.GitAnnexBuilder where
import Propellor import Propellor
@ -23,54 +25,56 @@ builddir = gitbuilderdir </> "build"
type TimeOut = String -- eg, 5h type TimeOut = String -- eg, 5h
autobuilder :: Architecture -> CronTimes -> TimeOut -> Property autobuilder :: Architecture -> CronTimes -> TimeOut -> Property HasInfo
autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
[ Apt.serviceInstalledRunning "cron" & Apt.serviceInstalledRunning "cron"
, Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $ & Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir
"git pull ; timeout " ++ timeout ++ " ./autobuild" ("git pull ; timeout " ++ timeout ++ " ./autobuild")
& rsyncpassword
where
context = Context ("gitannexbuilder " ++ arch)
pwfile = homedir </> "rsyncpassword"
-- The builduser account does not have a password set, -- The builduser account does not have a password set,
-- instead use the password privdata to hold the rsync server -- instead use the password privdata to hold the rsync server
-- password used to upload the built image. -- password used to upload the built image.
, withPrivData (Password builduser) context $ \getpw -> rsyncpassword = withPrivData (Password builduser) context $ \getpw ->
property "rsync password" $ getpw $ \pw -> do property "rsync password" $ getpw $ \pw -> do
oldpw <- liftIO $ catchDefaultIO "" $ oldpw <- liftIO $ catchDefaultIO "" $
readFileStrict pwfile readFileStrict pwfile
if pw /= oldpw if pw /= oldpw
then makeChange $ writeFile pwfile pw then makeChange $ writeFile pwfile pw
else noChange else noChange
]
where
context = Context ("gitannexbuilder " ++ arch)
pwfile = homedir </> "rsyncpassword"
tree :: Architecture -> Property tree :: Architecture -> Property HasInfo
tree buildarch = combineProperties "gitannexbuilder tree" tree buildarch = combineProperties "gitannexbuilder tree" $ props
[ Apt.installed ["git"] & Apt.installed ["git"]
-- gitbuilderdir directory already exists when docker volume is used, -- gitbuilderdir directory already exists when docker volume is used,
-- but with wrong owner. -- but with wrong owner.
, File.dirExists gitbuilderdir & File.dirExists gitbuilderdir
, File.ownerGroup gitbuilderdir builduser builduser & File.ownerGroup gitbuilderdir builduser builduser
, check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $ & gitannexbuildercloned
& builddircloned
where
gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $
userScriptProperty builduser userScriptProperty builduser
[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir
, "cd " ++ gitbuilderdir , "cd " ++ gitbuilderdir
, "git checkout " ++ buildarch , "git checkout " ++ buildarch
] ]
`describe` "gitbuilder setup" `describe` "gitbuilder setup"
, check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser builddircloned = check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser
[ "git clone git://git-annex.branchable.com/ " ++ builddir [ "git clone git://git-annex.branchable.com/ " ++ builddir
] ]
]
buildDepsApt :: Property buildDepsApt :: Property HasInfo
buildDepsApt = combineProperties "gitannexbuilder build deps" buildDepsApt = combineProperties "gitannexbuilder build deps" $ props
[ Apt.buildDep ["git-annex"] & Apt.buildDep ["git-annex"]
, Apt.installed ["liblockfile-simple-perl"] & Apt.installed ["liblockfile-simple-perl"]
, buildDepsNoHaskellLibs & buildDepsNoHaskellLibs
, "git-annex source build deps installed" ==> Apt.buildDepIn builddir & Apt.buildDepIn builddir
] `describe` "git-annex source build deps installed"
buildDepsNoHaskellLibs :: Property buildDepsNoHaskellLibs :: Property NoInfo
buildDepsNoHaskellLibs = Apt.installed buildDepsNoHaskellLibs = Apt.installed
["git", "rsync", "moreutils", "ca-certificates", ["git", "rsync", "moreutils", "ca-certificates",
"debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt", "debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt",
@ -82,7 +86,7 @@ buildDepsNoHaskellLibs = Apt.installed
-- Installs current versions of git-annex's deps from cabal, but only -- Installs current versions of git-annex's deps from cabal, but only
-- does so once. -- does so once.
cabalDeps :: Property cabalDeps :: Property NoInfo
cabalDeps = flagFile go cabalupdated cabalDeps = flagFile go cabalupdated
where where
go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"] go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"]
@ -108,7 +112,13 @@ androidAutoBuilderContainer dockerImage crontimes timeout =
& autobuilder "android" crontimes timeout & autobuilder "android" crontimes timeout
-- Android is cross-built in a Debian i386 container, using the Android NDK. -- Android is cross-built in a Debian i386 container, using the Android NDK.
androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container androidContainer
:: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i)))
=> (System -> Docker.Image)
-> Docker.ContainerName
-> Property i
-> FilePath
-> Docker.Container
androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
(dockerImage osver) (dockerImage osver)
& os osver & os osver

View File

@ -6,7 +6,7 @@ import Propellor.Property.User
import Utility.SafeCommand 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 NoInfo
installedFor user = check (not <$> hasGitDir user) $ installedFor user = check (not <$> hasGitDir user) $
property ("githome " ++ user) (go =<< liftIO (homedir user)) property ("githome " ++ user) (go =<< liftIO (homedir user))
`requires` Apt.installed ["git"] `requires` Apt.installed ["git"]

View File

@ -22,22 +22,18 @@ import Data.List
import System.Posix.Files import System.Posix.Files
import Data.String.Utils import Data.String.Utils
oldUseNetServer :: [Host] -> Property oldUseNetServer :: [Host] -> Property HasInfo
oldUseNetServer hosts = propertyList ("olduse.net server") oldUseNetServer hosts = propertyList "olduse.net server" $ props
[ oldUseNetInstalled "oldusenet-server" & oldUseNetInstalled "oldusenet-server"
, Obnam.latestVersion & Obnam.latestVersion
, Obnam.backup datadir "33 4 * * *" & oldUseNetBackup
[ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool)
, "--client-name=spool" (property "olduse.net spool in place" $ makeChange $ do
] Obnam.OnlyClient
`requires` Ssh.keyImported SshRsa "root" (Context "olduse.net")
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
, check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $
property "olduse.net spool in place" $ makeChange $ do
removeDirectoryRecursive newsspool removeDirectoryRecursive newsspool
createSymbolicLink (datadir </> "news") newsspool createSymbolicLink (datadir </> "news") newsspool
, Apt.installed ["leafnode"] )
, "/etc/news/leafnode/config" `File.hasContent` & Apt.installed ["leafnode"]
& "/etc/news/leafnode/config" `File.hasContent`
[ "# olduse.net configuration (deployed by propellor)" [ "# olduse.net configuration (deployed by propellor)"
, "expire = 1000000" -- no expiry via texpire , "expire = 1000000" -- no expiry via texpire
, "server = " -- no upstream server , "server = " -- no upstream server
@ -45,17 +41,22 @@ oldUseNetServer hosts = propertyList ("olduse.net server")
, "allowSTRANGERS = 42" -- lets anyone connect , "allowSTRANGERS = 42" -- lets anyone connect
, "nopost = 1" -- no new posting (just gather them) , "nopost = 1" -- no new posting (just gather them)
] ]
, "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" & "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"
, Apt.serviceInstalledRunning "openbsd-inetd" & Apt.serviceInstalledRunning "openbsd-inetd"
, File.notPresent "/etc/cron.daily/leafnode" & File.notPresent "/etc/cron.daily/leafnode"
, File.notPresent "/etc/cron.d/leafnode" & File.notPresent "/etc/cron.d/leafnode"
, Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";" & Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool expirecommand
& Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" uucpcommand
& Apache.siteEnabled "nntp.olduse.net" nntpcfg
where
newsspool = "/var/spool/news"
datadir = "/var/spool/oldusenet"
expirecommand = intercalate ";"
[ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm" [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm"
, "find -type d -empty | xargs --no-run-if-empty rmdir" , "find -type d -empty | xargs --no-run-if-empty rmdir"
] ]
, Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $ uucpcommand = "/usr/bin/uucp " ++ datadir
"/usr/bin/uucp " ++ datadir nntpcfg = apachecfg "nntp.olduse.net" False
, toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False
[ " DocumentRoot " ++ datadir ++ "/" [ " DocumentRoot " ++ datadir ++ "/"
, " <Directory " ++ datadir ++ "/>" , " <Directory " ++ datadir ++ "/>"
, " Options Indexes FollowSymlinks" , " Options Indexes FollowSymlinks"
@ -63,23 +64,25 @@ oldUseNetServer hosts = propertyList ("olduse.net server")
, Apache.allowAll , Apache.allowAll
, " </Directory>" , " </Directory>"
] ]
]
where
newsspool = "/var/spool/news"
datadir = "/var/spool/oldusenet"
oldUseNetShellBox :: Property oldUseNetBackup = Obnam.backup datadir "33 4 * * *"
oldUseNetShellBox = propertyList "olduse.net shellbox" [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
[ oldUseNetInstalled "oldusenet" , "--client-name=spool"
, Service.running "shellinabox" ] Obnam.OnlyClient
] `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net")
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
oldUseNetInstalled :: Apt.Package -> Property oldUseNetShellBox :: Property HasInfo
oldUseNetShellBox = propertyList "olduse.net shellbox" $ props
& oldUseNetInstalled "oldusenet"
& Service.running "shellinabox"
oldUseNetInstalled :: Apt.Package -> Property HasInfo
oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
propertyList ("olduse.net " ++ pkg) propertyList ("olduse.net " ++ pkg) $ props
[ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") & 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"
, scriptProperty & scriptProperty
[ "rm -rf /root/tmp/oldusenet" -- idenpotency [ "rm -rf /root/tmp/oldusenet" -- idenpotency
, "git clone git://olduse.net/ /root/tmp/oldusenet/source" , "git clone git://olduse.net/ /root/tmp/oldusenet/source"
, "cd /root/tmp/oldusenet/source/" , "cd /root/tmp/oldusenet/source/"
@ -88,12 +91,15 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
, "apt-get -fy install" -- dependencies , "apt-get -fy install" -- dependencies
, "rm -rf /root/tmp/oldusenet" , "rm -rf /root/tmp/oldusenet"
] `describe` "olduse.net built" ] `describe` "olduse.net built"
]
kgbServer :: Property HasInfo
kgbServer :: Property kgbServer = propertyList desc $ props
kgbServer = propertyList desc & installed
[ withOS desc $ \o -> case o of & File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
`onChange` Service.restarted "kgb-bot"
where
desc = "kgb.kitenet.net setup"
installed = withOS desc $ \o -> case o of
(Just (System (Debian Unstable) _)) -> (Just (System (Debian Unstable) _)) ->
ensureProperty $ propertyList desc ensureProperty $ propertyList desc
[ Apt.serviceInstalledRunning "kgb-bot" [ Apt.serviceInstalledRunning "kgb-bot"
@ -102,28 +108,22 @@ kgbServer = propertyList desc
`onChange` Service.running "kgb-bot" `onChange` Service.running "kgb-bot"
] ]
_ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"
, File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
`onChange` Service.restarted "kgb-bot"
]
where
desc = "kgb.kitenet.net setup"
mumbleServer :: [Host] -> Property mumbleServer :: [Host] -> Property HasInfo
mumbleServer hosts = combineProperties hn mumbleServer hosts = combineProperties hn $ props
[ Apt.serviceInstalledRunning "mumble-server" & Apt.serviceInstalledRunning "mumble-server"
, Obnam.latestVersion & Obnam.latestVersion
, Obnam.backup "/var/lib/mumble-server" "55 5 * * *" & Obnam.backup "/var/lib/mumble-server" "55 5 * * *"
[ "--repository=sftp://joey@usbackup.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam" [ "--repository=sftp://joey@usbackup.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam"
, "--client-name=mumble" , "--client-name=mumble"
] Obnam.OnlyClient ] Obnam.OnlyClient
`requires` Ssh.keyImported SshRsa "root" (Context hn) `requires` Ssh.keyImported SshRsa "root" (Context hn)
`requires` Ssh.knownHost hosts "usbackup.kitenet.net" "root" `requires` Ssh.knownHost hosts "usbackup.kitenet.net" "root"
, trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] & trivial (cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"])
]
where where
hn = "mumble.debian.net" hn = "mumble.debian.net"
obnamLowMem :: Property obnamLowMem :: Property NoInfo
obnamLowMem = combineProperties "obnam tuned for low memory use" obnamLowMem = combineProperties "obnam tuned for low memory use"
[ Obnam.latestVersion [ Obnam.latestVersion
, "/etc/obnam.conf" `File.containsLines` , "/etc/obnam.conf" `File.containsLines`
@ -135,10 +135,10 @@ obnamLowMem = combineProperties "obnam tuned for low memory use"
] ]
-- git.kitenet.net and git.joeyh.name -- git.kitenet.net and git.joeyh.name
gitServer :: [Host] -> Property gitServer :: [Host] -> Property HasInfo
gitServer hosts = propertyList "git.kitenet.net setup" gitServer hosts = propertyList "git.kitenet.net setup" $ props
[ Obnam.latestVersion & Obnam.latestVersion
, Obnam.backupEncrypted "/srv/git" "33 3 * * *" & Obnam.backupEncrypted "/srv/git" "33 3 * * *"
[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"
, "--client-name=wren" -- historical , "--client-name=wren" -- historical
] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1") ] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1")
@ -146,14 +146,14 @@ gitServer hosts = propertyList "git.kitenet.net setup"
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
`requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net") `requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net")
`requires` User.accountFor "family" `requires` User.accountFor "family"
, Apt.installed ["git", "rsync", "gitweb"] & Apt.installed ["git", "rsync", "gitweb"]
-- backport avoids channel flooding on branch merge -- backport avoids channel flooding on branch merge
, Apt.installedBackport ["kgb-client"] & Apt.installedBackport ["kgb-client"]
-- backport supports ssh event notification -- backport supports ssh event notification
, Apt.installedBackport ["git-annex"] & Apt.installedBackport ["git-annex"]
, File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext & File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext
, toProp $ Git.daemonRunning "/srv/git" & Git.daemonRunning "/srv/git"
, "/etc/gitweb.conf" `File.containsLines` & "/etc/gitweb.conf" `File.containsLines`
[ "$projectroot = '/srv/git';" [ "$projectroot = '/srv/git';"
, "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');" , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"
, "# disable snapshot download; overloads server" , "# disable snapshot download; overloads server"
@ -161,15 +161,14 @@ gitServer hosts = propertyList "git.kitenet.net setup"
] ]
`describe` "gitweb configured" `describe` "gitweb configured"
-- Repos push on to github. -- Repos push on to github.
, Ssh.knownHost hosts "github.com" "joey" & Ssh.knownHost hosts "github.com" "joey"
-- I keep the website used for gitweb checked into git.. -- I keep the website used for gitweb checked into git..
, Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing & Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
, website "git.kitenet.net" & website "git.kitenet.net"
, website "git.joeyh.name" & website "git.joeyh.name"
, toProp $ Apache.modEnabled "cgi" & Apache.modEnabled "cgi"
]
where where
website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True website hn = apacheSite hn True
[ " DocumentRoot /srv/web/git.kitenet.net/" [ " DocumentRoot /srv/web/git.kitenet.net/"
, " <Directory /srv/web/git.kitenet.net/>" , " <Directory /srv/web/git.kitenet.net/>"
, " Options Indexes ExecCGI FollowSymlinks" , " Options Indexes ExecCGI FollowSymlinks"
@ -188,18 +187,17 @@ gitServer hosts = propertyList "git.kitenet.net setup"
type AnnexUUID = String type AnnexUUID = String
-- | A website, with files coming from a git-annex repository. -- | A website, with files coming from a git-annex repository.
annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property HasInfo
annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props
[ Git.cloned "joey" origin dir Nothing & Git.cloned "joey" origin dir Nothing
`onChange` setup `onChange` setup
, alias hn & alias hn
, postupdatehook `File.hasContent` & postupdatehook `File.hasContent`
[ "#!/bin/sh" [ "#!/bin/sh"
, "exec git update-server-info" , "exec git update-server-info"
] `onChange` ] `onChange`
(postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) (postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes)))
, setupapache & setupapache
]
where where
dir = "/srv/web/" ++ hn dir = "/srv/web/" ++ hn
postupdatehook = dir </> ".git/hooks/post-update" postupdatehook = dir </> ".git/hooks/post-update"
@ -212,7 +210,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
, "git update-server-info" , "git update-server-info"
] ]
addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url
setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ setupapache = apacheSite hn True
[ " ServerAlias www."++hn [ " ServerAlias www."++hn
, "" , ""
, " DocumentRoot /srv/web/"++hn , " DocumentRoot /srv/web/"++hn
@ -230,6 +228,9 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
, " </Directory>" , " </Directory>"
] ]
apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty
apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle
apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
apachecfg hn withssl middle apachecfg hn withssl middle
| withssl = vhost False ++ vhost True | withssl = vhost False ++ vhost True
@ -268,20 +269,19 @@ mainhttpscert True =
, " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem"
] ]
gitAnnexDistributor :: Property gitAnnexDistributor :: Property HasInfo
gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
[ Apt.installed ["rsync"] & Apt.installed ["rsync"]
, File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") & File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor")
`onChange` Service.restarted "rsync" `onChange` Service.restarted "rsync"
, File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") & File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor")
`onChange` Service.restarted "rsync" `onChange` Service.restarted "rsync"
, "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" & "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"
`onChange` Service.running "rsync" `onChange` Service.running "rsync"
, endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"
, endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks"
-- git-annex distribution signing key -- git-annex distribution signing key
, Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey" & Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey"
]
where where
endpoint d = combineProperties ("endpoint " ++ d) endpoint d = combineProperties ("endpoint " ++ d)
[ File.dirExists d [ File.dirExists d
@ -289,11 +289,18 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync
] ]
-- Twitter, you kill us. -- Twitter, you kill us.
twitRss :: Property twitRss :: Property HasInfo
twitRss = combineProperties "twitter rss" twitRss = combineProperties "twitter rss" $ props
[ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing & Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing
, check (not <$> doesFileExist (dir </> "twitRss")) $ & check (not <$> doesFileExist (dir </> "twitRss")) compiled
userScriptProperty "joey" & feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"
& feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"
where
dir = "/srv/web/tmp.kitenet.net/twitrss"
crontime = "15 * * * *"
feed url desc = Cron.job desc crontime "joey" dir $
"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
compiled = userScriptProperty "joey"
[ "cd " ++ dir [ "cd " ++ dir
, "ghc --make twitRss" , "ghc --make twitRss"
] ]
@ -302,37 +309,28 @@ twitRss = combineProperties "twitter rss"
, "libghc-feed-dev" , "libghc-feed-dev"
, "libghc-tagsoup-dev" , "libghc-tagsoup-dev"
] ]
, feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"
, feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"
]
where
dir = "/srv/web/tmp.kitenet.net/twitrss"
crontime = "15 * * * *"
feed url desc = Cron.job desc crontime "joey" dir $
"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
-- Work around for expired ssl cert. -- Work around for expired ssl cert.
-- (no longer expired, TODO remove this and change urls) -- (no longer expired, TODO remove this and change urls)
pumpRss :: Property pumpRss :: Property NoInfo
pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/" pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/"
"wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null" "wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null"
ircBouncer :: Property ircBouncer :: Property HasInfo
ircBouncer = propertyList "IRC bouncer" ircBouncer = propertyList "IRC bouncer" $ props
[ Apt.installed ["znc"] & Apt.installed ["znc"]
, User.accountFor "znc" & User.accountFor "znc"
, File.dirExists (takeDirectory conf) & File.dirExists (takeDirectory conf)
, File.hasPrivContent conf anyContext & File.hasPrivContent conf anyContext
, File.ownerGroup conf "znc" "znc" & File.ownerGroup conf "znc" "znc"
, Cron.job "znconboot" "@reboot" "znc" "~" "znc" & Cron.job "znconboot" "@reboot" "znc" "~" "znc"
-- ensure running if it was not already -- ensure running if it was not already
, trivial $ userScriptProperty "znc" ["znc || true"] & trivial (userScriptProperty "znc" ["znc || true"])
`describe` "znc running" `describe` "znc running"
]
where where
conf = "/home/znc/.znc/configs/znc.conf" conf = "/home/znc/.znc/configs/znc.conf"
kiteShellBox :: Property kiteShellBox :: Property NoInfo
kiteShellBox = propertyList "kitenet.net shellinabox" kiteShellBox = propertyList "kitenet.net shellinabox"
[ Apt.installed ["shellinabox"] [ Apt.installed ["shellinabox"]
, File.hasContent "/etc/default/shellinabox" , File.hasContent "/etc/default/shellinabox"
@ -345,28 +343,34 @@ kiteShellBox = propertyList "kitenet.net shellinabox"
, Service.running "shellinabox" , Service.running "shellinabox"
] ]
githubBackup :: Property githubBackup :: Property HasInfo
githubBackup = propertyList "github-backup box" githubBackup = propertyList "github-backup box" $ props
[ Apt.installed ["github-backup", "moreutils"] & Apt.installed ["github-backup", "moreutils"]
, let f = "/home/joey/.github-keys" & githubKeys
in File.hasPrivContent f anyContext & Cron.niceJob "github-backup run" "30 4 * * *" "joey"
`onChange` File.ownerGroup f "joey" "joey" "/home/joey/lib/backup" backupcmd
, Cron.niceJob "github-backup run" "30 4 * * *" "joey" & Cron.niceJob "gitriddance" "30 4 * * *" "joey"
"/home/joey/lib/backup" $ intercalate "&&" $ "/home/joey/lib/backup" gitriddancecmd
where
backupcmd = intercalate "&&" $
[ "mkdir -p github" [ "mkdir -p github"
, "cd github" , "cd github"
, ". $HOME/.github-keys" , ". $HOME/.github-keys"
, "github-backup joeyh" , "github-backup joeyh"
] ]
, Cron.niceJob "gitriddance" "30 4 * * *" "joey" gitriddancecmd = intercalate "&&" $
"/home/joey/lib/backup" $ intercalate "&&" $
[ "cd github" [ "cd github"
, ". $HOME/.github-keys" , ". $HOME/.github-keys"
] ++ map gitriddance githubMirrors ] ++ map gitriddance githubMirrors
]
where
gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")"
githubKeys :: Property HasInfo
githubKeys =
let f = "/home/joey/.github-keys"
in File.hasPrivContent f anyContext
`onChange` File.ownerGroup f "joey" "joey"
-- these repos are only mirrored on github, I don't want -- these repos are only mirrored on github, I don't want
-- all the proprietary features -- all the proprietary features
githubMirrors :: [(String, String)] githubMirrors :: [(String, String)]
@ -380,12 +384,12 @@ githubMirrors =
where where
plzuseurl u = "please submit changes to " ++ u ++ " instead of using github pull requests" plzuseurl u = "please submit changes to " ++ u ++ " instead of using github pull requests"
rsyncNetBackup :: [Host] -> Property rsyncNetBackup :: [Host] -> Property NoInfo
rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" "30 5 * * *" rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" "30 5 * * *"
"joey" "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net" "joey" "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net"
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "joey" `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "joey"
backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property NoInfo
backupsBackedupTo hosts desthost destdir = Cron.niceJob desc backupsBackedupTo hosts desthost destdir = Cron.niceJob desc
"1 1 * * 3" "joey" "/" cmd "1 1 * * 3" "joey" "/" cmd
`requires` Ssh.knownHost hosts desthost "joey" `requires` Ssh.knownHost hosts desthost "joey"
@ -393,7 +397,7 @@ backupsBackedupTo hosts desthost destdir = Cron.niceJob desc
desc = "backups copied to " ++ desthost ++ " weekly" desc = "backups copied to " ++ desthost ++ " weekly"
cmd = "rsync -az --delete /home/joey/lib/backup " ++ desthost ++ ":" ++ destdir cmd = "rsync -az --delete /home/joey/lib/backup " ++ desthost ++ ":" ++ destdir
obnamRepos :: [String] -> Property obnamRepos :: [String] -> Property NoInfo
obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
(mkbase : map mkrepo rs) (mkbase : map mkrepo rs)
where where
@ -403,20 +407,20 @@ obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
mkdir d = File.dirExists d mkdir d = File.dirExists d
`before` File.ownerGroup d "joey" "joey" `before` File.ownerGroup d "joey" "joey"
podcatcher :: Property podcatcher :: Property NoInfo
podcatcher = Cron.niceJob "podcatcher run hourly" "55 * * * *" podcatcher = Cron.niceJob "podcatcher run hourly" "55 * * * *"
"joey" "/home/joey/lib/sound/podcasts" "joey" "/home/joey/lib/sound/podcasts"
"xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update" "xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update"
`requires` Apt.installed ["git-annex", "myrepos"] `requires` Apt.installed ["git-annex", "myrepos"]
kiteMailServer :: Property kiteMailServer :: Property HasInfo
kiteMailServer = propertyList "kitenet.net mail server" kiteMailServer = propertyList "kitenet.net mail server" $ props
[ Postfix.installed & Postfix.installed
, Apt.installed ["postfix-pcre"] & Apt.installed ["postfix-pcre"]
, Apt.serviceInstalledRunning "postgrey" & Apt.serviceInstalledRunning "postgrey"
, Apt.serviceInstalledRunning "spamassassin" & Apt.serviceInstalledRunning "spamassassin"
, "/etc/default/spamassassin" `File.containsLines` & "/etc/default/spamassassin" `File.containsLines`
[ "# Propellor deployed" [ "# Propellor deployed"
, "ENABLED=1" , "ENABLED=1"
, "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\"" , "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\""
@ -426,15 +430,15 @@ kiteMailServer = propertyList "kitenet.net mail server"
`describe` "spamd enabled" `describe` "spamd enabled"
`requires` Apt.serviceInstalledRunning "cron" `requires` Apt.serviceInstalledRunning "cron"
, Apt.serviceInstalledRunning "spamass-milter" & Apt.serviceInstalledRunning "spamass-milter"
-- Add -m to prevent modifying messages Subject or body. -- Add -m to prevent modifying messages Subject or body.
, "/etc/default/spamass-milter" `File.containsLine` & "/etc/default/spamass-milter" `File.containsLine`
"OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\"" "OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\""
`onChange` Service.restarted "spamass-milter" `onChange` Service.restarted "spamass-milter"
`describe` "spamass-milter configured" `describe` "spamass-milter configured"
, Apt.serviceInstalledRunning "amavisd-milter" & Apt.serviceInstalledRunning "amavisd-milter"
, "/etc/default/amavisd-milter" `File.containsLines` & "/etc/default/amavisd-milter" `File.containsLines`
[ "# Propellor deployed" [ "# Propellor deployed"
, "MILTERSOCKET=/var/spool/postfix/amavis/amavis.sock" , "MILTERSOCKET=/var/spool/postfix/amavis/amavis.sock"
, "MILTERSOCKETOWNER=\"postfix:postfix\"" , "MILTERSOCKETOWNER=\"postfix:postfix\""
@ -442,12 +446,12 @@ kiteMailServer = propertyList "kitenet.net mail server"
] ]
`onChange` Service.restarted "amavisd-milter" `onChange` Service.restarted "amavisd-milter"
`describe` "amavisd-milter configured for postfix" `describe` "amavisd-milter configured for postfix"
, Apt.serviceInstalledRunning "clamav-freshclam" & Apt.serviceInstalledRunning "clamav-freshclam"
, dkimInstalled & dkimInstalled
, Apt.installed ["maildrop"] & Apt.installed ["maildrop"]
, "/etc/maildroprc" `File.hasContent` & "/etc/maildroprc" `File.hasContent`
[ "# Global maildrop filter file (deployed with propellor)" [ "# Global maildrop filter file (deployed with propellor)"
, "DEFAULT=\"$HOME/Maildir\"" , "DEFAULT=\"$HOME/Maildir\""
, "MAILBOX=\"$DEFAULT/.\"" , "MAILBOX=\"$DEFAULT/.\""
@ -461,19 +465,19 @@ kiteMailServer = propertyList "kitenet.net mail server"
] ]
`describe` "maildrop configured" `describe` "maildrop configured"
, "/etc/aliases" `File.hasPrivContentExposed` ctx & "/etc/aliases" `File.hasPrivContentExposed` ctx
`onChange` Postfix.newaliases `onChange` Postfix.newaliases
, hasJoeyCAChain & hasJoeyCAChain
, hasPostfixCert ctx & hasPostfixCert ctx
, "/etc/postfix/mydomain" `File.containsLines` & "/etc/postfix/mydomain" `File.containsLines`
[ "/.*\\.kitenet\\.net/\tOK" [ "/.*\\.kitenet\\.net/\tOK"
, "/ikiwiki\\.info/\tOK" , "/ikiwiki\\.info/\tOK"
, "/joeyh\\.name/\tOK" , "/joeyh\\.name/\tOK"
] ]
`onChange` Postfix.reloaded `onChange` Postfix.reloaded
`describe` "postfix mydomain file configured" `describe` "postfix mydomain file configured"
, "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` & "/etc/postfix/obscure_client_relay.pcre" `File.hasContent`
-- Remove received lines for mails relayed from trusted -- Remove received lines for mails relayed from trusted
-- clients. These can be a privacy violation, or trigger -- clients. These can be a privacy violation, or trigger
-- spam filters. -- spam filters.
@ -485,16 +489,16 @@ kiteMailServer = propertyList "kitenet.net mail server"
] ]
`onChange` Postfix.reloaded `onChange` Postfix.reloaded
`describe` "postfix obscure_client_relay file configured" `describe` "postfix obscure_client_relay file configured"
, Postfix.mappedFile "/etc/postfix/virtual" & Postfix.mappedFile "/etc/postfix/virtual"
(flip File.containsLines (flip File.containsLines
[ "# *@joeyh.name to joey" [ "# *@joeyh.name to joey"
, "@joeyh.name\tjoey" , "@joeyh.name\tjoey"
] ]
) `describe` "postfix virtual file configured" ) `describe` "postfix virtual file configured"
`onChange` Postfix.reloaded `onChange` Postfix.reloaded
, Postfix.mappedFile "/etc/postfix/relay_clientcerts" $ & Postfix.mappedFile "/etc/postfix/relay_clientcerts"
flip File.hasPrivContentExposed ctx (flip File.hasPrivContentExposed ctx)
, Postfix.mainCfFile `File.containsLines` & Postfix.mainCfFile `File.containsLines`
[ "myhostname = kitenet.net" [ "myhostname = kitenet.net"
, "mydomain = $myhostname" , "mydomain = $myhostname"
, "append_dot_mydomain = no" , "append_dot_mydomain = no"
@ -543,24 +547,24 @@ kiteMailServer = propertyList "kitenet.net mail server"
`onChange` Postfix.reloaded `onChange` Postfix.reloaded
`describe` "postfix configured" `describe` "postfix configured"
, Apt.serviceInstalledRunning "dovecot-imapd" & Apt.serviceInstalledRunning "dovecot-imapd"
, Apt.serviceInstalledRunning "dovecot-pop3d" & Apt.serviceInstalledRunning "dovecot-pop3d"
, "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` & "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine`
"mail_location = maildir:~/Maildir" "mail_location = maildir:~/Maildir"
`onChange` Service.reloaded "dovecot" `onChange` Service.reloaded "dovecot"
`describe` "dovecot mail.conf" `describe` "dovecot mail.conf"
, "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine` & "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine`
"!include auth-passwdfile.conf.ext" "!include auth-passwdfile.conf.ext"
`onChange` Service.restarted "dovecot" `onChange` Service.restarted "dovecot"
`describe` "dovecot auth.conf" `describe` "dovecot auth.conf"
, File.hasPrivContent dovecotusers ctx & File.hasPrivContent dovecotusers ctx
`onChange` (dovecotusers `File.mode` `onChange` (dovecotusers `File.mode`
combineModes [ownerReadMode, groupReadMode]) combineModes [ownerReadMode, groupReadMode])
, File.ownerGroup dovecotusers "root" "dovecot" & File.ownerGroup dovecotusers "root" "dovecot"
, Apt.installed ["mutt", "bsd-mailx", "alpine"] & Apt.installed ["mutt", "bsd-mailx", "alpine"]
, pinescript `File.hasContent` & pinescript `File.hasContent`
[ "#!/bin/sh" [ "#!/bin/sh"
, "# deployed with propellor" , "# deployed with propellor"
, "set -e" , "set -e"
@ -574,14 +578,13 @@ kiteMailServer = propertyList "kitenet.net mail server"
`onChange` (pinescript `File.mode` `onChange` (pinescript `File.mode`
combineModes (readModes ++ executeModes)) combineModes (readModes ++ executeModes))
`describe` "pine wrapper script" `describe` "pine wrapper script"
, "/etc/pine.conf" `File.hasContent` & "/etc/pine.conf" `File.hasContent`
[ "# deployed with propellor" [ "# deployed with propellor"
, "inbox-path={localhost/novalidate-cert/NoRsh}inbox" , "inbox-path={localhost/novalidate-cert/NoRsh}inbox"
] ]
`describe` "pine configured to use local imap server" `describe` "pine configured to use local imap server"
, Apt.serviceInstalledRunning "mailman" & Apt.serviceInstalledRunning "mailman"
]
where where
ctx = Context "kitenet.net" ctx = Context "kitenet.net"
pinescript = "/usr/local/bin/pine" pinescript = "/usr/local/bin/pine"
@ -589,7 +592,7 @@ kiteMailServer = propertyList "kitenet.net mail server"
-- Configures postfix to relay outgoing mail to kitenet.net, with -- Configures postfix to relay outgoing mail to kitenet.net, with
-- verification via tls cert. -- verification via tls cert.
postfixClientRelay :: Context -> Property postfixClientRelay :: Context -> Property HasInfo
postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
[ "relayhost = kitenet.net" [ "relayhost = kitenet.net"
, "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem" , "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem"
@ -605,7 +608,7 @@ postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
`requires` hasPostfixCert ctx `requires` hasPostfixCert ctx
-- Configures postfix to have the dkim milter, and no other milters. -- Configures postfix to have the dkim milter, and no other milters.
dkimMilter :: Property dkimMilter :: Property HasInfo
dkimMilter = Postfix.mainCfFile `File.containsLines` dkimMilter = Postfix.mainCfFile `File.containsLines`
[ "smtpd_milters = inet:localhost:8891" [ "smtpd_milters = inet:localhost:8891"
, "non_smtpd_milters = inet:localhost:8891" , "non_smtpd_milters = inet:localhost:8891"
@ -618,22 +621,22 @@ dkimMilter = Postfix.mainCfFile `File.containsLines`
-- This does not configure postfix to use the dkim milter, -- This does not configure postfix to use the dkim milter,
-- nor does it set up domainkey DNS. -- nor does it set up domainkey DNS.
dkimInstalled :: Property dkimInstalled :: Property HasInfo
dkimInstalled = propertyList "opendkim installed" dkimInstalled = go `onChange` Service.restarted "opendkim"
[ Apt.serviceInstalledRunning "opendkim" where
, File.dirExists "/etc/mail" go = propertyList "opendkim installed" $ props
, File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") & Apt.serviceInstalledRunning "opendkim"
, File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim" & File.dirExists "/etc/mail"
, "/etc/default/opendkim" `File.containsLine` & File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net")
& File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim"
& "/etc/default/opendkim" `File.containsLine`
"SOCKET=\"inet:8891@localhost\"" "SOCKET=\"inet:8891@localhost\""
, "/etc/opendkim.conf" `File.containsLines` & "/etc/opendkim.conf" `File.containsLines`
[ "KeyFile /etc/mail/dkim.key" [ "KeyFile /etc/mail/dkim.key"
, "SubDomains yes" , "SubDomains yes"
, "Domain *" , "Domain *"
, "Selector mail" , "Selector mail"
] ]
]
`onChange` Service.restarted "opendkim"
-- This is the dkim public key, corresponding with /etc/mail/dkim.key -- This is the dkim public key, corresponding with /etc/mail/dkim.key
-- This value can be included in a domain's additional records to make -- This value can be included in a domain's additional records to make
@ -641,37 +644,36 @@ dkimInstalled = propertyList "opendkim installed"
domainKey :: (BindDomain, Record) domainKey :: (BindDomain, Record)
domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")
hasJoeyCAChain :: Property hasJoeyCAChain :: Property HasInfo
hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed`
Context "joeyca.pem" Context "joeyca.pem"
hasPostfixCert :: Context -> Property hasPostfixCert :: Context -> Property HasInfo
hasPostfixCert ctx = combineProperties "postfix tls cert installed" hasPostfixCert ctx = combineProperties "postfix tls cert installed"
[ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx [ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx
, "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx
] ]
kitenetHttps :: Property kitenetHttps :: Property HasInfo
kitenetHttps = propertyList "kitenet.net https certs" kitenetHttps = propertyList "kitenet.net https certs" $ props
[ File.hasPrivContent "/etc/ssl/certs/web.pem" ctx & File.hasPrivContent "/etc/ssl/certs/web.pem" ctx
, File.hasPrivContent "/etc/ssl/private/web.pem" ctx & File.hasPrivContent "/etc/ssl/private/web.pem" ctx
, File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx & File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx
, toProp $ Apache.modEnabled "ssl" & Apache.modEnabled "ssl"
]
where where
ctx = Context "kitenet.net" ctx = Context "kitenet.net"
-- Legacy static web sites and redirections from kitenet.net to newer -- Legacy static web sites and redirections from kitenet.net to newer
-- sites. -- sites.
legacyWebSites :: Property legacyWebSites :: Property HasInfo
legacyWebSites = propertyList "legacy web sites" legacyWebSites = propertyList "legacy web sites" $ props
[ Apt.serviceInstalledRunning "apache2" & Apt.serviceInstalledRunning "apache2"
, toProp $ Apache.modEnabled "rewrite" & Apache.modEnabled "rewrite"
, toProp $ Apache.modEnabled "cgi" & Apache.modEnabled "cgi"
, toProp $ Apache.modEnabled "speling" & Apache.modEnabled "speling"
, userDirHtml & userDirHtml
, kitenetHttps & kitenetHttps
, toProp $ Apache.siteEnabled "kitenet.net" $ apachecfg "kitenet.net" True & apacheSite "kitenet.net" True
-- /var/www is empty -- /var/www is empty
[ "DocumentRoot /var/www" [ "DocumentRoot /var/www"
, "<Directory /var/www>" , "<Directory /var/www>"
@ -758,8 +760,8 @@ legacyWebSites = propertyList "legacy web sites"
, "rewriterule /~kyle/family/wiki/(.*).rss http://macleawiki.branchable.com/$1/index.rss [L]" , "rewriterule /~kyle/family/wiki/(.*).rss http://macleawiki.branchable.com/$1/index.rss [L]"
, "rewriterule /~kyle/family/wiki(.*) http://macleawiki.branchable.com$1 [L]" , "rewriterule /~kyle/family/wiki(.*) http://macleawiki.branchable.com$1 [L]"
] ]
, alias "anna.kitenet.net" & alias "anna.kitenet.net"
, toProp $ Apache.siteEnabled "anna.kitenet.net" $ apachecfg "anna.kitenet.net" False & apacheSite "anna.kitenet.net" False
[ "DocumentRoot /home/anna/html" [ "DocumentRoot /home/anna/html"
, "<Directory /home/anna/html/>" , "<Directory /home/anna/html/>"
, " Options Indexes ExecCGI" , " Options Indexes ExecCGI"
@ -767,9 +769,9 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll , Apache.allowAll
, "</Directory>" , "</Directory>"
] ]
, alias "sows-ear.kitenet.net" & alias "sows-ear.kitenet.net"
, alias "www.sows-ear.kitenet.net" & alias "www.sows-ear.kitenet.net"
, toProp $ Apache.siteEnabled "sows-ear.kitenet.net" $ apachecfg "sows-ear.kitenet.net" False & apacheSite "sows-ear.kitenet.net" False
[ "ServerAlias www.sows-ear.kitenet.net" [ "ServerAlias www.sows-ear.kitenet.net"
, "DocumentRoot /srv/web/sows-ear.kitenet.net" , "DocumentRoot /srv/web/sows-ear.kitenet.net"
, "<Directory /srv/web/sows-ear.kitenet.net>" , "<Directory /srv/web/sows-ear.kitenet.net>"
@ -778,9 +780,9 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll , Apache.allowAll
, "</Directory>" , "</Directory>"
] ]
, alias "wortroot.kitenet.net" & alias "wortroot.kitenet.net"
, alias "www.wortroot.kitenet.net" & alias "www.wortroot.kitenet.net"
, toProp $ Apache.siteEnabled "wortroot.kitenet.net" $ apachecfg "wortroot.kitenet.net" False & apacheSite "wortroot.kitenet.net" False
[ "ServerAlias www.wortroot.kitenet.net" [ "ServerAlias www.wortroot.kitenet.net"
, "DocumentRoot /srv/web/wortroot.kitenet.net" , "DocumentRoot /srv/web/wortroot.kitenet.net"
, "<Directory /srv/web/wortroot.kitenet.net>" , "<Directory /srv/web/wortroot.kitenet.net>"
@ -789,8 +791,8 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll , Apache.allowAll
, "</Directory>" , "</Directory>"
] ]
, alias "creeksidepress.com" & alias "creeksidepress.com"
, toProp $ Apache.siteEnabled "creeksidepress.com" $ apachecfg "creeksidepress.com" False & apacheSite "creeksidepress.com" False
[ "ServerAlias www.creeksidepress.com" [ "ServerAlias www.creeksidepress.com"
, "DocumentRoot /srv/web/www.creeksidepress.com" , "DocumentRoot /srv/web/www.creeksidepress.com"
, "<Directory /srv/web/www.creeksidepress.com>" , "<Directory /srv/web/www.creeksidepress.com>"
@ -799,8 +801,8 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll , Apache.allowAll
, "</Directory>" , "</Directory>"
] ]
, alias "joey.kitenet.net" & alias "joey.kitenet.net"
, toProp $ Apache.siteEnabled "joey.kitenet.net" $ apachecfg "joey.kitenet.net" False & apacheSite "joey.kitenet.net" False
[ "DocumentRoot /var/www" [ "DocumentRoot /var/www"
, "<Directory /var/www/>" , "<Directory /var/www/>"
, " Options Indexes ExecCGI" , " Options Indexes ExecCGI"
@ -820,12 +822,12 @@ legacyWebSites = propertyList "legacy web sites"
, "# Redirect all to joeyh.name." , "# Redirect all to joeyh.name."
, "rewriterule (.*) http://joeyh.name$1 [r]" , "rewriterule (.*) http://joeyh.name$1 [r]"
] ]
]
userDirHtml :: Property userDirHtml :: Property HasInfo
userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
`onChange` Apache.reloaded `onChange` Apache.reloaded
`requires` (toProp $ Apache.modEnabled "userdir") `requires` (toProp $ Apache.modEnabled "userdir")
where where
munge = replace "public_html" "html" munge = replace "public_html" "html"
conf = "/etc/apache2/mods-available/userdir.conf" conf = "/etc/apache2/mods-available/userdir.conf"

View File

@ -36,7 +36,7 @@ sshBool False = "no"
sshdConfig :: FilePath sshdConfig :: FilePath
sshdConfig = "/etc/ssh/sshd_config" sshdConfig = "/etc/ssh/sshd_config"
setSshdConfig :: String -> Bool -> Property setSshdConfig :: String -> Bool -> Property NoInfo
setSshdConfig setting allowed = combineProperties "sshd config" setSshdConfig setting allowed = combineProperties "sshd config"
[ sshdConfig `File.lacksLine` (sshline $ not allowed) [ sshdConfig `File.lacksLine` (sshline $ not allowed)
, sshdConfig `File.containsLine` (sshline allowed) , sshdConfig `File.containsLine` (sshline allowed)
@ -46,10 +46,10 @@ setSshdConfig setting allowed = combineProperties "sshd config"
where where
sshline v = setting ++ " " ++ sshBool v sshline v = setting ++ " " ++ sshBool v
permitRootLogin :: Bool -> Property permitRootLogin :: Bool -> Property NoInfo
permitRootLogin = setSshdConfig "PermitRootLogin" permitRootLogin = setSshdConfig "PermitRootLogin"
passwordAuthentication :: Bool -> Property passwordAuthentication :: Bool -> Property NoInfo
passwordAuthentication = setSshdConfig "PasswordAuthentication" passwordAuthentication = setSshdConfig "PasswordAuthentication"
dotDir :: UserName -> IO FilePath dotDir :: UserName -> IO FilePath
@ -67,13 +67,13 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys"
where where
go f = not . null <$> catchDefaultIO "" (readFile f) go f = not . null <$> catchDefaultIO "" (readFile f)
restarted :: Property restarted :: Property NoInfo
restarted = Service.restarted "ssh" restarted = Service.restarted "ssh"
-- | Blows away existing host keys and make new ones. -- | Blows away existing host keys and make new ones.
-- Useful for systems installed from an image that might reuse host keys. -- Useful for systems installed from an image that might reuse host keys.
-- A flag file is used to only ever do this once. -- A flag file is used to only ever do this once.
randomHostKeys :: Property randomHostKeys :: Property NoInfo
randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restarted `onChange` restarted
where where
@ -90,7 +90,7 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
-- The corresponding private keys come from the privdata. -- The corresponding private keys come from the privdata.
-- --
-- Any host keysthat are not in the list are removed from the host. -- Any host keysthat are not in the list are removed from the host.
hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
hostKeys ctx l = propertyList desc $ catMaybes $ hostKeys ctx l = propertyList desc $ catMaybes $
map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup] map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]
where where
@ -101,7 +101,8 @@ hostKeys ctx l = propertyList desc $ catMaybes $
removestale b = map (File.notPresent . flip keyFile b) staletypes removestale b = map (File.notPresent . flip keyFile b) staletypes
cleanup cleanup
| null staletypes || null l = Nothing | null staletypes || null l = Nothing
| otherwise = Just $ property ("any other ssh host keys removed " ++ typelist staletypes) $ | otherwise = Just $ toProp $
property ("any other ssh host keys removed " ++ typelist staletypes) $
ensureProperty $ ensureProperty $
combineProperties desc (removestale True ++ removestale False) combineProperties desc (removestale True ++ removestale False)
`onChange` restarted `onChange` restarted
@ -110,10 +111,10 @@ hostKeys ctx l = propertyList desc $ catMaybes $
-- --
-- The public key is provided to this function; -- The public key is provided to this function;
-- the private key comes from the privdata; -- the private key comes from the privdata;
hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo
hostKey context keytype pub = combineProperties desc hostKey context keytype pub = combineProperties desc
[ pubKey keytype pub [ pubKey keytype pub
, property desc $ install writeFile True pub , toProp $ property desc $ install writeFile True pub
, withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
property desc $ getkey $ install writeFileProtected False property desc $ getkey $ install writeFileProtected False
] ]
@ -137,7 +138,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
-- | Indicates the host key that is used by a Host, but does not actually -- | Indicates the host key that is used by a Host, but does not actually
-- configure the host to use it. Normally this does not need to be used; -- configure the host to use it. Normally this does not need to be used;
-- use 'hostKey' instead. -- use 'hostKey' instead.
pubKey :: SshKeyType -> PubKeyText -> Property pubKey :: SshKeyType -> PubKeyText -> Property HasInfo
pubKey t k = pureInfoProperty ("ssh pubkey known") $ pubKey t k = pureInfoProperty ("ssh pubkey known") $
mempty { _sshPubKey = M.singleton t k } mempty { _sshPubKey = M.singleton t k }
@ -146,7 +147,7 @@ getPubKey = asks (_sshPubKey . hostInfo)
-- | Sets up a user with a ssh private key and public key pair from the -- | Sets up a user with a ssh private key and public key pair from the
-- PrivData. -- PrivData.
keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property HasInfo
keyImported keytype user context = combineProperties desc keyImported keytype user context = combineProperties desc
[ installkey (SshPubKey keytype user) (install writeFile ".pub") [ installkey (SshPubKey keytype user) (install writeFile ".pub")
, installkey (SshPrivKey keytype user) (install writeFileProtected "") , installkey (SshPrivKey keytype user) (install writeFileProtected "")
@ -179,7 +180,7 @@ fromKeyType SshEd25519 = "ed25519"
-- | Puts some host's ssh public key(s), as set using 'pubKey', -- | Puts some host's ssh public key(s), as set using 'pubKey',
-- into the known_hosts file for a user. -- into the known_hosts file for a user.
knownHost :: [Host] -> HostName -> UserName -> Property knownHost :: [Host] -> HostName -> UserName -> Property NoInfo
knownHost hosts hn user = property desc $ knownHost hosts hn user = property desc $
go =<< fromHost hosts hn getPubKey go =<< fromHost hosts hn getPubKey
where where
@ -199,7 +200,7 @@ knownHost hosts hn user = property desc $
-- | Makes a user have authorized_keys from the PrivData -- | Makes a user have authorized_keys from the PrivData
-- --
-- This removes any other lines from the file. -- This removes any other lines from the file.
authorizedKeys :: IsContext c => UserName -> c -> Property authorizedKeys :: IsContext c => UserName -> c -> Property HasInfo
authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get -> authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get ->
property (user ++ " has authorized_keys") $ get $ \v -> do property (user ++ " has authorized_keys") $ get $ \v -> do
f <- liftIO $ dotFile "authorized_keys" user f <- liftIO $ dotFile "authorized_keys" user
@ -213,7 +214,7 @@ authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \g
-- | Ensures that a user's authorized_keys contains a line. -- | Ensures that a user's authorized_keys contains a line.
-- Any other lines in the file are preserved as-is. -- Any other lines in the file are preserved as-is.
authorizedKey :: UserName -> String -> Property authorizedKey :: UserName -> String -> Property NoInfo
authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do
f <- liftIO $ dotFile "authorized_keys" user f <- liftIO $ dotFile "authorized_keys" user
ensureProperty $ ensureProperty $
@ -226,7 +227,7 @@ authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do
-- --
-- Revert to prevent it listening on a particular port. -- Revert to prevent it listening on a particular port.
listenPort :: Int -> RevertableProperty listenPort :: Int -> RevertableProperty
listenPort port = RevertableProperty enable disable listenPort port = enable <!> disable
where where
portline = "Port " ++ show port portline = "Port " ++ show port
enable = sshdConfig `File.containsLine` portline enable = sshdConfig `File.containsLine` portline

View File

@ -9,7 +9,7 @@ import Propellor.Property.User
-- | Allows a user to sudo. If the user has a password, sudo is configured -- | Allows a user to sudo. If the user has a password, sudo is configured
-- to require it. If not, NOPASSWORD is enabled for the user. -- to require it. If not, NOPASSWORD is enabled for the user.
enabledFor :: UserName -> Property enabledFor :: UserName -> Property NoInfo
enabledFor user = property desc go `requires` Apt.installed ["sudo"] enabledFor user = property desc go `requires` Apt.installed ["sudo"]
where where
go = do go = do

View File

@ -45,32 +45,32 @@ instance PropAccum Container where
getProperties (Container _ _ h) = hostProperties h getProperties (Container _ _ h) = hostProperties h
-- | Starts a systemd service. -- | Starts a systemd service.
started :: ServiceName -> Property started :: ServiceName -> Property NoInfo
started n = trivial $ cmdProperty "systemctl" ["start", n] started n = trivial $ cmdProperty "systemctl" ["start", n]
`describe` ("service " ++ n ++ " started") `describe` ("service " ++ n ++ " started")
-- | Stops a systemd service. -- | Stops a systemd service.
stopped :: ServiceName -> Property stopped :: ServiceName -> Property NoInfo
stopped n = trivial $ cmdProperty "systemctl" ["stop", n] stopped n = trivial $ cmdProperty "systemctl" ["stop", n]
`describe` ("service " ++ n ++ " stopped") `describe` ("service " ++ n ++ " stopped")
-- | Enables a systemd service. -- | Enables a systemd service.
enabled :: ServiceName -> Property enabled :: ServiceName -> Property NoInfo
enabled n = trivial $ cmdProperty "systemctl" ["enable", n] enabled n = trivial $ cmdProperty "systemctl" ["enable", n]
`describe` ("service " ++ n ++ " enabled") `describe` ("service " ++ n ++ " enabled")
-- | Disables a systemd service. -- | Disables a systemd service.
disabled :: ServiceName -> Property disabled :: ServiceName -> Property NoInfo
disabled n = trivial $ cmdProperty "systemctl" ["disable", n] disabled n = trivial $ cmdProperty "systemctl" ["disable", n]
`describe` ("service " ++ n ++ " disabled") `describe` ("service " ++ n ++ " disabled")
-- | Restarts a systemd service. -- | Restarts a systemd service.
restarted :: ServiceName -> Property restarted :: ServiceName -> Property NoInfo
restarted n = trivial $ cmdProperty "systemctl" ["restart", n] restarted n = trivial $ cmdProperty "systemctl" ["restart", n]
`describe` ("service " ++ n ++ " restarted") `describe` ("service " ++ n ++ " restarted")
-- | Enables persistent storage of the journal. -- | Enables persistent storage of the journal.
persistentJournal :: Property persistentJournal :: Property NoInfo
persistentJournal = check (not <$> doesDirectoryExist dir) $ persistentJournal = check (not <$> doesDirectoryExist dir) $
combineProperties "persistent systemd journal" combineProperties "persistent systemd journal"
[ cmdProperty "install" ["-d", "-g", "systemd-journal", dir] [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir]
@ -89,7 +89,7 @@ type Option = String
-- This assumes that there is only one [Header] per file, which is -- This assumes that there is only one [Header] per file, which is
-- currently the case. And it assumes the file already exists with -- currently the case. And it assumes the file already exists with
-- the right [Header], so new lines can just be appended to the end. -- the right [Header], so new lines can just be appended to the end.
configured :: FilePath -> Option -> String -> Property configured :: FilePath -> Option -> String -> Property NoInfo
configured cfgfile option value = combineProperties desc configured cfgfile option value = combineProperties desc
[ File.fileProperty desc (mapMaybe removeother) cfgfile [ File.fileProperty desc (mapMaybe removeother) cfgfile
, File.containsLine cfgfile line , File.containsLine cfgfile line
@ -103,13 +103,13 @@ configured cfgfile option value = combineProperties desc
| otherwise = Just l | otherwise = Just l
-- | Configures journald, restarting it so the changes take effect. -- | Configures journald, restarting it so the changes take effect.
journaldConfigured :: Option -> String -> Property journaldConfigured :: Option -> String -> Property NoInfo
journaldConfigured option value = journaldConfigured option value =
configured "/etc/systemd/journald.conf" option value configured "/etc/systemd/journald.conf" option value
`onChange` restarted "systemd-journald" `onChange` restarted "systemd-journald"
-- | Causes systemd to reload its configuration files. -- | Causes systemd to reload its configuration files.
daemonReloaded :: Property daemonReloaded :: Property NoInfo
daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"] daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"]
-- | Defines a container with a given machine name. -- | Defines a container with a given machine name.
@ -143,17 +143,12 @@ container name mkchroot = Container name c h
-- and deletes the chroot and all its contents. -- and deletes the chroot and all its contents.
nspawned :: Container -> RevertableProperty nspawned :: Container -> RevertableProperty
nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) = nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
RevertableProperty setup teardown p `describe` ("nspawned " ++ name)
where where
setup = combineProperties ("nspawned " ++ name) $ p = enterScript c
map toProp steps ++ [containerprovisioned] `before` chrootprovisioned
teardown = combineProperties ("not nspawned " ++ name) $ `before` nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h)
map (toProp . revert) (reverse steps) `before` containerprovisioned
steps =
[ enterScript c
, chrootprovisioned
, nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h)
]
-- Chroot provisioning is run in systemd-only mode, -- Chroot provisioning is run in systemd-only mode,
-- which sets up the chroot and ensures systemd and dbus are -- which sets up the chroot and ensures systemd and dbus are
@ -163,15 +158,17 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
-- Use nsenter to enter container and and run propellor to -- Use nsenter to enter container and and run propellor to
-- finish provisioning. -- finish provisioning.
containerprovisioned = Chroot.propellChroot chroot containerprovisioned =
(enterContainerProcess c) False Chroot.propellChroot chroot (enterContainerProcess c) False
<!>
doNothing
chroot = Chroot.Chroot loc system builderconf h chroot = Chroot.Chroot loc system builderconf h
-- | Sets up the service file for the container, and then starts -- | Sets up the service file for the container, and then starts
-- it running. -- it running.
nspawnService :: Container -> ChrootCfg -> RevertableProperty nspawnService :: Container -> ChrootCfg -> RevertableProperty
nspawnService (Container name _ _) cfg = RevertableProperty setup teardown nspawnService (Container name _ _) cfg = setup <!> teardown
where where
service = nspawnServiceName name service = nspawnServiceName name
servicefile = "/etc/systemd/system/multi-user.target.wants" </> service servicefile = "/etc/systemd/system/multi-user.target.wants" </> service
@ -215,7 +212,7 @@ nspawnServiceParams (SystemdNspawnCfg ps) =
-- This uses nsenter to enter the container, by looking up the pid of the -- This uses nsenter to enter the container, by looking up the pid of the
-- container's init process and using its namespace. -- container's init process and using its namespace.
enterScript :: Container -> RevertableProperty enterScript :: Container -> RevertableProperty
enterScript c@(Container name _ _) = RevertableProperty setup teardown enterScript c@(Container name _ _) = setup <!> teardown
where where
setup = combineProperties ("generated " ++ enterScriptFile c) setup = combineProperties ("generated " ++ enterScriptFile c)
[ scriptfile `File.hasContent` [ scriptfile `File.hasContent`

View File

@ -6,5 +6,5 @@ import qualified Propellor.Property.Apt as Apt
-- dbus is only a Recommends of systemd, but is needed for communication -- dbus is only a Recommends of systemd, but is needed for communication
-- from the systemd inside a container to the one outside, so make sure it -- from the systemd inside a container to the one outside, so make sure it
-- gets installed. -- gets installed.
installed :: Property installed :: Property NoInfo
installed = Apt.installed ["systemd", "dbus"] installed = Apt.installed ["systemd", "dbus"]

View File

@ -10,7 +10,7 @@ import System.Posix.Files
type HiddenServiceName = String type HiddenServiceName = String
isBridge :: Property isBridge :: Property NoInfo
isBridge = setup `requires` Apt.installed ["tor"] isBridge = setup `requires` Apt.installed ["tor"]
`describe` "tor bridge" `describe` "tor bridge"
where where
@ -21,7 +21,7 @@ isBridge = setup `requires` Apt.installed ["tor"]
, "Exitpolicy reject *:*" , "Exitpolicy reject *:*"
] `onChange` restarted ] `onChange` restarted
hiddenServiceAvailable :: HiddenServiceName -> Int -> Property hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo
hiddenServiceAvailable hn port = hiddenServiceHostName prop hiddenServiceAvailable hn port = hiddenServiceHostName prop
where where
prop = mainConfig `File.containsLines` prop = mainConfig `File.containsLines`
@ -30,13 +30,13 @@ hiddenServiceAvailable hn port = hiddenServiceHostName prop
] ]
`describe` "hidden service available" `describe` "hidden service available"
`onChange` Service.reloaded "tor" `onChange` Service.reloaded "tor"
hiddenServiceHostName p = adjustProperty p $ \satisfy -> do hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy r <- satisfy
h <- liftIO $ readFile (varLib </> hn </> "hostname") h <- liftIO $ readFile (varLib </> hn </> "hostname")
warningMessage $ unwords ["hidden service hostname:", h] warningMessage $ unwords ["hidden service hostname:", h]
return r return r
hiddenService :: HiddenServiceName -> Int -> Property hiddenService :: HiddenServiceName -> Int -> Property NoInfo
hiddenService hn port = mainConfig `File.containsLines` hiddenService hn port = mainConfig `File.containsLines`
[ unwords ["HiddenServiceDir", varLib </> hn] [ unwords ["HiddenServiceDir", varLib </> hn]
, unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port] , unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]
@ -44,7 +44,7 @@ hiddenService hn port = mainConfig `File.containsLines`
`describe` unwords ["hidden service available:", hn, show port] `describe` unwords ["hidden service available:", hn, show port]
`onChange` restarted `onChange` restarted
hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo
hiddenServiceData hn context = combineProperties desc hiddenServiceData hn context = combineProperties desc
[ installonion "hostname" [ installonion "hostname"
, installonion "private_key" , installonion "private_key"
@ -66,7 +66,7 @@ hiddenServiceData hn context = combineProperties desc
] ]
) )
restarted :: Property restarted :: Property NoInfo
restarted = Service.restarted "tor" restarted = Service.restarted "tor"
mainConfig :: FilePath mainConfig :: FilePath

View File

@ -6,7 +6,7 @@ import Propellor
data Eep = YesReallyDeleteHome data Eep = YesReallyDeleteHome
accountFor :: UserName -> Property accountFor :: UserName -> Property NoInfo
accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser" accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"
[ "--disabled-password" [ "--disabled-password"
, "--gecos", "" , "--gecos", ""
@ -15,7 +15,7 @@ accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdPropert
`describe` ("account for " ++ user) `describe` ("account for " ++ user)
-- | Removes user home directory!! Use with caution. -- | Removes user home directory!! Use with caution.
nuked :: UserName -> Eep -> Property nuked :: UserName -> Eep -> Property NoInfo
nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel" nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel"
[ "-r" [ "-r"
, user , user
@ -24,13 +24,13 @@ nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "use
-- | Only ensures that the user has some password set. It may or may -- | Only ensures that the user has some password set. It may or may
-- not be a password from the PrivData. -- not be a password from the PrivData.
hasSomePassword :: UserName -> Property hasSomePassword :: UserName -> Property HasInfo
hasSomePassword user = hasSomePassword' user hostContext hasSomePassword user = hasSomePassword' user hostContext
-- | While hasSomePassword uses the name of the host as context, -- | While hasSomePassword uses the name of the host as context,
-- this allows specifying a different context. This is useful when -- this allows specifying a different context. This is useful when
-- you want to use the same password on multiple hosts, for example. -- you want to use the same password on multiple hosts, for example.
hasSomePassword' :: IsContext c => UserName -> c -> Property hasSomePassword' :: IsContext c => UserName -> c -> Property HasInfo
hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $ hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $
hasPassword' user context hasPassword' user context
@ -40,10 +40,10 @@ hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus us
-- A user's password can be stored in the PrivData in either of two forms; -- A user's password can be stored in the PrivData in either of two forms;
-- the full cleartext <Password> or a <CryptPassword> hash. The latter -- the full cleartext <Password> or a <CryptPassword> hash. The latter
-- is obviously more secure. -- is obviously more secure.
hasPassword :: UserName -> Property hasPassword :: UserName -> Property HasInfo
hasPassword user = hasPassword' user hostContext hasPassword user = hasPassword' user hostContext
hasPassword' :: IsContext c => UserName -> c -> Property hasPassword' :: IsContext c => UserName -> c -> Property HasInfo
hasPassword' user context = go `requires` shadowConfig True hasPassword' user context = go `requires` shadowConfig True
where where
go = withSomePrivData srcs context $ go = withSomePrivData srcs context $
@ -66,7 +66,7 @@ setPassword getpassword = getpassword $ go
hPutStrLn h $ user ++ ":" ++ v hPutStrLn h $ user ++ ":" ++ v
hClose h hClose h
lockedPassword :: UserName -> Property lockedPassword :: UserName -> Property NoInfo
lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd" lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd"
[ "--lock" [ "--lock"
, user , user
@ -90,7 +90,7 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
homedir :: UserName -> IO FilePath homedir :: UserName -> IO FilePath
homedir user = homeDirectory <$> getUserEntryForName user homedir user = homeDirectory <$> getUserEntryForName user
hasGroup :: UserName -> GroupName -> Property hasGroup :: UserName -> GroupName -> Property NoInfo
hasGroup user group' = check test $ cmdProperty "adduser" hasGroup user group' = check test $ cmdProperty "adduser"
[ user [ user
, group' , group'
@ -100,7 +100,7 @@ hasGroup user group' = check test $ cmdProperty "adduser"
test = not . elem group' . words <$> readProcess "groups" [user] test = not . elem group' . words <$> readProcess "groups" [user]
-- | Controls whether shadow passwords are enabled or not. -- | Controls whether shadow passwords are enabled or not.
shadowConfig :: Bool -> Property shadowConfig :: Bool -> Property NoInfo
shadowConfig True = check (not <$> shadowExists) $ shadowConfig True = check (not <$> shadowExists) $
cmdProperty "shadowconfig" ["on"] cmdProperty "shadowconfig" ["on"]
`describe` "shadow passwords enabled" `describe` "shadow passwords enabled"

View File

@ -10,29 +10,29 @@
module Propellor.Types module Propellor.Types
( Host(..) ( Host(..)
, Desc , Desc
, Property(..) , Property
, HasInfo , HasInfo
, NoInfo , NoInfo
, hasInfo
, CInfo , CInfo
, infoProperty , infoProperty
, simpleProperty , simpleProperty
, propertySatisfy
, adjustPropertySatisfy , adjustPropertySatisfy
, propertyInfo , propertyInfo
, propertyChildren , propertyChildren
, RevertableProperty(..) , RevertableProperty(..)
, (<!>) , (<!>)
, IsProp(..)
, Combines(..) , Combines(..)
, CombinedType
, before , before
, combineWith , combineWith
, IsProp(..)
, Info(..) , Info(..)
, Propellor(..) , Propellor(..)
, EndAction(..) , EndAction(..)
, module Propellor.Types.OS , module Propellor.Types.OS
, module Propellor.Types.Dns , module Propellor.Types.Dns
, module Propellor.Types.Result , module Propellor.Types.Result
, propertySatisfy
, ignoreInfo , ignoreInfo
) where ) where
@ -75,6 +75,17 @@ newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
, MonadCatchIO , MonadCatchIO
) )
instance Monoid (Propellor Result) where
mempty = return NoChange
-- | The second action is only run if the first action does not fail.
mappend x y = do
rx <- x
case rx of
FailedChange -> return FailedChange
_ -> do
ry <- y
return (rx <> ry)
-- | An action that Propellor runs at the end, after trying to satisfy all -- | An action that Propellor runs at the end, after trying to satisfy all
-- properties. It's passed the combined Result of the entire Propellor run. -- properties. It's passed the combined Result of the entire Propellor run.
data EndAction = EndAction Desc (Result -> Propellor Result) data EndAction = EndAction Desc (Result -> Propellor Result)
@ -88,14 +99,12 @@ data Property i where
IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo
SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
-- | Indicates that a Property has associated Info.
data HasInfo data HasInfo
-- | Indicates that a Property does not have Info.
data NoInfo data NoInfo
hasInfo :: Property i -> Bool -- | Type level calculation of the combination of HasInfo and/or NoInfo
hasInfo (IProperty {}) = True
hasInfo _ = False
-- | Type level calculation of the combintion of HasInfo and/or NoInfo
type family CInfo x y type family CInfo x y
type instance CInfo HasInfo HasInfo = HasInfo type instance CInfo HasInfo HasInfo = HasInfo
type instance CInfo HasInfo NoInfo = HasInfo type instance CInfo HasInfo NoInfo = HasInfo
@ -128,15 +137,18 @@ toSProperty p@(SProperty {}) = p
ignoreInfo :: Property i -> Property NoInfo ignoreInfo :: Property i -> Property NoInfo
ignoreInfo = toSProperty ignoreInfo = toSProperty
-- | Gets the action that can be run to satisfy a Property.
-- You should never run this action directly. Use
-- 'Propellor.Engine.ensureProperty` instead.
propertySatisfy :: Property i -> Propellor Result
propertySatisfy (IProperty _ a _ _) = a
propertySatisfy (SProperty _ a _) = a
instance Show (Property NoInfo) where instance Show (Property NoInfo) where
show p = "property " ++ show (propertyDesc p) show p = "property " ++ show (propertyDesc p)
instance Show (Property HasInfo) where instance Show (Property HasInfo) where
show p = "property " ++ show (propertyDesc p) show p = "property " ++ show (propertyDesc p)
propertySatisfy :: Property i -> Propellor Result
propertySatisfy (IProperty _ a _ _) = a
propertySatisfy (SProperty _ a _) = a
-- | Changes the action that is performed to satisfy a property. -- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i
adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs
@ -165,6 +177,7 @@ class IsProp p where
describe :: p -> Desc -> p describe :: p -> Desc -> p
propertyDesc :: p -> Desc propertyDesc :: p -> Desc
toProp :: p -> Property HasInfo toProp :: p -> Property HasInfo
toSimpleProp :: p -> Maybe (Property NoInfo)
-- | Gets the info of the property, combined with all info -- | Gets the info of the property, combined with all info
-- of all children properties. -- of all children properties.
getInfoRecursive :: p -> Info getInfoRecursive :: p -> Info
@ -173,12 +186,14 @@ instance IsProp (Property HasInfo) where
describe (IProperty _ a i cs) d = IProperty d a i cs describe (IProperty _ a i cs) d = IProperty d a i cs
propertyDesc (IProperty d _ _ _) = d propertyDesc (IProperty d _ _ _) = d
toProp = id toProp = id
toSimpleProp _ = Nothing
getInfoRecursive (IProperty _ _ i cs) = getInfoRecursive (IProperty _ _ i cs) =
i <> mconcat (map getInfoRecursive cs) i <> mconcat (map getInfoRecursive cs)
instance IsProp (Property NoInfo) where instance IsProp (Property NoInfo) where
describe (SProperty _ a cs) d = SProperty d a cs describe (SProperty _ a cs) d = SProperty d a cs
propertyDesc (SProperty d _ _) = d propertyDesc (SProperty d _ _) = d
toProp = toIProperty toProp = toIProperty
toSimpleProp = Just
getInfoRecursive _ = mempty getInfoRecursive _ = mempty
instance IsProp RevertableProperty where instance IsProp RevertableProperty where
@ -187,10 +202,11 @@ instance IsProp RevertableProperty where
RevertableProperty (describe p1 d) (describe p2 ("not " ++ d)) RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
propertyDesc (RevertableProperty p1 _) = propertyDesc p1 propertyDesc (RevertableProperty p1 _) = propertyDesc p1
toProp (RevertableProperty p1 _) = p1 toProp (RevertableProperty p1 _) = p1
toSimpleProp = toSimpleProp . toProp
-- | Return the Info of the currently active side. -- | Return the Info of the currently active side.
getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
-- Type level calculation of the type that results from combining two types -- | Type level calculation of the type that results from combining two types
-- with `requires`. -- with `requires`.
type family CombinedType x y type family CombinedType x y
type instance CombinedType (Property x) (Property y) = Property (CInfo x y) type instance CombinedType (Property x) (Property y) = Property (CInfo x y)
@ -224,18 +240,18 @@ combineWith f x y = adjustPropertySatisfy (x `requires` y) $ \_ ->
instance Combines (Property HasInfo) (Property HasInfo) where instance Combines (Property HasInfo) (Property HasInfo) where
requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
IProperty d1 (a2 `andThen` a1) i1 (y : cs1) IProperty d1 (a2 <> a1) i1 (y : cs1)
instance Combines (Property HasInfo) (Property NoInfo) where instance Combines (Property HasInfo) (Property NoInfo) where
requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) = requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
IProperty d1 (a2 `andThen` a1) i1 (toIProperty y : cs1) IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1)
instance Combines (Property NoInfo) (Property HasInfo) where instance Combines (Property NoInfo) (Property HasInfo) where
requires x y = requires y x requires x y = requires y x
instance Combines (Property NoInfo) (Property NoInfo) where instance Combines (Property NoInfo) (Property NoInfo) where
requires (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = requires (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) =
SProperty d1 (a2 `andThen` a1) (y : cs1) SProperty d1 (a2 <> a1) (y : cs1)
instance Combines RevertableProperty (Property HasInfo) where instance Combines RevertableProperty (Property HasInfo) where
requires (RevertableProperty p1 p2) y = requires (RevertableProperty p1 p2) y =
@ -252,13 +268,6 @@ instance Combines RevertableProperty RevertableProperty where
-- when reverting, run actions in reverse order -- when reverting, run actions in reverse order
(y2 `requires` x2) (y2 `requires` x2)
andThen :: Propellor Result -> Propellor Result -> Propellor Result
x `andThen` y = do
r <- x
case r of
FailedChange -> return FailedChange
_ -> y
-- | Information about a host. -- | Information about a host.
data Info = Info data Info = Info
{ _os :: Val System { _os :: Val System