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

Merge branch 'joeyconfig' of git://git.kitenet.net/propellor into joeyconfig 

Conflicts:
	src/Propellor/Property/SiteSpecific/IABak.hs
This commit is contained in:
Daniel Brooks 2015-08-02 00:59:28 -04:00
parent 65b511e2d4 b7a9655a69
commit eb15f06896
59 changed files with 2241 additions and 1834 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -7,4 +7,7 @@ Setup
Setup.hi
Setup.o
docker
chroot
propellor.1
.lock
.lastchecked

14
Makefile
View File

@ -17,11 +17,15 @@ install:
cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1)
# cabal sdist does not preserve symlinks, so copy over file
cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done
cd dist/gittmp && git init && \
git add . \
&& git commit -q -m "distributed version of propellor" \
&& git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \
&& git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head
export GIT_AUTHOR_NAME=build \
&& export GIT_AUTHOR_EMAIL=build@buildhost \
&& export GIT_COMMITTER_NAME=build \
&& export GIT_COMMITTER_EMAIL=build@buildhost \
&& cd dist/gittmp && git init \
&& git add . \
&& git commit -q -m "distributed version of propellor" \
&& git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \
&& git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head
rm -rf dist/gittmp
clean:

136
config-joey.hs
View File

@ -25,6 +25,7 @@ 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.Chroot as Chroot
import qualified Propellor.Property.OS as OS
import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
import qualified Propellor.Property.HostingProvider.Linode as Linode
@ -45,6 +46,7 @@ hosts = -- (o) `
, gnu
, clam
, orca
, honeybee
, kite
, elephant
, beaver
@ -74,8 +76,6 @@ darkstar = host "darkstar.kitenet.net"
& ipv6 "2001:4830:1600:187::2" -- sixxs tunnel
& Apt.buildDep ["git-annex"] `period` Daily
& Docker.configured
! Docker.docked gitAnnexAndroidDev
& JoeySites.postfixClientRelay (Context "darkstar.kitenet.net")
& JoeySites.dkimMilter
@ -83,7 +83,6 @@ darkstar = host "darkstar.kitenet.net"
gnu :: Host
gnu = host "gnu.kitenet.net"
& Apt.buildDep ["git-annex"] `period` Daily
& Docker.configured
& JoeySites.postfixClientRelay (Context "gnu.kitenet.net")
& JoeySites.dkimMilter
@ -97,18 +96,18 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
& Ssh.randomHostKeys
& Apt.unattendedUpgrades
& Network.ipv6to4
& Tor.isRelay
& Tor.named "kite1"
& Tor.bandwidthRate (Tor.PerMonth "400 GB")
& Docker.configured
& Docker.garbageCollected `period` Daily
& Docker.docked webserver
& Systemd.nspawned webserver
& File.dirExists "/var/www/html"
& File.notPresent "/var/www/html/index.html"
& "/var/www/index.html" `File.hasContent` ["hello, world"]
& File.notPresent "/var/www/index.html"
& "/var/www/html/index.html" `File.hasContent` ["hello, world"]
& alias "helloworld.kitenet.net"
& Docker.docked oldusenetShellBox
& Systemd.nspawned oldusenetShellBox
& JoeySites.scrollBox
& alias "scroll.joeyh.name"
@ -129,15 +128,46 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
& Apt.unattendedUpgrades
& Postfix.satellite
& Apt.serviceInstalledRunning "ntp"
& Systemd.persistentJournal
& Docker.configured
& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h")
& Docker.docked (GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h")
& Docker.docked (GitAnnexBuilder.armelCompanionContainer dockerImage)
& Docker.docked (GitAnnexBuilder.armelAutoBuilderContainer dockerImage (Cron.Times "1 3 * * *") "5h")
& Docker.docked (GitAnnexBuilder.androidAutoBuilderContainer dockerImage (Cron.Times "1 1 * * *") "3h")
& Docker.garbageCollected `period` Daily
& Apt.buildDep ["git-annex"] `period` Daily
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.standardAutoBuilder
(System (Debian Unstable) "amd64") fifteenpast "2h")
& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
GitAnnexBuilder.standardAutoBuilder
(System (Debian Unstable) "i386") fifteenpast "2h")
& Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer
(Cron.Times "1 1 * * *") "3h")
where
fifteenpast = Cron.Times "15 * * * *"
honeybee :: Host
honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
[ "Arm git-annex build box." ]
& ipv6 "2001:4830:1600:187::2"
-- No unattended upgrades as there is currently no console access.
-- (Also, system is not currently running a stock kernel,
-- although it should be able to.)
& Postfix.satellite
& Apt.serviceInstalledRunning "aiccu"
& Apt.serviceInstalledRunning "swapspace"
& Apt.serviceInstalledRunning "ntp"
-- Not using systemd-nspawn because it's broken (kernel issue?)
-- & Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer
-- GitAnnexBuilder.armAutoBuilder
-- builderos Cron.Daily "22h")
& Chroot.provisioned
(Chroot.debootstrapped builderos mempty "/var/lib/container/armel-git-annex-builder"
& "/etc/timezone" `File.hasContent` ["America/New_York"]
& GitAnnexBuilder.armAutoBuilder
builderos (Cron.Times "1 1 * * *") "12h"
)
where
-- Using unstable to get new enough ghc for TH on arm.
builderos = System (Debian Unstable) "armel"
-- This is not a complete description of kite, since it's a
-- multiuser system with eg, user passwords that are not deployed
@ -222,9 +252,6 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
, "zsh"
]
& Docker.configured
& Docker.garbageCollected `period` Daily
& alias "nntp.olduse.net"
& JoeySites.oldUseNetServer hosts
@ -281,13 +308,14 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
& myDnsSecondary
& Docker.configured
& Docker.docked oldusenetShellBox
& Docker.docked openidProvider
`requires` Apt.serviceInstalledRunning "ntp"
& Docker.docked ancientKitenet
& Docker.docked jerryPlay
& Docker.garbageCollected `period` (Weekly (Just 1))
& Systemd.nspawned oldusenetShellBox
& JoeySites.scrollBox
& alias "scroll.joeyh.name"
& alias "eu.scroll.joeyh.name"
@ -295,7 +323,7 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
-- For https port 443, shellinabox with ssh login to
-- kitenet.net
& alias "shell.kitenet.net"
& Docker.docked kiteShellBox
& Systemd.nspawned kiteShellBox
-- Nothing is using http port 80, so listen on
-- that port for ssh, for traveling on bad networks that
-- block 22.
@ -316,6 +344,7 @@ beaver = host "beaver.kitenet.net"
-- Branchable is not completely deployed with propellor yet.
pell :: Host
pell = host "pell.branchable.com"
& alias "branchable.com"
& ipv4 "66.228.46.55"
& ipv6 "2600:3c03::f03c:91ff:fedf:c0e5"
@ -371,22 +400,21 @@ iabak = host "iabak.archiveteam.org"
--' __|II| ,.
---- __|II|II|__ ( \_,/\
--'-------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-.-'-
-------------------------- | [Docker] / --------------------------
-------------------------- | [Containers] / --------------------------
-------------------------- : / ---------------------------
--------------------------- \____, o ,' ----------------------------
---------------------------- '--,___________,' -----------------------------
-- Simple web server, publishing the outside host's /var/www
webserver :: Docker.Container
webserver :: Systemd.Container
webserver = standardStableContainer "webserver"
& Docker.publish "80:80"
& Docker.volume "/var/www:/var/www"
& Systemd.bind "/var/www"
& Apt.serviceInstalledRunning "apache2"
-- My own openid provider. Uses php, so containerized for security
-- and administrative sanity.
openidProvider :: Docker.Container
openidProvider = standardStableContainer "openid-provider"
openidProvider = standardStableDockerContainer "openid-provider"
& alias "openid.kitenet.net"
& Docker.publish "8081:80"
& OpenId.providerFor [User "joey", User "liw"]
@ -394,39 +422,30 @@ openidProvider = standardStableContainer "openid-provider"
-- Exhibit: kite's 90's website.
ancientKitenet :: Docker.Container
ancientKitenet = standardStableContainer "ancient-kitenet"
ancientKitenet = standardStableDockerContainer "ancient-kitenet"
& alias "ancient.kitenet.net"
& Docker.publish "1994:80"
& Apt.serviceInstalledRunning "apache2"
& Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www"
& Git.cloned (User "root") "git://kitenet-net.branchable.com/" "/var/www/html"
(Just "remotes/origin/old-kitenet.net")
oldusenetShellBox :: Docker.Container
oldusenetShellBox :: Systemd.Container
oldusenetShellBox = standardStableContainer "oldusenet-shellbox"
& alias "shell.olduse.net"
& Docker.publish "4200:4200"
& JoeySites.oldUseNetShellBox
-- for development of git-annex for android, using my git-annex work tree
gitAnnexAndroidDev :: Docker.Container
gitAnnexAndroidDev = GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir
& Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir)
where
gitannexdir = GitAnnexBuilder.homedir </> "git-annex"
jerryPlay :: Docker.Container
jerryPlay = standardContainer "jerryplay" Unstable "amd64"
jerryPlay = standardDockerContainer "jerryplay" Unstable "amd64"
& alias "jerryplay.kitenet.net"
& Docker.publish "2202:22"
& Docker.publish "8001:80"
& Apt.installed ["ssh"]
& User.hasSomePassword (User "root")
& Ssh.permitRootLogin True
kiteShellBox :: Docker.Container
& Ssh.permitRootLogin (Ssh.RootLogin True)
kiteShellBox :: Systemd.Container
kiteShellBox = standardStableContainer "kiteshellbox"
& JoeySites.kiteShellBox
& Docker.publish "443:443"
type Motd = [String]
@ -457,12 +476,25 @@ standardSystemUnhardened hn suite arch motd = host hn
& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
`onChange` Apt.autoRemove
standardStableContainer :: Docker.ContainerName -> Docker.Container
standardStableContainer name = standardContainer name (Stable "wheezy") "amd64"
-- This is my standard container setup, Featuring automatic upgrades.
standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container
standardContainer name suite arch = Docker.container name (dockerImage system)
standardContainer :: Systemd.MachineName -> DebianSuite -> Architecture -> Systemd.Container
standardContainer name suite arch = Systemd.container name chroot
& os system
& Apt.stdSourcesList `onChange` Apt.upgrade
& Apt.unattendedUpgrades
& Apt.cacheCleaned
where
system = System (Debian suite) arch
chroot = Chroot.debootstrapped system mempty
standardStableContainer :: Systemd.MachineName -> Systemd.Container
standardStableContainer name = standardContainer name (Stable "jessie") "amd64"
standardStableDockerContainer :: Docker.ContainerName -> Docker.Container
standardStableDockerContainer name = standardDockerContainer name (Stable "jessie") "amd64"
standardDockerContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Docker.Container
standardDockerContainer name suite arch = Docker.container name (dockerImage system)
& os system
& Apt.stdSourcesList `onChange` Apt.upgrade
& Apt.unattendedUpgrades
@ -473,10 +505,10 @@ standardContainer name suite arch = Docker.container name (dockerImage system)
-- Docker images I prefer to use.
dockerImage :: System -> Docker.Image
dockerImage (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch
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!
dockerImage (System (Debian Unstable) arch) = Docker.latestImage ("joeyh/debian-unstable-" ++ arch)
dockerImage (System (Debian Testing) arch) = Docker.latestImage ("joeyh/debian-unstable-" ++ arch)
dockerImage (System (Debian (Stable _)) arch) = Docker.latestImage ("joeyh/debian-stable-" ++ arch)
dockerImage _ = Docker.latestImage "debian-stable-official" -- does not currently exist!
myDnsSecondary :: Property HasInfo
myDnsSecondary = propertyList "dns secondary for all my domains" $ props

2
config-simple.hs
View File

@ -41,7 +41,7 @@ hosts =
-- A generic webserver in a Docker container.
webserverContainer :: Docker.Container
webserverContainer = Docker.container "webserver" "debian"
webserverContainer = Docker.container "webserver" (Docker.latestImage "debian")
& os (System (Debian (Stable "jessie")) "amd64")
& Apt.stdSourcesList
& Docker.publish "80:80"

55
debian/changelog vendored
View File

@ -1,11 +1,62 @@
propellor (2.5.0) UNRELEASED; urgency=medium
propellor (2.7.0) unstable; urgency=medium
* Ssh.permitRootLogin type changed to allow configuring WithoutPassword
and ForcedCommandsOnly (API change)
* setSshdConfig type changed, and setSshdConfigBool added with old type.
* Fix a bug in shim generation code for docker and chroots, that
sometimes prevented deployment of docker containers.
* Added onChangeFlagOnFail which is often a safer alternative to
onChange.
Thanks, Antoine Eiche.
* Work around broken git pull option parser in git 2.5.0,
which broke use of --upload-pack to send a git push when running
propellor --spin.
-- Joey Hess <id@joeyh.name> Thu, 30 Jul 2015 12:05:46 -0400
propellor (2.6.0) unstable; urgency=medium
* Replace String type synonym Docker.Image by a data type
which allows to specify an image name and an optional tag. (API change)
Thanks, Antoine Eiche.
* Added --unset to delete a privdata field.
* Version dependency on exceptions.
* Systemd: Add masked property.
Thanks, Sean Whitton
* Fix make install target to work even when git is not configured.
-- Joey Hess <id@joeyh.name> Fri, 10 Jul 2015 22:36:29 -0400
propellor (2.5.0) unstable; urgency=medium
* cmdProperty' renamed to cmdPropertyEnv to make way for a new,
more generic cmdProperty' (API change)
* Add docker image related properties.
Thanks, Antoine Eiche.
* Export CommandParam, boolSystem, safeSystem, shellEscape, and
* createProcess from Propellor.Property.Cmd, so they are available
for use in constricting your own Properties when using propellor
as a library.
* Improve enter-machine scripts for systemd-nspawn containers to unset most
environment variables.
* Fix Postfix.satellite bug; the default relayhost was set to the
domain, not to smtp.domain as documented.
* Mount /proc inside a chroot before provisioning it, to work around #787227
* --spin now works when given a short hostname that only resolves to an
ipv6 address.
* Added publish property for systemd-spawn containers, for port publishing.
(Needs systemd version 220.)
* Added bind and bindRo properties for systemd-spawn containers.
* Firewall: Port was changed to a newtype, and the Port and PortRange
constructors of Rules were changed to DPort and DportRange, respectively.
(API change)
* Docker: volume and publish accept Bound FilePath and Bound Port,
respectively. They also continue to accept Strings, for backwards
compatibility.
* Docker: Added environment property.
Thanks Antoine Eiche.
-- Joey Hess <id@joeyh.name> Thu, 07 May 2015 12:08:34 -0400
-- Joey Hess <id@joeyh.name> Tue, 09 Jun 2015 17:08:43 -0400
propellor (2.4.0) unstable; urgency=medium

4
debian/control vendored
View File

@ -16,7 +16,7 @@ Build-Depends:
libghc-quickcheck2-dev,
libghc-mtl-dev,
libghc-transformers-dev,
libghc-exceptions-dev,
libghc-exceptions-dev (>= 0.6),
Maintainer: Gergely Nagy <algernon@madhouse-project.org>
Standards-Version: 3.9.6
Vcs-Git: git://git.joeyh.name/propellor
@ -38,7 +38,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-quickcheck2-dev,
libghc-mtl-dev,
libghc-transformers-dev,
libghc-exceptions-dev,
libghc-exceptions-dev (>= 0.6),
git,
Description: property-based host configuration management in haskell
Propellor enures that the system it's run in satisfies a list of

4
doc/usage.mdwn
View File

@ -71,6 +71,10 @@ and configured in haskell.
Sets a field of privdata. The content is read in from stdin.
* propellor --unset field context
Removes a value from the privdata store.
* propellor --dump field context
Outputs the privdata value to stdout.

2844
privdata.joey/privdata.gpg
View File

File diff suppressed because it is too large Load Diff

7
propellor.cabal
View File

@ -1,6 +1,6 @@
Name: propellor
Version: 2.4.0
Cabal-Version: >= 1.6
Version: 2.7.0
Cabal-Version: >= 1.8
License: BSD3
Maintainer: Joey Hess <id@joeyh.name>
Author: Joey Hess
@ -38,7 +38,7 @@ Executable propellor
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async, time, QuickCheck, mtl, transformers,
exceptions
exceptions (>= 0.6)
if (! os(windows))
Build-Depends: unix
@ -121,6 +121,7 @@ Library
Propellor.Exception
Propellor.Types
Propellor.Types.Chroot
Propellor.Types.Container
Propellor.Types.Docker
Propellor.Types.Dns
Propellor.Types.Empty

1
src/Propellor/Bootstrap.hs
View File

@ -6,7 +6,6 @@ module Propellor.Bootstrap (
) where
import Propellor
import Utility.SafeCommand
import System.Posix.Files
import Data.List

21
src/Propellor/CmdLine.hs
View File

@ -7,7 +7,7 @@ import System.Environment (getArgs)
import Data.List
import System.Exit
import System.PosixCompat
import qualified Network.BSD
import Network.Socket
import Propellor
import Propellor.Gpg
@ -18,7 +18,6 @@ import Propellor.Types.CmdLine
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
import Utility.SafeCommand
usage :: Handle -> IO ()
usage h = hPutStrLn h $ unlines
@ -52,6 +51,7 @@ processCmdLine = go =<< getArgs
_ -> Spin <$> mapM hostname ps <*> pure Nothing
go ("--add-key":k:[]) = return $ AddKey k
go ("--set":f:c:[]) = withprivfield f c Set
go ("--unset":f:c:[]) = withprivfield f c Unset
go ("--dump":f:c:[]) = withprivfield f c Dump
go ("--edit":f:c:[]) = withprivfield f c Edit
go ("--list-fields":[]) = return ListFields
@ -95,6 +95,7 @@ defaultMain hostlist = do
go _ (Continue cmdline) = go False cmdline
go _ Check = return ()
go _ (Set field context) = setPrivData field context
go _ (Unset field context) = unsetPrivData field context
go _ (Dump field context) = dumpPrivData field context
go _ (Edit field context) = editPrivData field context
go _ ListFields = listPrivDataFields hostlist
@ -166,9 +167,15 @@ updateFirst' cmdline next = ifM fetchOrigin
, next
)
-- Gets the fully qualified domain name, given a string that might be
-- a short name to look up in the DNS.
hostname :: String -> IO HostName
hostname s
| "." `isInfixOf` s = pure s
| otherwise = do
h <- Network.BSD.getHostByName s
return (Network.BSD.hostName h)
hostname s = go =<< catchDefaultIO [] dnslookup
where
dnslookup = getAddrInfo (Just canonname) (Just s) Nothing
canonname = defaultHints { addrFlags = [AI_CANONNAME] }
go (AddrInfo { addrCanonName = Just v } : _) = pure v
go _
| "." `isInfixOf` s = pure s -- assume it's a fqdn
| otherwise =
error $ "cannot find host " ++ s ++ " in the DNS"

1
src/Propellor/Git.hs
View File

@ -3,7 +3,6 @@ module Propellor.Git where
import Propellor
import Propellor.PrivData.Paths
import Propellor.Gpg
import Utility.SafeCommand
import Utility.FileMode
getCurrentBranch :: IO String

21
src/Propellor/PrivData.hs
View File

@ -6,6 +6,7 @@ module Propellor.PrivData (
withSomePrivData,
addPrivData,
setPrivData,
unsetPrivData,
dumpPrivData,
editPrivData,
filterPrivData,
@ -143,6 +144,11 @@ setPrivData field context = do
putStrLn "Enter private data on stdin; ctrl-D when done:"
setPrivDataTo field context =<< hGetContentsStrict stdin
unsetPrivData :: PrivDataField -> Context -> IO ()
unsetPrivData field context = do
modifyPrivData $ M.delete (field, context)
putStrLn "Private data unset."
dumpPrivData :: PrivDataField -> Context -> IO ()
dumpPrivData field context =
maybe (error "Requested privdata is not set.") putStrLn
@ -192,17 +198,22 @@ listPrivDataFields hosts = do
setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
setPrivDataTo field context value = do
makePrivDataDir
m <- decryptPrivData
let m' = M.insert (field, context) (chomp value) m
gpgEncrypt privDataFile (show m')
modifyPrivData set
putStrLn "Private data set."
void $ boolSystem "git" [Param "add", File privDataFile]
where
set = M.insert (field, context) (chomp value)
chomp s
| end s == "\n" = chomp (beginning s)
| otherwise = s
modifyPrivData :: (PrivMap -> PrivMap) -> IO ()
modifyPrivData f = do
makePrivDataDir
m <- decryptPrivData
let m' = f m
gpgEncrypt privDataFile (show m')
void $ boolSystem "git" [Param "add", File privDataFile]
decryptPrivData :: IO PrivMap
decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile

35
src/Propellor/Property.hs
View File

@ -54,6 +54,41 @@ onChange = combineWith $ \p hook -> do
return $ r <> r'
_ -> return r
-- | Same as `onChange` except that if property y fails, a flag file
-- is generated. On next run, if the flag file is present, property y
-- is executed even if property x doesn't change.
--
-- With `onChange`, if y fails, the property x `onChange` y returns
-- `FailedChange`. But if this property is applied again, it returns
-- `NoChange`. This behavior can cause trouble...
onChangeFlagOnFail
:: (Combines (Property x) (Property y))
=> FilePath
-> Property x
-> Property y
-> CombinedType (Property x) (Property y)
onChangeFlagOnFail flagfile p1 p2 =
combineWith go p1 p2
where
go s1 s2 = do
r1 <- s1
case r1 of
MadeChange -> flagFailed s2
_ -> ifM (liftIO $ doesFileExist flagfile)
(flagFailed s2
, return r1
)
flagFailed s = do
r <- s
liftIO $ case r of
FailedChange -> createFlagFile
_ -> removeFlagFile
return r
createFlagFile = unlessM (doesFileExist flagfile) $ do
createDirectoryIfMissing True (takeDirectory flagfile)
writeFile flagfile ""
removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile
-- | Alias for @flip describe@
(==>) :: IsProp (Property i) => Desc -> Property i -> Property i
(==>) = flip describe

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

@ -4,7 +4,6 @@ import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Utility.SafeCommand
type ConfigFile = [String]

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

@ -19,7 +19,7 @@ import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Shim as Shim
import Utility.SafeCommand
import Propellor.Property.Mount
import qualified Data.Map as M
import Data.List.Utils
@ -56,8 +56,9 @@ debootstrapped system conf location = case system of
-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
--
-- Reverting this property removes the chroot. Note that it does not ensure
-- that any processes that might be running inside the chroot are stopped.
-- Reverting this property removes the chroot. Anything mounted inside it
-- is first unmounted. Note that it does not ensure that any processes
-- that might be running inside the chroot are stopped.
provisioned :: Chroot -> RevertableProperty
provisioned c = provisioned' (propigateChrootInfo c) c False
@ -69,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
@ -94,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"
@ -117,19 +118,21 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
, File localdir, File mntpnt
]
)
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
@ -156,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"

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

@ -1,22 +1,32 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Property.Cmd (
-- * Properties for running commands and scripts
cmdProperty,
cmdProperty',
cmdPropertyEnv,
Script,
scriptProperty,
userScriptProperty,
-- * Lower-level interface for running commands
CommandParam(..),
boolSystem,
boolSystemEnv,
safeSystem,
safeSystemEnv,
shellEscape,
createProcess,
) where
import Control.Applicative
import Data.List
import "mtl" Control.Monad.Reader
import System.Process (CreateProcess)
import Propellor.Types
import Propellor.Property
import Utility.SafeCommand
import Utility.Env
import Utility.Process (createProcess, CreateProcess)
-- | A property that can be satisfied by running a command.
--
@ -40,15 +50,18 @@ cmdPropertyEnv cmd params env = property desc $ liftIO $ do
where
desc = unwords $ cmd : params
-- | A property that can be satisfied by running a series of shell commands.
scriptProperty :: [String] -> Property NoInfo
-- | A series of shell commands. (Without a leading hashbang.)
type Script = [String]
-- | A property that can be satisfied by running a script.
scriptProperty :: Script -> 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,
-- | A property that can satisfied by running a script
-- as user (cd'd to their home directory).
userScriptProperty :: User -> [String] -> Property NoInfo
userScriptProperty :: User -> Script -> Property NoInfo
userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user]
where
shellcmd = intercalate " ; " ("set -e" : "cd" : script)

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

@ -4,7 +4,6 @@ import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Propellor.Bootstrap
import Utility.SafeCommand
import Utility.FileMode
import Data.Char

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

@ -15,7 +15,6 @@ import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Chroot.Util
import Propellor.Property.Mount
import Utility.Path
import Utility.SafeCommand
import Utility.FileMode
import Data.List
@ -107,9 +106,7 @@ unpopulated d = null <$> catchDefaultIO [] (dirContents d)
removetarget :: FilePath -> IO ()
removetarget target = do
submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
. filter (dirContains target)
<$> mountPoints
submnts <- mountPointsBelow target
forM_ submnts umountLazy
removeDirectoryRecursive target

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

@ -16,22 +16,26 @@ module Propellor.Property.Docker (
memoryLimited,
garbageCollected,
tweaked,
Image,
Image(..),
latestImage,
ContainerName,
Container,
HasImage(..),
-- * Container configuration
dns,
hostname,
Publishable,
publish,
expose,
user,
Mountable,
volume,
volumes_from,
workdir,
memory,
cpuShares,
link,
environment,
ContainerAlias,
restartAlways,
restartOnFailure,
@ -43,12 +47,12 @@ 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
import qualified Propellor.Property.Cmd as Cmd
import qualified Propellor.Shim as Shim
import Utility.SafeCommand
import Utility.Path
import Utility.ThreadScheduler
@ -152,8 +156,8 @@ docked ctr@(Container _ h) =
imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo
imageBuilt directory ctr = describe built msg
where
msg = "docker image " ++ image ++ " built from " ++ directory
built = Cmd.cmdProperty' dockercmd ["build", "--tag", image, "./"] workDir
msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
workDir p = p { cwd = Just directory }
image = getImageName ctr
@ -161,8 +165,8 @@ imageBuilt directory ctr = describe built msg
imagePulled :: HasImage c => c -> Property NoInfo
imagePulled ctr = describe pulled msg
where
msg = "docker image " ++ image ++ " pulled"
pulled = Cmd.cmdProperty dockercmd ["pull", image]
msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
image = getImageName ctr
propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo
@ -240,8 +244,52 @@ data ContainerInfo = ContainerInfo Image [RunParam]
-- | Parameters to pass to `docker run` when creating a container.
type RunParam = String
-- | A docker image, that can be used to run a container.
type Image = String
-- | ImageID is an image identifier to perform action on images. An
-- ImageID can be the name of an container image, a UID, etc.
--
-- It just encapsulates a String to avoid the definition of a String
-- instance of ImageIdentifier.
newtype ImageID = ImageID String
-- | Used to perform Docker action on an image.
--
-- Minimal complete definition: `imageIdentifier`
class ImageIdentifier i where
-- | For internal purposes only.
toImageID :: i -> ImageID
toImageID = ImageID . imageIdentifier
-- | A string that Docker can use as an image identifier.
imageIdentifier :: i -> String
instance ImageIdentifier ImageID where
imageIdentifier (ImageID i) = i
toImageID = id
-- | A docker image, that can be used to run a container. The user has
-- to specify a name and can provide an optional tag.
-- See <http://docs.docker.com/userguide/dockerimages/ Docker Image Documention>
-- for more information.
data Image = Image
{ repository :: String
, tag :: Maybe String
}
deriving (Eq, Read, Show)
-- | Defines a Docker image without any tag. This is considered by
-- Docker as the latest image of the provided repository.
latestImage :: String -> Image
latestImage repo = Image repo Nothing
instance ImageIdentifier Image where
-- | The format of the imageIdentifier of an `Image` is:
-- repository | repository:tag
imageIdentifier i = repository i ++ (maybe "" ((++) ":") $ tag i)
-- | The UID of an image. This UID is generated by Docker.
newtype ImageUID = ImageUID String
instance ImageIdentifier ImageUID where
imageIdentifier (ImageUID uid) = uid
-- | Set custom dns server for container.
dns :: String -> Property HasInfo
@ -255,10 +303,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
@ -268,11 +325,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.
@ -327,6 +394,11 @@ restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
restartNever :: Property HasInfo
restartNever = runProp "restart" "no"
-- | Set environment variable with a tuple composed by the environment
-- variable name and its value.
environment :: (String, String) -> Property HasInfo
environment (k, v) = runProp "env" $ k ++ "=" ++ v
-- | A container is identified by its name, and the host
-- on which it's deployed.
data ContainerId = ContainerId
@ -397,7 +469,9 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
return FailedChange
restartcontainer = do
oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
oldimage <- liftIO $
fromMaybe (toImageID image) . fmap toImageID <$>
commitContainer cid
void $ liftIO $ removeContainer cid
go oldimage
@ -426,16 +500,14 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
retry (n-1) a
_ -> return v
go img = do
liftIO $ do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
shim <- liftIO $ Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid)
liftIO $ writeFile (identFile cid) (show ident)
ensureProperty $ property "run" $ liftIO $
toResult <$> runContainer img
(runps ++ ["-i", "-d", "-t"])
[shim, "--continue", show (DockerInit (fromContainerId cid))]
go img = liftIO $ do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
shim <- Shim.setup (localdir </> "propellor") Nothing (localdir </> shimdir cid)
writeFile (identFile cid) (show ident)
toResult <$> runContainer img
(runps ++ ["-i", "-d", "-t"])
[shim, "--continue", show (DockerInit (fromContainerId cid))]
-- | Called when propellor is running inside a docker container.
-- The string should be the container's ContainerId.
@ -536,20 +608,20 @@ removeContainer :: ContainerId -> IO Bool
removeContainer cid = catchBoolIO $
snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing
removeImage :: Image -> IO Bool
removeImage :: ImageIdentifier i => i -> IO Bool
removeImage image = catchBoolIO $
snd <$> processTranscript dockercmd ["rmi", image ] Nothing
snd <$> processTranscript dockercmd ["rmi", imageIdentifier image] Nothing
runContainer :: Image -> [RunParam] -> [String] -> IO Bool
runContainer :: ImageIdentifier i => i -> [RunParam] -> [String] -> IO Bool
runContainer image ps cmd = boolSystem dockercmd $ map Param $
"run" : (ps ++ image : cmd)
"run" : (ps ++ (imageIdentifier image) : cmd)
inContainerProcess :: ContainerId -> [String] -> [String] -> CreateProcess
inContainerProcess cid ps cmd = proc dockercmd ("exec" : ps ++ [fromContainerId cid] ++ cmd)
commitContainer :: ContainerId -> IO (Maybe Image)
commitContainer :: ContainerId -> IO (Maybe ImageUID)
commitContainer cid = catchMaybeIO $
takeWhile (/= '\n')
ImageUID . takeWhile (/= '\n')
<$> readProcess dockercmd ["commit", fromContainerId cid]
data ContainerFilter = RunningContainers | AllContainers
@ -567,8 +639,8 @@ listContainers status =
| otherwise = baseps
baseps = ["ps", "--no-trunc"]
listImages :: IO [Image]
listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Property HasInfo
runProp field val = pureInfoProperty (param) $ dockerInfo $

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

@ -9,7 +9,6 @@ module Propellor.Property.Firewall (
Target(..),
Proto(..),
Rules(..),
Port,
ConnectionState(..)
) where
@ -18,7 +17,6 @@ import Data.Char
import Data.List
import Propellor
import Utility.SafeCommand
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network
@ -46,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'
@ -56,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 :-

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

@ -4,7 +4,6 @@ import Propellor
import Propellor.Property.File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Utility.SafeCommand
import Data.List

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

@ -1,23 +1,33 @@
module Propellor.Property.Mount where
import Propellor
import Utility.SafeCommand
import Utility.Path
type FsType = String
type Source = String
-- | Lists all mount points of the system.
mountPoints :: IO [FilePath]
mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
-- | Finds all filesystems mounted inside the specified directory.
mountPointsBelow :: FilePath -> IO [FilePath]
mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
. filter (dirContains target)
<$> mountPoints
-- | Filesystem type mounted at a given location.
getFsType :: FilePath -> IO (Maybe FsType)
getFsType mnt = catchDefaultIO Nothing $
headMaybe . lines
<$> readProcess "findmnt" ["-n", mnt, "--output", "fstype"]
-- | Unmounts a device, lazily so any running processes don't block it.
umountLazy :: FilePath -> IO ()
umountLazy mnt =
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
errorMessage $ "failed unmounting " ++ mnt
-- | Mounts a device.
mount :: FsType -> Source -> FilePath -> IO Bool
mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]

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

@ -16,7 +16,6 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Property.Reboot as Reboot
import Propellor.Property.Mount
import Propellor.Property.Chroot.Util (stdPATH)
import Utility.SafeCommand
import System.Posix.Files (rename, fileExist)
import Control.Exception (throw)

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

@ -4,7 +4,6 @@ import Propellor
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cron as Cron
import qualified Propellor.Property.Gpg as Gpg
import Utility.SafeCommand
import Data.List

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

@ -22,10 +22,11 @@ reloaded :: Property NoInfo
reloaded = Service.reloaded "postfix"
-- | Configures postfix as a satellite system, which
-- relays all mail through a relay host, which defaults to smtp.domain.
-- relays all mail through a relay host, which defaults to smtp.domain,
-- but can be changed by @mainCf "relayhost"@.
--
-- The smarthost may refuse to relay mail on to other domains, without
-- futher coniguration/keys. But this should be enough to get cron job
-- further configuration/keys. But this should be enough to get cron job
-- mail flowing to a place where it will be seen.
satellite :: Property NoInfo
satellite = check (not <$> mainCfIsSet "relayhost") setup
@ -34,14 +35,14 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup
setup = trivial $ property "postfix satellite system" $ do
hn <- asks hostName
let (_, domain) = separate (== '.') hn
ensureProperties
ensureProperties
[ Apt.reConfigure "postfix"
[ ("postfix/main_mailer_type", "select", "Satellite system")
, ("postfix/root_address", "string", "root")
, ("postfix/destinations", "string", "localhost")
, ("postfix/mailname", "string", hn)
]
, mainCf ("relayhost", domain)
, mainCf ("relayhost", "smtp." ++ domain)
`onChange` reloaded
]
@ -57,7 +58,7 @@ mappedFile f setup = setup f
`onChange` cmdProperty "postmap" [f]
-- | Run newaliases command, which should be done after changing
-- </etc/aliases>.
-- @/etc/aliases@.
newaliases :: Property NoInfo
newaliases = trivial $ cmdProperty "newaliases" []
@ -65,7 +66,7 @@ newaliases = trivial $ cmdProperty "newaliases" []
mainCfFile :: FilePath
mainCfFile = "/etc/postfix/main.cf"
-- | Sets a main.cf name=value pair. Does not reload postfix immediately.
-- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately.
mainCf :: (String, String) -> Property NoInfo
mainCf (name, value) = check notset set
`describe` ("postfix main.cf " ++ setting)
@ -74,7 +75,7 @@ mainCf (name, value) = check notset set
notset = (/= Just value) <$> getMainCf name
set = cmdProperty "postconf" ["-e", setting]
-- | Gets a man.cf setting.
-- | Gets a main.cf setting.
getMainCf :: String -> IO (Maybe String)
getMainCf name = parse . lines <$> readProcess "postconf" [name]
where
@ -130,9 +131,9 @@ dedupCf ls =
-- | Installs saslauthd and configures it for postfix, authenticating
-- against PAM.
--
-- Does not configure postfix to use it; eg smtpd_sasl_auth_enable = yes
-- Does not configure postfix to use it; eg @smtpd_sasl_auth_enable = yes@
-- needs to be set to enable use. See
-- https://wiki.debian.org/PostfixAndSASL
-- <https://wiki.debian.org/PostfixAndSASL>.
saslAuthdInstalled :: Property NoInfo
saslAuthdInstalled = setupdaemon
`requires` Service.running "saslauthd"

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

@ -1,7 +1,6 @@
module Propellor.Property.Reboot where
import Propellor
import Utility.SafeCommand
now :: Property NoInfo
now = cmdProperty "reboot" []

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

@ -1,7 +1,6 @@
module Propellor.Property.Service where
import Propellor
import Utility.SafeCommand
type ServiceName = String

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

@ -6,9 +6,9 @@ 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)
builduser :: UserName
@ -48,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
@ -69,7 +67,6 @@ tree buildarch = combineProperties "gitannexbuilder tree" $ props
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"
@ -84,6 +81,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
@ -92,46 +96,60 @@ 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 -> Docker.Image) -> Architecture -> Int -> TimeOut -> Docker.Container
standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder")
(dockerImage $ System (Debian Testing) arch)
& os (System (Debian Testing) arch)
& Apt.stdSourcesList
& Apt.installed ["systemd"]
& Apt.unattendedUpgrades
& User.accountFor (User builduser)
& tree arch
& buildDepsApt
& autobuilder arch (Cron.Times $ show buildminute ++ " * * * *") timeout
& Docker.tweaked
autoBuilderContainer :: (System -> Property HasInfo) -> System -> Times -> TimeOut -> Systemd.Container
autoBuilderContainer mkprop osver@(System _ arch) crontime timeout =
Systemd.container name bootstrap
& mkprop osver
& buildDepsApt
& autobuilder arch crontime timeout
where
name = arch ++ "-git-annex-builder"
bootstrap = Chroot.debootstrapped osver mempty
androidAutoBuilderContainer :: (System -> Docker.Image) -> Times -> TimeOut -> Docker.Container
androidAutoBuilderContainer dockerImage crontimes timeout =
androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir
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
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
androidAutoBuilderContainer crontimes timeout =
androidContainer "android-git-annex-builder" (tree "android") builddir
& Apt.unattendedUpgrades
& autobuilder "android" crontimes timeout
-- Android is cross-built in a Debian i386 container, using the Android NDK.
androidContainer
:: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i)))
=> (System -> Docker.Image)
-> Docker.ContainerName
=> Systemd.MachineName
-> Property i
-> FilePath
-> Docker.Container
androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name
(dockerImage osver)
-> Systemd.Container
androidContainer name setupgitannexdir gitannexdir = Systemd.container name bootstrap
& os osver
& Apt.stdSourcesList
& Apt.installed ["systemd"]
& Docker.tweaked
& User.accountFor (User builduser)
& File.dirExists gitbuilderdir
& File.ownerGroup homedir (User builduser) (Group builduser)
& buildDepsApt
& flagFile chrootsetup ("/chrootsetup")
`requires` setupgitannexdir
& 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
@ -139,54 +157,5 @@ androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.containe
chrootsetup = scriptProperty
[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
]
haskellpkgsinstalled = userScriptProperty (User builduser)
[ "cd " ++ gitannexdir ++ " && ./standalone/android/install-haskell-packages"
]
osver = System (Debian Testing) "i386"
-- 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"
osver = System (Debian (Stable "jessie")) "i386"
bootstrap = Chroot.debootstrapped osver mempty

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

@ -3,7 +3,6 @@ module Propellor.Property.SiteSpecific.GitHome where
import Propellor
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.User
import Utility.SafeCommand
-- | Clones Joey Hess's git home directory, and runs its fixups script.
installedFor :: User -> Property NoInfo

7
src/Propellor/Property/SiteSpecific/IABak.hs
View File

@ -35,7 +35,7 @@ gitServer knownhosts = propertyList "iabak git server" $ props
& Cron.niceJob "shardstats" (Cron.Times "*/30 * * * *") (User "root") "/"
"/usr/local/IA.BAK/shardstats-all"
& Cron.niceJob "shardmaint" Cron.Daily (User "root") "/"
"/usr/local/IA.BAK/shardmaint"
"/usr/local/IA.BAK/shardmaint-fast; /usr/local/IA.BAK/shardmaint"
registrationServer :: [Host] -> Property HasInfo
registrationServer knownhosts = propertyList "iabak registration server" $ props
@ -64,14 +64,13 @@ graphiteServer = propertyList "iabak graphite server" $ props
, "pattern = ^carbon\\."
, "retentions = 60:90d"
, "[iabak-connections]"
, "pattern = ^iabak\.shardstats\.connections"
, "pattern = ^iabak\\.shardstats\\.connections"
, "retentions = 1h:1y,3h:10y"
, "[iabak]"
, "[iabak-default]"
, "pattern = ^iabak\\."
, "retentions = 10m:30d,1h:1y,3h:10y"
, "[default_1min_for_1day]"
, "pattern = .*"
, "retentions = 60s:1d"
]
& graphiteCSRF
& cmdProperty "graphite-manage" ["syncdb", "--noinput"] `flagFile` "/etc/flagFiles/graphite-syncdb"

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

@ -15,7 +15,6 @@ import qualified Propellor.Property.User as User
import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Apache as Apache
import qualified Propellor.Property.Postfix as Postfix
import Utility.SafeCommand
import Utility.FileMode
import Data.List
@ -30,7 +29,6 @@ scrollBox = propertyList "scroll server" $ props
"libghc-bytestring-dev", "libghc-mtl-dev", "libghc-ncurses-dev",
"libghc-random-dev", "libghc-monad-loops-dev", "libghc-text-dev",
"libghc-ifelse-dev", "libghc-case-insensitive-dev",
"libghc-transformers-dev",
"libghc-data-default-dev", "libghc-optparse-applicative-dev"]
& userScriptProperty (User "scroll")
[ "cd " ++ d </> "scroll"
@ -389,7 +387,7 @@ twitRss = combineProperties "twitter rss" $ props
-- Work around for expired ssl cert.
pumpRss :: Property NoInfo
pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.kitenet.net/"
"wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"
"wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"
ircBouncer :: Property HasInfo
ircBouncer = propertyList "IRC bouncer" $ props
@ -407,7 +405,7 @@ ircBouncer = propertyList "IRC bouncer" $ props
kiteShellBox :: Property NoInfo
kiteShellBox = propertyList "kitenet.net shellinabox"
[ Apt.installed ["openssl", "shellinabox"]
[ Apt.installed ["openssl", "shellinabox", "openssh-client"]
, File.hasContent "/etc/default/shellinabox"
[ "# Deployed by propellor"
, "SHELLINABOX_DAEMON_START=1"
@ -861,6 +859,8 @@ legacyWebSites = propertyList "legacy web sites" $ props
, " AllowOverride None"
, Apache.allowAll
, "</Directory>"
, "RewriteEngine On"
, "RewriteRule .* http://www.sowsearpoetry.org/ [L]"
]
& alias "wortroot.kitenet.net"
& alias "www.wortroot.kitenet.net"

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

@ -1,7 +1,10 @@
module Propellor.Property.Ssh (
PubKeyText,
sshdConfig,
ConfigKeyword,
setSshdConfigBool,
setSshdConfig,
RootLogin(..),
permitRootLogin,
passwordAuthentication,
noPasswords,
@ -24,11 +27,11 @@ import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import Propellor.Property.User
import Utility.SafeCommand
import Utility.FileMode
import System.PosixCompat
import qualified Data.Map as M
import Data.List
type PubKeyText = String
@ -39,21 +42,37 @@ sshBool False = "no"
sshdConfig :: FilePath
sshdConfig = "/etc/ssh/sshd_config"
setSshdConfig :: String -> Bool -> Property NoInfo
setSshdConfig setting allowed = combineProperties "sshd config"
[ sshdConfig `File.lacksLine` (sshline $ not allowed)
, sshdConfig `File.containsLine` (sshline allowed)
]
`onChange` restarted
`describe` unwords [ "ssh config:", setting, sshBool allowed ]
where
sshline v = setting ++ " " ++ sshBool v
type ConfigKeyword = String
permitRootLogin :: Bool -> Property NoInfo
permitRootLogin = setSshdConfig "PermitRootLogin"
setSshdConfigBool :: ConfigKeyword -> Bool -> Property NoInfo
setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed)
setSshdConfig :: ConfigKeyword -> String -> Property NoInfo
setSshdConfig setting val = File.fileProperty desc f sshdConfig
`onChange` restarted
where
desc = unwords [ "ssh config:", setting, val ]
cfgline = setting ++ " " ++ val
wantedline s
| s == cfgline = True
| (setting ++ " ") `isPrefixOf` s = False
| otherwise = True
f ls
| cfgline `elem` ls = filter wantedline ls
| otherwise = filter wantedline ls ++ [cfgline]
data RootLogin
= RootLogin Bool -- ^ allow or prevent root login
| WithoutPassword -- ^ disable password authentication for root, while allowing other authentication methods
| ForcedCommandsOnly -- ^ allow root login with public-key authentication, but only if a forced command has been specified for the public key
permitRootLogin :: RootLogin -> Property NoInfo
permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b
permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password"
permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only"
passwordAuthentication :: Bool -> Property NoInfo
passwordAuthentication = setSshdConfig "PasswordAuthentication"
passwordAuthentication = setSshdConfigBool "PasswordAuthentication"
-- | Configure ssh to not allow password logins.
--

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

@ -1,31 +1,51 @@
{-# LANGUAGE FlexibleInstances #-}
module Propellor.Property.Systemd (
module Propellor.Property.Systemd.Core,
-- * Services
ServiceName,
MachineName,
started,
stopped,
enabled,
disabled,
masked,
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
import Propellor.Property.Systemd.Core
import Utility.SafeCommand
import Utility.FileMode
import Data.List
@ -45,6 +65,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")
@ -55,6 +78,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")
@ -64,11 +90,32 @@ disabled :: ServiceName -> Property NoInfo
disabled n = trivial $ cmdProperty "systemctl" ["disable", n]
`describe` ("service " ++ n ++ " disabled")
-- | Masks a systemd service.
masked :: ServiceName -> RevertableProperty
masked n = systemdMask <!> systemdUnmask
where
systemdMask = trivial $ cmdProperty "systemctl" ["mask", n]
`describe` ("service " ++ n ++ " masked")
systemdUnmask = trivial $ cmdProperty "systemctl" ["unmask", n]
`describe` ("service " ++ n ++ " unmasked")
-- | 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) $
@ -87,7 +134,8 @@ type Option = String
-- 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
-- currently the case for files like journald.conf and system.conf.
-- 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
@ -102,15 +150,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.
--
@ -123,6 +171,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
@ -153,8 +202,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.
@ -178,8 +226,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 = (==)
@ -216,15 +270,19 @@ enterScript c@(Container name _ _) = setup <!> teardown
where
setup = combineProperties ("generated " ++ enterScriptFile c)
[ scriptfile `File.hasContent`
[ "#!/bin/sh"
[ "#!/usr/bin/perl"
, "# Generated by propellor"
, "pid=\"$(machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2)\" || true"
, "if [ -n \"$pid\" ]; then"
, "\tnsenter -p -u -n -i -m -t \"$pid\" \"$@\""
, "else"
, "\techo container not running >&2"
, "\texit 1"
, "fi"
, "my $pid=`machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2`;"
, "chomp $pid;"
, "if (length $pid) {"
, "\tforeach my $var (keys %ENV) {"
, "\t\tdelete $ENV{$var} unless $var eq 'PATH' || $var eq 'TERM';"
, "\t}"
, "\texec('nsenter', '-p', '-u', '-n', '-i', '-m', '-t', $pid, @ARGV);"
, "} else {"
, "\tdie 'container not running';"
, "}"
, "exit(1);"
]
, scriptfile `File.mode` combineModes (readModes ++ executeModes)
]
@ -234,8 +292,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"
@ -267,3 +325,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

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

@ -103,13 +103,8 @@ bandwidthRate' s divby = case readSize dataUnits s of
Nothing -> property ("unable to parse " ++ s) noChange
hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo
hiddenServiceAvailable hn port = hiddenServiceHostName prop
hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port
where
prop = configured
[ ("HiddenServiceDir", varLib </> hn)
, ("HiddenServicePort", unwords [show port, "127.0.0.1:" ++ show port])
]
`describe` "hidden service available"
hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy
h <- liftIO $ readFile (varLib </> hn </> "hostname")
@ -164,7 +159,7 @@ type NickName = String
-- | Convert String to a valid tor NickName.
saneNickname :: String -> NickName
saneNickname s
saneNickname s
| null n = "unnamed"
| otherwise = n
where

6
src/Propellor/Shim.hs
View File

@ -8,7 +8,6 @@ module Propellor.Shim (setup, cleanEnv, file) where
import Propellor
import Utility.LinuxMkLibs
import Utility.SafeCommand
import Utility.FileMode
import Utility.FileSystemEncoding
@ -21,7 +20,7 @@ import System.Posix.Files
-- Propellor may be running from an existing shim, in which case it's
-- simply reused.
setup :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath
setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do
setup propellorbin propellorbinpath dest = checkAlreadyShimmed shim $ do
createDirectoryIfMissing True dest
libs <- parseLdd <$> readProcess "ldd" [propellorbin]
@ -40,7 +39,6 @@ setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do
fromMaybe (error "cannot find gconv directory") $
headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs
let linkerparams = ["--library-path", intercalate ":" libdirs ]
let shim = file propellorbin dest
writeFile shim $ unlines
[ shebang
, "GCONV_PATH=" ++ shellEscape gconvdir
@ -50,6 +48,8 @@ setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do
]
modifyFileMode shim (addModes executeModes)
return shim
where
shim = file propellorbin dest
shebang :: String
shebang = "#!/bin/sh"

31
src/Propellor/Spin.hs
View File

@ -14,8 +14,7 @@ import System.Posix.Directory
import Control.Concurrent.Async
import qualified Data.ByteString as B
import qualified Data.Set as S
import qualified Network.BSD as BSD
import Network.Socket (inet_ntoa)
import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr)
import Propellor
import Propellor.Protocol
@ -98,17 +97,21 @@ spin target relay hst = do
getSshTarget :: HostName -> Host -> IO String
getSshTarget target hst
| null configips = return target
| otherwise = go =<< tryIO (BSD.getHostByName target)
| otherwise = go =<< tryIO (dnslookup target)
where
go (Left e) = useip (show e)
go (Right hostentry) = ifM (anyM matchingconfig (BSD.hostAddresses hostentry))
( return target
, do
ips <- mapM inet_ntoa (BSD.hostAddresses hostentry)
useip ("DNS " ++ show ips ++ " vs configured " ++ show configips)
)
go (Right addrinfos) = do
configaddrinfos <- catMaybes <$> mapM iptoaddr configips
if any (`elem` configaddrinfos) (map addrAddress addrinfos)
then return target
else useip ("DNS lookup did not return any of the expected addresses " ++ show configips)
matchingconfig a = flip elem configips <$> inet_ntoa a
dnslookup h = getAddrInfo (Just $ defaultHints { addrFlags = [AI_CANONNAME] }) (Just h) Nothing
-- Convert a string containing an IP address into a SockAddr.
iptoaddr :: String -> IO (Maybe SockAddr)
iptoaddr ip = catchDefaultIO Nothing $ headMaybe . map addrAddress
<$> getAddrInfo (Just $ defaultHints { addrFlags = [AI_NUMERICHOST] }) (Just ip) Nothing
useip why = case headMaybe configips of
Nothing -> return target
@ -144,11 +147,15 @@ update forhost = do
hout <- dup stdOutput
hClose stdin
hClose stdout
-- Not using git pull because git 2.5.0 badly
-- broke its option parser.
unlessM (boolSystem "git" (pullparams hin hout)) $
errorMessage "git pull from client failed"
errorMessage "git fetch from client failed"
unlessM (boolSystem "git" [Param "merge", Param "FETCH_HEAD"]) $
errorMessage "git merge from client failed"
where
pullparams hin hout =
[ Param "pull"
[ Param "fetch"
, Param "--progress"
, Param "--upload-pack"
, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout

6
src/Propellor/Ssh.hs
View File

@ -1,7 +1,6 @@
module Propellor.Ssh where
import Propellor
import Utility.SafeCommand
import Utility.UserInfo
import System.PosixCompat
@ -23,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)
@ -38,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

1
src/Propellor/Types/CmdLine.hs
View File

@ -10,6 +10,7 @@ data CmdLine
| Spin [HostName] (Maybe HostName)
| SimpleRun HostName
| Set PrivDataField Context
| Unset PrivDataField Context
| Dump PrivDataField Context
| Edit PrivDataField Context
| ListFields

30
src/Propellor/Types/Container.hs Normal file
View File

@ -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

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

@ -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)

2
src/Utility/Data.hs
View File

@ -5,6 +5,8 @@
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Data where
{- First item in the list that is not Nothing. -}

2
src/Utility/Directory.hs
View File

@ -6,6 +6,7 @@
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory where
@ -18,6 +19,7 @@ import Control.Applicative
import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe
import Prelude
#ifdef mingw32_HOST_OS
import qualified System.Win32 as Win32

2
src/Utility/Env.hs
View File

@ -6,6 +6,7 @@
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Env where
@ -13,6 +14,7 @@ module Utility.Env where
import Utility.Exception
import Control.Applicative
import Data.Maybe
import Prelude
import qualified System.Environment as E
import qualified System.SetEnv
#else

1
src/Utility/Exception.hs
View File

@ -6,6 +6,7 @@
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Exception (
module X,

13
src/Utility/FileMode.hs
View File

@ -22,15 +22,12 @@ import Utility.Exception
{- Applies a conversion function to a file's mode. -}
modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode f convert = void $ modifyFileMode' f convert
modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' f convert = do
modifyFileMode f convert = do
s <- getFileStatus f
let old = fileMode s
let new = convert old
when (new /= old) $
setFileMode f new
return old
{- Adds the specified FileModes to the input mode, leaving the rest
- unchanged. -}
@ -41,14 +38,6 @@ addModes ms m = combineModes (m:ms)
removeModes :: [FileMode] -> FileMode -> FileMode
removeModes ms m = m `intersectFileModes` complement (combineModes ms)
{- Runs an action after changing a file's mode, then restores the old mode. -}
withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode file convert a = bracket setup cleanup go
where
setup = modifyFileMode' file convert
cleanup oldmode = modifyFileMode file (const oldmode)
go _ = a
writeModes :: [FileMode]
writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]

1
src/Utility/FileSystemEncoding.hs
View File

@ -6,6 +6,7 @@
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.FileSystemEncoding (
fileEncoding,

15
src/Utility/LinuxMkLibs.hs
View File

@ -7,7 +7,12 @@
module Utility.LinuxMkLibs where
import Control.Applicative
import Utility.PartialPrelude
import Utility.Directory
import Utility.Process
import Utility.Monad
import Utility.Path
import Data.Maybe
import System.Directory
import System.FilePath
@ -15,12 +20,8 @@ import Data.List.Utils
import System.Posix.Files
import Data.Char
import Control.Monad.IfElse
import Utility.PartialPrelude
import Utility.Directory
import Utility.Process
import Utility.Monad
import Utility.Path
import Control.Applicative
import Prelude
{- Installs a library. If the library is a symlink to another file,
- install the file it links to, and update the symlink to be relative. -}

10
src/Utility/Misc.hs
View File

@ -6,23 +6,25 @@
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Misc where
import Utility.FileSystemEncoding
import Utility.Monad
import System.IO
import Control.Monad
import Foreign
import Data.Char
import Data.List
import Control.Applicative
import System.Exit
#ifndef mingw32_HOST_OS
import System.Posix.Process (getAnyProcessStatus)
import Utility.Exception
#endif
import Utility.FileSystemEncoding
import Utility.Monad
import Control.Applicative
import Prelude
{- A version of hgetContents that is not lazy. Ensures file is
- all read before it gets closed. -}

2
src/Utility/Monad.hs
View File

@ -5,6 +5,8 @@
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Monad where
import Data.Maybe

2
src/Utility/PartialPrelude.hs
View File

@ -5,6 +5,8 @@
- them being accidentially used.
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.PartialPrelude where
import qualified Data.Maybe

2
src/Utility/Path.hs
View File

@ -6,6 +6,7 @@
-}
{-# LANGUAGE PackageImports, CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Path where
@ -16,6 +17,7 @@ import Data.List
import Data.Maybe
import Data.Char
import Control.Applicative
import Prelude
#ifdef mingw32_HOST_OS
import qualified System.FilePath.Posix as Posix

1
src/Utility/PosixFiles.hs
View File

@ -8,6 +8,7 @@
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.PosixFiles (
module X,

82
src/Utility/Process.hs
View File

@ -1,12 +1,13 @@
{- System.Process enhancements, including additional ways of running
- processes, and logging.
-
- Copyright 2012 Joey Hess <id@joeyh.name>
- Copyright 2012-2015 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP, Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Process (
module X,
@ -54,6 +55,7 @@ import qualified System.Posix.IO
import Control.Applicative
#endif
import Data.Maybe
import Prelude
import Utility.Misc
import Utility.Exception
@ -63,8 +65,8 @@ type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Hand
data StdHandle = StdinHandle | StdoutHandle | StderrHandle
deriving (Eq)
{- Normally, when reading from a process, it does not need to be fed any
- standard input. -}
-- | Normally, when reading from a process, it does not need to be fed any
-- standard input.
readProcess :: FilePath -> [String] -> IO String
readProcess cmd args = readProcessEnv cmd args Nothing
@ -82,9 +84,8 @@ readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
hClose h
return output
{- Runs an action to write to a process on its stdin,
- returns its output, and also allows specifying the environment.
-}
-- | Runs an action to write to a process on its stdin,
-- returns its output, and also allows specifying the environment.
writeReadProcessEnv
:: FilePath
-> [String]
@ -124,8 +125,8 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do
, env = environ
}
{- Waits for a ProcessHandle, and throws an IOError if the process
- did not exit successfully. -}
-- | Waits for a ProcessHandle, and throws an IOError if the process
-- did not exit successfully.
forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
forceSuccessProcess p pid = do
code <- waitForProcess pid
@ -133,10 +134,10 @@ forceSuccessProcess p pid = do
ExitSuccess -> return ()
ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
{- Waits for a ProcessHandle and returns True if it exited successfully.
- Note that using this with createProcessChecked will throw away
- the Bool, and is only useful to ignore the exit code of a process,
- while still waiting for it. -}
-- | Waits for a ProcessHandle and returns True if it exited successfully.
-- Note that using this with createProcessChecked will throw away
-- the Bool, and is only useful to ignore the exit code of a process,
-- while still waiting for it. -}
checkSuccessProcess :: ProcessHandle -> IO Bool
checkSuccessProcess pid = do
code <- waitForProcess pid
@ -147,13 +148,13 @@ ignoreFailureProcess pid = do
void $ waitForProcess pid
return True
{- Runs createProcess, then an action on its handles, and then
- forceSuccessProcess. -}
-- | Runs createProcess, then an action on its handles, and then
-- forceSuccessProcess.
createProcessSuccess :: CreateProcessRunner
createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
{- Runs createProcess, then an action on its handles, and then
- a checker action on its exit code, which must wait for the process. -}
-- | Runs createProcess, then an action on its handles, and then
-- a checker action on its exit code, which must wait for the process.
createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
createProcessChecked checker p a = do
t@(_, _, _, pid) <- createProcess p
@ -161,14 +162,14 @@ createProcessChecked checker p a = do
_ <- checker pid
either E.throw return r
{- Leaves the process running, suitable for lazy streaming.
- Note: Zombies will result, and must be waited on. -}
-- | Leaves the process running, suitable for lazy streaming.
-- Note: Zombies will result, and must be waited on.
createBackgroundProcess :: CreateProcessRunner
createBackgroundProcess p a = a =<< createProcess p
{- Runs a process, optionally feeding it some input, and
- returns a transcript combining its stdout and stderr, and
- whether it succeeded or failed. -}
-- | Runs a process, optionally feeding it some input, and
-- returns a transcript combining its stdout and stderr, and
-- whether it succeeded or failed.
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
processTranscript cmd opts input = processTranscript' cmd opts Nothing input
@ -232,9 +233,9 @@ processTranscript' cmd opts environ input = do
hClose inh
writeinput Nothing _ = return ()
{- Runs a CreateProcessRunner, on a CreateProcess structure, that
- is adjusted to pipe only from/to a single StdHandle, and passes
- the resulting Handle to an action. -}
-- | Runs a CreateProcessRunner, on a CreateProcess structure, that
-- is adjusted to pipe only from/to a single StdHandle, and passes
-- the resulting Handle to an action.
withHandle
:: StdHandle
-> CreateProcessRunner
@ -256,7 +257,7 @@ withHandle h creator p a = creator p' $ a . select
| h == StderrHandle =
(stderrHandle, base { std_err = CreatePipe })
{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
-- | Like withHandle, but passes (stdin, stdout) handles to the action.
withIOHandles
:: CreateProcessRunner
-> CreateProcess
@ -270,7 +271,7 @@ withIOHandles creator p a = creator p' $ a . ioHandles
, std_err = Inherit
}
{- Like withHandle, but passes (stdout, stderr) handles to the action. -}
-- | Like withHandle, but passes (stdout, stderr) handles to the action.
withOEHandles
:: CreateProcessRunner
-> CreateProcess
@ -284,8 +285,8 @@ withOEHandles creator p a = creator p' $ a . oeHandles
, std_err = CreatePipe
}
{- Forces the CreateProcessRunner to run quietly;
- both stdout and stderr are discarded. -}
-- | Forces the CreateProcessRunner to run quietly;
-- both stdout and stderr are discarded.
withQuietOutput
:: CreateProcessRunner
-> CreateProcess
@ -297,8 +298,8 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
}
creator p' $ const $ return ()
{- Stdout and stderr are discarded, while the process is fed stdin
- from the handle. -}
-- | Stdout and stderr are discarded, while the process is fed stdin
-- from the handle.
feedWithQuietOutput
:: CreateProcessRunner
-> CreateProcess
@ -319,11 +320,11 @@ devNull = "/dev/null"
devNull = "NUL"
#endif
{- Extract a desired handle from createProcess's tuple.
- These partial functions are safe as long as createProcess is run
- with appropriate parameters to set up the desired handle.
- Get it wrong and the runtime crash will always happen, so should be
- easily noticed. -}
-- | Extract a desired handle from createProcess's tuple.
-- These partial functions are safe as long as createProcess is run
-- with appropriate parameters to set up the desired handle.
-- Get it wrong and the runtime crash will always happen, so should be
-- easily noticed.
type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
stdinHandle :: HandleExtractor
stdinHandle (Just h, _, _, _) = h
@ -344,7 +345,7 @@ oeHandles _ = error "expected oeHandles"
processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
processHandle (_, _, _, pid) = pid
{- Debugging trace for a CreateProcess. -}
-- | Debugging trace for a CreateProcess.
debugProcess :: CreateProcess -> IO ()
debugProcess p = do
debugM "Utility.Process" $ unwords
@ -360,15 +361,15 @@ debugProcess p = do
piped Inherit = False
piped _ = True
{- Shows the command that a CreateProcess will run. -}
-- | Shows the command that a CreateProcess will run.
showCmd :: CreateProcess -> String
showCmd = go . cmdspec
where
go (ShellCommand s) = s
go (RawCommand c ps) = c ++ " " ++ show ps
{- Starts an interactive process. Unlike runInteractiveProcess in
- System.Process, stderr is inherited. -}
-- | Starts an interactive process. Unlike runInteractiveProcess in
-- System.Process, stderr is inherited.
startInteractiveProcess
:: FilePath
-> [String]
@ -384,7 +385,8 @@ startInteractiveProcess cmd args environ = do
(Just from, Just to, _, pid) <- createProcess p
return (pid, to, from)
{- Wrapper around System.Process function that does debug logging. -}
-- | Wrapper around 'System.Process.createProcess' from System.Process,
-- that does debug logging.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess p = do
debugProcess p

1
src/Utility/QuickCheck.hs
View File

@ -19,6 +19,7 @@ import System.Posix.Types
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Applicative
import Prelude
instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
arbitrary = M.fromList <$> arbitrary

64
src/Utility/SafeCommand.hs
View File

@ -5,44 +5,45 @@
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.SafeCommand where
import System.Exit
import Utility.Process
import Data.String.Utils
import Control.Applicative
import System.FilePath
import Data.Char
import Control.Applicative
import Prelude
{- A type for parameters passed to a shell command. A command can
- be passed either some Params (multiple parameters can be included,
- whitespace-separated, or a single Param (for when parameters contain
- whitespace), or a File.
-}
data CommandParam = Params String | Param String | File FilePath
-- | Parameters that can be passed to a shell command.
data CommandParam
= 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. -}
-- | 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:"./"
{- Run a system command, and returns True or False
- if it succeeded or failed.
-}
-- | Run a system command, and returns True or False if it succeeded or failed.
--
-- This and other command running functions in this module log the commands
-- run at debug level, using System.Log.Logger.
boolSystem :: FilePath -> [CommandParam] -> IO Bool
boolSystem command params = boolSystem' command params id
@ -56,7 +57,7 @@ boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bo
boolSystemEnv command params environ = boolSystem' command params $
\p -> p { env = environ }
{- Runs a system command, returning the exit status. -}
-- | Runs a system command, returning the exit status.
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
safeSystem command params = safeSystem' command params id
@ -71,23 +72,22 @@ safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Ex
safeSystemEnv command params environ = safeSystem' command params $
\p -> p { env = environ }
{- Wraps a shell command line inside sh -c, allowing it to be run in a
- login shell that may not support POSIX shell, eg csh. -}
-- | Wraps a shell command line inside sh -c, allowing it to be run in a
-- login shell that may not support POSIX shell, eg csh.
shellWrap :: String -> String
shellWrap cmdline = "sh -c " ++ shellEscape cmdline
{- Escapes a filename or other parameter to be safely able to be exposed to
- the shell.
-
- This method works for POSIX shells, as well as other shells like csh.
-}
-- | Escapes a filename or other parameter to be safely able to be exposed to
-- the shell.
--
-- This method works for POSIX shells, as well as other shells like csh.
shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
where
-- replace ' with '"'"'
escaped = join "'\"'\"'" $ split "'" f
{- Unescapes a set of shellEscaped words or filenames. -}
-- | Unescapes a set of shellEscaped words or filenames.
shellUnEscape :: String -> [String]
shellUnEscape [] = []
shellUnEscape s = word : shellUnEscape rest
@ -104,19 +104,19 @@ shellUnEscape s = word : shellUnEscape rest
| c == q = findword w cs
| otherwise = inquote q (w++[c]) cs
{- For quickcheck. -}
-- | For quickcheck.
prop_idempotent_shellEscape :: String -> Bool
prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
prop_idempotent_shellEscape_multiword :: [String] -> Bool
prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
{- Segments a list of filenames into groups that are all below the maximum
- command-line length limit. -}
-- | Segments a list of filenames into groups that are all below the maximum
-- command-line length limit.
segmentXargsOrdered :: [FilePath] -> [[FilePath]]
segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered
{- Not preserving data is a little faster, and streams better when
- there are a great many filesnames. -}
-- | Not preserving order is a little faster, and streams better when
-- there are a great many filenames.
segmentXargsUnordered :: [FilePath] -> [[FilePath]]
segmentXargsUnordered l = go l [] 0 []
where

3
src/Utility/Scheduled.hs
View File

@ -32,7 +32,6 @@ import Utility.QuickCheck
import Utility.PartialPrelude
import Utility.Misc
import Control.Applicative
import Data.List
import Data.Time.Clock
import Data.Time.LocalTime
@ -41,6 +40,8 @@ import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.OrdinalDate
import Data.Tuple.Utils
import Data.Char
import Control.Applicative
import Prelude
{- Some sort of scheduled event. -}
data Schedule = Schedule Recurrance ScheduledTime

1
src/Utility/Tmp.hs
View File

@ -6,6 +6,7 @@
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Tmp where

6
src/Utility/UserInfo.hs
View File

@ -6,6 +6,7 @@
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.UserInfo (
myHomeDir,
@ -13,12 +14,13 @@ module Utility.UserInfo (
myUserGecos,
) where
import Utility.Env
import System.PosixCompat
#ifndef mingw32_HOST_OS
import Control.Applicative
#endif
import Utility.Env
import Prelude
{- Current user's home directory.
-