summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Propellor.hs24
-rw-r--r--Propellor/Attr.hs47
-rw-r--r--Propellor/CmdLine.hs65
-rw-r--r--Propellor/Engine.hs10
-rw-r--r--Propellor/PrivData.hs1
-rw-r--r--Propellor/Property.hs51
-rw-r--r--Propellor/Property/Apt.hs4
-rw-r--r--Propellor/Property/Hostname.hs12
-rw-r--r--Propellor/Property/SiteSpecific/JoeySites.hs4
-rw-r--r--Propellor/Types.hs78
-rw-r--r--Propellor/Types/Attr.hs16
-rw-r--r--TODO4
-rw-r--r--config-joey.hs132
-rw-r--r--propellor.cabal2
14 files changed, 288 insertions, 162 deletions
diff --git a/Propellor.hs b/Propellor.hs
index 1f1d7eca..e6312248 100644
--- a/Propellor.hs
+++ b/Propellor.hs
@@ -2,8 +2,9 @@
-- | Pulls in lots of useful modules for building and using Properties.
--
--- Propellor enures that the system it's run in satisfies a list of
--- properties, taking action as necessary when a property is not yet met.
+-- When propellor runs on a Host, it ensures that its list of Properties
+-- is satisfied, taking action as necessary when a Property is not
+-- currently satisfied.
--
-- A simple propellor program example:
--
@@ -13,15 +14,16 @@
-- > import qualified Propellor.Property.Apt as Apt
-- >
-- > main :: IO ()
--- > main = defaultMain getProperties
+-- > main = defaultMain hosts
-- >
--- > getProperties :: HostName -> Maybe [Property]
--- > getProperties "example.com" = Just
--- > [ Apt.installed ["mydaemon"]
--- > , "/etc/mydaemon.conf" `File.containsLine` "secure=1"
--- > `onChange` cmdProperty "service" ["mydaemon", "restart"]
--- > ]
--- > getProperties _ = Nothing
+-- > hosts :: [Host]
+-- > hosts =
+-- > [ host "example.com"
+-- > & Apt.installed ["mydaemon"]
+-- > & "/etc/mydaemon.conf" `File.containsLine` "secure=1"
+-- > `onChange` cmdProperty "service" ["mydaemon", "restart"]
+-- > ! Apt.installed ["unwantedpackage"]
+-- > ]
--
-- See config.hs for a more complete example, and clone Propellor's
-- git repository for a deployable system using Propellor:
@@ -31,6 +33,7 @@ module Propellor (
module Propellor.Types
, module Propellor.Property
, module Propellor.Property.Cmd
+ , module Propellor.Attr
, module Propellor.PrivData
, module Propellor.Engine
, module Propellor.Exception
@@ -47,6 +50,7 @@ import Propellor.Property.Cmd
import Propellor.PrivData
import Propellor.Message
import Propellor.Exception
+import Propellor.Attr
import Utility.PartialPrelude as X
import Utility.Process as X
diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
new file mode 100644
index 00000000..4bc1c2c7
--- /dev/null
+++ b/Propellor/Attr.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE PackageImports #-}
+
+module Propellor.Attr where
+
+import Propellor.Types
+import Propellor.Types.Attr
+
+import "mtl" Control.Monad.Reader
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty
+pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
+ (return NoChange)
+
+hostname :: HostName -> AttrProperty
+hostname name = pureAttrProperty ("hostname " ++ name) $
+ \d -> d { _hostname = name }
+
+getHostName :: Propellor HostName
+getHostName = asks _hostname
+
+cname :: Domain -> AttrProperty
+cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
+
+cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty
+cnameFor domain mkp =
+ let p = mkp domain
+ in AttrProperty p (addCName domain)
+
+addCName :: HostName -> Attr -> Attr
+addCName domain d = d { _cnames = S.insert domain (_cnames d) }
+
+hostnameless :: Attr
+hostnameless = newAttr (error "hostname Attr not specified")
+
+hostAttr :: Host -> Attr
+hostAttr (Host _ mkattrs) = mkattrs hostnameless
+
+hostProperties :: Host -> [Property]
+hostProperties (Host ps _) = ps
+
+hostMap :: [Host] -> M.Map HostName Host
+hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l
+
+findHost :: [Host] -> HostName -> Maybe Host
+findHost l hn = M.lookup hn (hostMap l)
diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs
index 2026c47a..5be91c4f 100644
--- a/Propellor/CmdLine.hs
+++ b/Propellor/CmdLine.hs
@@ -55,8 +55,8 @@ processCmdLine = go =<< getArgs
else return $ Run s
go _ = usage
-defaultMain :: [HostName -> Maybe [Property]] -> IO ()
-defaultMain getprops = do
+defaultMain :: [Host] -> IO ()
+defaultMain hostlist = do
DockerShim.cleanEnv
checkDebugMode
cmdline <- processCmdLine
@@ -64,25 +64,26 @@ defaultMain getprops = do
go True cmdline
where
go _ (Continue cmdline) = go False cmdline
- go _ (Set host field) = setPrivData host field
+ go _ (Set hn field) = setPrivData hn field
go _ (AddKey keyid) = addKey keyid
- go _ (Chain host) = withprops host $ \hostattr ps -> do
- r <- runPropellor hostattr $ ensureProperties ps
+ go _ (Chain hn) = withprops hn $ \attr ps -> do
+ r <- runPropellor attr $ ensureProperties ps
putStrLn $ "\n" ++ show r
- go _ (Docker host) = Docker.chain host
+ go _ (Docker hn) = Docker.chain hn
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
- go False (Spin host) = withprops host $ const . const $ spin host
- go False (Run host) = ifM ((==) 0 <$> getRealUserID)
- ( onlyProcess $ withprops host mainProperties
- , go True (Spin host)
+ go False (Spin hn) = withprops hn $ const . const $ spin hn
+ go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
+ ( onlyProcess $ withprops hn mainProperties
+ , go True (Spin hn)
)
- go False (Boot host) = onlyProcess $ withprops host $ boot
+ go False (Boot hn) = onlyProcess $ withprops hn boot
- withprops host a = maybe (unknownhost host) (a hostattr) $
- headMaybe $ catMaybes $ map (\get -> get host) getprops
- where
- hostattr = mkHostAttr host
+ withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
+ withprops hn a = maybe
+ (unknownhost hn)
+ (\h -> a (hostAttr h) (hostProperties h))
+ (findHost hostlist hn)
onlyProcess :: IO a -> IO a
onlyProcess a = bracket lock unlock (const a)
@@ -166,16 +167,16 @@ getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
spin :: HostName -> IO ()
-spin host = do
+spin hn = do
url <- getUrl
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
void $ boolSystem "git" [Param "push"]
- cacheparams <- toCommand <$> sshCachingParams host
- go cacheparams url =<< gpgDecrypt (privDataFile host)
+ cacheparams <- toCommand <$> sshCachingParams hn
+ go cacheparams url =<< gpgDecrypt (privDataFile hn)
where
go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
let finish = do
- senddata toh (privDataFile host) privDataMarker privdata
+ senddata toh (privDataFile hn) privDataMarker privdata
hClose toh
-- Display remaining output.
@@ -188,10 +189,10 @@ spin host = do
NeedGitClone -> do
hClose toh
hClose fromh
- sendGitClone host url
+ sendGitClone hn url
go cacheparams url privdata
- user = "root@"++host
+ user = "root@"++hn
bootstrapcmd = shellWrap $ intercalate " ; "
[ "if [ ! -d " ++ localdir ++ " ]"
@@ -202,7 +203,7 @@ spin host = do
, "else " ++ intercalate " && "
[ "cd " ++ localdir
, "if ! test -x ./propellor; then make deps build; fi"
- , "./propellor --boot " ++ host
+ , "./propellor --boot " ++ hn
]
, "fi"
]
@@ -218,18 +219,18 @@ spin host = do
showremote s = putStrLn s
senddata toh f marker s = void $
- actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do
+ actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
sendMarked toh marker s
return True
sendGitClone :: HostName -> String -> IO ()
-sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ do
+sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do
branch <- getCurrentBranch
- cacheparams <- sshCachingParams host
+ cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
- , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++host++":"++remotebundle)]
- , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++host), Param $ unpackcmd branch]
+ , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
+ , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
]
where
remotebundle = "/usr/local/propellor.git"
@@ -277,15 +278,15 @@ fromMarked marker s
len = length marker
matches = filter (marker `isPrefixOf`) $ lines s
-boot :: HostAttr -> [Property] -> IO ()
-boot hostattr ps = do
+boot :: Attr -> [Property] -> IO ()
+boot attr ps = do
sendMarked stdout statusMarker $ show Ready
reply <- hGetContentsStrict stdin
makePrivDataDir
maybe noop (writeFileProtected privDataLocal) $
fromMarked privDataMarker reply
- mainProperties hostattr ps
+ mainProperties attr ps
addKey :: String -> IO ()
addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
@@ -347,11 +348,11 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
-- Parameters can be passed to both ssh and scp.
sshCachingParams :: HostName -> IO [CommandParam]
-sshCachingParams hostname = do
+sshCachingParams hn = do
home <- myHomeDir
let cachedir = home </> ".ssh" </> "propellor"
createDirectoryIfMissing False cachedir
- let socketfile = cachedir </> hostname ++ ".sock"
+ let socketfile = cachedir </> hn ++ ".sock"
return
[ Param "-o", Param ("ControlPath=" ++ socketfile)
, Params "-o ControlMaster=auto -o ControlPersist=yes"
diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs
index c527dc38..81d979ac 100644
--- a/Propellor/Engine.hs
+++ b/Propellor/Engine.hs
@@ -12,12 +12,12 @@ import Propellor.Types
import Propellor.Message
import Propellor.Exception
-runPropellor :: HostAttr -> Propellor a -> IO a
-runPropellor hostattr a = runReaderT (runWithHostAttr a) hostattr
+runPropellor :: Attr -> Propellor a -> IO a
+runPropellor attr a = runReaderT (runWithAttr a) attr
-mainProperties :: HostAttr -> [Property] -> IO ()
-mainProperties hostattr ps = do
- r <- runPropellor hostattr $
+mainProperties :: Attr -> [Property] -> IO ()
+mainProperties attr ps = do
+ r <- runPropellor attr $
ensureProperties [Property "overall" $ ensureProperties ps]
setTitle "propellor: done"
hFlush stdout
diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs
index 7f5a23dc..5adc9e94 100644
--- a/Propellor/PrivData.hs
+++ b/Propellor/PrivData.hs
@@ -12,6 +12,7 @@ import Control.Monad
import "mtl" Control.Monad.Reader
import Propellor.Types
+import Propellor.Attr
import Propellor.Message
import Utility.Monad
import Utility.PartialPrelude
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
index 7af69ea8..ccc060ff 100644
--- a/Propellor/Property.hs
+++ b/Propellor/Property.hs
@@ -9,6 +9,8 @@ import Control.Monad.IfElse
import "mtl" Control.Monad.Reader
import Propellor.Types
+import Propellor.Types.Attr
+import Propellor.Attr
import Propellor.Engine
import Utility.Monad
@@ -94,17 +96,46 @@ boolProperty desc a = Property desc $ ifM (liftIO a)
revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
--- | Starts a list of Properties
-props :: [Property]
-props = []
+-- | Starts accumulating the properties of a Host.
+--
+-- > host "example.com"
+-- > & someproperty
+-- > ! oldproperty
+-- > & otherproperty
+host :: HostName -> Host
+host hn = Host [] (\_ -> newAttr hn)
+
+-- | Adds a property to a Host
+-- Can add Properties, RevertableProperties, and AttrProperties
+(&) :: IsProp p => Host -> p -> Host
+(Host ps as) & p = Host (ps ++ [toProp p]) (as . getAttr p)
--- | Adds a property to the list.
--- Can add both Properties and RevertableProperties.
-(&) :: IsProp p => [Property] -> p -> [Property]
-ps & p = ps ++ [toProp p]
infixl 1 &
--- | Adds a property to the list in reverted form.
-(!) :: [Property] -> RevertableProperty -> [Property]
-ps ! p = ps ++ [toProp $ revert p]
+-- | Adds a property to the Host in reverted form.
+(!) :: Host -> RevertableProperty -> Host
+(Host ps as) ! p = Host (ps ++ [toProp q]) (as . getAttr q)
+ where
+ q = revert p
+
infixl 1 !
+
+-- | Makes a propertyList of a set of properties, using the same syntax
+-- used by `host`.
+--
+-- > template "my template" $ props
+-- & someproperty
+-- ! oldproperty
+--
+-- Note that none of the properties can define Attrs, because
+-- they will not propigate out to the host that this is added to.
+--
+-- Unfortunately, this is not currently enforced at the type level, so
+-- attempting to set an Attr in here will be run time error.
+template :: Desc -> Host -> Property
+template desc h@(Host ps _)
+ | hostAttr h == hostAttr props = propertyList desc ps
+ | otherwise = error $ desc ++ ": template contains Attr"
+
+props :: Host
+props = Host [] (\_ -> hostnameless)
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
index 937d1404..4da13a2f 100644
--- a/Propellor/Property/Apt.hs
+++ b/Propellor/Property/Apt.hs
@@ -180,8 +180,8 @@ reConfigure package vals = reconfigure `requires` setselections
setselections = Property "preseed" $ makeChange $
withHandle StdinHandle createProcessSuccess
(proc "debconf-set-selections" []) $ \h -> do
- forM_ vals $ \(template, tmpltype, value) ->
- hPutStrLn h $ unwords [package, template, tmpltype, value]
+ forM_ vals $ \(tmpl, tmpltype, value) ->
+ hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
hClose h
reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]
diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs
index 0708b3ff..03613ac9 100644
--- a/Propellor/Property/Hostname.hs
+++ b/Propellor/Property/Hostname.hs
@@ -13,14 +13,14 @@ sane :: Property
sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName)
setTo :: HostName -> Property
-setTo hostname = combineProperties desc go
- `onChange` cmdProperty "hostname" [host]
+setTo hn = combineProperties desc go
+ `onChange` cmdProperty "hostname" [basehost]
where
- desc = "hostname " ++ hostname
- (host, domain) = separate (== '.') hostname
+ desc = "hostname " ++ hn
+ (basehost, domain) = separate (== '.') hn
go = catMaybes
- [ Just $ "/etc/hostname" `File.hasContent` [host]
+ [ Just $ "/etc/hostname" `File.hasContent` [basehost]
, if null domain
then Nothing
else Just $ File.fileProperty desc
@@ -28,7 +28,7 @@ setTo hostname = combineProperties desc go
]
hostip = "127.0.1.1"
- hostline = hostip ++ "\t" ++ hostname ++ " " ++ host
+ hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost
addhostline ls = hostline : filter (not . hashostip) ls
hashostip l = headMaybe (words l) == Just hostip
diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs
index 029064dd..46373170 100644
--- a/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -6,8 +6,8 @@ module Propellor.Property.SiteSpecific.JoeySites where
import Propellor
import qualified Propellor.Property.Apt as Apt
-oldUseNetshellBox :: Property
-oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $
+oldUseNetShellBox :: Property
+oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $
propertyList ("olduse.net shellbox")
[ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
`describe` "olduse.net build deps"
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index 6a1c888a..e6e02126 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -1,7 +1,33 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Propellor.Types where
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Propellor.Types
+ ( Host(..)
+ , Attr
+ , HostName
+ , UserName
+ , GroupName
+ , Propellor(..)
+ , Property(..)
+ , RevertableProperty(..)
+ , AttrProperty(..)
+ , IsProp
+ , describe
+ , toProp
+ , getAttr
+ , requires
+ , Desc
+ , Result(..)
+ , System(..)
+ , Distribution(..)
+ , DebianSuite(..)
+ , Release
+ , Architecture
+ , ActionResult(..)
+ , CmdLine(..)
+ , PrivDataField(..)
+ ) where
import Data.Monoid
import Control.Applicative
@@ -9,44 +35,39 @@ import System.Console.ANSI
import "mtl" Control.Monad.Reader
import "MonadCatchIO-transformers" Control.Monad.CatchIO
-type HostName = String
-type GroupName = String
-type UserName = String
+import Propellor.Types.Attr
--- | The core data type of Propellor, this reprecents a property
--- that the system should have, and an action to ensure it has the
--- property.
-data Property = Property
- { propertyDesc :: Desc
- -- | must be idempotent; may run repeatedly
- , propertySatisfy :: Propellor Result
- }
+data Host = Host [Property] (Attr -> Attr)
--- | A property that can be reverted.
-data RevertableProperty = RevertableProperty Property Property
+type UserName = String
+type GroupName = String
-- | Propellor's monad provides read-only access to attributes of the
-- system.
-newtype Propellor p = Propellor { runWithHostAttr :: ReaderT HostAttr IO p }
+newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
deriving
( Monad
, Functor
, Applicative
- , MonadReader HostAttr
+ , MonadReader Attr
, MonadIO
, MonadCatchIO
)
--- | The attributes of a system. For example, its hostname.
-newtype HostAttr = HostAttr
- { _hostname :: HostName
+-- | The core data type of Propellor, this represents a property
+-- that the system should have, and an action to ensure it has the
+-- property.
+data Property = Property
+ { propertyDesc :: Desc
+ -- | must be idempotent; may run repeatedly
+ , propertySatisfy :: Propellor Result
}
-mkHostAttr :: HostName -> HostAttr
-mkHostAttr = HostAttr
+-- | A property that can be reverted.
+data RevertableProperty = RevertableProperty Property Property
-getHostName :: Propellor HostName
-getHostName = asks _hostname
+-- | A property that affects the Attr.
+data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
class IsProp p where
-- | Sets description.
@@ -55,6 +76,7 @@ class IsProp p where
-- | Indicates that the first property can only be satisfied
-- once the second one is.
requires :: p -> Property -> p
+ getAttr :: p -> (Attr -> Attr)
instance IsProp Property where
describe p d = p { propertyDesc = d }
@@ -64,6 +86,7 @@ instance IsProp Property where
case r of
FailedChange -> return FailedChange
_ -> propertySatisfy x
+ getAttr _ = id
instance IsProp RevertableProperty where
-- | Sets the description of both sides.
@@ -72,6 +95,13 @@ instance IsProp RevertableProperty where
toProp (RevertableProperty p1 _) = p1
(RevertableProperty p1 p2) `requires` y =
RevertableProperty (p1 `requires` y) p2
+ getAttr _ = id
+
+instance IsProp AttrProperty where
+ describe (AttrProperty p a) d = AttrProperty (describe p d) a
+ toProp (AttrProperty p _) = toProp p
+ (AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a
+ getAttr (AttrProperty _ a) = a
type Desc = String
diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs
new file mode 100644
index 00000000..20e5e631
--- /dev/null
+++ b/Propellor/Types/Attr.hs
@@ -0,0 +1,16 @@
+module Propellor.Types.Attr where
+
+import qualified Data.Set as S
+
+-- | The attributes of a host. For example, its hostname.
+data Attr = Attr
+ { _hostname :: HostName
+ , _cnames :: S.Set Domain
+ }
+ deriving (Eq, Show)
+
+newAttr :: HostName -> Attr
+newAttr hn = Attr hn S.empty
+
+type HostName = String
+type Domain = String
diff --git a/TODO b/TODO
index 0cc8db1b..a203169c 100644
--- a/TODO
+++ b/TODO
@@ -3,8 +3,8 @@
but only once despite many config changes being made to satisfy
properties. onChange is a poor substitute.
* Currently only Debian and derivatives are supported by most Properties.
- One way to improve that would be to parameterize Properties with a
- Distribution witness.
+ This could be improved by making the Distribution of the system part
+ of its HostAttr.
* Display of docker container properties is a bit wonky. It always
says they are unchanged even when they changed and triggered a
reprovision.
diff --git a/config-joey.hs b/config-joey.hs
index d1a33230..92aa9093 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -20,76 +20,68 @@ import qualified Propellor.Property.Git as Git
import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
-import Data.List
-main :: IO ()
-main = defaultMain [host, Docker.containerProperties container]
-
--- | This is where the system's HostName, either as returned by uname
--- or one specified on the command line, is converted into a list of
--- Properties for that system.
---
--- Edit this to configure propellor!
-host :: HostName -> Maybe [Property]
--- Clam is a tor bridge, and an olduse.net shellbox and other fun stuff.
-host "clam.kitenet.net" = Just $ withSystemd $ props
- & cleanCloudAtCost
- & standardSystem Unstable
- & Apt.unattendedUpgrades
- & Network.ipv6to4
- & Apt.installed ["git-annex", "mtr"]
- & Tor.isBridge
- & JoeySites.oldUseNetshellBox
- & Docker.docked container "openid-provider"
- `requires` Apt.installed ["ntp"]
- & Docker.docked container "ancient-kitenet"
- & Docker.configured
- & Docker.garbageCollected `period` Daily
--- Orca is the main git-annex build box.
-host "orca.kitenet.net" = Just $ props -- no systemd due to #726375
- & standardSystem Unstable
- & Hostname.sane
- & Apt.unattendedUpgrades
- & Docker.configured
- & Apt.buildDep ["git-annex"] `period` Daily
- & Docker.docked container "amd64-git-annex-builder"
- & Docker.docked container "i386-git-annex-builder"
- ! Docker.docked container "armel-git-annex-builder-companion"
- ! Docker.docked container "armel-git-annex-builder"
- & Docker.garbageCollected `period` Daily
--- Diatom is my downloads and git repos server, and secondary dns server.
-host "diatom.kitenet.net" = Just $ props
- & standardSystem Stable
- & Hostname.sane
- & Apt.unattendedUpgrades
- & Apt.serviceInstalledRunning "ntp"
- & Dns.zones myDnsSecondary
- & Apt.serviceInstalledRunning "apache2"
- & Apt.installed ["git", "git-annex", "rsync"]
- & Apt.buildDep ["git-annex"] `period` Daily
- & Git.daemonRunning "/srv/git"
- & File.ownerGroup "/srv/git" "joey" "joey"
- -- git repos restore (how?)
- -- family annex needs family members to have accounts,
- -- ssh host key etc.. finesse?
- -- (also should upgrade git-annex-shell for it..)
- -- kgb installation and setup
- -- ssh keys for branchable and github repo hooks
- -- gitweb
- -- downloads.kitenet.net setup (including ssh key to turtle)
--- My laptop
-host "darkstar.kitenet.net" = Just $ props
- & Docker.configured
- & Apt.buildDep ["git-annex"] `period` Daily
-
--- add more hosts here...
---host "foo.example.com" =
-host _ = Nothing
+hosts :: [Host]
+hosts =
+ [ host "clam.kitenet.net"
+ & cleanCloudAtCost
+ & standardSystem Unstable
+ & Apt.unattendedUpgrades
+ & Network.ipv6to4
+ & Tor.isBridge
+ & Docker.configured
+ & cname "shell.olduse.net"
+ `requires` JoeySites.oldUseNetShellBox
+ & "openid.kitenet.net"
+ `cnameFor` Docker.docked container
+ `requires` Apt.installed ["ntp"]
+ & "ancient.kitenet.net"
+ `cnameFor` Docker.docked container
+ & Docker.garbageCollected `period` Daily
+ & Apt.installed ["git-annex", "mtr", "screen"]
+ -- Orca is the main git-annex build box.
+ , host "orca.kitenet.net"
+ & standardSystem Unstable
+ & Hostname.sane
+ & Apt.unattendedUpgrades
+ & Docker.configured
+ & Docker.docked container "amd64-git-annex-builder"
+ & Docker.docked container "i386-git-annex-builder"
+ ! Docker.docked container "armel-git-annex-builder-companion"
+ ! Docker.docked container "armel-git-annex-builder"
+ & Docker.garbageCollected `period` Daily
+ & Apt.buildDep ["git-annex"] `period` Daily
+ -- Important stuff that needs not too much memory or CPU.
+ , host "diatom.kitenet.net"
+ & standardSystem Stable
+ & Hostname.sane
+ & Apt.unattendedUpgrades
+ & Apt.serviceInstalledRunning "ntp"
+ & Dns.zones myDnsSecondary
+ & Apt.serviceInstalledRunning "apache2"
+ & Apt.installed ["git", "git-annex", "rsync"]
+ & Apt.buildDep ["git-annex"] `period` Daily
+ & Git.daemonRunning "/srv/git"
+ & File.ownerGroup "/srv/git" "joey" "joey"
+ -- git repos restore (how?)
+ -- family annex needs family members to have accounts,
+ -- ssh host key etc.. finesse?
+ -- (also should upgrade git-annex-shell for it..)
+ -- kgb installation and setup
+ -- ssh keys for branchable and github repo hooks
+ -- gitweb
+ -- downloads.kitenet.net setup (including ssh key to turtle)
+ -- My laptop
+ , host "darkstar.kitenet.net"
+ & Docker.configured
+ & Apt.buildDep ["git-annex"] `period` Daily
+ ]
-- | This is where Docker containers are set up. A container
-- can vary by hostname where it's used, or be the same everywhere.
container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)
container _parenthost name
+{-
-- Simple web server, publishing the outside host's /var/www
| name == "webserver" = Just $ standardContainer Stable "amd64"
[ Docker.publish "8080:80"
@@ -148,7 +140,7 @@ container _parenthost name
& GitAnnexBuilder.builder arch "15 * * * *" True
& Apt.unattendedUpgrades
]
-
+-}
| otherwise = Nothing
-- | Docker images I prefer to use.
@@ -159,7 +151,7 @@ image _ = "debian-stable-official" -- does not currently exist!
-- This is my standard system setup
standardSystem :: DebianSuite -> Property
-standardSystem suite = propertyList "standard system" $ props
+standardSystem suite = template "standard system" $ props
& Apt.stdSourcesList suite `onChange` Apt.upgrade
& Apt.installed ["etckeeper"]
& Apt.installed ["ssh"]
@@ -179,9 +171,7 @@ standardSystem suite = propertyList "standard system" $ props
& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
`onChange` Apt.autoRemove
-withSystemd :: [Property] -> [Property]
-withSystemd ps = ps ++ [Apt.installed ["systemd-sysv"] `onChange` Reboot.now]
-
+{-
-- This is my standard container setup, featuring automatic upgrades.
standardContainer :: DebianSuite -> Architecture -> [Docker.Containerized Property] -> Docker.Container
standardContainer suite arch ps = Docker.containerFrom
@@ -190,6 +180,7 @@ standardContainer suite arch ps = Docker.containerFrom
& Apt.stdSourcesList suite
& Apt.unattendedUpgrades
] ++ ps
+-}
-- Clean up a system as installed by cloudatcost.com
cleanCloudAtCost :: Property
@@ -218,3 +209,6 @@ myDnsSecondary =
where
master = ["80.68.85.49", "2001:41c8:125:49::10"] -- wren
branchablemaster = ["66.228.46.55", "2600:3c03::f03c:91ff:fedf:c0e5"]
+
+main :: IO ()
+main = defaultMain hosts --, Docker.containerProperties container]
diff --git a/propellor.cabal b/propellor.cabal
index 0c7e3494..5497cc6b 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -88,12 +88,14 @@ Library
Propellor.Property.SiteSpecific.GitHome
Propellor.Property.SiteSpecific.JoeySites
Propellor.Property.SiteSpecific.GitAnnexBuilder
+ Propellor.Attr
Propellor.Message
Propellor.PrivData
Propellor.Engine
Propellor.Exception
Propellor.Types
Other-Modules:
+ Propellor.Types.Attr
Propellor.CmdLine
Propellor.SimpleSh
Propellor.Property.Docker.Shim