cadey
/
propellor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'joeyconfig' 

Conflicts:
	doc/todo/info_propigation_out_of_nested_properties.mdwn
	privdata.joey/privdata.gpg
This commit is contained in:
Joey Hess 2015-01-25 15:16:58 -04:00
parent 1df70ba81d cdd88b080a
commit 401b857eef
63 changed files with 1626 additions and 899 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
config-joey.hs
View File

@ -25,6 +25,7 @@ import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Gpg as Gpg
import qualified Propellor.Property.Systemd as Systemd
import qualified Propellor.Property.Journald as Journald
import qualified Propellor.Property.OS as OS
import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean
import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
@ -46,7 +47,6 @@ hosts = -- (o) `
, kite
, diatom
, elephant
, testvm
] ++ monsters
testvm :: Host
@ -140,11 +140,13 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
, (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFZftKMnH/zH29BHMKbcBO4QsgTrstYFVhbrzrlRzBO3")
]
& Network.static "eth0" `requires` Network.cleanInterfacesFile
& Apt.installed ["linux-image-amd64"]
& Linode.chainPVGrub 5
& Apt.unattendedUpgrades
& Systemd.installed
& Systemd.persistentJournal
& Journald.systemMaxUse "500MiB"
& Ssh.passwordAuthentication True
-- Since ssh password authentication is allowed:
& Apt.serviceInstalledRunning "fail2ban"
@ -254,7 +256,7 @@ diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64"
& JoeySites.oldUseNetServer hosts
& alias "ns2.kitenet.net"
& myDnsPrimary False "kitenet.net" []
& myDnsPrimary True "kitenet.net" []
& myDnsPrimary True "joeyh.name" []
& myDnsPrimary True "ikiwiki.info" []
& myDnsPrimary True "olduse.net"
@ -327,13 +329,14 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
& Ssh.listenPort 80
--' __|II| ,.
---- __|II|II|__ ( \_,/\
------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-
----------------------- | [Docker] / ----------------------
----------------------- : / -----------------------
------------------------ \____, o ,' ------------------------
------------------------- '--,___________,' -------------------------
--' __|II| ,.
---- __|II|II|__ ( \_,/\
--'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-.-'-
-------------------------- | [Docker] / --------------------------
-------------------------- : / ---------------------------
--------------------------- \____, o ,' ----------------------------
---------------------------- '--,___________,' -----------------------------
-- Simple web server, publishing the outside host's /var/www
webserver :: Docker.Container
webserver = standardStableContainer "webserver"
@ -434,13 +437,12 @@ dockerImage (System (Debian Testing) arch) = "joeyh/debian-unstable-" ++ arch
dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch
dockerImage _ = "debian-stable-official" -- does not currently exist!
myDnsSecondary :: Property
myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp
[ Dns.secondary hosts "kitenet.net"
, Dns.secondary hosts "joeyh.name"
, Dns.secondary hosts "ikiwiki.info"
, Dns.secondary hosts "olduse.net"
]
myDnsSecondary :: Property HasInfo
myDnsSecondary = propertyList "dns secondary for all my domains" $ props
& Dns.secondary hosts "kitenet.net"
& Dns.secondary hosts "joeyh.name"
& Dns.secondary hosts "ikiwiki.info"
& Dns.secondary hosts "olduse.net"
branchableSecondary :: RevertableProperty
branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com"
@ -456,23 +458,11 @@ myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly No
, (RootDomain, NS $ AbsDomain "ns4.kitenet.net")
, (RootDomain, NS $ AbsDomain "ns6.gandi.net")
, (RootDomain, MX 0 $ AbsDomain "kitenet.net")
-- SPF only allows IP address of kitenet.net to send mail.
, (RootDomain, TXT "v=spf1 a:kitenet.net -all")
, (RootDomain, TXT "v=spf1 a a:kitenet.net ~all")
, JoeySites.domainKey
] ++ extras
-- o
-- ___ o o
{-----\ / o \ ___o o
{ \ __ \ / _ (X___>-- __o
_____________________{ ______\___ \__/ | \__/ \____ |X__>
< \___//|\\___/\ \____________ _
\ ___/ | \___ # # \ (-)
\ O O O # | \ # >=)
\______________________________# # / #__________________/ (-}
monsters :: [Host] -- Systems I don't manage with propellor,
monsters = -- but do want to track their public keys etc.
[ host "usw-s002.rsync.net"
@ -508,3 +498,17 @@ monsters = -- but do want to track their public keys etc.
& ipv4 "76.7.162.101"
& ipv4 "76.7.162.186"
]
-- o
-- ___ o o
{-----\ / o \ ___o o
{ \ __ \ / _ (X___>-- __o
_____________________{ ______\___ \__/ | \__/ \____ |X__>
< \___//|\\___/\ \____________ _
\ ___/ | \___ # # \ (-)
\ O O O # | \ # >=)
\______________________________# # / #__________________/ (-}

28
debian/changelog vendored
View File

@ -1,3 +1,31 @@
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.
* Properties now form a tree, instead of the flat list used before.
This includes the properties used inside a container.
* Fix info propigation from fallback combinator's second Property.
* Added systemd configuration properties.
* Added journald configuration properties.
* Added more network interface configuration properties.
* Implemented OS.preserveNetwork.
-- Joey Hess <id@joeyh.name> Thu, 15 Jan 2015 20:14:29 -0400
propellor (1.3.2) unstable; urgency=medium
* SSHFP records are also generated for CNAMES of hosts.

2
debian/control vendored
View File

@ -18,7 +18,7 @@ Build-Depends:
libghc-monadcatchio-transformers-dev,
Maintainer: Gergely Nagy <algernon@madhouse-project.org>
Standards-Version: 3.9.6
Vcs-Git: git://git.kitenet.net/propellor
Vcs-Git: git://git.joeyh.name/propellor
Homepage: http://propellor.branchable.com/
Package: propellor

29
doc/todo/RevertableProperty_with_NoInfo.mdwn Normal file
View File

@ -0,0 +1,29 @@
Currently, a RevertableProperty's Properties always both HasInfo. This
means that if a Property NoInfo is updated to be a RevertableProperty, and
someplace called ensureProperty on it, that will refuse to compile.
The workaround is generally to export the original NoInfo property under
a different name, so it can still be used with ensureProperty.
This could be fixed:
data RevertableProperty i1 i2 where
RProp :: Property i1 -> Property i2 -> RevertableProperty i1 i2
However, needing to write "RevertableProperty HasInfo NoInfo" is quite
a mouthful!
Since only 2 places in the propellor source code currently need to deal
with this, it doesn't currently seem worth making the change, unless a less
intrusive way can be found.
Probably related would be to make RevertableProperty a constructor in the
Property GADT, which would allow more property combinators to work on
RevertableProperties. That would look like:
data Propety i where
...
RProp :: Property i1 -> Property i2 -> Property (CInfo i1 i2)
In this case, there's only one Info/NoInfo encompassing both sides, and
so ensureProperty could only be used on it if both sides were NoInfo.

2
doc/todo/info_propigation_out_of_nested_properties.mdwn
View File

@ -1,3 +1,5 @@
> Now [[fixed|done]]!! --[[Joey]]
Currently, Info about a Host's Properties is propigated to the host by
examining the tree of Properties.

9
propellor.cabal
View File

@ -85,6 +85,7 @@ Library
Propellor.Property.Gpg
Propellor.Property.Group
Propellor.Property.Grub
Propellor.Property.Journald
Propellor.Property.Mount
Propellor.Property.Network
Propellor.Property.Nginx
@ -94,6 +95,7 @@ Library
Propellor.Property.Postfix
Propellor.Property.Prosody
Propellor.Property.Reboot
Propellor.Property.List
Propellor.Property.Scheduled
Propellor.Property.Service
Propellor.Property.Ssh
@ -108,7 +110,7 @@ Library
Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites
Propellor.Property.SiteSpecific.GitAnnexBuilder
Propellor.Host
Propellor.PropAccum
Propellor.CmdLine
Propellor.Info
Propellor.Message
@ -122,6 +124,9 @@ Library
Propellor.Types.Empty
Propellor.Types.OS
Propellor.Types.PrivData
Propellor.Types.Val
Propellor.Types.Result
Propellor.Types.CmdLine
Other-Modules:
Propellor.Git
Propellor.Gpg
@ -133,11 +138,13 @@ Library
Propellor.Property.Chroot.Util
Utility.Applicative
Utility.Data
Utility.DataUnits
Utility.Directory
Utility.Env
Utility.Exception
Utility.FileMode
Utility.FileSystemEncoding
Utility.HumanNumber
Utility.LinuxMkLibs
Utility.Misc
Utility.Monad

8
src/Propellor.hs
View File

@ -27,13 +27,14 @@
--
-- See config.hs for a more complete example, and clone Propellor's
-- git repository for a deployable system using Propellor:
-- git clone <git://git.kitenet.net/propellor>
-- git clone <git://git.joeyh.name/propellor>
module Propellor (
module Propellor.Types
, module Propellor.Property
, module Propellor.Property.List
, module Propellor.Property.Cmd
, module Propellor.Host
, module Propellor.PropAccum
, module Propellor.Info
, module Propellor.PrivData
, module Propellor.Types.PrivData
@ -48,13 +49,14 @@ module Propellor (
import Propellor.Types
import Propellor.Property
import Propellor.Engine
import Propellor.Property.List
import Propellor.Property.Cmd
import Propellor.PrivData
import Propellor.Types.PrivData
import Propellor.Message
import Propellor.Exception
import Propellor.Info
import Propellor.Host
import Propellor.PropAccum
import Utility.PartialPrelude as X
import Utility.Process as X

1
src/Propellor/CmdLine.hs
View File

@ -13,6 +13,7 @@ import Propellor
import Propellor.Gpg
import Propellor.Git
import Propellor.Spin
import Propellor.Types.CmdLine
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim

13
src/Propellor/Engine.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GADTs #-}
module Propellor.Engine (
mainProperties,
@ -35,7 +36,7 @@ import Utility.Monad
mainProperties :: Host -> IO ()
mainProperties host = do
ret <- runPropellor host $
ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty]
ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
h <- mkMessageHandle
whenConsole h $
setTitle "propellor: done"
@ -43,6 +44,8 @@ mainProperties host = do
case ret of
FailedChange -> exitWith (ExitFailure 1)
_ -> exitWith ExitSuccess
where
ps = map ignoreInfo $ hostProperties host
-- | Runs a Propellor action with the specified host.
--
@ -62,11 +65,13 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc
-- | For when code running in the Propellor monad needs to ensure a
-- Property.
ensureProperty :: Property -> Propellor Result
--
-- This can only be used on a Property that has NoInfo.
ensureProperty :: Property NoInfo -> Propellor Result
ensureProperty = catchPropellor . propertySatisfy
-- | Ensures a list of Properties, with a display of each as it runs.
ensureProperties :: [Property] -> Propellor Result
ensureProperties :: [Property NoInfo] -> Propellor Result
ensureProperties ps = ensure ps NoChange
where
ensure [] rs = return rs
@ -77,7 +82,7 @@ ensureProperties ps = ensure ps NoChange
-- | Lifts an action into a different host.
--
-- For example, `fromHost hosts "otherhost" getPubKey`
-- > fromHost hosts "otherhost" getPubKey
fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
fromHost l hn getter = case findHost l hn of
Nothing -> return Nothing

64
src/Propellor/Host.hs
View File

@ -1,64 +0,0 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Host where
import Data.Monoid
import qualified Data.Set as S
import Propellor.Types
import Propellor.Info
import Propellor.Property
import Propellor.PrivData
-- | Starts accumulating the properties of a Host.
--
-- > host "example.com"
-- > & someproperty
-- > ! oldproperty
-- > & otherproperty
host :: HostName -> Host
host hn = Host hn [] mempty
-- | Something that can accumulate properties.
class Hostlike h where
-- | Adds a property.
--
-- Can add Properties and RevertableProperties
(&) :: IsProp p => h -> p -> h
-- | Like (&), but adds the property as the
-- first property of the host. Normally, property
-- order should not matter, but this is useful
-- when it does.
(&^) :: IsProp p => h -> p -> h
getHost :: h -> Host
instance Hostlike Host where
(Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
getHost h = h
-- | Adds a property in reverted form.
(!) :: Hostlike h => h -> RevertableProperty -> h
h ! p = h & revert p
infixl 1 &^
infixl 1 &
infixl 1 !
-- | When eg, docking a container, some of the Info about the container
-- should propigate out to the Host it's on. This includes DNS info,
-- so that eg, aliases of the container are reflected in the dns for the
-- host where it runs.
--
-- This adjusts the Property that docks a container, to include such info
-- from the container.
propigateInfo :: Hostlike hl => hl -> Property -> (Info -> Info) -> Property
propigateInfo hl p f = combineProperties (propertyDesc p) $
p' : dnsprops ++ privprops
where
p' = p { propertyInfo = f (propertyInfo p) }
i = hostInfo (getHost hl)
dnsprops = map addDNS (S.toList $ _dns i)
privprops = map addPrivDataField (S.toList $ _privDataFields i)

15
src/Propellor/Info.hs
View File

@ -3,6 +3,7 @@
module Propellor.Info where
import Propellor.Types
import Propellor.Types.Val
import "mtl" Control.Monad.Reader
import qualified Data.Set as S
@ -11,13 +12,13 @@ import Data.Maybe
import Data.Monoid
import Control.Applicative
pureInfoProperty :: Desc -> Info -> Property
pureInfoProperty desc = Property ("has " ++ desc) (return NoChange)
pureInfoProperty :: Desc -> Info -> Property HasInfo
pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
askInfo :: (Info -> Val a) -> Propellor (Maybe a)
askInfo f = asks (fromVal . f . hostInfo)
os :: System -> Property
os :: System -> Property HasInfo
os system = pureInfoProperty ("Operating " ++ show system) $
mempty { _os = Val system }
@ -33,11 +34,11 @@ getOS = askInfo _os
-- When propellor --spin is used to deploy a host, it checks
-- if the host's IP Property matches the DNS. If the DNS is missing or
-- out of date, the host will instead be contacted directly by IP address.
ipv4 :: String -> Property
ipv4 :: String -> Property HasInfo
ipv4 = addDNS . Address . IPv4
-- | Indidate that a host has an AAAA record in the DNS.
ipv6 :: String -> Property
ipv6 :: String -> Property HasInfo
ipv6 = addDNS . Address . IPv6
-- | Indicates another name for the host in the DNS.
@ -46,7 +47,7 @@ ipv6 = addDNS . Address . IPv6
-- to use their address, rather than using a CNAME. This avoids various
-- problems with CNAMEs, and also means that when multiple hosts have the
-- same alias, a DNS round-robin is automatically set up.
alias :: Domain -> Property
alias :: Domain -> Property HasInfo
alias d = pureInfoProperty ("alias " ++ d) $ mempty
{ _aliases = S.singleton d
-- A CNAME is added here, but the DNS setup code converts it to an
@ -54,7 +55,7 @@ alias d = pureInfoProperty ("alias " ++ d) $ mempty
, _dns = S.singleton $ CNAME $ AbsDomain d
}
addDNS :: Record -> Property
addDNS :: Record -> Property HasInfo
addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }
where
rdesc (CNAME d) = unwords ["alias", ddesc d]

91
src/Propellor/PrivData.hs
View File

@ -1,6 +1,19 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
module Propellor.PrivData where
module Propellor.PrivData (
withPrivData,
withSomePrivData,
addPrivData,
setPrivData,
dumpPrivData,
editPrivData,
filterPrivData,
listPrivDataFields,
makePrivDataDir,
decryptPrivData,
PrivMap,
) where
import Control.Applicative
import System.IO
@ -48,29 +61,29 @@ import Utility.Table
-- being used, which is necessary to ensure that the privdata is sent to
-- the remote host by propellor.
withPrivData
:: (IsContext c, IsPrivDataSource s)
:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> s
-> c
-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property)
-> Property
-> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i)
-> Property HasInfo
withPrivData s = withPrivData' snd [s]
-- Like withPrivData, but here any one of a list of PrivDataFields can be used.
withSomePrivData
:: (IsContext c, IsPrivDataSource s)
:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> [s]
-> c
-> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property)
-> Property
-> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i)
-> Property HasInfo
withSomePrivData = withPrivData' id
withPrivData'
:: (IsContext c, IsPrivDataSource s)
:: (IsContext c, IsPrivDataSource s, IsProp (Property i))
=> ((PrivDataField, PrivData) -> v)
-> [s]
-> c
-> (((v -> Propellor Result) -> Propellor Result) -> Property)
-> Property
-> (((v -> Propellor Result) -> Propellor Result) -> Property i)
-> Property HasInfo
withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
maybe missing (a . feed) =<< getM get fieldlist
where
@ -82,20 +95,28 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
Context cname <- mkHostContext hc <$> asks hostName
warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")"
liftIO $ putStrLn $ "Fix this by running:"
liftIO $ forM_ srclist $ \src -> do
putStrLn $ " propellor --set '" ++ show (privDataField src) ++ "' '" ++ cname ++ "' \\"
maybe noop (\d -> putStrLn $ " " ++ d) (describePrivDataSource src)
putStrLn ""
liftIO $ showSet $
map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist
return FailedChange
addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = fieldset } }
addinfo p = infoProperty
(propertyDesc p)
(propertySatisfy p)
(propertyInfo p <> mempty { _privData = privset })
(propertyChildren p)
privset = S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
fieldnames = map show fieldlist
fieldset = S.fromList $ zip fieldlist (repeat hc)
fieldlist = map privDataField srclist
hc = asHostContext c
addPrivDataField :: (PrivDataField, HostContext) -> Property
addPrivDataField v = pureInfoProperty (show v) $
mempty { _privDataFields = S.singleton v }
showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO ()
showSet l = forM_ l $ \(f, Context c, md) -> do
putStrLn $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\"
maybe noop (\d -> putStrLn $ " " ++ d) md
putStrLn ""
addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo
addPrivData v = pureInfoProperty (show v) $
mempty { _privData = S.singleton v }
{- Gets the requested field's value, in the specified context if it's
- available, from the host's local privdata cache. -}
@ -107,12 +128,12 @@ getLocalPrivData field context =
type PrivMap = M.Map (PrivDataField, Context) PrivData
{- Get only the set of PrivData that the Host's Info says it uses. -}
-- | Get only the set of PrivData that the Host's Info says it uses.
filterPrivData :: Host -> PrivMap -> PrivMap
filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
where
used = S.map (\(f, c) -> (f, mkHostContext c (hostName host))) $
_privDataFields $ hostInfo host
used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $
_privData $ hostInfo host
getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
getPrivData field context = M.lookup (field, context)
@ -142,10 +163,17 @@ editPrivData field context = do
listPrivDataFields :: [Host] -> IO ()
listPrivDataFields hosts = do
m <- decryptPrivData
showtable "Currently set data:" $
map mkrow (M.keys m)
showtable "Data that would be used if set:" $
map mkrow (M.keys $ M.difference wantedmap m)
section "Currently set data:"
showtable $ map mkrow (M.keys m)
let missing = M.keys $ M.difference wantedmap m
unless (null missing) $ do
section "Missing data that would be used if set:"
showtable $ map mkrow missing
section "How to set missing data:"
showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing
where
header = ["Field", "Context", "Used by"]
mkrow k@(field, (Context context)) =
@ -153,12 +181,13 @@ listPrivDataFields hosts = do
, shellEscape context
, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby
]
mkhostmap host = M.fromList $ map (\(f, c) -> ((f, mkHostContext c (hostName host)), [hostName host])) $
S.toList $ _privDataFields $ hostInfo host
usedby = M.unionsWith (++) $ map mkhostmap hosts
mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $
S.toList $ _privData $ hostInfo host
usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const $ [hostName h]) hosts
wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")
showtable desc rows = do
putStrLn $ "\n" ++ desc
descmap = M.unions $ map (\h -> mkhostmap h id) hosts
section desc = putStrLn $ "\n" ++ desc
showtable rows = do
putStr $ unlines $ formatTable $ tableWithHeader header rows
setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()

92
src/Propellor/PropAccum.hs Normal file
View File

@ -0,0 +1,92 @@
{-# LANGUAGE PackageImports #-}
module Propellor.PropAccum where
import Data.Monoid
import Propellor.Types
import Propellor.Property
-- | Starts accumulating the properties of a Host.
--
-- > host "example.com"
-- > & someproperty
-- > ! oldproperty
-- > & otherproperty
host :: HostName -> Host
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.
class PropAccum h where
-- | Adds a property.
--
-- Can add Properties and RevertableProperties
(&) :: IsProp p => h -> p -> h
-- | Like (&), but adds the property at the front of the list.
(&^) :: IsProp p => h -> p -> h
getProperties :: h -> [Property HasInfo]
instance PropAccum Host where
(Host hn ps is) & p = Host hn (ps ++ [toProp p])
(is <> getInfoRecursive p)
(Host hn ps is) &^ p = Host hn ([toProp p] ++ ps)
(getInfoRecursive p <> is)
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.
(!) :: PropAccum h => h -> RevertableProperty -> h
h ! p = h & revert p
infixl 1 &^
infixl 1 &
infixl 1 !
-- | Adjust the provided Property, adding to its
-- propertyChidren the properties of the provided container.
--
-- The Info of the propertyChildren is adjusted to only include
-- info that should be propigated out to the Property.
--
-- DNS Info is propigated, so that eg, aliases of a PropAccum
-- are reflected in the dns for the host where it runs.
--
-- PrivData Info is propigated, so that properties used inside a
-- PropAccum will have the necessary PrivData available.
propigateContainer
:: (PropAccum container)
=> container
-> Property HasInfo
-> Property HasInfo
propigateContainer c prop = infoProperty
(propertyDesc prop)
(propertySatisfy prop)
(propertyInfo prop)
(propertyChildren prop ++ hostprops)
where
hostprops = map go $ getProperties c
go p =
let i = propertyInfo p
i' = mempty
{ _dns = _dns i
, _privData = _privData i
}
cs = map go (propertyChildren p)
in infoProperty (propertyDesc p) (propertySatisfy p) i' cs

103
src/Propellor/Property.hs
View File

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

14
src/Propellor/Property/Apache.hs
View File

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

75
src/Propellor/Property/Apt.hs
View File

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

30
src/Propellor/Property/Chroot.hs
View File

@ -1,5 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Chroot (
Chroot(..),
BuilderConf(..),
debootstrapped,
provisioned,
-- * Internal use
@ -10,6 +13,7 @@ module Propellor.Property.Chroot (
) where
import Propellor
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
@ -28,10 +32,10 @@ data BuilderConf
= UsingDeboostrap Debootstrap.DebootstrapConfig
deriving (Show)
instance Hostlike Chroot where
instance PropAccum Chroot where
(Chroot l s c h) & p = Chroot l s c (h & p)
(Chroot l s c h) &^ p = Chroot l s c (h &^ p)
getHost (Chroot _ _ _ h) = h
getProperties (Chroot _ _ _ h) = hostProperties h
-- | Defines a Chroot at the given location, built with debootstrap.
--
@ -57,12 +61,13 @@ debootstrapped system conf location = case system of
provisioned :: Chroot -> RevertableProperty
provisioned c = provisioned' (propigateChrootInfo c) c False
provisioned' :: (Property -> Property) -> Chroot -> Bool -> RevertableProperty
provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = RevertableProperty
provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
(propigator $ go "exists" setup)
<!>
(go "removed" teardown)
where
go desc a = property (chrootDesc c desc) $ ensureProperties [a]
go desc a = propertyList (chrootDesc c desc) [a]
setup = propellChroot c (inChrootProcess c) systemdonly
`requires` toProp built
@ -75,15 +80,21 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert
teardown = toProp (revert built)
propigateChrootInfo :: Chroot -> Property -> Property
propigateChrootInfo c p = propigateInfo c p (<> chrootInfo c)
propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
propigateChrootInfo c p = propigateContainer c p'
where
p' = infoProperty
(propertyDesc p)
(propertySatisfy p)
(propertyInfo p <> chrootInfo c)
(propertyChildren p)
chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ _ h) =
mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }
-- | 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
let d = localdir </> shimdir c
let me = localdir </> "propellor"
@ -140,7 +151,8 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
r <- runPropellor h $ ensureProperties $
if systemdonly
then [Systemd.installed]
else hostProperties h
else map ignoreInfo $
hostProperties h
putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"

8
src/Propellor/Property/Cmd.hs
View File

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

6
src/Propellor/Property/Cron.hs
View File

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

52
src/Propellor/Property/Debootstrap.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Debootstrap (
Url,
DebootstrapConfig(..),
@ -56,19 +58,18 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2
-- Note that reverting this property does not stop any processes
-- currently running in the chroot.
built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty
built = built' (toProp installed)
built' :: Property -> FilePath -> System -> DebootstrapConfig -> RevertableProperty
built' installprop target system@(System _ arch) config =
RevertableProperty setup teardown
built target system config = built' (toProp installed) target system config <!> teardown
where
setup = check (unpopulated target <||> ispartial) setupprop
`requires` installprop
teardown = check (not <$> unpopulated target) teardownprop
unpopulated d = null <$> catchDefaultIO [] (dirContents d)
teardownprop = property ("removed debootstrapped " ++ target) $
makeChange (removetarget target)
built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
built' installprop target system@(System _ arch) config =
check (unpopulated target <||> ispartial) setupprop
`requires` installprop
where
setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
createDirectoryIfMissing True target
-- Don't allow non-root users to see inside the chroot,
@ -93,24 +94,25 @@ built' installprop target system@(System _ arch) config =
, return FailedChange
)
teardownprop = property ("removed debootstrapped " ++ target) $
makeChange removetarget
removetarget = do
submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
. filter (dirContains target)
<$> mountPoints
forM_ submnts umountLazy
removeDirectoryRecursive target
-- A failed debootstrap run will leave a debootstrap directory;
-- recover by deleting it and trying again.
ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
( do
removetarget
removetarget target
return True
, return False
)
unpopulated :: FilePath -> IO Bool
unpopulated d = null <$> catchDefaultIO [] (dirContents d)
removetarget :: FilePath -> IO ()
removetarget target = do
submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
. filter (dirContains target)
<$> mountPoints
forM_ submnts umountLazy
removeDirectoryRecursive target
extractSuite :: System -> Maybe String
extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
@ -122,7 +124,7 @@ extractSuite (System (Ubuntu r) _) = Just r
-- Note that installation from source is done by downloading the tarball
-- from a Debian mirror, with no cryptographic verification.
installed :: RevertableProperty
installed = RevertableProperty install remove
installed = install <!> remove
where
install = withOS "debootstrap installed" $ \o ->
ifM (liftIO $ isJust <$> programPath)
@ -142,18 +144,18 @@ installed = RevertableProperty install remove
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
sourceInstall :: Property
sourceInstall :: Property NoInfo
sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')
`requires` perlInstalled
`requires` arInstalled
perlInstalled :: Property
perlInstalled :: Property NoInfo
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "perl"
]
arInstalled :: Property
arInstalled :: Property NoInfo
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "binutils"
@ -197,7 +199,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
return MadeChange
_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
sourceRemove :: Property
sourceRemove :: Property NoInfo
sourceRemove = property "debootstrap not installed from source" $ liftIO $
ifM (doesDirectoryExist sourceInstallDir)
( do

31
src/Propellor/Property/Dns.hs
View File

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

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

75
src/Propellor/Property/Docker.hs
View File

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

30
src/Propellor/Property/File.hs
View File

@ -9,7 +9,7 @@ import System.PosixCompat.Types
type Line = String
-- | Replaces all the content of a file.
hasContent :: FilePath -> [Line] -> Property
hasContent :: FilePath -> [Line] -> Property NoInfo
f `hasContent` newcontent = fileProperty ("replace " ++ 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.
-- 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
-- | Like hasPrivContent, but allows specifying a source
-- 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
-- | Leaves the file at its default or current mode,
-- allowing "private" data to be read.
--
-- Use with caution!
hasPrivContentExposed :: IsContext c => FilePath -> c -> Property
hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo
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
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 =
withPrivData source context $ \getcontent ->
property desc $ getcontent $ \privcontent ->
@ -45,10 +45,10 @@ hasPrivContent' writer source f context =
desc = "privcontent " ++ f
-- | Ensures that a line is present in a file, adding it to the end if not.
containsLine :: FilePath -> Line -> Property
containsLine :: FilePath -> Line -> Property NoInfo
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
where
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.
-- Note that the file is ensured to exist, so if it doesn't, an empty
-- file will be written.
lacksLine :: FilePath -> Line -> Property
lacksLine :: FilePath -> Line -> Property NoInfo
f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property
notPresent :: FilePath -> Property NoInfo
notPresent f = check (doesFileExist f) $ property (f ++ " not present") $
makeChange $ nukeFile f
fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
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)
where
go True = do
@ -86,12 +86,12 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
setOwnerAndGroup f' (fileOwner s) (fileGroup s)
-- | Ensures a directory exists.
dirExists :: FilePath -> Property
dirExists :: FilePath -> Property NoInfo
dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $
makeChange $ createDirectoryIfMissing True d
-- | Ensures that a file/dir has the specified owner and group.
ownerGroup :: FilePath -> UserName -> GroupName -> Property
ownerGroup :: FilePath -> UserName -> GroupName -> Property NoInfo
ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
r <- ensureProperty $ cmdProperty "chown" [og, f]
if r == FailedChange
@ -101,7 +101,7 @@ ownerGroup f owner group = property (f ++ " owner " ++ og) $ do
og = owner ++ ":" ++ group
-- | 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
liftIO $ modifyFileMode f (\_old -> v)
noChange

5
src/Propellor/Property/Firewall.hs
View File

@ -9,6 +9,7 @@ module Propellor.Property.Firewall (
Target(..),
Proto(..),
Rules(..),
Port,
ConnectionState(..)
) where
@ -21,10 +22,10 @@ import Utility.SafeCommand
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network
installed :: Property
installed :: Property NoInfo
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
where
r = Rule c t rs

8
src/Propellor/Property/Git.hs
View File

@ -13,7 +13,7 @@ import Data.List
--
-- Note that reverting this property does not remove or stop inetd.
daemonRunning :: FilePath -> RevertableProperty
daemonRunning exportdir = RevertableProperty setup unsetup
daemonRunning exportdir = setup <!> unsetup
where
setup = containsLine conf (mkl "tcp4")
`requires`
@ -48,7 +48,7 @@ daemonRunning exportdir = RevertableProperty setup unsetup
, exportdir
]
installed :: Property
installed :: Property NoInfo
installed = Apt.installed ["git"]
type RepoUrl = String
@ -62,7 +62,7 @@ type Branch = String
-- it will be recursively deleted first.
--
-- 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)
`requires` installed
where
@ -98,7 +98,7 @@ isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--re
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) $
dirExists repo : case gitshared of
NotShared ->

4
src/Propellor/Property/Gpg.hs
View File

@ -6,7 +6,7 @@ import Utility.FileSystemEncoding
import System.PosixCompat
installed :: Property
installed :: Property NoInfo
installed = Apt.installed ["gnupg"]
-- 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.
-- 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
`requires` installed
where

2
src/Propellor/Property/Group.hs
View File

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

10
src/Propellor/Property/Grub.hs
View File

@ -4,10 +4,10 @@ import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
-- | Eg, "hd0,0" or "xen/xvda1"
-- | Eg, \"hd0,0\" or \"xen/xvda1\"
type GrubDevice = String
-- | Eg, "/dev/sda"
-- | Eg, \"\/dev/sda\"
type OSDevice = String
type TimeoutSecs = Int
@ -21,7 +21,7 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- This includes running update-grub, so that the grub boot menu is
-- created. It will be automatically updated when kernel packages are
-- installed.
installed :: BIOS -> Property
installed :: BIOS -> Property NoInfo
installed bios =
Apt.installed [pkg] `describe` "grub package installed"
`before`
@ -43,7 +43,7 @@ installed bios =
-- on the device; it always does the work to reinstall it. It's a good idea
-- to arrange for this property to only run once, by eg making it be run
-- onChange after OS.cleanInstallOnce.
boots :: OSDevice -> Property
boots :: OSDevice -> Property NoInfo
boots dev = cmdProperty "grub-install" [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
-- "xen/xvda".
chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property
chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo
chainPVGrub rootdev bootdev timeout = combineProperties desc
[ File.dirExists "/boot/grub"
, "/boot/grub/menu.lst" `File.hasContent`

2
src/Propellor/Property/HostingProvider/CloudAtCost.hs
View File

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

2
src/Propellor/Property/HostingProvider/DigitalOcean.hs
View File

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

2
src/Propellor/Property/HostingProvider/Linode.hs
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
-- Debian kernels compressed with xz. This sets up pv-grub chaing to enable
-- it.
chainPVGrub :: Grub.TimeoutSecs -> Property
chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo
chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"

6
src/Propellor/Property/Hostname.hs
View File

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

53
src/Propellor/Property/Journald.hs Normal file
View File

@ -0,0 +1,53 @@
module Propellor.Property.Journald where
import Propellor
import qualified Propellor.Property.Systemd as Systemd
import Utility.DataUnits
-- | Configures journald, restarting it so the changes take effect.
configured :: Systemd.Option -> String -> Property NoInfo
configured option value =
Systemd.configured "/etc/systemd/journald.conf" option value
`onChange` Systemd.restarted "systemd-journald"
-- The string is parsed to get a data size.
-- Examples: "100 megabytes" or "0.5tb"
type DataSize = String
configuredSize :: Systemd.Option -> DataSize -> Property NoInfo
configuredSize option s = case readSize dataUnits s of
Just sz -> configured option (systemdSizeUnits sz)
Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange
systemMaxUse :: DataSize -> Property NoInfo
systemMaxUse = configuredSize "SystemMaxUse"
runtimeMaxUse :: DataSize -> Property NoInfo
runtimeMaxUse = configuredSize "RuntimeMaxUse"
systemKeepFree :: DataSize -> Property NoInfo
systemKeepFree = configuredSize "SystemKeepFree"
runtimeKeepFree :: DataSize -> Property NoInfo
runtimeKeepFree = configuredSize "RuntimeKeepFree"
systemMaxFileSize :: DataSize -> Property NoInfo
systemMaxFileSize = configuredSize "SystemMaxFileSize"
runtimeMaxFileSize :: DataSize -> Property NoInfo
runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize"
-- Generates size units as used in journald.conf.
systemdSizeUnits :: Integer -> String
systemdSizeUnits sz = filter (/= ' ') (roughSize cfgfileunits True sz)
where
cfgfileunits :: [Unit]
cfgfileunits =
[ Unit (p 6) "E" "exabyte"
, Unit (p 5) "P" "petabyte"
, Unit (p 4) "T" "terabyte"
, Unit (p 3) "G" "gigabyte"
, Unit (p 2) "M" "megabyte"
, Unit (p 1) "K" "kilobyte"
]
p :: Integer -> Integer
p n = 1024^n

63
src/Propellor/Property/List.hs Normal file
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)

109
src/Propellor/Property/Network.hs
View File

@ -3,28 +3,93 @@ module Propellor.Property.Network where
import Propellor
import Propellor.Property.File
interfaces :: FilePath
interfaces = "/etc/network/interfaces"
-- | 6to4 ipv6 connection, should work anywhere
ipv6to4 :: Property
ipv6to4 = fileProperty "ipv6to4" go interfaces
`onChange` ifUp "sit0"
where
go ls
| all (`elem` ls) stanza = ls
| otherwise = ls ++ stanza
stanza =
[ "# Automatically added by propeller"
, "iface sit0 inet6 static"
, "\taddress 2002:5044:5531::1"
, "\tnetmask 64"
, "\tgateway ::192.88.99.1"
, "auto sit0"
, "# End automatically added by propeller"
]
type Interface = String
ifUp :: Interface -> Property
ifUp :: Interface -> Property NoInfo
ifUp iface = cmdProperty "ifup" [iface]
-- | Resets /etc/network/interfaces to a clean and empty state,
-- containing just the standard loopback interface, and with
-- interfacesD enabled.
--
-- This can be used as a starting point to defining other interfaces.
--
-- No interfaces are brought up or down by this property.
cleanInterfacesFile :: Property NoInfo
cleanInterfacesFile = hasContent interfacesFile
[ "# Deployed by propellor, do not edit."
, ""
, "source-directory interfaces.d"
, ""
, "# The loopback network interface"
, "auto lo"
, "iface lo inet loopback"
]
`describe` ("clean " ++ interfacesFile)
-- | Writes a static interface file for the specified interface.
--
-- The interface has to be up already. It could have been brought up by
-- DHCP, or by other means. The current ipv4 addresses
-- and routing configuration of the interface are written into the file.
--
-- If the interface file already exists, this property does nothing,
-- no matter its content.
--
-- (ipv6 addresses are not included because it's assumed they come up
-- automatically in most situations.)
static :: Interface -> Property NoInfo
static iface = check (not <$> doesFileExist f) setup
`describe` desc
`requires` interfacesDEnabled
where
f = interfaceDFile iface
desc = "static " ++ iface
setup = property desc $ do
ls <- liftIO $ lines <$> readProcess "ip"
["-o", "addr", "show", iface, "scope", "global"]
stanzas <- liftIO $ concat <$> mapM mkstanza ls
ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas
mkstanza ipline = case words ipline of
-- Note that the IP address is written CIDR style, so
-- the netmask does not need to be specified separately.
(_:iface':"inet":addr:_) | iface' == iface -> do
gw <- getgateway
return $ catMaybes
[ Just $ "iface " ++ iface ++ " inet static"
, Just $ "\taddress " ++ addr
, ("\tgateway " ++) <$> gw
]
_ -> return []
getgateway = do
rs <- lines <$> readProcess "ip"
["route", "show", "scope", "global", "dev", iface]
return $ case words <$> headMaybe rs of
Just ("default":"via":gw:_) -> Just gw
_ -> Nothing
-- | 6to4 ipv6 connection, should work anywhere
ipv6to4 :: Property NoInfo
ipv6to4 = hasContent (interfaceDFile "sit0")
[ "# Deployed by propellor, do not edit."
, "iface sit0 inet6 static"
, "\taddress 2002:5044:5531::1"
, "\tnetmask 64"
, "\tgateway ::192.88.99.1"
, "auto sit0"
]
`describe` "ipv6to4"
`requires` interfacesDEnabled
`onChange` ifUp "sit0"
interfacesFile :: FilePath
interfacesFile = "/etc/network/interfaces"
-- | A file in the interfaces.d directory.
interfaceDFile :: Interface -> FilePath
interfaceDFile iface = "/etc/network/interfaces.d" </> iface
-- | Ensures that files in the the interfaces.d directory are used.
interfacesDEnabled :: Property NoInfo
interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d"
`describe` "interfaces.d directory enabled"

10
src/Propellor/Property/Nginx.hs
View File

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

29
src/Propellor/Property/OS.hs
View File

@ -10,6 +10,7 @@ module Propellor.Property.OS (
import Propellor
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Ssh as Ssh
import qualified Propellor.Property.Network as Network
import qualified Propellor.Property.User as User
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Reboot as Reboot
@ -51,7 +52,7 @@ import Control.Exception (throw)
-- > `onChange` propertyList "fixing up after clean install"
-- > [ preserveNetwork
-- > , preserveResolvConf
-- > , preserverRootSshAuthorized
-- > , preserveRootSshAuthorized
-- > , Apt.update
-- > -- , Grub.boots "/dev/sda"
-- > -- `requires` Grub.installed Grub.PC
@ -64,7 +65,7 @@ import Control.Exception (throw)
-- > & User.accountFor "joey"
-- > & User.hasSomePassword "joey"
-- > -- rest of system properties here
cleanInstallOnce :: Confirmation -> Property
cleanInstallOnce :: Confirmation -> Property NoInfo
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation
where
@ -88,7 +89,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
(Just u@(System (Ubuntu _) _)) -> debootstrap u
_ -> error "os is not declared to be Debian or Ubuntu"
debootstrap targetos = ensureProperty $ toProp $
debootstrap targetos = ensureProperty $
-- Ignore the os setting, and install debootstrap from
-- source, since we don't know what OS we're running in yet.
Debootstrap.built' Debootstrap.sourceInstall
@ -179,7 +180,7 @@ massRename = go []
data Confirmation = Confirmed HostName
confirmed :: Desc -> Confirmation -> Property
confirmed :: Desc -> Confirmation -> Property NoInfo
confirmed desc (Confirmed c) = property desc $ do
hostname <- asks hostName
if hostname /= c
@ -191,11 +192,21 @@ confirmed desc (Confirmed c) = property desc $ do
-- | </etc/network/interfaces> is configured to bring up the network
-- interface that currently has a default route configured, using
-- the same (static) IP address.
preserveNetwork :: Property
preserveNetwork = undefined -- TODO
preserveNetwork :: Property NoInfo
preserveNetwork = go `requires` Network.cleanInterfacesFile
where
go = property "preserve network configuration" $ do
ls <- liftIO $ lines <$> readProcess "ip"
["route", "list", "scope", "global"]
case words <$> headMaybe ls of
Just ("default":"via":_:"dev":iface:_) ->
ensureProperty $ Network.static iface
_ -> do
warningMessage "did not find any default ipv4 route"
return FailedChange
-- | </etc/resolv.conf> is copied from the old OS
preserveResolvConf :: Property
preserveResolvConf :: Property NoInfo
preserveResolvConf = check (fileExist oldloc) $
property (newloc ++ " copied from old OS") $ do
ls <- liftIO $ lines <$> readFile oldloc
@ -207,7 +218,7 @@ preserveResolvConf = check (fileExist oldloc) $
-- | </root/.ssh/authorized_keys> has added to it any ssh keys that
-- were authorized in the old OS. Any other contents of the file are
-- retained.
preserveRootSshAuthorized :: Property
preserveRootSshAuthorized :: Property NoInfo
preserveRootSshAuthorized = check (fileExist oldloc) $
property (newloc ++ " copied from old OS") $ do
ks <- liftIO $ lines <$> readFile oldloc
@ -217,7 +228,7 @@ preserveRootSshAuthorized = check (fileExist oldloc) $
oldloc = oldOSDir ++ newloc
-- Removes the old OS's backup from </old-os>
oldOSRemoved :: Confirmation -> Property
oldOSRemoved :: Confirmation -> Property NoInfo
oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
go `requires` confirmed "old OS backup removal confirmed" confirmation
where

14
src/Propellor/Property/Obnam.hs
View File

@ -36,7 +36,7 @@ data NumClients = OnlyClient | MultipleClients
-- > `requires` Ssh.keyImported SshRsa "root" (Context hostname)
--
-- 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
`requires` restored dir params
@ -46,7 +46,7 @@ backup dir crontimes params numclients =
--
-- The gpg secret key will be automatically imported
-- 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 =
backup dir crontimes params' numclients
`requires` Gpg.keyImported keyid "root"
@ -54,7 +54,7 @@ backupEncrypted dir crontimes params numclients keyid =
params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params
-- | Does a backup, but does not automatically restore.
backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo
backup' dir crontimes params numclients = cronjob `describe` desc
where
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
-- 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
`requires` installed
where
@ -108,17 +108,17 @@ restored dir params = property (dir ++ " restored by obnam") go
, return FailedChange
)
installed :: Property
installed :: Property NoInfo
installed = Apt.installed ["obnam"]
-- | Ensures that a recent version of obnam gets installed.
--
-- Only does anything for Debian Stable.
latestVersion :: Property
latestVersion :: Property NoInfo
latestVersion = withOS "obnam latest version" $ \o -> case o of
(Just (System (Debian suite) _)) | isStable suite -> ensureProperty $
Apt.setSourcesListD (stablesources suite) "obnam"
`requires` toProp (Apt.trustsKey key)
`requires` Apt.trustsKey' key
_ -> noChange
where
stablesources suite =

4
src/Propellor/Property/OpenId.hs
View File

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

26
src/Propellor/Property/Postfix.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Postfix where
import Propellor
@ -9,13 +11,13 @@ import qualified Data.Map as M
import Data.List
import Data.Char
installed :: Property
installed :: Property NoInfo
installed = Apt.serviceInstalledRunning "postfix"
restarted :: Property
restarted :: Property NoInfo
restarted = Service.restarted "postfix"
reloaded :: Property
reloaded :: Property NoInfo
reloaded = Service.reloaded "postfix"
-- | 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
-- futher coniguration/keys. But this should be enough to get cron job
-- mail flowing to a place where it will be seen.
satellite :: Property
satellite :: Property NoInfo
satellite = check (not <$> mainCfIsSet "relayhost") setup
`requires` installed
where
@ -45,13 +47,17 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup
-- | Sets up a file by running a property (which the filename is passed
-- to). If the setup property makes a change, postmap will be run on the
-- file, and postfix will be reloaded.
mappedFile :: FilePath -> (FilePath -> Property) -> Property
mappedFile
:: Combines (Property x) (Property NoInfo)
=> FilePath
-> (FilePath -> Property x)
-> Property (CInfo x NoInfo)
mappedFile f setup = setup f
`onChange` cmdProperty "postmap" [f]
-- | Run newaliases command, which should be done after changing
-- </etc/aliases>.
newaliases :: Property
newaliases :: Property NoInfo
newaliases = trivial $ cmdProperty "newaliases" []
-- | The main config file for postfix.
@ -59,7 +65,7 @@ mainCfFile :: FilePath
mainCfFile = "/etc/postfix/main.cf"
-- | 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
`describe` ("postfix main.cf " ++ setting)
where
@ -77,8 +83,8 @@ getMainCf name = parse . lines <$> readProcess "postconf" [name]
(_, v) -> v
parse [] = Nothing
-- | Checks if a main.cf field is set. A field that is set to ""
-- is considered not set.
-- | Checks if a main.cf field is set. A field that is set to
-- the empty string is considered not set.
mainCfIsSet :: String -> IO Bool
mainCfIsSet name = do
v <- getMainCf name
@ -96,7 +102,7 @@ mainCfIsSet name = do
--
-- Note that multiline configurations that continue onto the next line
-- are not currently supported.
dedupMainCf :: Property
dedupMainCf :: Property NoInfo
dedupMainCf = fileProperty "postfix main.cf dedupped" dedupCf mainCfFile
dedupCf :: [String] -> [String]

10
src/Propellor/Property/Prosody.hs
View File

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

4
src/Propellor/Property/Reboot.hs
View File

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

8
src/Propellor/Property/Scheduled.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Scheduled
( period
, 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
-- last run.
period :: Property -> Recurrance -> Property
period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do
period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i
period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do
lasttime <- liftIO $ getLastChecked (propertyDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow
@ -34,7 +36,7 @@ period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy ->
desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
-- | 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
Just recurrance -> period prop recurrance
Nothing -> property "periodParse" $ do

8
src/Propellor/Property/Service.hs
View File

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

66
src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
View File

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

2
src/Propellor/Property/SiteSpecific/GitHome.hs
View File

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

451
src/Propellor/Property/SiteSpecific/JoeySites.hs
View File

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

38
src/Propellor/Property/Ssh.hs
View File

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

2
src/Propellor/Property/Sudo.hs
View File

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

83
src/Propellor/Property/Systemd.hs
View File

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

2
src/Propellor/Property/Systemd/Core.hs
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
-- from the systemd inside a container to the one outside, so make sure it
-- gets installed.
installed :: Property
installed :: Property NoInfo
installed = Apt.installed ["systemd", "dbus"]

12
src/Propellor/Property/Tor.hs
View File

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

18
src/Propellor/Property/User.hs
View File

@ -6,7 +6,7 @@ import Propellor
data Eep = YesReallyDeleteHome
accountFor :: UserName -> Property
accountFor :: UserName -> Property NoInfo
accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"
[ "--disabled-password"
, "--gecos", ""
@ -15,7 +15,7 @@ accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdPropert
`describe` ("account for " ++ user)
-- | 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"
[ "-r"
, 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
-- not be a password from the PrivData.
hasSomePassword :: UserName -> Property
hasSomePassword :: UserName -> Property HasInfo
hasSomePassword user = hasSomePassword' user hostContext
-- | While hasSomePassword uses the name of the host as context,
-- this allows specifying a different context. This is useful when
-- you want to use the same password on multiple hosts, for example.
hasSomePassword' :: IsContext c => UserName -> c -> Property
hasSomePassword' :: IsContext c => UserName -> c -> Property HasInfo
hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $
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;
-- the full cleartext <Password> or a <CryptPassword> hash. The latter
-- is obviously more secure.
hasPassword :: UserName -> Property
hasPassword :: UserName -> Property HasInfo
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
where
go = withSomePrivData srcs context $
@ -66,7 +66,7 @@ setPassword getpassword = getpassword $ go
hPutStrLn h $ user ++ ":" ++ v
hClose h
lockedPassword :: UserName -> Property
lockedPassword :: UserName -> Property NoInfo
lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd"
[ "--lock"
, user
@ -90,7 +90,7 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
homedir :: UserName -> IO FilePath
homedir user = homeDirectory <$> getUserEntryForName user
hasGroup :: UserName -> GroupName -> Property
hasGroup :: UserName -> GroupName -> Property NoInfo
hasGroup user group' = check test $ cmdProperty "adduser"
[ user
, group'
@ -100,7 +100,7 @@ hasGroup user group' = check test $ cmdProperty "adduser"
test = not . elem group' . words <$> readProcess "groups" [user]
-- | Controls whether shadow passwords are enabled or not.
shadowConfig :: Bool -> Property
shadowConfig :: Bool -> Property NoInfo
shadowConfig True = check (not <$> shadowExists) $
cmdProperty "shadowconfig" ["on"]
`describe` "shadow passwords enabled"

1
src/Propellor/Spin.hs
View File

@ -24,6 +24,7 @@ import Propellor.PrivData.Paths
import Propellor.Git
import Propellor.Ssh
import Propellor.Gpg
import Propellor.Types.CmdLine
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand

332
src/Propellor/Types.hs
View File

@ -1,44 +1,48 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Propellor.Types
( Host(..)
, Info(..)
, getInfo
, Propellor(..)
, Property(..)
, RevertableProperty(..)
, IsProp
, describe
, toProp
, requires
, Desc
, Result(..)
, ToResult(..)
, ActionResult(..)
, CmdLine(..)
, PrivDataField(..)
, PrivData
, Context(..)
, anyContext
, SshKeyType(..)
, Val(..)
, fromVal
, RunLog
, Property
, HasInfo
, NoInfo
, CInfo
, infoProperty
, simpleProperty
, adjustPropertySatisfy
, propertyInfo
, propertyDesc
, propertyChildren
, RevertableProperty(..)
, (<!>)
, IsProp(..)
, Combines(..)
, CombinedType
, before
, combineWith
, Info(..)
, Propellor(..)
, EndAction(..)
, module Propellor.Types.OS
, module Propellor.Types.Dns
, module Propellor.Types.Result
, propertySatisfy
, ignoreInfo
) where
import Data.Monoid
import Control.Applicative
import System.Console.ANSI
import System.Posix.Types
import "mtl" Control.Monad.RWS.Strict
import "MonadCatchIO-transformers" Control.Monad.CatchIO
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Propellor.Types.Dns as Dns
import Propellor.Types.OS
import Propellor.Types.Chroot
@ -46,137 +50,228 @@ import Propellor.Types.Dns
import Propellor.Types.Docker
import Propellor.Types.PrivData
import Propellor.Types.Empty
import Propellor.Types.Val
import Propellor.Types.Result
import qualified Propellor.Types.Dns as Dns
-- | Everything Propellor knows about a system: Its hostname,
-- properties and other info.
-- properties and their collected info.
data Host = Host
{ hostName :: HostName
, hostProperties :: [Property]
, hostProperties :: [Property HasInfo]
, hostInfo :: Info
}
deriving (Show)
-- | Propellor's monad provides read-only access to info about the host
-- it's running on, and a writer to accumulate logs about the run.
newtype Propellor p = Propellor { runWithHost :: RWST Host RunLog () IO p }
-- it's running on, and a writer to accumulate EndActions.
newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
deriving
( Monad
, Functor
, Applicative
, MonadReader Host
, MonadWriter RunLog
, MonadWriter [EndAction]
, MonadIO
, 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
-- properties. It's passed the combined Result of the entire Propellor run.
data EndAction = EndAction Desc (Result -> Propellor Result)
type Desc = String
-- | The core data type of Propellor, this represents a property
-- that the system should have, and an action to ensure it has the
-- property.
data Property = Property
{ propertyDesc :: Desc
, propertySatisfy :: Propellor Result
-- ^ must be idempotent; may run repeatedly
, propertyInfo :: Info
-- ^ a property can add info to the host.
}
data Property i where
IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo
SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
instance Show Property where
show p = "property " ++ show (propertyDesc p)
-- | Indicates that a Property has associated Info.
data HasInfo
-- | Indicates that a Property does not have Info.
data NoInfo
-- | Type level calculation of the combination of HasInfo and/or NoInfo
type family CInfo x y
type instance CInfo HasInfo HasInfo = HasInfo
type instance CInfo HasInfo NoInfo = HasInfo
type instance CInfo NoInfo HasInfo = HasInfo
type instance CInfo NoInfo NoInfo = NoInfo
-- | Constructs a Property with associated Info.
infoProperty
:: Desc -- ^ description of the property
-> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly)
-> Info -- ^ info associated with the property
-> [Property i] -- ^ child properties
-> Property HasInfo
infoProperty d a i cs = IProperty d a i (map toIProperty cs)
-- | Constructs a Property with no Info.
simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo
simpleProperty = SProperty
toIProperty :: Property i -> Property HasInfo
toIProperty p@(IProperty {}) = p
toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs)
toSProperty :: Property i -> Property NoInfo
toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs)
toSProperty p@(SProperty {}) = p
-- | Makes a version of a Proprty without its Info.
-- Use with caution!
ignoreInfo :: Property i -> Property NoInfo
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 i) where
show p = "property " ++ show (propertyDesc p)
-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i
adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs
adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs
propertyInfo :: Property i -> Info
propertyInfo (IProperty _ _ i _) = i
propertyInfo (SProperty {}) = mempty
propertyDesc :: Property i -> Desc
propertyDesc (IProperty d _ _ _) = d
propertyDesc (SProperty d _ _) = d
-- | A Property can include a list of child properties that it also
-- satisfies. This allows them to be introspected to collect their info, etc.
propertyChildren :: Property i -> [Property i]
propertyChildren (IProperty _ _ _ cs) = cs
propertyChildren (SProperty _ _ cs) = cs
-- | A property that can be reverted.
data RevertableProperty = RevertableProperty Property Property
data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo)
-- | Makes a revertable property; the first Property is run
-- normally and the second is run when it's reverted.
(<!>) :: Property i1 -> Property i2 -> RevertableProperty
p1 <!> p2 = RevertableProperty (toIProperty p1) (toIProperty p2)
class IsProp p where
-- | Sets description.
describe :: p -> Desc -> p
toProp :: p -> Property
-- | Indicates that the first property can only be satisfied
-- once the second one is.
requires :: p -> Property -> p
getInfo :: p -> Info
toProp :: p -> Property HasInfo
getDesc :: p -> Desc
-- | Gets the info of the property, combined with all info
-- of all children properties.
getInfoRecursive :: p -> Info
instance IsProp Property where
describe p d = p { propertyDesc = d }
toProp p = p
getInfo = propertyInfo
x `requires` y = Property (propertyDesc x) satisfy info
where
info = getInfo y <> getInfo x
satisfy = do
r <- propertySatisfy y
case r of
FailedChange -> return FailedChange
_ -> propertySatisfy x
instance IsProp (Property HasInfo) where
describe (IProperty _ a i cs) d = IProperty d a i cs
toProp = id
getDesc = propertyDesc
getInfoRecursive (IProperty _ _ i cs) =
i <> mconcat (map getInfoRecursive cs)
instance IsProp (Property NoInfo) where
describe (SProperty _ a cs) d = SProperty d a cs
toProp = toIProperty
getDesc = propertyDesc
getInfoRecursive _ = mempty
instance IsProp RevertableProperty where
-- | Sets the description of both sides.
describe (RevertableProperty p1 p2) d =
RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))
getDesc (RevertableProperty p1 _) = getDesc p1
toProp (RevertableProperty p1 _) = p1
(RevertableProperty p1 p2) `requires` y =
RevertableProperty (p1 `requires` y) p2
-- | Return the Info of the currently active side.
getInfo (RevertableProperty p1 _p2) = getInfo p1
getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
type Desc = String
-- | Type level calculation of the type that results from combining two types
-- with `requires`.
type family CombinedType x y
type instance CombinedType (Property x) (Property y) = Property (CInfo x y)
type instance CombinedType RevertableProperty (Property NoInfo) = RevertableProperty
type instance CombinedType RevertableProperty (Property HasInfo) = RevertableProperty
type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty
data Result = NoChange | MadeChange | FailedChange
deriving (Read, Show, Eq)
class Combines x y where
-- | Indicates that the first property depends on the second,
-- so before the first is ensured, the second will be ensured.
requires :: x -> y -> CombinedType x y
-- | 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 :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x
before x y = (y `requires` x) `describe` (getDesc x)
instance Monoid Result where
mempty = NoChange
-- | Combines together two properties, yielding a property that
-- has the description and info of the first, and that has the second
-- property as a child. The two actions to satisfy the properties
-- are passed to a function that can combine them in arbitrary ways.
combineWith
:: (Combines (Property x) (Property y))
=> (Propellor Result -> Propellor Result -> Propellor Result)
-> Property x
-> Property y
-> CombinedType (Property x) (Property y)
combineWith f x y = adjustPropertySatisfy (x `requires` y) $ \_ ->
f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y)
mappend FailedChange _ = FailedChange
mappend _ FailedChange = FailedChange
mappend MadeChange _ = MadeChange
mappend _ MadeChange = MadeChange
mappend NoChange NoChange = NoChange
instance Combines (Property HasInfo) (Property HasInfo) where
requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
IProperty d1 (a2 <> a1) i1 (y : cs1)
class ToResult t where
toResult :: t -> Result
instance Combines (Property HasInfo) (Property NoInfo) where
requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1)
instance ToResult Bool where
toResult False = FailedChange
toResult True = MadeChange
instance Combines (Property NoInfo) (Property HasInfo) where
requires (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1)
-- | Results of actions, with color.
class ActionResult a where
getActionResult :: a -> (String, ColorIntensity, Color)
instance Combines (Property NoInfo) (Property NoInfo) where
requires (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) =
SProperty d1 (a2 <> a1) (y : cs1)
instance ActionResult Bool where
getActionResult False = ("failed", Vivid, Red)
getActionResult True = ("done", Dull, Green)
instance Combines RevertableProperty (Property HasInfo) where
requires (RevertableProperty p1 p2) y =
RevertableProperty (p1 `requires` y) p2
instance ActionResult Result where
getActionResult NoChange = ("ok", Dull, Green)
getActionResult MadeChange = ("done", Vivid, Green)
getActionResult FailedChange = ("failed", Vivid, Red)
instance Combines RevertableProperty (Property NoInfo) where
requires (RevertableProperty p1 p2) y =
RevertableProperty (p1 `requires` toIProperty y) p2
data CmdLine
= Run HostName
| Spin [HostName] (Maybe HostName)
| SimpleRun HostName
| Set PrivDataField Context
| Dump PrivDataField Context
| Edit PrivDataField Context
| ListFields
| AddKey String
| Merge
| Serialized CmdLine
| Continue CmdLine
| Update (Maybe HostName)
| Relay HostName
| DockerInit HostName
| DockerChain HostName String
| ChrootChain HostName FilePath Bool Bool
| GitPush Fd Fd
deriving (Read, Show, Eq)
instance Combines RevertableProperty RevertableProperty where
requires (RevertableProperty x1 x2) (RevertableProperty y1 y2) =
RevertableProperty
(x1 `requires` y1)
-- when reverting, run actions in reverse order
(y2 `requires` x2)
-- | Information about a host.
data Info = Info
{ _os :: Val System
, _privDataFields :: S.Set (PrivDataField, HostContext)
, _privData :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext)
, _sshPubKey :: M.Map SshKeyType String
, _aliases :: S.Set HostName
, _dns :: S.Set Dns.Record
@ -190,7 +285,7 @@ instance Monoid Info where
mempty = Info mempty mempty mempty mempty mempty mempty mempty mempty
mappend old new = Info
{ _os = _os old <> _os new
, _privDataFields = _privDataFields old <> _privDataFields new
, _privData = _privData old <> _privData new
, _sshPubKey = _sshPubKey new `M.union` _sshPubKey old
, _aliases = _aliases old <> _aliases new
, _dns = _dns old <> _dns new
@ -202,7 +297,7 @@ instance Monoid Info where
instance Empty Info where
isEmpty i = and
[ isEmpty (_os i)
, isEmpty (_privDataFields i)
, isEmpty (_privData i)
, isEmpty (_sshPubKey i)
, isEmpty (_aliases i)
, isEmpty (_dns i)
@ -210,26 +305,3 @@ instance Empty Info where
, isEmpty (_dockerinfo i)
, isEmpty (_chrootinfo i)
]
data Val a = Val a | NoVal
deriving (Eq, Show)
instance Monoid (Val a) where
mempty = NoVal
mappend old new = case new of
NoVal -> old
_ -> new
instance Empty (Val a) where
isEmpty NoVal = True
isEmpty _ = False
fromVal :: Val a -> Maybe a
fromVal (Val a) = Just a
fromVal NoVal = Nothing
type RunLog = [EndAction]
-- | An action that Propellor runs at the end, after trying to satisfy all
-- properties. It's passed the combined Result of the entire Propellor run.
data EndAction = EndAction Desc (Result -> Propellor Result)

27
src/Propellor/Types/CmdLine.hs Normal file
View File

@ -0,0 +1,27 @@
module Propellor.Types.CmdLine where
import Propellor.Types.OS
import Propellor.Types.PrivData
import System.Posix.Types
data CmdLine
= Run HostName
| Spin [HostName] (Maybe HostName)
| SimpleRun HostName
| Set PrivDataField Context
| Dump PrivDataField Context
| Edit PrivDataField Context
| ListFields
| AddKey String
| Merge
| Serialized CmdLine
| Continue CmdLine
| Update (Maybe HostName)
| Relay HostName
| DockerInit HostName
| DockerChain HostName String
| ChrootChain HostName FilePath Bool Bool
| GitPush Fd Fd
deriving (Read, Show, Eq)

4
src/Propellor/Types/PrivData.hs
View File

@ -24,9 +24,11 @@ data PrivDataSource
| PrivDataSourceFileFromCommand PrivDataField FilePath String
| PrivDataSource PrivDataField String
type PrivDataSourceDesc = String
class IsPrivDataSource s where
privDataField :: s -> PrivDataField
describePrivDataSource :: s -> Maybe String
describePrivDataSource :: s -> Maybe PrivDataSourceDesc
instance IsPrivDataSource PrivDataField where
privDataField = id

37
src/Propellor/Types/Result.hs Normal file
View File

@ -0,0 +1,37 @@
module Propellor.Types.Result where
import Data.Monoid
import System.Console.ANSI
-- | There can be three results of satisfying a Property.
data Result = NoChange | MadeChange | FailedChange
deriving (Read, Show, Eq)
instance Monoid Result where
mempty = NoChange
mappend FailedChange _ = FailedChange
mappend _ FailedChange = FailedChange
mappend MadeChange _ = MadeChange
mappend _ MadeChange = MadeChange
mappend NoChange NoChange = NoChange
class ToResult t where
toResult :: t -> Result
instance ToResult Bool where
toResult False = FailedChange
toResult True = MadeChange
-- | Results of actions, with color.
class ActionResult a where
getActionResult :: a -> (String, ColorIntensity, Color)
instance ActionResult Bool where
getActionResult False = ("failed", Vivid, Red)
getActionResult True = ("done", Dull, Green)
instance ActionResult Result where
getActionResult NoChange = ("ok", Dull, Green)
getActionResult MadeChange = ("done", Vivid, Green)
getActionResult FailedChange = ("failed", Vivid, Red)

22
src/Propellor/Types/Val.hs Normal file
View File

@ -0,0 +1,22 @@
module Propellor.Types.Val where
import Data.Monoid
import Propellor.Types.Empty
data Val a = Val a | NoVal
deriving (Eq, Show)
instance Monoid (Val a) where
mempty = NoVal
mappend old new = case new of
NoVal -> old
_ -> new
instance Empty (Val a) where
isEmpty NoVal = True
isEmpty _ = False
fromVal :: Val a -> Maybe a
fromVal (Val a) = Just a
fromVal NoVal = Nothing

161
src/Utility/DataUnits.hs Normal file
View File

@ -0,0 +1,161 @@
{- data size display and parsing
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-
-
- And now a rant:
-
- In the beginning, we had powers of two, and they were good.
-
- Disk drive manufacturers noticed that some powers of two were
- sorta close to some powers of ten, and that rounding down to the nearest
- power of ten allowed them to advertise their drives were bigger. This
- was sorta annoying.
-
- Then drives got big. Really, really big. This was good.
-
- Except that the small rounding error perpretrated by the drive
- manufacturers suffered the fate of a small error, and became a large
- error. This was bad.
-
- So, a committee was formed. And it arrived at a committee-like decision,
- which satisfied noone, confused everyone, and made the world an uglier
- place. As with all committees, this was meh.
-
- And the drive manufacturers happily continued selling drives that are
- increasingly smaller than you'd expect, if you don't count on your
- fingers. But that are increasingly too big for anyone to much notice.
- This caused me to need git-annex.
-
- Thus, I use units here that I loathe. Because if I didn't, people would
- be confused that their drives seem the wrong size, and other people would
- complain at me for not being standards compliant. And we call this
- progress?
-}
module Utility.DataUnits (
dataUnits,
storageUnits,
memoryUnits,
bandwidthUnits,
oldSchoolUnits,
Unit(..),
roughSize,
compareSizes,
readSize
) where
import Data.List
import Data.Char
import Utility.HumanNumber
type ByteSize = Integer
type Name = String
type Abbrev = String
data Unit = Unit ByteSize Abbrev Name
deriving (Ord, Show, Eq)
dataUnits :: [Unit]
dataUnits = storageUnits ++ memoryUnits
{- Storage units are (stupidly) powers of ten. -}
storageUnits :: [Unit]
storageUnits =
[ Unit (p 8) "YB" "yottabyte"
, Unit (p 7) "ZB" "zettabyte"
, Unit (p 6) "EB" "exabyte"
, Unit (p 5) "PB" "petabyte"
, Unit (p 4) "TB" "terabyte"
, Unit (p 3) "GB" "gigabyte"
, Unit (p 2) "MB" "megabyte"
, Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe
, Unit (p 0) "B" "byte"
]
where
p :: Integer -> Integer
p n = 1000^n
{- Memory units are (stupidly named) powers of 2. -}
memoryUnits :: [Unit]
memoryUnits =
[ Unit (p 8) "YiB" "yobibyte"
, Unit (p 7) "ZiB" "zebibyte"
, Unit (p 6) "EiB" "exbibyte"
, Unit (p 5) "PiB" "pebibyte"
, Unit (p 4) "TiB" "tebibyte"
, Unit (p 3) "GiB" "gibibyte"
, Unit (p 2) "MiB" "mebibyte"
, Unit (p 1) "KiB" "kibibyte"
, Unit (p 0) "B" "byte"
]
where
p :: Integer -> Integer
p n = 2^(n*10)
{- Bandwidth units are only measured in bits if you're some crazy telco. -}
bandwidthUnits :: [Unit]
bandwidthUnits = error "stop trying to rip people off"
{- Do you yearn for the days when men were men and megabytes were megabytes? -}
oldSchoolUnits :: [Unit]
oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
where
mingle (Unit _ a n, Unit s' _ _) = Unit s' a n
{- approximate display of a particular number of bytes -}
roughSize :: [Unit] -> Bool -> ByteSize -> String
roughSize units short i
| i < 0 = '-' : findUnit units' (negate i)
| otherwise = findUnit units' i
where
units' = sortBy (flip compare) units -- largest first
findUnit (u@(Unit s _ _):us) i'
| i' >= s = showUnit i' u
| otherwise = findUnit us i'
findUnit [] i' = showUnit i' (last units') -- bytes
showUnit x (Unit size abbrev name) = s ++ " " ++ unit
where
v = (fromInteger x :: Double) / fromInteger size
s = showImprecise 2 v
unit
| short = abbrev
| s == "1" = name
| otherwise = name ++ "s"
{- displays comparison of two sizes -}
compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String
compareSizes units abbrev old new
| old > new = roughSize units abbrev (old - new) ++ " smaller"
| old < new = roughSize units abbrev (new - old) ++ " larger"
| otherwise = "same"
{- Parses strings like "10 kilobytes" or "0.5tb". -}
readSize :: [Unit] -> String -> Maybe ByteSize
readSize units input
| null parsednum || null parsedunit = Nothing
| otherwise = Just $ round $ number * fromIntegral multiplier
where
(number, rest) = head parsednum
multiplier = head parsedunit
unitname = takeWhile isAlpha $ dropWhile isSpace rest
parsednum = reads input :: [(Double, String)]
parsedunit = lookupUnit units unitname
lookupUnit _ [] = [1] -- no unit given, assume bytes
lookupUnit [] _ = []
lookupUnit (Unit s a n:us) v
| a ~~ v || n ~~ v = [s]
| plural n ~~ v || a ~~ byteabbrev v = [s]
| otherwise = lookupUnit us v
a ~~ b = map toLower a == map toLower b
plural n = n ++ "s"
byteabbrev a = a ++ "b"

21
src/Utility/HumanNumber.hs Normal file
View File

@ -0,0 +1,21 @@
{- numbers for humans
-
- Copyright 2012-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
module Utility.HumanNumber where
{- Displays a fractional value as a string with a limited number
- of decimal digits. -}
showImprecise :: RealFrac a => Int -> a -> String
showImprecise precision n
| precision == 0 || remainder == 0 = show (round n :: Integer)
| otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder)
where
int :: Integer
(int, frac) = properFraction n
remainder = round (frac * 10 ^ precision) :: Integer
pad0s s = replicate (precision - length s) '0' ++ s
striptrailing0s = reverse . dropWhile (== '0') . reverse

13
src/Utility/Table.hs
View File

@ -16,13 +16,14 @@ tableWithHeader header rows = header : map linesep header : rows
where
linesep = map (const '-')
-- | Formats a table to lines, automatically padding rows to the same size.
-- | Formats a table to lines, automatically padding columns to the same size.
formatTable :: Table -> [String]
formatTable table = map (\r -> unwords (map pad (zip r rowsizes))) table
formatTable table = map (\r -> unwords (map pad (zip r colsizes))) table
where
pad (cell, size) = cell ++ take (size - length cell) padding
padding = repeat ' '
rowsizes = sumrows (map (map length) table)
sumrows [] = repeat 0
sumrows [r] = r
sumrows (r1:r2:rs) = sumrows $ map (uncurry max) (zip r1 r2) : rs
colsizes = reverse $ (0:) $ drop 1 $ reverse $
sumcols (map (map length) table)
sumcols [] = repeat 0
sumcols [r] = r
sumcols (r1:r2:rs) = sumcols $ map (uncurry max) (zip r1 r2) : rs