Merge branch 'joeyconfig'
Conflicts: doc/todo/info_propigation_out_of_nested_properties.mdwn privdata.joey/privdata.gpg
This commit is contained in:
commit
401b857eef
|
@ -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"
|
||||
|
@ -329,11 +331,12 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
|
|||
|
||||
--' __|II| ,.
|
||||
---- __|II|II|__ ( \_,/\
|
||||
------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-
|
||||
----------------------- | [Docker] / ----------------------
|
||||
----------------------- : / -----------------------
|
||||
------------------------ \____, o ,' ------------------------
|
||||
------------------------- '--,___________,' -------------------------
|
||||
--'-------'\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 # | \ # >=)
|
||||
\______________________________# # / #__________________/ (-}
|
||||
|
||||
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
|
@ -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.
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
|
@ -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]
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
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' <- ensureProperty hook
|
||||
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]
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
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
|
||||
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 = 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"
|
||||
|
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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,25 +94,26 @@ built' installprop target system@(System _ arch) config =
|
|||
, return FailedChange
|
||||
)
|
||||
|
||||
teardownprop = property ("removed debootstrapped " ++ target) $
|
||||
makeChange removetarget
|
||||
-- A failed debootstrap run will leave a debootstrap directory;
|
||||
-- recover by deleting it and trying again.
|
||||
ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
|
||||
( do
|
||||
removetarget target
|
||||
return True
|
||||
, return False
|
||||
)
|
||||
|
||||
removetarget = do
|
||||
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
|
||||
|
||||
-- A failed debootstrap run will leave a debootstrap directory;
|
||||
-- recover by deleting it and trying again.
|
||||
ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
|
||||
( do
|
||||
removetarget
|
||||
return True
|
||||
, return False
|
||||
)
|
||||
|
||||
extractSuite :: System -> Maybe String
|
||||
extractSuite (System (Debian s) _) = Just $ Apt.showSuite s
|
||||
extractSuite (System (Ubuntu r) _) = Just r
|
||||
|
@ -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
|
||||
|
|
|
@ -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
|
||||
]
|
||||
(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 $
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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,6 +478,7 @@ chain hostlist hn s = case toContainerId s of
|
|||
changeWorkingDirectory localdir
|
||||
onlyProcess (provisioningLock cid) $ do
|
||||
r <- runPropellor h $ ensureProperties $
|
||||
map ignoreInfo $
|
||||
hostProperties h
|
||||
putStrLn $ "\n" ++ show r
|
||||
|
||||
|
@ -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)] }
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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`
|
||||
|
|
|
@ -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" ==>
|
||||
|
|
|
@ -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`
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
|
@ -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)
|
|
@ -3,28 +3,93 @@ module Propellor.Property.Network where
|
|||
import Propellor
|
||||
import Propellor.Property.File
|
||||
|
||||
interfaces :: FilePath
|
||||
interfaces = "/etc/network/interfaces"
|
||||
type Interface = String
|
||||
|
||||
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
|
||||
ipv6to4 = fileProperty "ipv6to4" go interfaces
|
||||
`onChange` ifUp "sit0"
|
||||
where
|
||||
go ls
|
||||
| all (`elem` ls) stanza = ls
|
||||
| otherwise = ls ++ stanza
|
||||
stanza =
|
||||
[ "# Automatically added by propeller"
|
||||
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"
|
||||
, "# End automatically added by propeller"
|
||||
]
|
||||
`describe` "ipv6to4"
|
||||
`requires` interfacesDEnabled
|
||||
`onChange` ifUp "sit0"
|
||||
|
||||
type Interface = String
|
||||
interfacesFile :: FilePath
|
||||
interfacesFile = "/etc/network/interfaces"
|
||||
|
||||
ifUp :: Interface -> Property
|
||||
ifUp iface = cmdProperty "ifup" [iface]
|
||||
-- | 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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"]
|
||||
|
|
|
@ -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,11 +289,18 @@ 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"
|
||||
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"
|
||||
]
|
||||
|
@ -302,37 +309,28 @@ twitRss = combineProperties "twitter rss"
|
|||
, "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"
|
||||
]
|
||||
where
|
||||
dir = "/srv/web/tmp.kitenet.net/twitrss"
|
||||
crontime = "15 * * * *"
|
||||
feed url desc = Cron.job desc crontime "joey" dir $
|
||||
"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
|
||||
|
||||
-- Work around for expired ssl cert.
|
||||
-- (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 "&&" $
|
||||
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"
|
||||
]
|
||||
, Cron.niceJob "gitriddance" "30 4 * * *" "joey"
|
||||
"/home/joey/lib/backup" $ intercalate "&&" $
|
||||
gitriddancecmd = intercalate "&&" $
|
||||
[ "cd github"
|
||||
, ". $HOME/.github-keys"
|
||||
] ++ map gitriddance githubMirrors
|
||||
]
|
||||
where
|
||||
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`
|
||||
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`
|
||||
& "/etc/opendkim.conf" `File.containsLines`
|
||||
[ "KeyFile /etc/mail/dkim.key"
|
||||
, "SubDomains yes"
|
||||
, "Domain *"
|
||||
, "Selector mail"
|
||||
]
|
||||
]
|
||||
`onChange` Service.restarted "opendkim"
|
||||
|
||||
-- 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"
|
||||
|
||||
|
|
|
@ -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,7 +101,8 @@ 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) $
|
||||
| otherwise = Just $ toProp $
|
||||
property ("any other ssh host keys removed " ++ typelist staletypes) $
|
||||
ensureProperty $
|
||||
combineProperties desc (removestale True ++ removestale False)
|
||||
`onChange` restarted
|
||||
|
@ -109,10 +111,10 @@ hostKeys ctx l = propertyList desc $ catMaybes $
|
|||
--
|
||||
-- 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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
instance PropAccum 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
|
||||
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`
|
||||
|
|
|
@ -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"]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
-- | 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
|
||||
|
||||
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
|
||||
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 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
|
||||
|
||||
instance Monoid Result where
|
||||
mempty = NoChange
|
||||
-- | 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)
|
||||
|
||||
mappend FailedChange _ = FailedChange
|
||||
mappend _ FailedChange = FailedChange
|
||||
mappend MadeChange _ = MadeChange
|
||||
mappend _ MadeChange = MadeChange
|
||||
mappend NoChange NoChange = 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)
|
||||
|
||||
class ToResult t where
|
||||
toResult :: t -> Result
|
||||
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)
|
||||
|
||||
instance ToResult Bool where
|
||||
toResult False = FailedChange
|
||||
toResult True = MadeChange
|
||||
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)
|
||||
|
||||
-- | Results of actions, with color.
|
||||
class ActionResult a where
|
||||
getActionResult :: a -> (String, ColorIntensity, Color)
|
||||
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)
|
||||
|
||||
instance ActionResult Bool where
|
||||
getActionResult False = ("failed", Vivid, Red)
|
||||
getActionResult True = ("done", Dull, Green)
|
||||
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 Result where
|
||||
getActionResult NoChange = ("ok", Dull, Green)
|
||||
getActionResult MadeChange = ("done", Vivid, Green)
|
||||
getActionResult FailedChange = ("failed", Vivid, Red)
|
||||
instance Combines RevertableProperty (Property HasInfo) where
|
||||
requires (RevertableProperty p1 p2) y =
|
||||
RevertableProperty (p1 `requires` 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 (Property NoInfo) where
|
||||
requires (RevertableProperty p1 p2) y =
|
||||
RevertableProperty (p1 `requires` toIProperty y) p2
|
||||
|
||||
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)
|
||||
|
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
|
@ -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)
|
|
@ -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
|
|
@ -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"
|
|
@ -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
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue