summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-06-03 12:17:56 -0400
committerJoey Hess2015-06-03 12:17:56 -0400
commit5d3408d32292402ccd69bfadb3c28937a96eda5d (patch)
tree24c10a1a53d0e85f4699bc18e377764598c0536d /src
parentce0e1a6dc82acb7fd8e64a9ec4c6ff0acf87e241 (diff)
parentfd9d172bcd9f217b67a60ed2e694bad4f6602d32 (diff)
Merge branch 'joeyconfig'
Conflicts: privdata.joey/privdata.gpg
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/Chroot.hs37
-rw-r--r--src/Propellor/Property/Docker.hs36
-rw-r--r--src/Propellor/Property/Firewall.hs23
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs90
-rw-r--r--src/Propellor/Property/Systemd.hs139
-rw-r--r--src/Propellor/Ssh.hs5
-rw-r--r--src/Propellor/Types/Container.hs30
-rw-r--r--src/Propellor/Types/OS.hs4
-rw-r--r--src/Utility/SafeCommand.hs14
9 files changed, 257 insertions, 121 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 0e9d00d8..ded108bc 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -16,10 +16,10 @@ import Propellor
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Property.Chroot.Util
-import Propellor.Property.Mount
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Shim as Shim
+import Propellor.Property.Mount
import qualified Data.Map as M
import Data.List.Utils
@@ -70,7 +70,7 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
where
go desc a = propertyList (chrootDesc c desc) [a]
- setup = propellChroot c (inChrootProcess c) systemdonly
+ setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
`requires` toProp built
built = case (system, builderconf) of
@@ -95,7 +95,7 @@ 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 NoInfo
+propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo
propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
@@ -103,7 +103,6 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
( pure (Shim.file me d)
, Shim.setup me Nothing d
)
- liftIO mountproc
ifM (liftIO $ bindmount shim)
( chainprovision shim
, return FailedChange
@@ -119,25 +118,21 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
, File localdir, File mntpnt
]
)
-
- -- /proc needs to be mounted in the chroot for the linker to use
- -- /proc/self/exe which is necessary for some commands to work
- mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $
- void $ mount "proc" "proc" procloc
- procloc = loc </> "proc"
chainprovision shim = do
parenthost <- asks hostName
cmd <- liftIO $ toChain parenthost c systemdonly
pe <- liftIO standardPathEnv
- let p = mkproc
+ (p, cleanup) <- liftIO $ mkproc
[ shim
, "--continue"
, show cmd
]
let p' = p { env = Just pe }
- liftIO $ withHandle StdoutHandle createProcessSuccess p'
+ r <- liftIO $ withHandle StdoutHandle createProcessSuccess p'
processChainOutput
+ liftIO cleanup
+ return r
toChain :: HostName -> Chroot -> Bool -> IO CmdLine
toChain parenthost (Chroot loc _ _ _) systemdonly = do
@@ -164,8 +159,22 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"
-inChrootProcess :: Chroot -> [String] -> CreateProcess
-inChrootProcess (Chroot loc _ _ _) cmd = proc "chroot" (loc:cmd)
+inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
+inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
+ mountproc
+ return (proc "chroot" (loc:cmd), cleanup)
+ where
+ -- /proc needs to be mounted in the chroot for the linker to use
+ -- /proc/self/exe which is necessary for some commands to work
+ mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $
+ void $ mount "proc" "proc" procloc
+
+ procloc = loc </> "proc"
+
+ cleanup
+ | keepprocmounted = noop
+ | otherwise = whenM (elem procloc <$> mountPointsBelow loc) $
+ umountLazy procloc
provisioningLock :: FilePath -> FilePath
provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index fd7e37b2..1dcc3522 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -23,9 +23,11 @@ module Propellor.Property.Docker (
-- * Container configuration
dns,
hostname,
+ Publishable,
publish,
expose,
user,
+ Mountable,
volume,
volumes_from,
workdir,
@@ -43,6 +45,7 @@ module Propellor.Property.Docker (
import Propellor hiding (init)
import Propellor.Types.Docker
+import Propellor.Types.Container
import Propellor.Types.CmdLine
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
@@ -254,10 +257,19 @@ hostname = runProp "hostname"
name :: String -> Property HasInfo
name = runProp "name"
+class Publishable p where
+ toPublish :: p -> String
+
+instance Publishable (Bound Port) where
+ toPublish p = show (hostSide p) ++ ":" ++ show (containerSide p)
+
+-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort
+instance Publishable String where
+ toPublish = id
+
-- | Publish a container's port to the host
--- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
-publish :: String -> Property HasInfo
-publish = runProp "publish"
+publish :: Publishable p => p -> Property HasInfo
+publish = runProp "publish" . toPublish
-- | Expose a container's port without publishing it.
expose :: String -> Property HasInfo
@@ -267,11 +279,21 @@ expose = runProp "expose"
user :: String -> Property HasInfo
user = runProp "user"
--- | Mount a volume
--- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
+class Mountable p where
+ toMount :: p -> String
+
+instance Mountable (Bound FilePath) where
+ toMount p = hostSide p ++ ":" ++ containerSide p
+
+-- | string format: [host-dir]:[container-dir]:[rw|ro]
+--
-- With just a directory, creates a volume in the container.
-volume :: String -> Property HasInfo
-volume = runProp "volume"
+instance Mountable String where
+ toMount = id
+
+-- | Mount a volume
+volume :: Mountable v => v -> Property HasInfo
+volume = runProp "volume" . toMount
-- | Mount a volume from the specified container into the current
-- container.
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index ab57b122..d643b185 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -9,7 +9,6 @@ module Propellor.Property.Firewall (
Target(..),
Proto(..),
Rules(..),
- Port,
ConnectionState(..)
) where
@@ -45,8 +44,8 @@ toIpTable r = map Param $
toIpTableArg :: Rules -> [String]
toIpTableArg Everything = []
toIpTableArg (Proto proto) = ["-p", map toLower $ show proto]
-toIpTableArg (Port port) = ["--dport", show port]
-toIpTableArg (PortRange (f,t)) = ["--dport", show f ++ ":" ++ show t]
+toIpTableArg (DPort port) = ["--dport", show port]
+toIpTableArg (DPortRange (f,t)) = ["--dport", show f ++ ":" ++ show t]
toIpTableArg (IFace iface) = ["-i", iface]
toIpTableArg (Ctstate states) = ["-m", "conntrack","--ctstate", concat $ intersperse "," (map show states)]
toIpTableArg (r :- r') = toIpTableArg r <> toIpTableArg r'
@@ -55,33 +54,31 @@ data Rule = Rule
{ ruleChain :: Chain
, ruleTarget :: Target
, ruleRules :: Rules
- } deriving (Eq, Show, Read)
+ } deriving (Eq, Show)
data Chain = INPUT | OUTPUT | FORWARD
- deriving (Eq,Show,Read)
+ deriving (Eq, Show)
data Target = ACCEPT | REJECT | DROP | LOG
- deriving (Eq,Show,Read)
+ deriving (Eq, Show)
data Proto = TCP | UDP | ICMP
- deriving (Eq,Show,Read)
-
-type Port = Int
+ deriving (Eq, Show)
data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID
- deriving (Eq,Show,Read)
+ deriving (Eq, Show)
data Rules
= Everything
| Proto Proto
-- ^There is actually some order dependency between proto and port so this should be a specific
-- data type with proto + ports
- | Port Port
- | PortRange (Port,Port)
+ | DPort Port
+ | DPortRange (Port,Port)
| IFace Network.Interface
| Ctstate [ ConnectionState ]
| Rules :- Rules -- ^Combine two rules
- deriving (Eq,Show,Read)
+ deriving (Eq, Show)
infixl 0 :-
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 3c638721..70075968 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -6,9 +6,7 @@ import Propellor
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.User as User
import qualified Propellor.Property.Cron as Cron
-import qualified Propellor.Property.Ssh as Ssh
import qualified Propellor.Property.File as File
-import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Systemd as Systemd
import qualified Propellor.Property.Chroot as Chroot
import Propellor.Property.Cron (Times)
@@ -50,8 +48,6 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
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 (User builduser) (Group builduser)
& gitannexbuildercloned
@@ -86,6 +82,13 @@ buildDepsNoHaskellLibs = Apt.installed
"alex", "happy", "c2hs"
]
+haskellPkgsInstalled :: String -> Property NoInfo
+haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
+ where
+ go = userScriptProperty (User builduser)
+ [ "cd " ++ builddir ++ " && ./standalone/ " ++ dir ++ "/install-haskell-packages"
+ ]
+
-- Installs current versions of git-annex's deps from cabal, but only
-- does so once.
cabalDeps :: Property NoInfo
@@ -94,23 +97,36 @@ cabalDeps = flagFile go cabalupdated
go = userScriptProperty (User builduser) ["cabal update && cabal install git-annex --only-dependencies || true"]
cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
-standardAutoBuilderContainer :: System -> Times -> TimeOut -> Systemd.Container
-standardAutoBuilderContainer osver@(System _ arch) crontime timeout =
+autoBuilderContainer :: (System -> Property HasInfo) -> System -> Times -> TimeOut -> Systemd.Container
+autoBuilderContainer mkprop osver@(System _ arch) crontime timeout =
Systemd.container name bootstrap
- & standardAutoBuilder osver crontime timeout
+ & mkprop osver
+ & buildDepsApt
+ & autobuilder arch crontime timeout
where
name = arch ++ "-git-annex-builder"
bootstrap = Chroot.debootstrapped osver mempty
-standardAutoBuilder :: System -> Times -> TimeOut -> Property HasInfo
-standardAutoBuilder osver@(System _ arch) crontime timeout =
- propertyList "git-annex-builder" $ props
+standardAutoBuilder :: System -> Property HasInfo
+standardAutoBuilder osver@(System _ arch) =
+ propertyList "standard git-annex autobuilder" $ props
& os osver
& Apt.stdSourcesList
& Apt.unattendedUpgrades
& User.accountFor (User builduser)
& tree arch
- & buildDepsApt
+
+armAutoBuilder :: System -> Times -> TimeOut -> Property HasInfo
+armAutoBuilder osver@(System _ arch) crontime timeout =
+ propertyList "arm git-annex autobuilder" $ props
+ & standardAutoBuilder osver
+ & buildDepsNoHaskellLibs
+ -- Works around ghc crash with parallel builds on arm.
+ & (homedir </> ".cabal" </> "config")
+ `File.lacksLine` "jobs: $ncpus"
+ -- Install patched haskell packages for portability to
+ -- arm NAS's using old kernel versions.
+ & haskellPkgsInstalled "linux"
& autobuilder arch crontime timeout
androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container
@@ -135,7 +151,7 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name boot
& flagFile chrootsetup ("/chrootsetup")
`requires` setupgitannexdir
& buildDepsApt
- & flagFile haskellpkgsinstalled ("/haskellpkgsinstalled")
+ & haskellPkgsInstalled "android"
where
-- Use git-annex's android chroot setup script, which will install
-- ghc-android and the NDK, all build deps, etc, in the home
@@ -143,55 +159,5 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name boot
chrootsetup = scriptProperty
[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
]
- haskellpkgsinstalled = userScriptProperty (User builduser)
- [ "cd " ++ gitannexdir ++ " && ./standalone/android/install-haskell-packages"
- ]
osver = System (Debian Testing) "i386"
bootstrap = Chroot.debootstrapped osver mempty
-
--- armel builder has a companion container using amd64 that
--- runs the build first to get TH splices. They need
--- to have the same versions of all haskell libraries installed.
-armelCompanionContainer :: (System -> Docker.Image) -> Docker.Container
-armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion"
- (dockerImage $ System (Debian Unstable) "amd64")
- & os (System (Debian Testing) "amd64")
- & Apt.stdSourcesList
- & Apt.installed ["systemd"]
- -- This volume is shared with the armel builder.
- & Docker.volume gitbuilderdir
- & User.accountFor (User builduser)
- -- Install current versions of build deps from cabal.
- & tree "armel"
- & buildDepsNoHaskellLibs
- & cabalDeps
- -- The armel builder can ssh to this companion.
- & Docker.expose "22"
- & Apt.serviceInstalledRunning "ssh"
- & Ssh.authorizedKeys (User builduser) (Context "armel-git-annex-builder")
- & Docker.tweaked
-
-armelAutoBuilderContainer :: (System -> Docker.Image) -> Times -> TimeOut -> Docker.Container
-armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder"
- (dockerImage $ System (Debian Unstable) "armel")
- & os (System (Debian Testing) "armel")
- & Apt.stdSourcesList
- & Apt.installed ["systemd"]
- & Apt.installed ["openssh-client"]
- & Docker.link "armel-git-annex-builder-companion" "companion"
- & Docker.volumes_from "armel-git-annex-builder-companion"
- & User.accountFor (User builduser)
- -- TODO: automate installing haskell libs
- -- (Currently have to run
- -- git-annex/standalone/linux/install-haskell-packages
- -- which is not fully automated.)
- & buildDepsNoHaskellLibs
- & autobuilder "armel" crontimes timeout
- `requires` tree "armel"
- & Ssh.keyImported SshRsa (User builduser) (Context "armel-git-annex-builder")
- & trivial writecompanionaddress
- & Docker.tweaked
- where
- writecompanionaddress = scriptProperty
- [ "echo \"$COMPANION_PORT_22_TCP_ADDR\" > " ++ homedir </> "companion_address"
- ] `describe` "companion_address file"
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index c698f780..17849980 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -1,26 +1,46 @@
+{-# LANGUAGE FlexibleInstances #-}
+
module Propellor.Property.Systemd (
- module Propellor.Property.Systemd.Core,
+ -- * Services
ServiceName,
- MachineName,
started,
stopped,
enabled,
disabled,
+ running,
restarted,
- persistentJournal,
+ networkd,
+ journald,
+ -- * Configuration
+ installed,
Option,
configured,
- journaldConfigured,
daemonReloaded,
+ -- * Journal
+ persistentJournal,
+ journaldConfigured,
+ -- * Containers
+ MachineName,
Container,
container,
nspawned,
+ -- * Container configuration
containerCfg,
resolvConfed,
+ linkJournal,
+ privateNetwork,
+ module Propellor.Types.Container,
+ Proto(..),
+ Publishable,
+ publish,
+ Bindable,
+ bind,
+ bindRo,
) where
import Propellor
import Propellor.Types.Chroot
+import Propellor.Types.Container
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.File as File
@@ -44,6 +64,9 @@ instance PropAccum Container where
getProperties (Container _ _ h) = hostProperties h
-- | Starts a systemd service.
+--
+-- Note that this does not configure systemd to start the service on boot,
+-- it only ensures that the service is currently running.
started :: ServiceName -> Property NoInfo
started n = trivial $ cmdProperty "systemctl" ["start", n]
`describe` ("service " ++ n ++ " started")
@@ -54,6 +77,9 @@ stopped n = trivial $ cmdProperty "systemctl" ["stop", n]
`describe` ("service " ++ n ++ " stopped")
-- | Enables a systemd service.
+--
+-- This does not ensure the service is started, it only configures systemd
+-- to start it on boot.
enabled :: ServiceName -> Property NoInfo
enabled n = trivial $ cmdProperty "systemctl" ["enable", n]
`describe` ("service " ++ n ++ " enabled")
@@ -63,11 +89,23 @@ disabled :: ServiceName -> Property NoInfo
disabled n = trivial $ cmdProperty "systemctl" ["disable", n]
`describe` ("service " ++ n ++ " disabled")
+-- | Ensures that a service is both enabled and started
+running :: ServiceName -> Property NoInfo
+running n = trivial $ started n `requires` enabled n
+
-- | Restarts a systemd service.
restarted :: ServiceName -> Property NoInfo
restarted n = trivial $ cmdProperty "systemctl" ["restart", n]
`describe` ("service " ++ n ++ " restarted")
+-- | The systemd-networkd service.
+networkd :: ServiceName
+networkd = "systemd-networkd"
+
+-- | The systemd-journald service.
+journald :: ServiceName
+journald = "systemd-journald"
+
-- | Enables persistent storage of the journal.
persistentJournal :: Property NoInfo
persistentJournal = check (not <$> doesDirectoryExist dir) $
@@ -101,15 +139,15 @@ configured cfgfile option value = combineProperties desc
| setting `isPrefixOf` l = Nothing
| otherwise = Just l
+-- | Causes systemd to reload its configuration files.
+daemonReloaded :: Property NoInfo
+daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"]
+
-- | 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 NoInfo
-daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"]
+ `onChange` restarted journald
-- | Defines a container with a given machine name.
--
@@ -122,6 +160,7 @@ container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
container name mkchroot = Container name c h
& os system
& resolvConfed
+ & linkJournal
where
c@(Chroot.Chroot _ system _ _) = mkchroot (containerDir name)
h = Host name [] mempty
@@ -152,8 +191,7 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
-- Chroot provisioning is run in systemd-only mode,
-- which sets up the chroot and ensures systemd and dbus are
-- installed, but does not handle the other provisions.
- chrootprovisioned = Chroot.provisioned'
- (Chroot.propigateChrootInfo chroot) chroot True
+ chrootprovisioned = Chroot.provisioned' (Chroot.propigateChrootInfo chroot) chroot True
-- Use nsenter to enter container and and run propellor to
-- finish provisioning.
@@ -177,8 +215,14 @@ nspawnService (Container name _ _) cfg = setup <!> teardown
return $ unlines $
"# deployed by propellor" : map addparams ls
addparams l
- | "ExecStart=" `isPrefixOf` l =
- l ++ " " ++ unwords (nspawnServiceParams cfg)
+ | "ExecStart=" `isPrefixOf` l = unwords $
+ [ "ExecStart = /usr/bin/systemd-nspawn"
+ , "--quiet"
+ , "--keep-unit"
+ , "--boot"
+ , "--directory=" ++ containerDir name
+ , "--machine=%i"
+ ] ++ nspawnServiceParams cfg
| otherwise = l
goodservicefile = (==)
@@ -237,8 +281,8 @@ enterScript c@(Container name _ _) = setup <!> teardown
enterScriptFile :: Container -> FilePath
enterScriptFile (Container name _ _ ) = "/usr/local/bin/enter-" ++ mungename name
-enterContainerProcess :: Container -> [String] -> CreateProcess
-enterContainerProcess = proc . enterScriptFile
+enterContainerProcess :: Container -> [String] -> IO (CreateProcess, IO ())
+enterContainerProcess c ps = pure (proc (enterScriptFile c) ps, noop)
nspawnServiceName :: MachineName -> ServiceName
nspawnServiceName name = "systemd-nspawn@" ++ name ++ ".service"
@@ -270,3 +314,68 @@ containerCfg p = RevertableProperty (mk True) (mk False)
-- This property is enabled by default. Revert it to disable it.
resolvConfed :: RevertableProperty
resolvConfed = containerCfg "bind=/etc/resolv.conf"
+
+-- | Link the container's journal to the host's if possible.
+-- (Only works if the host has persistent journal enabled.)
+--
+-- This property is enabled by default. Revert it to disable it.
+linkJournal :: RevertableProperty
+linkJournal = containerCfg "link-journal=try-guest"
+
+-- | Disconnect networking of the container from the host.
+privateNetwork :: RevertableProperty
+privateNetwork = containerCfg "private-network"
+
+class Publishable a where
+ toPublish :: a -> String
+
+instance Publishable Port where
+ toPublish (Port n) = show n
+
+instance Publishable (Bound Port) where
+ toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v)
+
+data Proto = TCP | UDP
+
+instance Publishable (Proto, Bound Port) where
+ toPublish (TCP, fp) = "tcp:" ++ toPublish fp
+ toPublish (UDP, fp) = "udp:" ++ toPublish fp
+
+-- | Publish a port from the container to the host.
+--
+-- This feature was first added in systemd version 220.
+--
+-- This property is only needed (and will only work) if the container
+-- is configured to use private networking. Also, networkd should be enabled
+-- both inside the container, and on the host. For example:
+--
+-- > foo :: Host
+-- > foo = host "foo.example.com"
+-- > & Systemd.running Systemd.networkd
+-- > & Systemd.nspawned webserver
+-- >
+-- > webserver :: Systemd.container
+-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped (System (Debian Testing) "amd64") mempty)
+-- > & Systemd.privateNetwork
+-- > & Systemd.running Systemd.networkd
+-- > & Systemd.publish (Port 80 ->- Port 8080)
+-- > & Apt.installedRunning "apache2"
+publish :: Publishable p => p -> RevertableProperty
+publish p = containerCfg $ "--port=" ++ toPublish p
+
+class Bindable a where
+ toBind :: a -> String
+
+instance Bindable FilePath where
+ toBind f = f
+
+instance Bindable (Bound FilePath) where
+ toBind v = hostSide v ++ ":" ++ containerSide v
+
+-- | Bind mount a file or directory from the host into the container.
+bind :: Bindable p => p -> RevertableProperty
+bind p = containerCfg $ "--bind=" ++ toBind p
+
+-- | Read-only mind mount.
+bindRo :: Bindable p => p -> RevertableProperty
+bindRo p = containerCfg $ "--bind-ro=" ++ toBind p
diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs
index ac9295d1..3fe78f7a 100644
--- a/src/Propellor/Ssh.hs
+++ b/src/Propellor/Ssh.hs
@@ -22,7 +22,8 @@ sshCachingParams hn = do
let ps =
[ Param "-o"
, Param ("ControlPath=" ++ socketfile)
- , Params "-o ControlMaster=auto -o ControlPersist=yes"
+ , Param "-o", Param "ControlMaster=auto"
+ , Param "-o", Param "ControlPersist=yes"
]
maybe noop (expireold ps socketfile)
@@ -37,7 +38,7 @@ sshCachingParams hn = do
then touchFile f
else do
void $ boolSystem "ssh" $
- [ Params "-O stop" ] ++ ps ++
+ [ Param "-O", Param "stop" ] ++ ps ++
[ Param "localhost" ]
nukeFile f
tenminutes = 600
diff --git a/src/Propellor/Types/Container.hs b/src/Propellor/Types/Container.hs
new file mode 100644
index 00000000..d21bada7
--- /dev/null
+++ b/src/Propellor/Types/Container.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Propellor.Types.Container where
+
+-- | A value that can be bound between the host and a container.
+--
+-- For example, a Bound Port is a Port on the container that is bound to
+-- a Port on the host.
+data Bound v = Bound
+ { hostSide :: v
+ , containerSide :: v
+ }
+
+-- | Create a Bound value, from two different values for the host and
+-- container.
+--
+-- For example, @Port 8080 -<- Port 80@ means that port 8080 on the host
+-- is bound to port 80 from the container.
+(-<-) :: (hostv ~ v, containerv ~ v) => hostv -> containerv -> Bound v
+(-<-) hostv containerv = Bound hostv containerv
+
+-- | Flipped version of -<- with the container value first and host value
+-- second.
+(->-) :: (containerv ~ v, hostv ~ v) => hostv -> containerv -> Bound v
+(->-) containerv hostv = Bound hostv containerv
+
+-- | Create a Bound value, that is the same on both the host and container.
+same :: v -> Bound v
+same v = Bound v v
+
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 58bd809a..c46d9a28 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -10,6 +10,7 @@ module Propellor.Types.OS (
User(..),
Group(..),
userGroup,
+ Port(..),
) where
import Network.BSD (HostName)
@@ -42,3 +43,6 @@ newtype Group = Group String
-- | Makes a Group with the same name as the User.
userGroup :: User -> Group
userGroup (User u) = Group u
+
+newtype Port = Port Int
+ deriving (Eq, Show)
diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs
index 82e35049..9102b726 100644
--- a/src/Utility/SafeCommand.hs
+++ b/src/Utility/SafeCommand.hs
@@ -19,25 +19,23 @@ import Prelude
-- | Parameters that can be passed to a shell command.
data CommandParam
- = Params String -- ^ Contains multiple parameters, separated by whitespace
- | Param String -- ^ A single parameter
+ = Param String -- ^ A parameter
| File FilePath -- ^ The name of a file
deriving (Eq, Show, Ord)
-- | Used to pass a list of CommandParams to a function that runs
-- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
-toCommand = concatMap unwrap
+toCommand = map unwrap
where
- unwrap (Param s) = [s]
- unwrap (Params s) = filter (not . null) (split " " s)
+ unwrap (Param s) = s
-- Files that start with a non-alphanumeric that is not a path
-- separator are modified to avoid the command interpreting them as
-- options or other special constructs.
unwrap (File s@(h:_))
- | isAlphaNum h || h `elem` pathseps = [s]
- | otherwise = ["./" ++ s]
- unwrap (File s) = [s]
+ | isAlphaNum h || h `elem` pathseps = s
+ | otherwise = "./" ++ s
+ unwrap (File s) = s
-- '/' is explicitly included because it's an alternative
-- path separator on Windows.
pathseps = pathSeparator:"./"