summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorDaniel Brooks2015-08-02 00:59:28 -0400
committerDaniel Brooks2015-08-02 00:59:28 -0400
commiteb15f06896aeb208d19f6f322905c7782125356e (patch)
tree6f28ac50e476e83b212e2827a10d4b6dee0730c9 /src
parent65b511e2d4f4ec9864167e414e76b967eda32dba (diff)
parentb7a9655a695103b3ca2e4e6edfe305f9b44d9250 (diff)
Merge branch 'joeyconfig' of git://git.kitenet.net/propellor into joeyconfig
Conflicts: src/Propellor/Property/SiteSpecific/IABak.hs
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Bootstrap.hs1
-rw-r--r--src/Propellor/CmdLine.hs21
-rw-r--r--src/Propellor/Git.hs1
-rw-r--r--src/Propellor/PrivData.hs21
-rw-r--r--src/Propellor/Property.hs35
-rw-r--r--src/Propellor/Property/Apache.hs1
-rw-r--r--src/Propellor/Property/Chroot.hs37
-rw-r--r--src/Propellor/Property/Cmd.hs23
-rw-r--r--src/Propellor/Property/Cron.hs1
-rw-r--r--src/Propellor/Property/Debootstrap.hs5
-rw-r--r--src/Propellor/Property/Docker.hs140
-rw-r--r--src/Propellor/Property/Firewall.hs24
-rw-r--r--src/Propellor/Property/Git.hs1
-rw-r--r--src/Propellor/Property/Mount.hs12
-rw-r--r--src/Propellor/Property/OS.hs1
-rw-r--r--src/Propellor/Property/Obnam.hs1
-rw-r--r--src/Propellor/Property/Postfix.hs19
-rw-r--r--src/Propellor/Property/Reboot.hs1
-rw-r--r--src/Propellor/Property/Service.hs1
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs131
-rw-r--r--src/Propellor/Property/SiteSpecific/GitHome.hs1
-rw-r--r--src/Propellor/Property/SiteSpecific/IABak.hs7
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs8
-rw-r--r--src/Propellor/Property/Ssh.hs41
-rw-r--r--src/Propellor/Property/Systemd.hs173
-rw-r--r--src/Propellor/Property/Tor.hs9
-rw-r--r--src/Propellor/Shim.hs6
-rw-r--r--src/Propellor/Spin.hs31
-rw-r--r--src/Propellor/Ssh.hs6
-rw-r--r--src/Propellor/Types/CmdLine.hs1
-rw-r--r--src/Propellor/Types/Container.hs30
-rw-r--r--src/Propellor/Types/OS.hs4
-rw-r--r--src/Utility/Data.hs2
-rw-r--r--src/Utility/Directory.hs2
-rw-r--r--src/Utility/Env.hs2
-rw-r--r--src/Utility/Exception.hs1
-rw-r--r--src/Utility/FileMode.hs13
-rw-r--r--src/Utility/FileSystemEncoding.hs1
-rw-r--r--src/Utility/LinuxMkLibs.hs15
-rw-r--r--src/Utility/Misc.hs10
-rw-r--r--src/Utility/Monad.hs2
-rw-r--r--src/Utility/PartialPrelude.hs2
-rw-r--r--src/Utility/Path.hs2
-rw-r--r--src/Utility/PosixFiles.hs1
-rw-r--r--src/Utility/Process.hs82
-rw-r--r--src/Utility/QuickCheck.hs1
-rw-r--r--src/Utility/SafeCommand.hs64
-rw-r--r--src/Utility/Scheduled.hs3
-rw-r--r--src/Utility/Tmp.hs1
-rw-r--r--src/Utility/UserInfo.hs6
50 files changed, 657 insertions, 347 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 51ba69a4..1cf921cf 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -6,7 +6,6 @@ module Propellor.Bootstrap (
) 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
index 1298daf2..95a633ec 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -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"
diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs
index 34bc43e2..0b9b4b35 100644
--- a/src/Propellor/Git.hs
+++ b/src/Propellor/Git.hs
@@ -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
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 71aa820d..d0426e75 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -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
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 1801902e..b90d5b86 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -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
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index a7c7e690..fe81dcd8 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -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]
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index e56cb6ed..ded108bc 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -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"
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 859302c8..23816a94 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -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)
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index d2feaf3c..e9bb93ac 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -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
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 5d6a8bed..8d974eba 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -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
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index fdc312ce..05f25c31 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -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 $
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index 66292c8b..d643b185 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -9,7 +9,6 @@ module Propellor.Property.Firewall (
Target(..),
Proto(..),
Rules(..),
- Port,
ConnectionState(..)
) where
@@ -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 :-
diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs
index 0fc22616..48871b40 100644
--- a/src/Propellor/Property/Git.hs
+++ b/src/Propellor/Property/Git.hs
@@ -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
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index f4d10302..ff47f4d9 100644
--- 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
index 11fa6c82..5364456a 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -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)
diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs
index da27e263..94b023f3 100644
--- a/src/Propellor/Property/Obnam.hs
+++ b/src/Propellor/Property/Obnam.hs
@@ -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
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index 073d5dc8..b062cbac 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -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"
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index 750968ff..d45969a8 100644
--- 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
index 8da502f7..9cc010e8 100644
--- 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/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 511fd888..7f893431 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -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
-
-androidAutoBuilderContainer :: (System -> Docker.Image) -> Times -> TimeOut -> Docker.Container
-androidAutoBuilderContainer dockerImage crontimes timeout =
- androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir
+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
+
+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
diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs
index d6dce7c0..40f2ecd8 100644
--- a/src/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/src/Propellor/Property/SiteSpecific/GitHome.hs
@@ -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
diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs
index 4ddc6380..8ed3b38f 100644
--- a/src/Propellor/Property/SiteSpecific/IABak.hs
+++ b/src/Propellor/Property/SiteSpecific/IABak.hs
@@ -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"
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 36808919..b6524f69 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -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"
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 37e65728..fca7d037 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -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)
- ]
+type ConfigKeyword = String
+
+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
- `describe` unwords [ "ssh config:", setting, sshBool allowed ]
where
- sshline v = setting ++ " " ++ sshBool v
+ 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 :: Bool -> Property NoInfo
-permitRootLogin = setSshdConfig "PermitRootLogin"
+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.
--
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 07cf81ee..5c8a35e3 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -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
diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs
index 3af4a70c..f1aaeeb1 100644
--- a/src/Propellor/Property/Tor.hs
+++ b/src/Propellor/Property/Tor.hs
@@ -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
diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs
index 5fc1ea05..7cdecefd 100644
--- a/src/Propellor/Shim.hs
+++ b/src/Propellor/Shim.hs
@@ -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"
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 986305d7..61d519c3 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -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
diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs
index 97c3eb6d..3fe78f7a 100644
--- 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 @@ 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
diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs
index bd0cbdfd..96949957 100644
--- a/src/Propellor/Types/CmdLine.hs
+++ b/src/Propellor/Types/CmdLine.hs
@@ -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
diff --git a/src/Propellor/Types/Container.hs b/src/Propellor/Types/Container.hs
new file mode 100644
index 00000000..d21bada7
--- /dev/null
+++ b/src/Propellor/Types/Container.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Propellor.Types.Container where
+
+-- | A value that can be bound between the host and a container.
+--
+-- For example, a Bound Port is a Port on the container that is bound to
+-- a Port on the host.
+data Bound v = Bound
+ { hostSide :: v
+ , containerSide :: v
+ }
+
+-- | Create a Bound value, from two different values for the host and
+-- container.
+--
+-- For example, @Port 8080 -<- Port 80@ means that port 8080 on the host
+-- is bound to port 80 from the container.
+(-<-) :: (hostv ~ v, containerv ~ v) => hostv -> containerv -> Bound v
+(-<-) hostv containerv = Bound hostv containerv
+
+-- | Flipped version of -<- with the container value first and host value
+-- second.
+(->-) :: (containerv ~ v, hostv ~ v) => hostv -> containerv -> Bound v
+(->-) containerv hostv = Bound hostv containerv
+
+-- | Create a Bound value, that is the same on both the host and container.
+same :: v -> Bound v
+same v = Bound v v
+
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 58bd809a..c46d9a28 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -10,6 +10,7 @@ module Propellor.Types.OS (
User(..),
Group(..),
userGroup,
+ Port(..),
) where
import Network.BSD (HostName)
@@ -42,3 +43,6 @@ newtype Group = Group String
-- | Makes a Group with the same name as the User.
userGroup :: User -> Group
userGroup (User u) = Group u
+
+newtype Port = Port Int
+ deriving (Eq, Show)
diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs
index 5ecd218f..27c0a824 100644
--- 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
index 2e037fdd..7322cd85 100644
--- 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.Applicative
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
index fdf06d80..c56f4ec2 100644
--- 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 @@ 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
diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
index ab47ae95..9d4236c4 100644
--- 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
index 201b8451..fdf1b56b 100644
--- a/src/Utility/FileMode.hs
+++ b/src/Utility/FileMode.hs
@@ -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]
diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs
index 139b74fe..41c5972a 100644
--- 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
index db64d123..fdeb7795 100644
--- 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 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. -}
diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs
index e4eccac4..45d5a063 100644
--- 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
index 878e0da6..ac751043 100644
--- 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
index 6efa093f..55795563 100644
--- 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
index 9f0737fe..8e3c2bdd 100644
--- 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.List
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
index 5a94ead0..4550bebd 100644
--- 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
index cbbe8a81..469f7659 100644
--- 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 <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
diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs
index 54200d3f..cd408ddc 100644
--- a/src/Utility/QuickCheck.hs
+++ b/src/Utility/QuickCheck.hs
@@ -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
diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs
index 9eaa5308..9102b726 100644
--- a/src/Utility/SafeCommand.hs
+++ b/src/Utility/SafeCommand.hs
@@ -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
diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs
index e077a1fe..b3813323 100644
--- a/src/Utility/Scheduled.hs
+++ b/src/Utility/Scheduled.hs
@@ -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
diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs
index dc559813..de970fe5 100644
--- 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
index 5bf8d5c0..7e94cafa 100644
--- 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 @@ 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.
-