diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,34 @@ +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 Tue, 09 Jun 2015 17:08:43 -0400 + propellor (2.4.0) unstable; urgency=medium * Propellor no longer supports Debian wheezy (oldstable). diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -25,12 +25,14 @@ 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 import qualified Propellor.Property.SiteSpecific.GitHome as GitHome import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder import qualified Propellor.Property.SiteSpecific.IABak as IABak +import qualified Propellor.Property.SiteSpecific.Branchable as Branchable import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites @@ -44,9 +46,11 @@ , gnu , clam , orca + , honeybee , kite , elephant , beaver + , pell , iabak ] ++ monsters @@ -72,8 +76,6 @@ & 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 @@ -81,7 +83,6 @@ gnu :: Host gnu = host "gnu.kitenet.net" & Apt.buildDep ["git-annex"] `period` Daily - & Docker.configured & JoeySites.postfixClientRelay (Context "gnu.kitenet.net") & JoeySites.dkimMilter @@ -95,18 +96,18 @@ & 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" @@ -127,16 +128,47 @@ & 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 -- with propellor. @@ -220,9 +252,6 @@ , "zsh" ] - & Docker.configured - & Docker.garbageCollected `period` Daily - & alias "nntp.olduse.net" & JoeySites.oldUseNetServer hosts @@ -279,13 +308,14 @@ & 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" @@ -293,7 +323,7 @@ -- 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. @@ -311,6 +341,31 @@ & Cron.niceJob "system disk backed up" Cron.Weekly (User "root") "/" "rsync -a -x / /home/joey/lib/backup/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" + + -- All the websites I host at branchable that don't use + -- branchable.com dns. + & alias "olduse.net" + & alias "www.olduse.net" + & alias "www.kitenet.net" + & alias "joeyh.name" + & alias "campaign.joeyh.name" + & alias "ikiwiki.info" + & alias "git.ikiwiki.info" + & alias "l10n.ikiwiki.info" + & alias "dist-bugs.kitenet.net" + & alias "family.kitenet.net" + + & Apt.installed ["linux-image-amd64"] + & Linode.chainPVGrub 5 + & Apt.unattendedUpgrades + & Branchable.server hosts + iabak :: Host iabak = host "iabak.archiveteam.org" & ipv4 "124.6.40.227" @@ -338,28 +393,28 @@ & IABak.gitServer monsters & IABak.registrationServer monsters & IABak.graphiteServer + & IABak.publicFace where admins = map User ["joey", "db48x"] --' __|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"] @@ -367,39 +422,30 @@ -- 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 + +kiteShellBox :: Systemd.Container kiteShellBox = standardStableContainer "kiteshellbox" & JoeySites.kiteShellBox - & Docker.publish "443:443" type Motd = [String] @@ -430,16 +476,29 @@ & 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 + & Apt.cacheCleaned & Docker.tweaked where system = System (Debian suite) arch @@ -491,19 +550,6 @@ & ipv6 "2001:4978:f:2d9::2" , host "mouse.kitenet.net" & ipv6 "2001:4830:1600:492::2" - , host "branchable.com" - & ipv4 "66.228.46.55" - & ipv6 "2600:3c03::f03c:91ff:fedf:c0e5" - & alias "olduse.net" - & alias "www.olduse.net" - & alias "www.kitenet.net" - & alias "joeyh.name" - & alias "campaign.joeyh.name" - & alias "ikiwiki.info" - & alias "git.ikiwiki.info" - & alias "l10n.ikiwiki.info" - & alias "dist-bugs.kitenet.net" - & alias "family.kitenet.net" , host "animx" & ipv4 "76.7.162.101" & ipv4 "76.7.162.186" diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,34 @@ +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 Tue, 09 Jun 2015 17:08:43 -0400 + propellor (2.4.0) unstable; urgency=medium * Propellor no longer supports Debian wheezy (oldstable). diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 2.4.0 +Version: 2.5.0 Cabal-Version: >= 1.6 License: BSD3 Maintainer: Joey Hess @@ -33,7 +33,7 @@ Executable propellor Main-Is: wrapper.hs - GHC-Options: -Wall -threaded -O0 + GHC-Options: -threaded -O0 -Wall -fno-warn-tabs Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, @@ -45,7 +45,7 @@ Executable propellor-config Main-Is: config.hs - GHC-Options: -Wall -threaded -O0 + GHC-Options: -threaded -O0 -Wall -fno-warn-tabs Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, @@ -56,7 +56,7 @@ Build-Depends: unix Library - GHC-Options: -Wall -O0 + GHC-Options: -O0 -Wall -fno-warn-tabs Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, @@ -110,6 +110,8 @@ Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.GitAnnexBuilder + Propellor.Property.SiteSpecific.Branchable + Propellor.Property.SiteSpecific.IABak Propellor.PropAccum Propellor.CmdLine Propellor.Info @@ -119,6 +121,7 @@ Propellor.Exception Propellor.Types Propellor.Types.Chroot + Propellor.Types.Container Propellor.Types.Docker Propellor.Types.Dns Propellor.Types.Empty diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -6,7 +6,6 @@ ) where import Propellor -import Utility.SafeCommand import System.Posix.Files import Data.List diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -7,7 +7,7 @@ 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 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 @@ -166,9 +165,15 @@ , 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" diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs --- a/src/Propellor/Git.hs +++ b/src/Propellor/Git.hs @@ -3,7 +3,6 @@ import Propellor import Propellor.PrivData.Paths import Propellor.Gpg -import Utility.SafeCommand import Utility.FileMode getCurrentBranch :: IO String diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -4,7 +4,6 @@ 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] diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -109,7 +109,7 @@ f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" runApt :: [String] -> Property NoInfo -runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv +runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv noninteractiveEnv :: [(String, String)] noninteractiveEnv = @@ -170,7 +170,7 @@ buildDepIn :: FilePath -> Property NoInfo buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] where - go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"] + go = cmdPropertyEnv "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"] noninteractiveEnv -- | Package installation may fail becuse the archive has changed. @@ -251,7 +251,7 @@ forM_ vals $ \(tmpl, tmpltype, value) -> hPutStrLn h $ unwords [package, tmpl, tmpltype, value] hClose h - reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv + reconfigure = cmdPropertyEnv "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv -- | Ensures that a service is installed and running. -- diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -19,7 +19,7 @@ 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 @@ -- | 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 @@ 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 @@ 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 @@ , 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 @@ putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" -inChrootProcess :: Chroot -> [String] -> CreateProcess -inChrootProcess (Chroot loc _ _ _) cmd = proc "chroot" (loc:cmd) +inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) +inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do + mountproc + return (proc "chroot" (loc:cmd), cleanup) + where + -- /proc needs to be mounted in the chroot for the linker to use + -- /proc/self/exe which is necessary for some commands to work + mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $ + void $ mount "proc" "proc" procloc + + procloc = loc "proc" + + cleanup + | keepprocmounted = noop + | otherwise = whenM (elem procloc <$> mountPointsBelow loc) $ + umountLazy procloc provisioningLock :: FilePath -> FilePath provisioningLock containerloc = "chroot" mungeloc containerloc ++ ".lock" diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -1,10 +1,21 @@ {-# 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 @@ -15,31 +26,42 @@ import Propellor.Property import Utility.SafeCommand import Utility.Env +import Utility.Process (createProcess, CreateProcess) -- | A property that can be satisfied by running a command. -- -- The command must exit 0 on success. cmdProperty :: String -> [String] -> Property NoInfo -cmdProperty cmd params = cmdProperty' cmd params [] +cmdProperty cmd params = cmdProperty' cmd params id +cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> Property NoInfo +cmdProperty' cmd params mkprocess = property desc $ liftIO $ do + toResult <$> boolSystem' cmd (map Param params) mkprocess + where + desc = unwords $ cmd : params + -- | A property that can be satisfied by running a command, --- with added environment. -cmdProperty' :: String -> [String] -> [(String, String)] -> Property NoInfo -cmdProperty' cmd params env = property desc $ liftIO $ do +-- with added environment variables in addition to the standard +-- environment. +cmdPropertyEnv :: String -> [String] -> [(String, String)] -> Property NoInfo +cmdPropertyEnv cmd params env = property desc $ liftIO $ do env' <- addEntries env <$> getEnvironment toResult <$> boolSystemEnv cmd (map Param params) (Just env') 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) diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -4,7 +4,6 @@ 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 diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -15,7 +15,6 @@ 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 @@ 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 diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} -- | Docker support for propellor -- @@ -11,24 +11,30 @@ configured, container, docked, + imageBuilt, + imagePulled, memoryLimited, garbageCollected, tweaked, Image, ContainerName, Container, + HasImage(..), -- * Container configuration dns, hostname, + Publishable, publish, expose, user, + Mountable, volume, volumes_from, workdir, memory, cpuShares, link, + environment, ContainerAlias, restartAlways, restartOnFailure, @@ -40,11 +46,12 @@ 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 @@ -78,6 +85,15 @@ -- | A docker container. data Container = Container Image Host +class HasImage a where + getImageName :: a -> Image + +instance HasImage Image where + getImageName = id + +instance HasImage Container where + getImageName (Container i _) = i + instance PropAccum Container where (Container i h) & p = Container i (h & p) (Container i h) &^ p = Container i (h &^ p) @@ -135,6 +151,23 @@ ] ] +-- | Build the image from a directory containing a Dockerfile. +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 + workDir p = p { cwd = Just directory } + image = getImageName ctr + +-- | Pull the image from the standard Docker Hub registry. +imagePulled :: HasImage c => c -> Property NoInfo +imagePulled ctr = describe pulled msg + where + msg = "docker image " ++ image ++ " pulled" + pulled = Cmd.cmdProperty dockercmd ["pull", image] + image = getImageName ctr + propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p' where @@ -225,10 +258,19 @@ 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 @@ -238,12 +280,22 @@ 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. volumes_from :: ContainerName -> Property HasInfo @@ -297,6 +349,11 @@ 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 @@ -396,16 +453,14 @@ 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. diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -9,7 +9,6 @@ Target(..), Proto(..), Rules(..), - Port, ConnectionState(..) ) where @@ -18,7 +17,6 @@ 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 @@ 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 @@ { ruleChain :: Chain , ruleTarget :: Target , ruleRules :: Rules - } deriving (Eq, Show, Read) + } deriving (Eq, Show) data Chain = INPUT | OUTPUT | FORWARD - deriving (Eq,Show,Read) + deriving (Eq, Show) data Target = ACCEPT | REJECT | DROP | LOG - deriving (Eq,Show,Read) + deriving (Eq, Show) data Proto = TCP | UDP | ICMP - deriving (Eq,Show,Read) - -type Port = Int + deriving (Eq, Show) data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID - deriving (Eq,Show,Read) + deriving (Eq, Show) data Rules = Everything | Proto Proto -- ^There is actually some order dependency between proto and port so this should be a specific -- data type with proto + ports - | Port Port - | PortRange (Port,Port) + | DPort Port + | DPortRange (Port,Port) | IFace Network.Interface | Ctstate [ ConnectionState ] | Rules :- Rules -- ^Combine two rules - deriving (Eq,Show,Read) + deriving (Eq, Show) infixl 0 :- diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -4,7 +4,6 @@ import Propellor.Property.File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service -import Utility.SafeCommand import Data.List diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs --- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs +++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -9,7 +9,7 @@ import Data.List --- Digital Ocean does not provide any way to boot +-- | Digital Ocean does not provide any way to boot -- the kernel provided by the distribution, except using kexec. -- Without this, some old, and perhaps insecure kernel will be used. -- @@ -40,7 +40,7 @@ findVersion kernelver <$> readProcess "file" ("-L" : kernelimages) --- File output looks something like this, we want to unambiguously +-- | File output looks something like this, we want to unambiguously -- match the running kernel version: -- Linux kernel x86 boot executable bzImage, version 3.16-3-amd64 (debian-kernel@lists.debian.org) #1 SMP Debian 3.1, RO-rootFS, swap_dev 0x2, Normal VGA findVersion :: String -> String -> Bool diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs --- a/src/Propellor/Property/HostingProvider/Linode.hs +++ b/src/Propellor/Property/HostingProvider/Linode.hs @@ -6,7 +6,7 @@ import Utility.FileMode -- | Linode's pv-grub-x86_64 does not currently support booting recent --- Debian kernels compressed with xz. This sets up pv-grub chaing to enable +-- Debian kernels compressed with xz. This sets up pv-grub chaining to enable -- it. chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda" diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -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] diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -16,7 +16,6 @@ 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) diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -4,7 +4,6 @@ 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 diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -22,7 +22,8 @@ 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 @@ -34,14 +35,14 @@ 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 ] diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs --- a/src/Propellor/Property/Reboot.hs +++ b/src/Propellor/Property/Reboot.hs @@ -1,7 +1,6 @@ module Propellor.Property.Reboot where import Propellor -import Utility.SafeCommand now :: Property NoInfo now = cmdProperty "reboot" [] diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs --- a/src/Propellor/Property/Service.hs +++ b/src/Propellor/Property/Service.hs @@ -1,7 +1,6 @@ module Propellor.Property.Service where import Propellor -import Utility.SafeCommand type ServiceName = String diff --git a/src/Propellor/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/Branchable.hs @@ -0,0 +1,66 @@ +module Propellor.Property.SiteSpecific.Branchable where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Postfix as Postfix +import qualified Propellor.Property.Gpg as Gpg +import qualified Propellor.Property.Sudo as Sudo + +server :: [Host] -> Property HasInfo +server hosts = propertyList "branchable server" $ props + & "/etc/timezone" `File.hasContent` ["Etc/UTC"] + & "/etc/locale.gen" `File.containsLines` + [ "en_GB.UTF-8 UTF-8" + , "en_US.UTF-8 UTF-8" + , "fi_FI.UTF-8 UTF-8" + ] + `onChange` cmdProperty "locale-gen" [] + + & Apt.installed ["etckeeper", "ssh", "popularity-contest"] + & Apt.serviceInstalledRunning "apache2" + & Apt.serviceInstalledRunning "ntp" + + & Apt.serviceInstalledRunning "openssh-server" + & Ssh.passwordAuthentication False + & Ssh.hostKeys (Context "branchable.com") + [ (SshDsa, "ssh-dss AAAAB3NzaC1kc3MAAACBAK9HnfpyIm8aEhKuF5oz6KyaLwFs2oWeToVkqVuykyy5Y8jWDZPtkpv+1TeOnjcOvJSZ1cCqB8iXlsP9Dr5z98w5MfzsRQM2wIw0n+wvmpPmUhjVdGh+wTpfP9bcyFHhj/f1Ymdq9hEWB26bnf4pbTbJW2ip8ULshMvn5CQ/ugV3AAAAFQCAjpRd1fquRiIuLJMwej0VcyoZKQAAAIBe91Grvz/icL3nlqXYrifXyr9dsw8bPN+BMu+hQtFsQXNJBylxwf8FtbRlmvZXmRjdVYqFVyxSsrL2pMsWlds51iXOr9pdsPG5a4OgJyRHsveBz3tz6HgYYPcr3Oxp7C6G6wrzwsaGK862SgRp/bbD226k9dODRBy3ogMhk/MvAgAAAIEApfknql3vZbDVa88ZnwbNKDOv8L1hb6blbKAMt2vJbqJMvu3EP9CsP9hGyEQh5YCAl2F9KEU3bJXN1BG76b7CiYtWK95lpL1XmCCWnJBCcdEhw998GfJS424frPw7qGmXLxJKYxEyioB90/IDp2dC+WaLcLOYHM9SroCQTIK5A1g= root@pell") + , (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEA1M0aNLgcgcgf0tkmt/8vCDZLok8Xixz7Nun9wB6NqVXxfzAR4te+zyO7FucVwyTY5QHmiwwpmyNfaC21AAILhXGm12SUKSAirF9BkQk7bhQuz4T/dPlEt3d3SxQ3OZlXtPp4LzXWOyS0OXSzIb+HeaDA+hFXlQnp/gE7RyAzR1+xhWPO7Mz1q5O/+4dXANnW32t6P7Puob6NsglVDpLrMRYjkO+0RgCVbYMzB5+UnkthkZsIINaYwsNhW2GKMKbRZeyp5en5t1NJprGXdw0BqdBqd/rcBpOxmhHE1U7rw+GS1uZwCFWWv0aZbaXEJ6wY7mETFkqs0QXi5jtoKn95Gw== root@pell") + ] + + & Apt.installed ["procmail", "bsd-mailx"] + & "/etc/aliases" `File.hasPrivContentExposed` (Context "branchable.com") + `onChange` Postfix.newaliases + & "/etc/mailname" `File.hasContent` ["branchable.com"] + & Postfix.installed + & Postfix.mainCf ("mailbox_command", "procmail -a \"$EXTENSION\"") + + -- Obnam is run by a cron job in ikiwiki-hosting. + & "/etc/obnam.conf" `File.hasContent` + [ "[config]" + , "repository = sftp://joey@eubackup.kitenet.net/home/joey/lib/backup/pell.obnam" + , "log = /var/log/obnam.log" + , "encrypt-with = " ++ obnamkey + , "log-level = info" + , "log-max = 1048576" + , "keep = 7d,5w,12m" + , "upload-queue-size = 128" + , "lru-size = 128" + ] + & Gpg.keyImported (Gpg.GpgKeyId obnamkey) (User "root") + & Ssh.keyImported SshRsa (User "root") (Context "branchable.com") + & Ssh.knownHost hosts "eubackup.kitenet.net" (User "root") + & Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + + & adminuser "joey" + & adminuser "liw" + where + obnamkey = "41E1A9B9" + adminuser u = propertyList ("admin user " ++ u) $ props + & User.accountFor (User u) + & User.hasSomePassword (User u) + & Sudo.enabledFor (User u) + & User.hasGroup (User u) (Group "adm") + & User.hasGroup (User u) (Group "systemd-journal") diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -6,9 +6,9 @@ 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 @@ 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 @@ -84,6 +82,13 @@ "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 +97,61 @@ 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") + & buildDepsApt + & 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 +159,5 @@ 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" + bootstrap = Chroot.debootstrapped osver mempty diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs --- a/src/Propellor/Property/SiteSpecific/GitHome.hs +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -3,7 +3,6 @@ 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 diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/IABak.hs @@ -0,0 +1,104 @@ +module Propellor.Property.SiteSpecific.IABak where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Git as Git +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apache as Apache +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Ssh as Ssh + +repo :: String +repo = "https://github.com/ArchiveTeam/IA.BAK/" + +userrepo :: String +userrepo = "git@gitlab.com:archiveteam/IA.bak.users.git" + +publicFace :: Property HasInfo +publicFace = propertyList "iabak public face" $ props + & Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server") + & Apt.serviceInstalledRunning "apache2" + & Cron.niceJob "graph-gen" (Cron.Times "*/10 * * * *") (User "root") "/" + "/usr/local/IA.BAK/web/graph-gen.sh" + +gitServer :: [Host] -> Property HasInfo +gitServer knownhosts = propertyList "iabak git server" $ props + & Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server") + & Git.cloned (User "root") repo "/usr/local/IA.BAK/client" (Just "master") + & Ssh.keyImported SshRsa (User "root") (Context "IA.bak.users.git") + & Ssh.knownHost knownhosts "gitlab.com" (User "root") + & Git.cloned (User "root") userrepo "/usr/local/IA.BAK/pubkeys" (Just "master") + & Apt.serviceInstalledRunning "apache2" + & cmdProperty "ln" ["-sf", "/usr/local/IA.BAK/pushme.cgi", "/usr/lib/cgi-bin/pushme.cgi"] + & File.containsLine "/etc/sudoers" "www-data ALL=NOPASSWD:/usr/local/IA.BAK/pushed.sh" + & 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-fast; /usr/local/IA.BAK/shardmaint" + +registrationServer :: [Host] -> Property HasInfo +registrationServer knownhosts = propertyList "iabak registration server" $ props + & User.accountFor (User "registrar") + & Ssh.keyImported SshRsa (User "registrar") (Context "IA.bak.users.git") + & Ssh.knownHost knownhosts "gitlab.com" (User "registrar") + & Git.cloned (User "registrar") repo "/home/registrar/IA.BAK" (Just "server") + & Git.cloned (User "registrar") userrepo "/home/registrar/users" (Just "master") + & Apt.serviceInstalledRunning "apache2" + & Apt.installed ["perl", "perl-modules"] + & cmdProperty "ln" ["-sf", "/home/registrar/IA.BAK/registrar/register.cgi", link] + & cmdProperty "chown" ["-h", "registrar:registrar", link] + & File.containsLine "/etc/sudoers" "www-data ALL=(registrar) NOPASSWD:/home/registrar/IA.BAK/registrar/register.pl" + & Apt.installed ["kgb-client"] + & File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext + `requires` File.dirExists "/etc/kgb-bot/" + where + link = "/usr/lib/cgi-bin/register.cgi" + +graphiteServer :: Property HasInfo +graphiteServer = propertyList "iabak graphite server" $ props + & Apt.serviceInstalledRunning "apache2" + & Apt.installed ["libapache2-mod-wsgi", "graphite-carbon", "graphite-web"] + & File.hasContent "/etc/carbon/storage-schemas.conf" + [ "[carbon]" + , "pattern = ^carbon\\." + , "retentions = 60:90d" + , "[iabak-connections]" + , "pattern = ^iabak\\.shardstats\\.connections" + , "retentions = 1h:1y,3h:10y" + , "[iabak-default]" + , "pattern = ^iabak\\." + , "retentions = 10m:30d,1h:1y,3h:10y" + , "[default_1min_for_1day]" + , "pattern = .*" + ] + & graphiteCSRF + & cmdProperty "graphite-manage" ["syncdb", "--noinput"] `flagFile` "/etc/flagFiles/graphite-syncdb" + & cmdProperty "graphite-manage" ["createsuperuser", "--noinput", "--username=joey", "--email=joey@localhost"] `flagFile` "/etc/flagFiles/graphite-user-joey" + `flagFile` "/etc/graphite-superuser-joey" + & cmdProperty "graphite-manage" ["createsuperuser", "--noinput", "--username=db48x", "--email=db48x@localhost"] `flagFile` "/etc/flagFiles/graphite-user-db48x" + `flagFile` "/etc/graphite-superuser-db48x" + -- TODO: deal with passwords somehow + & File.ownerGroup "/var/lib/graphite/graphite.db" (User "_graphite") (Group "_graphite") + & "/etc/apache2/ports.conf" `File.containsLine` "Listen 8080" + `onChange` Apache.restarted + & Apache.siteEnabled "iabak-graphite-web" + [ "" + , " WSGIDaemonProcess _graphite processes=5 threads=5 display-name='%{GROUP}' inactivity-timeout=120 user=_graphite group=_graphite" + , " WSGIProcessGroup _graphite" + , " WSGIImportScript /usr/share/graphite-web/graphite.wsgi process-group=_graphite application-group=%{GLOBAL}" + , " WSGIScriptAlias / /usr/share/graphite-web/graphite.wsgi" + , " Alias /content/ /usr/share/graphite-web/static/" + , " " + , " SetHandler None" + , " " + , " ErrorLog ${APACHE_LOG_DIR}/graphite-web_error.log" + , " LogLevel warn" + , " CustomLog ${APACHE_LOG_DIR}/graphite-web_access.log combined" + , "" + ] + where + graphiteCSRF = withPrivData (Password "csrf-token") (Context "iabak.archiveteam.org") $ + \gettoken -> property "graphite-web CSRF token" $ + gettoken $ \token -> ensureProperty $ File.containsLine + "/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ token ++"'") diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -15,7 +15,6 @@ 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 @@ "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" @@ -470,7 +468,7 @@ `requires` Ssh.knownHost hosts srchost (User "joey") where desc = "backups copied from " ++ srchost ++ " on boot" - cmd = "rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir srchost + cmd = "sleep 30m && rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir srchost obnamRepos :: [String] -> Property NoInfo obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -24,7 +24,6 @@ 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 diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -1,31 +1,50 @@ +{-# LANGUAGE FlexibleInstances #-} + module Propellor.Property.Systemd ( - module Propellor.Property.Systemd.Core, + -- * Services ServiceName, - MachineName, started, stopped, enabled, disabled, + running, restarted, - persistentJournal, + networkd, + journald, + -- * Configuration + installed, Option, configured, - journaldConfigured, daemonReloaded, + -- * Journal + persistentJournal, + journaldConfigured, + -- * Containers + MachineName, Container, container, nspawned, + -- * Container configuration containerCfg, resolvConfed, + linkJournal, + privateNetwork, + module Propellor.Types.Container, + Proto(..), + Publishable, + publish, + Bindable, + bind, + bindRo, ) where import Propellor import Propellor.Types.Chroot +import Propellor.Types.Container import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File import Propellor.Property.Systemd.Core -import Utility.SafeCommand import Utility.FileMode import Data.List @@ -45,6 +64,9 @@ 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 +77,9 @@ `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 +89,23 @@ disabled n = trivial $ cmdProperty "systemctl" ["disable", n] `describe` ("service " ++ n ++ " disabled") +-- | Ensures that a service is both enabled and started +running :: ServiceName -> Property NoInfo +running n = trivial $ started n `requires` enabled n + -- | Restarts a systemd service. restarted :: ServiceName -> Property NoInfo restarted n = trivial $ cmdProperty "systemctl" ["restart", n] `describe` ("service " ++ n ++ " restarted") +-- | The systemd-networkd service. +networkd :: ServiceName +networkd = "systemd-networkd" + +-- | The systemd-journald service. +journald :: ServiceName +journald = "systemd-journald" + -- | Enables persistent storage of the journal. persistentJournal :: Property NoInfo persistentJournal = check (not <$> doesDirectoryExist dir) $ @@ -102,15 +139,15 @@ | 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 +160,7 @@ 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 +191,7 @@ -- 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 +215,14 @@ 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 +259,19 @@ 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 +281,8 @@ 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 +314,68 @@ -- This property is enabled by default. Revert it to disable it. resolvConfed :: RevertableProperty resolvConfed = containerCfg "bind=/etc/resolv.conf" + +-- | Link the container's journal to the host's if possible. +-- (Only works if the host has persistent journal enabled.) +-- +-- This property is enabled by default. Revert it to disable it. +linkJournal :: RevertableProperty +linkJournal = containerCfg "link-journal=try-guest" + +-- | Disconnect networking of the container from the host. +privateNetwork :: RevertableProperty +privateNetwork = containerCfg "private-network" + +class Publishable a where + toPublish :: a -> String + +instance Publishable Port where + toPublish (Port n) = show n + +instance Publishable (Bound Port) where + toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v) + +data Proto = TCP | UDP + +instance Publishable (Proto, Bound Port) where + toPublish (TCP, fp) = "tcp:" ++ toPublish fp + toPublish (UDP, fp) = "udp:" ++ toPublish fp + +-- | Publish a port from the container to the host. +-- +-- This feature was first added in systemd version 220. +-- +-- This property is only needed (and will only work) if the container +-- is configured to use private networking. Also, networkd should be enabled +-- both inside the container, and on the host. For example: +-- +-- > foo :: Host +-- > foo = host "foo.example.com" +-- > & Systemd.running Systemd.networkd +-- > & Systemd.nspawned webserver +-- > +-- > webserver :: Systemd.container +-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped (System (Debian Testing) "amd64") mempty) +-- > & Systemd.privateNetwork +-- > & Systemd.running Systemd.networkd +-- > & Systemd.publish (Port 80 ->- Port 8080) +-- > & Apt.installedRunning "apache2" +publish :: Publishable p => p -> RevertableProperty +publish p = containerCfg $ "--port=" ++ toPublish p + +class Bindable a where + toBind :: a -> String + +instance Bindable FilePath where + toBind f = f + +instance Bindable (Bound FilePath) where + toBind v = hostSide v ++ ":" ++ containerSide v + +-- | Bind mount a file or directory from the host into the container. +bind :: Bindable p => p -> RevertableProperty +bind p = containerCfg $ "--bind=" ++ toBind p + +-- | Read-only mind mount. +bindRo :: Bindable p => p -> RevertableProperty +bindRo p = containerCfg $ "--bind-ro=" ++ toBind p diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -8,7 +8,6 @@ import Propellor import Utility.LinuxMkLibs -import Utility.SafeCommand import Utility.FileMode import Utility.FileSystemEncoding diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -14,8 +14,7 @@ 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 @@ 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 diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs --- a/src/Propellor/Ssh.hs +++ b/src/Propellor/Ssh.hs @@ -1,7 +1,6 @@ module Propellor.Ssh where import Propellor -import Utility.SafeCommand import Utility.UserInfo import System.PosixCompat @@ -23,7 +22,8 @@ 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 @@ then touchFile f else do void $ boolSystem "ssh" $ - [ Params "-O stop" ] ++ ps ++ + [ Param "-O", Param "stop" ] ++ ps ++ [ Param "localhost" ] nukeFile f tenminutes = 600 diff --git a/src/Propellor/Types/Container.hs b/src/Propellor/Types/Container.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types/Container.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies #-} + +module Propellor.Types.Container where + +-- | A value that can be bound between the host and a container. +-- +-- For example, a Bound Port is a Port on the container that is bound to +-- a Port on the host. +data Bound v = Bound + { hostSide :: v + , containerSide :: v + } + +-- | Create a Bound value, from two different values for the host and +-- container. +-- +-- For example, @Port 8080 -<- Port 80@ means that port 8080 on the host +-- is bound to port 80 from the container. +(-<-) :: (hostv ~ v, containerv ~ v) => hostv -> containerv -> Bound v +(-<-) hostv containerv = Bound hostv containerv + +-- | Flipped version of -<- with the container value first and host value +-- second. +(->-) :: (containerv ~ v, hostv ~ v) => hostv -> containerv -> Bound v +(->-) containerv hostv = Bound hostv containerv + +-- | Create a Bound value, that is the same on both the host and container. +same :: v -> Bound v +same v = Bound v v + diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -10,6 +10,7 @@ User(..), Group(..), userGroup, + Port(..), ) where import Network.BSD (HostName) @@ -42,3 +43,6 @@ -- | Makes a Group with the same name as the User. userGroup :: User -> Group userGroup (User u) = Group u + +newtype Port = Port Int + deriving (Eq, Show) diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs --- a/src/Utility/Data.hs +++ b/src/Utility/Data.hs @@ -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. -} diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs --- a/src/Utility/Directory.hs +++ b/src/Utility/Directory.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory where @@ -18,6 +19,7 @@ import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe +import Prelude #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs --- a/src/Utility/Env.hs +++ b/src/Utility/Env.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Env where @@ -13,6 +14,7 @@ import Utility.Exception import Control.Applicative import Data.Maybe +import Prelude import qualified System.Environment as E import qualified System.SetEnv #else diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs --- a/src/Utility/Exception.hs +++ b/src/Utility/Exception.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Exception ( module X, diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs --- a/src/Utility/FileMode.hs +++ b/src/Utility/FileMode.hs @@ -22,15 +22,12 @@ {- 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. -} @@ -40,14 +37,6 @@ {- Removes the specified FileModes from the input mode. -} 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] diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( fileEncoding, diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -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 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. -} diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs --- a/src/Utility/Misc.hs +++ b/src/Utility/Misc.hs @@ -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. -} diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs --- a/src/Utility/Monad.hs +++ b/src/Utility/Monad.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.Monad where import Data.Maybe diff --git a/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs --- a/src/Utility/PartialPrelude.hs +++ b/src/Utility/PartialPrelude.hs @@ -5,6 +5,8 @@ - them being accidentially used. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.PartialPrelude where import qualified Data.Maybe diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE PackageImports, CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path where @@ -16,6 +17,7 @@ import Data.Maybe import Data.Char import Control.Applicative +import Prelude #ifdef mingw32_HOST_OS import qualified System.FilePath.Posix as Posix diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs --- a/src/Utility/PosixFiles.hs +++ b/src/Utility/PosixFiles.hs @@ -8,6 +8,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.PosixFiles ( module X, diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -1,12 +1,13 @@ {- System.Process enhancements, including additional ways of running - processes, and logging. - - - Copyright 2012 Joey Hess + - Copyright 2012-2015 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( module X, @@ -54,6 +55,7 @@ import Control.Applicative #endif import Data.Maybe +import Prelude import Utility.Misc import Utility.Exception @@ -63,8 +65,8 @@ 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 @@ 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 @@ , 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 @@ 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 @@ 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 @@ _ <- 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 @@ 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 @@ | 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 @@ , 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 @@ , 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 @@ } 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 = "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 @@ 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 @@ 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 @@ (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 diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs --- a/src/Utility/QuickCheck.hs +++ b/src/Utility/QuickCheck.hs @@ -19,6 +19,7 @@ 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 diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -1,84 +1,93 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2015 Joey Hess - - 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 = boolSystemEnv command params Nothing +boolSystem command params = boolSystem' command params id -boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ +boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool +boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess where dispatch ExitSuccess = True dispatch _ = False -{- Runs a system command, returning the exit status. -} +boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +boolSystemEnv command params environ = boolSystem' command params $ + \p -> p { env = environ } + +-- | Runs a system command, returning the exit status. safeSystem :: FilePath -> [CommandParam] -> IO ExitCode -safeSystem command params = safeSystemEnv command params Nothing +safeSystem command params = safeSystem' command params id -safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode -safeSystemEnv command params environ = do - (_, _, _, pid) <- createProcess (proc command $ toCommand params) - { env = environ } +safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode +safeSystem' command params mkprocess = do + (_, _, _, pid) <- createProcess p waitForProcess pid + where + p = mkprocess $ proc command (toCommand params) -{- 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. -} +safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode +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. 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 @@ -95,19 +104,19 @@ | 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 diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -32,7 +32,6 @@ 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.OrdinalDate import Data.Tuple.Utils import Data.Char +import Control.Applicative +import Prelude {- Some sort of scheduled event. -} data Schedule = Schedule Recurrance ScheduledTime diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs --- a/src/Utility/Tmp.hs +++ b/src/Utility/Tmp.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Tmp where diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.UserInfo ( myHomeDir, @@ -13,12 +14,13 @@ 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. -