summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Bootstrap.hs11
-rw-r--r--src/Propellor/Engine.hs56
-rw-r--r--src/Propellor/Gpg.hs2
-rw-r--r--src/Propellor/Info.hs4
-rw-r--r--src/Propellor/Message.hs27
-rw-r--r--src/Propellor/Property.hs15
-rw-r--r--src/Propellor/Property/Apache.hs8
-rw-r--r--src/Propellor/Property/Apt/PPA.hs3
-rw-r--r--src/Propellor/Property/Bootstrap.hs15
-rw-r--r--src/Propellor/Property/Chroot.hs20
-rw-r--r--src/Propellor/Property/ConfFile.hs11
-rw-r--r--src/Propellor/Property/DiskImage.hs144
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs8
-rw-r--r--src/Propellor/Property/Docker.hs12
-rw-r--r--src/Propellor/Property/File.hs50
-rw-r--r--src/Propellor/Property/FreeDesktop.hs29
-rw-r--r--src/Propellor/Property/Grub.hs18
-rw-r--r--src/Propellor/Property/HostingProvider/Linode.hs5
-rw-r--r--src/Propellor/Property/Hostname.hs2
-rw-r--r--src/Propellor/Property/LightDM.hs3
-rw-r--r--src/Propellor/Property/Sbuild.hs4
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs27
-rw-r--r--src/Propellor/Property/Systemd.hs2
-rw-r--r--src/Propellor/Property/User.hs8
-rw-r--r--src/Propellor/Property/XFCE.hs41
-rw-r--r--src/Propellor/Property/ZFS/Process.hs3
-rw-r--r--src/Propellor/Protocol.hs10
-rw-r--r--src/Propellor/Spin.hs102
-rw-r--r--src/Propellor/Ssh.hs18
-rw-r--r--src/Propellor/Types/Bootloader.hs12
-rw-r--r--src/Propellor/Types/Dns.hs8
-rw-r--r--src/Propellor/Types/OS.hs2
-rw-r--r--src/Propellor/Types/ZFS.hs4
-rw-r--r--src/Utility/DataUnits.hs8
-rw-r--r--src/Utility/FileMode.hs22
-rw-r--r--src/Utility/FileSystemEncoding.hs41
-rw-r--r--src/Utility/LinuxMkLibs.hs2
-rw-r--r--src/Utility/PartialPrelude.hs2
-rw-r--r--src/Utility/Path.hs32
-rw-r--r--src/Utility/Process.hs28
-rw-r--r--src/Utility/SafeCommand.hs4
-rw-r--r--src/Utility/Scheduled.hs2
-rw-r--r--src/Utility/Split.hs30
-rw-r--r--src/Utility/Tuple.hs17
44 files changed, 582 insertions, 290 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 29c55213..4b3f2da2 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -3,6 +3,8 @@ module Propellor.Bootstrap (
checkBinaryCommand,
installGitCommand,
buildPropellor,
+ checkDepsCommand,
+ buildCommand,
) where
import Propellor.Base
@@ -83,7 +85,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "ghc"
, "cabal-install"
, "libghc-async-dev"
- , "libghc-missingh-dev"
+ , "libghc-split-dev"
, "libghc-hslogger-dev"
, "libghc-unix-compat-dev"
, "libghc-ansi-terminal-dev"
@@ -94,13 +96,14 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "libghc-exceptions-dev"
, "libghc-stm-dev"
, "libghc-text-dev"
+ , "libghc-hashable-dev"
]
fbsddeps =
[ "gnupg"
, "ghc"
, "hs-cabal-install"
, "hs-async"
- , "hs-MissingH"
+ , "hs-split"
, "hs-hslogger"
, "hs-unix-compat"
, "hs-ansi-terminal"
@@ -111,13 +114,14 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "hs-exceptions"
, "hs-stm"
, "hs-text"
+ , "hs-hashable"
]
archlinuxdeps =
[ "gnupg"
, "ghc"
, "cabal-install"
, "haskell-async"
- , "haskell-missingh"
+ , "haskell-split"
, "haskell-hslogger"
, "haskell-unix-compat"
, "haskell-ansi-terminal"
@@ -129,6 +133,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "haskell-exceptions"
, "haskell-stm"
, "haskell-text"
+ , "hashell-hashable"
]
installGitCommand :: Maybe System -> ShellCommand
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 08f535e0..f54da929 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -8,6 +8,8 @@ module Propellor.Engine (
fromHost,
fromHost',
onlyProcess,
+ chainPropellor,
+ runChainPropellor,
) where
import System.Exit
@@ -17,7 +19,9 @@ import "mtl" Control.Monad.RWS.Strict
import System.PosixCompat
import System.Posix.IO
import System.FilePath
+import System.Console.Concurrent
import Control.Applicative
+import Control.Concurrent.Async
import Prelude
import Propellor.Types
@@ -28,6 +32,8 @@ import Propellor.Exception
import Propellor.Info
import Utility.Exception
import Utility.Directory
+import Utility.Process
+import Utility.PartialPrelude
-- | Gets the Properties of a Host, and ensures them all,
-- with nice display of what's being done.
@@ -96,3 +102,53 @@ onlyProcess lockfile a = bracket lock unlock (const a)
return l
unlock = closeFd
alreadyrunning = error "Propellor is already running on this host!"
+
+-- | Chains to a propellor sub-Process, forwarding its output on to the
+-- display, except for the last line which is a Result.
+chainPropellor :: CreateProcess -> IO Result
+chainPropellor p =
+ -- We want to use outputConcurrent to display output
+ -- as it's received. If only stdout were captured,
+ -- concurrent-output would buffer all outputConcurrent.
+ -- Also capturing stderr avoids that problem.
+ withOEHandles createProcessSuccess p $ \(outh, errh) -> do
+ (r, ()) <- processChainOutput outh
+ `concurrently` forwardChainError errh
+ return r
+
+-- | Reads and displays each line from the Handle, except for the last line
+-- which is a Result.
+processChainOutput :: Handle -> IO Result
+processChainOutput h = go Nothing
+ where
+ go lastline = do
+ v <- catchMaybeIO (hGetLine h)
+ case v of
+ Nothing -> case lastline of
+ Nothing -> do
+ return FailedChange
+ Just l -> case readish l of
+ Just r -> pure r
+ Nothing -> do
+ outputConcurrent (l ++ "\n")
+ return FailedChange
+ Just s -> do
+ outputConcurrent $
+ maybe "" (\l -> if null l then "" else l ++ "\n") lastline
+ go (Just s)
+
+forwardChainError :: Handle -> IO ()
+forwardChainError h = do
+ v <- catchMaybeIO (hGetLine h)
+ case v of
+ Nothing -> return ()
+ Just s -> do
+ errorConcurrent (s ++ "\n")
+ forwardChainError h
+
+-- | Used by propellor sub-Processes that are run by chainPropellor.
+runChainPropellor :: Host -> Propellor Result -> IO ()
+runChainPropellor h a = do
+ r <- runPropellor h a
+ flushConcurrentOutput
+ putStrLn $ "\n" ++ show r
diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs
index 6ac153cc..43c4eddf 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -2,7 +2,6 @@ module Propellor.Gpg where
import System.IO
import Data.Maybe
-import Data.List.Utils
import Control.Monad
import Control.Applicative
import Prelude
@@ -18,6 +17,7 @@ import Utility.Misc
import Utility.Tmp
import Utility.Env
import Utility.Directory
+import Utility.Split
type KeyId = String
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 49ca689f..ed6c2d85 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -84,13 +84,13 @@ askInfo = asks (fromInfo . hostInfo)
-- It also lets the type checker know that all the properties of the
-- host must support Debian.
--
--- > & osDebian (Stable "jessie") X86_64
+-- > & osDebian (Stable "stretch") X86_64
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian = osDebian' Linux
-- Use to specify a different `DebianKernel` than the default `Linux`
--
--- > & osDebian' KFreeBSD (Stable "jessie") X86_64
+-- > & osDebian' KFreeBSD (Stable "stretch") X86_64
osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 97573516..7715088f 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -14,7 +14,6 @@ module Propellor.Message (
infoMessage,
errorMessage,
stopPropellorMessage,
- processChainOutput,
messagesDone,
createProcessConcurrent,
withConcurrentOutput,
@@ -31,7 +30,6 @@ import Prelude
import Propellor.Types
import Propellor.Types.Exception
-import Utility.PartialPrelude
import Utility.Monad
import Utility.Exception
@@ -102,7 +100,7 @@ actionMessage' mhn desc a = do
warningMessage :: MonadIO m => String -> m ()
warningMessage s = liftIO $
- outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
+ errorConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
infoMessage :: MonadIO m => [String] -> m ()
infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
@@ -113,7 +111,7 @@ infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
-- property fail. Propellor will continue to the next property.
errorMessage :: MonadIO m => String -> m a
errorMessage s = liftIO $ do
- outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
+ errorConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
-- Normally this exception gets caught and is not displayed,
-- and propellor continues. So it's only displayed if not
-- caught, and so we say, cannot continue.
@@ -142,27 +140,6 @@ colorLine intensity color msg = concat <$> sequence
, pure "\n"
]
--- | Reads and displays each line from the Handle, except for the last line
--- which is a Result.
-processChainOutput :: Handle -> IO Result
-processChainOutput h = go Nothing
- where
- go lastline = do
- v <- catchMaybeIO (hGetLine h)
- case v of
- Nothing -> case lastline of
- Nothing -> do
- return FailedChange
- Just l -> case readish l of
- Just r -> pure r
- Nothing -> do
- outputConcurrent (l ++ "\n")
- return FailedChange
- Just s -> do
- outputConcurrent $
- maybe "" (\l -> if null l then "" else l ++ "\n") lastline
- go (Just s)
-
-- | Called when all messages about properties have been printed.
messagesDone :: IO ()
messagesDone = outputConcurrent
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 94c82c9f..55e688ab 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -50,8 +50,9 @@ import Data.Monoid
import Control.Monad.IfElse
import "mtl" Control.Monad.RWS.Strict
import System.Posix.Files
-import qualified Data.Hash.MD5 as MD5
+import Data.Maybe
import Data.List
+import Data.Hashable
import Control.Applicative
import Prelude
@@ -64,8 +65,8 @@ import Propellor.Info
import Propellor.EnsureProperty
import Utility.Exception
import Utility.Monad
-import Utility.Misc
import Utility.Directory
+import Utility.Misc
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
@@ -228,12 +229,12 @@ changesFile p f = checkResult getstat comparestat p
-- Changes to mtime etc that do not change file content are treated as
-- NoChange.
changesFileContent :: Checkable p i => p i -> FilePath -> Property i
-changesFileContent p f = checkResult getmd5 comparemd5 p
+changesFileContent p f = checkResult gethash comparehash p
where
- getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrict f
- comparemd5 oldmd5 = do
- newmd5 <- getmd5
- return $ if oldmd5 == newmd5 then NoChange else MadeChange
+ gethash = catchMaybeIO $ hash <$> readFileStrict f
+ comparehash oldhash = do
+ newhash <- gethash
+ return $ if oldhash == newhash then NoChange else MadeChange
-- | Determines if the first file is newer than the second file.
--
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index 554a5837..854d0eaa 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -189,7 +189,7 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
`requires` modEnabled "ssl"
`before` setuphttps
teardown = siteDisabled domain
- setuphttp = siteEnabled' domain $
+ setuphttp = (siteEnabled' domain $
-- The sslconffile is only created after letsencrypt gets
-- the cert. The "*" is needed to make apache not error
-- when the file doesn't exist.
@@ -201,23 +201,23 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
, "RewriteRule ^/.well-known/(.*) - [L]"
-- Everything else redirects to https
, "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]"
- ]
+ ])
+ `requires` File.dirExists (takeDirectory cf)
setuphttps = LetsEncrypt.letsEncrypt letos domain docroot
`onChange` postsetuphttps
postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props
- & File.dirExists (takeDirectory cf)
& File.hasContent cf sslvhost
`onChange` reloaded
-- always reload since the cert has changed
& reloaded
where
- cf = sslconffile "letsencrypt"
sslvhost = vhost (Port 443)
[ "SSLEngine on"
, "SSLCertificateFile " ++ LetsEncrypt.certFile domain
, "SSLCertificateKeyFile " ++ LetsEncrypt.privKeyFile domain
, "SSLCertificateChainFile " ++ LetsEncrypt.chainFile domain
]
+ cf = sslconffile "letsencrypt"
sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf"
vhost p ls =
[ "<VirtualHost *:" ++ val p ++">"
diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs
index 346125ff..a8f7db15 100644
--- a/src/Propellor/Property/Apt/PPA.hs
+++ b/src/Propellor/Property/Apt/PPA.hs
@@ -6,10 +6,11 @@ module Propellor.Property.Apt.PPA where
import Data.List
import Control.Applicative
import Prelude
-import Data.String.Utils
import Data.String (IsString(..))
+
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
+import Utility.Split
-- | Ensure software-properties-common is installed.
installed :: Property DebianLike
diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs
index 5678a865..767d6ef7 100644
--- a/src/Propellor/Property/Bootstrap.hs
+++ b/src/Propellor/Property/Bootstrap.hs
@@ -17,17 +17,17 @@ data RepoSource
-- | Bootstraps a propellor installation into
-- /usr/local/propellor/
--
--- Normally, propellor is already bootstrapped when it runs, so this
--- property is not useful. However, this can be useful inside a
--- chroot used to build a disk image, to make the disk image
--- have propellor installed.
+-- This property only does anything when used inside a chroot.
+-- This is particularly useful inside a chroot used to build a
+-- disk image, to make the disk image have propellor installed.
--
-- The git repository is cloned (or pulled to update if it already exists).
--
-- All build dependencies are installed, using distribution packages
-- or falling back to using cabal.
bootstrappedFrom :: RepoSource -> Property Linux
-bootstrappedFrom reposource = go `requires` clonedFrom reposource
+bootstrappedFrom reposource = check inChroot $
+ go `requires` clonedFrom reposource
where
go :: Property Linux
go = property "Propellor bootstrapped" $ do
@@ -35,7 +35,8 @@ bootstrappedFrom reposource = go `requires` clonedFrom reposource
assumeChange $ exposeTrueLocaldir $ const $
runShellCommand $ buildShellCommand
[ "cd " ++ localdir
- , bootstrapPropellorCommand system
+ , checkDepsCommand system
+ , buildCommand
]
-- | Clones the propellor repeository into /usr/local/propellor/
@@ -83,7 +84,7 @@ clonedFrom reposource = case reposource of
-- configuration.
copygitconfig :: Property Linux
copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do
- let gitconfig = localdir <> ".git" <> "config"
+ let gitconfig = localdir </> ".git" </> "config"
cfg <- liftIO $ B.readFile gitconfig
exposeTrueLocaldir $ const $
liftIO $ B.writeFile gitconfig cfg
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 5f764d47..65749e34 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -33,11 +33,10 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount
import Utility.FileMode
+import Utility.Split
import qualified Data.Map as M
-import Data.List.Utils
import System.Posix.Directory
-import System.Console.Concurrent
-- | Specification of a chroot. Normally you'll use `debootstrapped` or
-- `bootstrapped` to construct a Chroot value.
@@ -201,9 +200,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
, "--continue"
, show cmd
]
- let p' = p { env = Just pe }
- r <- liftIO $ withHandle StdoutHandle createProcessSuccess p'
- processChainOutput
+ r <- liftIO $ chainPropellor (p { env = Just pe })
liftIO cleanup
return r
@@ -223,13 +220,12 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
go h = do
changeWorkingDirectory localdir
when onconsole forceConsole
- onlyProcess (provisioningLock loc) $ do
- r <- runPropellor (setInChroot h) $ ensureChildProperties $
- if systemdonly
- then [toChildProperty Systemd.installed]
- else hostProperties h
- flushConcurrentOutput
- putStrLn $ "\n" ++ show r
+ onlyProcess (provisioningLock loc) $
+ runChainPropellor (setInChroot h) $
+ ensureChildProperties $
+ if systemdonly
+ then [toChildProperty Systemd.installed]
+ else hostProperties h
chain _ _ = errorMessage "bad chain command"
inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs
index b49c626e..ce092ec9 100644
--- a/src/Propellor/Property/ConfFile.hs
+++ b/src/Propellor/Property/ConfFile.hs
@@ -11,6 +11,7 @@ module Propellor.Property.ConfFile (
containsIniSetting,
hasIniSection,
lacksIniSection,
+ iniFileContains,
) where
import Propellor.Base
@@ -114,3 +115,13 @@ lacksIniSection f header = adjustIniSection
(const []) -- remove all lines of section
id -- add no lines if section is missing
f
+
+-- | Specifies the whole content of a .ini file.
+--
+-- Revertijg this causes the file not to exist.
+iniFileContains :: FilePath -> [(IniSection, [(IniKey, String)])] -> RevertableProperty UnixLike UnixLike
+iniFileContains f l = f `hasContent` content <!> notPresent f
+ where
+ content = concatMap sectioncontent l
+ sectioncontent (section, keyvalues) = iniHeader section :
+ map (\(key, value) -> key ++ "=" ++ value) keyvalues
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 90b7010b..9300b201 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -13,11 +13,7 @@ module Propellor.Property.DiskImage (
imageRebuilt,
imageBuiltFrom,
imageExists,
- -- * Finalization
- Finalization,
- grubBooted,
Grub.BIOS(..),
- noFinalization,
) where
import Propellor.Base
@@ -33,6 +29,8 @@ import Propellor.Property.Mount
import Propellor.Property.Fstab (SwapPartition(..), genFstab)
import Propellor.Property.Partition
import Propellor.Property.Rsync
+import Propellor.Types.Info
+import Propellor.Types.Bootloader
import Propellor.Container
import Utility.Path
@@ -49,7 +47,11 @@ type DiskImage = FilePath
-- First the specified Chroot is set up, and its properties are satisfied.
--
-- Then, the disk image is set up, and the chroot is copied into the
--- appropriate partition(s) of it.
+-- appropriate partition(s) of it.
+--
+-- The partitions default to being sized just large enough to fit the files
+-- from the chroot. You can use `addFreeSpace` to make them a bit larger
+-- than that, or `setSize` to use a fixed size.
--
-- Note that the disk image file is reused if it already exists,
-- to avoid expensive IO to generate a new one. And, it's updated in-place,
@@ -67,7 +69,7 @@ type DiskImage = FilePath
-- >
-- > foo = host "foo.example.com" $ props
-- > & imageBuilt "/srv/diskimages/disk.img" mychroot
--- > MSDOS (grubBooted PC)
+-- > MSDOS
-- > [ partition EXT2 `mountedAt` "/boot"
-- > `setFlag` BootFlag
-- > , partition EXT4 `mountedAt` "/"
@@ -79,6 +81,7 @@ type DiskImage = FilePath
-- > mychroot d = debootstrapped mempty d $ props
-- > & osDebian Unstable X86_64
-- > & Apt.installed ["linux-image-amd64"]
+-- > & Grub.installed PC
-- > & User.hasPassword (User "root")
-- > & User.accountFor (User "demo")
-- > & User.hasPassword (User "demo")
@@ -92,7 +95,7 @@ type DiskImage = FilePath
-- > foo = host "foo.example.com" $ props
-- > & imageBuilt "/srv/diskimages/bar-disk.img"
-- > (hostChroot bar (Debootstrapped mempty))
--- > MSDOS (grubBooted PC)
+-- > MSDOS
-- > [ partition EXT2 `mountedAt` "/boot"
-- > `setFlag` BootFlag
-- > , partition EXT4 `mountedAt` "/"
@@ -104,18 +107,19 @@ type DiskImage = FilePath
-- > bar = host "bar.example.com" $ props
-- > & osDebian Unstable X86_64
-- > & Apt.installed ["linux-image-amd64"]
+-- > & Grub.installed PC
-- > & hasPassword (User "root")
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux
+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt = imageBuilt' False
-- | Like 'built', but the chroot is deleted and rebuilt from scratch each
-- time. This is more expensive, but useful to ensure reproducible results
-- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuilt = imageBuilt' True
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux
-imageBuilt' rebuild img mkchroot tabletype final partspec =
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux
+imageBuilt' rebuild img mkchroot tabletype partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
@@ -135,12 +139,16 @@ imageBuilt' rebuild img mkchroot tabletype final partspec =
-- Before ensuring any other properties of the chroot,
-- avoid starting services. Reverted by imageFinalized.
&^ Chroot.noServices
- -- First stage finalization.
- & fst final
& cachesCleaned
-- Only propagate privdata Info from this chroot, nothing else.
propprivdataonly (Chroot.Chroot d b ip h) =
Chroot.Chroot d b (\c _ -> ip c onlyPrivData) h
+ -- Pick boot loader finalization based on which bootloader is
+ -- installed.
+ final = case fromInfo (containerInfo chroot) of
+ [GrubInstalled] -> grubBooted
+ [] -> unbootable "no bootloader is installed"
+ _ -> unbootable "multiple bootloaders are installed; don't know which to use"
-- | This property is automatically added to the chroot when building a
-- disk image. It cleans any caches of information that can be omitted;
@@ -247,7 +255,7 @@ getMountSz szm l (Just mntpt) =
--
-- If the file is too large, truncates it down to the specified size.
imageExists :: FilePath -> ByteSize -> Property Linux
-imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
+imageExists img isz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
Just s
@@ -258,21 +266,24 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
_ -> do
L.writeFile img (L.replicate (fromIntegral sz) 0)
return MadeChange
-
--- | A pair of properties. The first property is satisfied within the
--- chroot, and is typically used to download the boot loader.
---
--- The second property is run after the disk image is created,
--- with its populated partition tree mounted in the provided
--- location from the provided loop devices. This will typically
--- take care of installing the boot loader to the image.
+ where
+ sz = ceiling (fromInteger isz / sectorsize) * ceiling sectorsize
+ -- Disks have a sector size, and making a disk image not
+ -- aligned to a sector size will confuse some programs.
+ -- Common sector sizes are 512 and 4096; use 4096 as it's larger.
+ sectorsize = 4096 :: Double
+
+-- | A property that is run after the disk image is created, with
+-- its populated partition tree mounted in the provided
+-- location from the provided loop devices. This is typically used to
+-- install a boot loader in the image's superblock.
--
--- It's ok if the second property leaves additional things mounted
+-- It's ok if the property leaves additional things mounted
-- in the partition tree.
-type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
+type Finalization = (FilePath -> [LoopDev] -> Property Linux)
imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
-imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
+imageFinalized final mnts mntopts devs (PartTable _ parts) =
property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
go w top `finally` liftIO (unmountall top)
@@ -316,48 +327,53 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")
-noFinalization :: Finalization
-noFinalization = (doNothing, \_ _ -> doNothing)
+unbootable :: String -> Finalization
+unbootable msg = \_ _ -> property desc $ do
+ warningMessage (desc ++ ": " ++ msg)
+ return FailedChange
+ where
+ desc = "image is not bootable"
-- | Makes grub be the boot loader of the disk image.
-grubBooted :: Grub.BIOS -> Finalization
-grubBooted bios = (Grub.installed' bios, boots)
+--
+-- This does not install the grub package. You will need to add
+-- the `Grub.installed` property to the chroot.
+grubBooted :: Finalization
+grubBooted mnt loopdevs = combineProperties "disk image boots using grub" $ props
+ -- bind mount host /dev so grub can access the loop devices
+ & bindMount "/dev" (inmnt "/dev")
+ & mounted "proc" "proc" (inmnt "/proc") mempty
+ & mounted "sysfs" "sys" (inmnt "/sys") mempty
+ -- update the initramfs so it gets the uuid of the root partition
+ & inchroot "update-initramfs" ["-u"]
+ `assume` MadeChange
+ -- work around for http://bugs.debian.org/802717
+ & check haveosprober (inchroot "chmod" ["-x", osprober])
+ & inchroot "update-grub" []
+ `assume` MadeChange
+ & check haveosprober (inchroot "chmod" ["+x", osprober])
+ & inchroot "grub-install" [wholediskloopdev]
+ `assume` MadeChange
+ -- sync all buffered changes out to the disk image
+ -- may not be necessary, but seemed needed sometimes
+ -- when using the disk image right away.
+ & cmdProperty "sync" []
+ `assume` NoChange
where
- boots mnt loopdevs = combineProperties "disk image boots using grub" $ props
- -- bind mount host /dev so grub can access the loop devices
- & bindMount "/dev" (inmnt "/dev")
- & mounted "proc" "proc" (inmnt "/proc") mempty
- & mounted "sysfs" "sys" (inmnt "/sys") mempty
- -- update the initramfs so it gets the uuid of the root partition
- & inchroot "update-initramfs" ["-u"]
- `assume` MadeChange
- -- work around for http://bugs.debian.org/802717
- & check haveosprober (inchroot "chmod" ["-x", osprober])
- & inchroot "update-grub" []
- `assume` MadeChange
- & check haveosprober (inchroot "chmod" ["+x", osprober])
- & inchroot "grub-install" [wholediskloopdev]
- `assume` MadeChange
- -- sync all buffered changes out to the disk image
- -- may not be necessary, but seemed needed sometimes
- -- when using the disk image right away.
- & cmdProperty "sync" []
- `assume` NoChange
- where
- -- cannot use </> since the filepath is absolute
- inmnt f = mnt ++ f
-
- inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
-
- haveosprober = doesFileExist (inmnt osprober)
- osprober = "/etc/grub.d/30_os-prober"
-
- -- It doesn't matter which loopdev we use; all
- -- come from the same disk image, and it's the loop dev
- -- for the whole disk image we seek.
- wholediskloopdev = case loopdevs of
- (l:_) -> wholeDiskLoopDev l
- [] -> error "No loop devs provided!"
+ -- cannot use </> since the filepath is absolute
+ inmnt f = mnt ++ f
+
+ inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
+
+ haveosprober = doesFileExist (inmnt osprober)
+ osprober = "/etc/grub.d/30_os-prober"
+
+ -- It doesn't matter which loopdev we use; all
+ -- come from the same disk image, and it's the loop dev
+ -- for the whole disk image we seek.
+ wholediskloopdev = case loopdevs of
+ (l:_) -> wholeDiskLoopDev l
+ [] -> error "No loop devs provided!"
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild mntpt (Just d)
diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs
index 4b05df03..2b14baa0 100644
--- a/src/Propellor/Property/DiskImage/PartSpec.hs
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -69,6 +69,14 @@ addFreeSpace (mp, o, p) freesz = (mp, o, \sz -> p (sz <> freesz))
setSize :: PartSpec -> PartSize -> PartSpec
setSize (mp, o, p) sz = (mp, o, const (p sz))
+-- | Sets the percent of the filesystem blocks reserved for the super-user.
+--
+-- The default is 5% for ext2 and ext4. Some filesystems may not support
+-- this.
+reservedSpacePercentage :: PartSpec -> Int -> PartSpec
+reservedSpacePercentage s percent = adjustp s $ \p ->
+ p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }
+
-- | Sets a flag on the partition.
setFlag :: PartSpec -> PartFlag -> PartSpec
setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 1080418b..66418253 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -59,13 +59,13 @@ import qualified Propellor.Property.Pacman as Pacman
import qualified Propellor.Shim as Shim
import Utility.Path
import Utility.ThreadScheduler
+import Utility.Split
import Control.Concurrent.Async hiding (link)
import System.Posix.Directory
import System.Posix.Process
import Prelude hiding (init)
import Data.List hiding (init)
-import Data.List.Utils
import qualified Data.Map as M
import System.Console.Concurrent
@@ -576,8 +576,7 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d
let p = inContainerProcess cid
(if isConsole msgh then ["-it"] else [])
(shim : params)
- r <- withHandle StdoutHandle createProcessSuccess p $
- processChainOutput
+ r <- chainPropellor p
when (r /= FailedChange) $
setProvisionedFlag cid
return r
@@ -596,10 +595,9 @@ chain hostlist hn s = case toContainerId s of
where
go cid h = do
changeWorkingDirectory localdir
- onlyProcess (provisioningLock cid) $ do
- r <- runPropellor h $ ensureChildProperties $ hostProperties h
- flushConcurrentOutput
- putStrLn $ "\n" ++ show r
+ onlyProcess (provisioningLock cid) $
+ runChainPropellor h $
+ ensureChildProperties $ hostProperties h
stopContainer :: ContainerId -> IO Bool
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 459fe2c7..3293599a 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
module Propellor.Property.File where
@@ -105,11 +105,11 @@ hasPrivContent' writemode source f context =
-- | Replaces the content of a file with the transformed content of another file
basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike
-f `basedOn` (f', a) = property' desc $ \o -> do
- tmpl <- liftIO $ readFile f'
+f `basedOn` (src, a) = property' desc $ \o -> do
+ tmpl <- liftIO $ readFile src
ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f
where
- desc = f ++ " is based on " ++ f'
+ desc = f ++ " is based on " ++ src
-- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property UnixLike
@@ -150,23 +150,26 @@ link `isSymlinkedTo` (LinkTarget target) = property desc $
-- | Ensures that a file is a copy of another (regular) file.
isCopyOf :: FilePath -> FilePath -> Property UnixLike
-f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')
+f `isCopyOf` src = property desc $ go =<< (liftIO $ tryIO $ getFileStatus src)
where
- desc = f ++ " is copy of " ++ f'
+ desc = f ++ " is copy of " ++ src
go (Right stat) = if isRegularFile stat
- then gocmp =<< (liftIO $ cmp)
- else warningMessage (f' ++ " is not a regular file") >>
+ then ifM (liftIO $ doesFileExist f)
+ ( gocmp =<< (liftIO $ cmp)
+ , doit
+ )
+ else warningMessage (src ++ " is not a regular file") >>
return FailedChange
go (Left e) = warningMessage (show e) >> return FailedChange
- cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File f']
+ cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File src]
gocmp ExitSuccess = noChange
gocmp (ExitFailure 1) = doit
gocmp _ = warningMessage "cmp failed" >> return FailedChange
- doit = makeChange $ copy f' `viaStableTmp` f
- copy src dest = unlessM (runcp src dest) $ errorMessage "cp failed"
- runcp src dest = boolSystem "cp"
+ doit = makeChange $ copy `viaStableTmp` f
+ copy dest = unlessM (runcp dest) $ errorMessage "cp failed"
+ runcp dest = boolSystem "cp"
[Param "--preserve=all", Param "--", File src, File dest]
-- | Ensures that a file/dir has the specified owner and group.
@@ -177,6 +180,20 @@ ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og)
`changesFile` f
og = owner ++ ":" ++ group
+-- | Given a base directory, and a relative path under that
+-- directory, applies a property to each component of the path in turn,
+-- starting with the base directory.
+--
+-- For example, to make a file owned by a user, making sure their home
+-- directory and the subdirectories to it are also owned by them:
+--
+-- > "/home/user/program/file" `hasContent` ["foo"]
+-- > `before` applyPath "/home/user" ".config/program/file"
+-- > (\f -> ownerGroup f (User "user") (Group "user"))
+applyPath :: Monoid (Property metatypes) => FilePath -> FilePath -> (FilePath -> Property metatypes) -> Property metatypes
+applyPath basedir relpath mkp = mconcat $
+ map mkp (scanl (</>) basedir (splitPath relpath))
+
-- | Ensures that a file/dir has the specfied mode.
mode :: FilePath -> FileMode -> Property UnixLike
mode f v = p `changesFile` f
@@ -290,3 +307,12 @@ readConfigFileName = readish . unescape
Nothing -> '_' : ns ++ unescape cs'
Just n -> chr n : unescape cs'
unescape (c:cs) = c : unescape cs
+
+data Overwrite = OverwriteExisting | PreserveExisting
+
+-- | When passed PreserveExisting, only ensures the property when the file
+-- does not exist.
+checkOverwrite :: Overwrite -> FilePath -> (FilePath -> Property i) -> Property i
+checkOverwrite OverwriteExisting f mkp = mkp f
+checkOverwrite PreserveExisting f mkp =
+ check (not <$> doesFileExist f) (mkp f)
diff --git a/src/Propellor/Property/FreeDesktop.hs b/src/Propellor/Property/FreeDesktop.hs
new file mode 100644
index 00000000..75dcbdfa
--- /dev/null
+++ b/src/Propellor/Property/FreeDesktop.hs
@@ -0,0 +1,29 @@
+-- | Freedesktop.org configuration file properties.
+
+module Propellor.Property.FreeDesktop where
+
+import Propellor.Base
+import Propellor.Property.ConfFile
+
+desktopFile :: String -> FilePath
+desktopFile s = s ++ ".desktop"
+
+-- | Name used in a desktop file; user visible.
+type Name = String
+
+-- | Command that a dekstop file runs. May include parameters.
+type Exec = String
+
+-- | Specifies an autostart file. By default it will be located in the
+-- system-wide autostart directory.
+autostart :: FilePath -> Name -> Exec -> RevertableProperty UnixLike UnixLike
+autostart f n e = ("/etc/xdg/autostart" </> f) `iniFileContains`
+ [ ("Desktop Entry",
+ [ ("Type", "Application")
+ , ("Version", "1.0")
+ , ("Name", n)
+ , ("Comment", "Autostart")
+ , ("Terminal", "False")
+ , ("Exec", e)
+ ] )
+ ]
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 9dd5e8e1..4bad7b2b 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -3,6 +3,9 @@ module Propellor.Property.Grub where
import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
+import Propellor.Property.Chroot (inChroot)
+import Propellor.Types.Info
+import Propellor.Types.Bootloader
-- | Eg, \"hd0,0\" or \"xen/xvda1\"
type GrubDevice = String
@@ -18,9 +21,10 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- | Installs the grub package. This does not make grub be used as the
-- bootloader.
--
--- This includes running update-grub.
-installed :: BIOS -> Property DebianLike
-installed bios = installed' bios `onChange` mkConfig
+-- This includes running update-grub, unless it's run in a chroot.
+installed :: BIOS -> Property (HasInfo + DebianLike)
+installed bios = installed' bios
+ `onChange` (check (not <$> inChroot) mkConfig)
-- Run update-grub, to generate the grub boot menu. It will be
-- automatically updated when kernel packages are installed.
@@ -29,11 +33,11 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" []
`assume` MadeChange
-- | Installs grub; does not run update-grub.
-installed' :: BIOS -> Property Linux
-installed' bios = (aptinstall `pickOS` unsupportedOS)
+installed' :: BIOS -> Property (HasInfo + DebianLike)
+installed' bios = setInfoProperty aptinstall
+ (toInfo [GrubInstalled])
`describe` "grub package installed"
where
- aptinstall :: Property DebianLike
aptinstall = Apt.installed [debpkg]
debpkg = case bios of
PC -> "grub-pc"
@@ -64,7 +68,7 @@ boots dev = tightenTargets $ cmdProperty "grub-install" [dev]
--
-- The rootdev should be in the form "hd0", while the bootdev is in the form
-- "xen/xvda".
-chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike
+chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property (HasInfo + DebianLike)
chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
& File.dirExists "/boot/grub"
& "/boot/grub/menu.lst" `File.hasContent`
diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs
index fca3df63..ebe8d261 100644
--- a/src/Propellor/Property/HostingProvider/Linode.hs
+++ b/src/Propellor/Property/HostingProvider/Linode.hs
@@ -8,7 +8,7 @@ import Utility.FileMode
-- | Configures grub to use the serial console as set up by Linode.
-- Useful when running a distribution supplied kernel.
-- <https://www.linode.com/docs/tools-reference/custom-kernels-distros/run-a-distribution-supplied-kernel-with-kvm>
-serialGrub :: Property DebianLike
+serialGrub :: Property (HasInfo + DebianLike)
serialGrub = "/etc/default/grub" `File.containsLines`
[ "GRUB_CMDLINE_LINUX=\"console=ttyS0,19200n8\""
, "GRUB_DISABLE_LINUX_UUID=true"
@@ -17,11 +17,12 @@ serialGrub = "/etc/default/grub" `File.containsLines`
]
`onChange` Grub.mkConfig
`requires` Grub.installed Grub.PC
+ `describe` "GRUB configured for Linode serial console"
-- | Linode's pv-grub-x86_64 (only used for its older XEN instances)
-- does not support booting recent Debian kernels compressed
-- with xz. This sets up pv-grub chaining to enable it.
-chainPVGrub :: Grub.TimeoutSecs -> Property DebianLike
+chainPVGrub :: Grub.TimeoutSecs -> Property (HasInfo + DebianLike)
chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"
-- | Linode disables mlocate's cron job's execute permissions,
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index e1342d91..1eb9d690 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -3,9 +3,9 @@ module Propellor.Property.Hostname where
import Propellor.Base
import qualified Propellor.Property.File as File
import Propellor.Property.Chroot (inChroot)
+import Utility.Split
import Data.List
-import Data.List.Utils
-- | Ensures that the hostname is set using best practices, to whatever
-- name the `Host` has.
diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs
index 339fa9a3..69538d89 100644
--- a/src/Propellor/Property/LightDM.hs
+++ b/src/Propellor/Property/LightDM.hs
@@ -10,7 +10,8 @@ installed :: Property DebianLike
installed = Apt.installed ["lightdm"]
-- | Configures LightDM to skip the login screen and autologin as a user.
-autoLogin :: User -> Property UnixLike
+autoLogin :: User -> Property DebianLike
autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting`
("SeatDefaults", "autologin-user", u)
`describe` "lightdm autologin"
+ `requires` installed
diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs
index 00109381..460d0b16 100644
--- a/src/Propellor/Property/Sbuild.hs
+++ b/src/Propellor/Property/Sbuild.hs
@@ -98,10 +98,10 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Property.Schroot as Schroot
import qualified Propellor.Property.Reboot as Reboot
import qualified Propellor.Property.User as User
-
import Utility.FileMode
+import Utility.Split
+
import Data.List
-import Data.List.Utils
type Suite = String
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 063a2eda..6e0d6c4e 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -22,10 +22,10 @@ import qualified Propellor.Property.Systemd as Systemd
import qualified Propellor.Property.Fail2Ban as Fail2Ban
import qualified Propellor.Property.LetsEncrypt as LetsEncrypt
import Utility.FileMode
+import Utility.Split
import Data.List
import System.Posix.Files
-import Data.String.Utils
scrollBox :: Property (HasInfo + DebianLike)
scrollBox = propertyList "scroll server" $ props
@@ -248,7 +248,7 @@ gitServer hosts = propertyList "git.kitenet.net setup" $ props
]
`describe` "cgit configured"
-- I keep the website used for git.kitenet.net/git.joeyh.name checked into git..
- & Git.cloned (User "root") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
+ & Git.cloned (User "joey") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
-- Don't need global apache configuration for cgit.
! Apache.confEnabled "cgit"
& website "git.kitenet.net"
@@ -681,6 +681,10 @@ dkimInstalled = go `onChange` Service.restarted "opendkim"
& File.ownerGroup "/etc/mail/dkim.key" (User "opendkim") (Group "opendkim")
& "/etc/default/opendkim" `File.containsLine`
"SOCKET=\"inet:8891@localhost\""
+ `onChange`
+ (cmdProperty "/lib/opendkim/opendkim.service.generate" []
+ `assume` MadeChange)
+ `onChange` Service.restarted "opendkim"
& "/etc/opendkim.conf" `File.containsLines`
[ "KeyFile /etc/mail/dkim.key"
, "SubDomains yes"
@@ -694,9 +698,22 @@ dkimInstalled = go `onChange` Service.restarted "opendkim"
domainKey :: (BindDomain, Record)
domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")
-hasJoeyCAChain :: Property (HasInfo + UnixLike)
-hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed`
- Context "joeyca.pem"
+postfixSaslPasswordClient :: Property (HasInfo + DebianLike)
+postfixSaslPasswordClient = combineProperties "postfix uses SASL password to authenticate with smarthost" $ props
+ & Postfix.satellite
+ & Postfix.mappedFile "/etc/postfix/sasl_passwd"
+ (`File.hasPrivContent` (Context "kitenet.net"))
+ & Postfix.mainCfFile `File.containsLines`
+ [ "# TLS setup for SASL auth to kite"
+ , "smtp_sasl_auth_enable = yes"
+ , "smtp_tls_security_level = encrypt"
+ , "smtp_sasl_tls_security_options = noanonymous"
+ , "relayhost = [kitenet.net]"
+ , "smtp_sasl_password_maps = hash:/etc/postfix/sasl_passwd"
+ , "# kite's fingerprint"
+ , "smtp_tls_fingerprint_cert_match = 13:B0:0C:F3:11:83:A5:EB:A9:37:C6:C5:ED:16:60:86"
+ ]
+ `onChange` Postfix.reloaded
hasPostfixCert :: Context -> Property (HasInfo + UnixLike)
hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 7c40bd16..d1a94aa8 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -55,9 +55,9 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.File as File
import Propellor.Property.Systemd.Core
import Utility.FileMode
+import Utility.Split
import Data.List
-import Data.List.Utils
import qualified Data.Map as M
type ServiceName = String
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index 0c7e48f2..ce2611bc 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -97,8 +97,12 @@ setPassword getpassword = getpassword $ go
-- | Makes a user's password be the passed String. Highly insecure:
-- The password is right there in your config file for anyone to see!
hasInsecurePassword :: User -> String -> Property DebianLike
-hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $
- chpasswd u p []
+hasInsecurePassword u@(User n) p = go
+ `requires` shadowConfig True
+ where
+ go :: Property DebianLike
+ go = property (n ++ " has insecure password") $
+ chpasswd u p []
chpasswd :: User -> String -> [String] -> Propellor Result
chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuccess
diff --git a/src/Propellor/Property/XFCE.hs b/src/Propellor/Property/XFCE.hs
new file mode 100644
index 00000000..dc57660f
--- /dev/null
+++ b/src/Propellor/Property/XFCE.hs
@@ -0,0 +1,41 @@
+module Propellor.Property.XFCE where
+
+import Propellor.Base
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.User as User
+
+installed :: Property DebianLike
+installed = Apt.installed ["task-xfce-desktop"]
+ `describe` "XFCE desktop installed"
+
+-- | Minimal install of XFCE, with a terminal emulator and panel,
+-- and X and network-manager, but not any of the extra apps.
+installedMin :: Property DebianLike
+installedMin = Apt.installedMin ["xfce4", "xfce4-terminal", "task-desktop"]
+ `describe` "minimal XFCE desktop installed"
+
+-- | Installs network-manager-gnome, which is the way to get
+-- network-manager to manage networking in XFCE too.
+networkManager :: Property DebianLike
+networkManager = Apt.installedMin ["network-manager-gnome"]
+
+-- | Normally at first login, XFCE asks what kind of panel the user wants.
+-- This enables the default configuration noninteractively.
+defaultPanelFor :: User -> File.Overwrite -> Property DebianLike
+defaultPanelFor u@(User username) overwrite = property' desc $ \w -> do
+ home <- liftIO $ User.homedir u
+ ensureProperty w (go home)
+ where
+ desc = "default XFCE panel for " ++ username
+ basecf = ".config" </> "xfce4" </> "xfconf"
+ </> "xfce-perchannel-xml" </> "xfce4-panel.xml"
+ -- This location is probably Debian-specific.
+ defcf = "/etc/xdg/xfce4/panel/default.xml"
+ go :: FilePath -> Property DebianLike
+ go home = tightenTargets $
+ File.checkOverwrite overwrite (home </> basecf) $ \cf ->
+ cf `File.isCopyOf` defcf
+ `before` File.applyPath home basecf
+ (\f -> File.ownerGroup f u (userGroup u))
+ `requires` Apt.installed ["xfce4-panel"]
diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs
index 372bac6d..42b23df2 100644
--- a/src/Propellor/Property/ZFS/Process.hs
+++ b/src/Propellor/Property/ZFS/Process.hs
@@ -5,7 +5,8 @@
module Propellor.Property.ZFS.Process where
import Propellor.Base
-import Data.String.Utils (split)
+import Utility.Split
+
import Data.List
-- | Gets the properties of a ZFS volume.
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index e90155f3..ae7e0404 100644
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@@ -53,7 +53,11 @@ sendMarked' h marker s = do
hFlush h
getMarked :: Handle -> Marker -> IO (Maybe String)
-getMarked h marker = go =<< catchMaybeIO (hGetLine h)
+getMarked h marker = do
+ -- Avoid buffering anything in Handle, so that the data after
+ -- the marker will be available to be read from the underlying Fd.
+ hSetBuffering stdin NoBuffering
+ go =<< catchMaybeIO (hGetLine h)
where
go Nothing = return Nothing
go (Just l) = case fromMarked marker l of
@@ -65,8 +69,8 @@ getMarked h marker = go =<< catchMaybeIO (hGetLine h)
debug ["received marked", marker]
return (Just v)
-req :: Stage -> Marker -> (String -> IO ()) -> IO ()
-req stage marker a = do
+reqMarked :: Stage -> Marker -> (String -> IO ()) -> IO ()
+reqMarked stage marker a = do
debug ["requested marked", marker]
sendMarked' stdout statusMarker (show stage)
maybe noop a =<< getMarked stdin marker
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 3b3729f9..cd964e16 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -178,34 +178,16 @@ getSshTarget target hst
update :: Maybe HostName -> IO ()
update forhost = do
whenM hasGitRepo $
- req NeedRepoUrl repoUrlMarker setRepoUrl
+ reqMarked NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
createDirectoryIfMissing True (takeDirectory privfile)
- req NeedPrivData privDataMarker $
+ reqMarked NeedPrivData privDataMarker $
writeFileProtected privfile
whenM hasGitRepo $
- req NeedGitPush gitPushMarker $ \_ -> do
- hin <- dup stdInput
- hout <- dup stdOutput
- hClose stdin
- hClose stdout
- -- Not using git pull because git 2.5.0 badly
- -- broke its option parser.
- unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $
- errorMessage "git fetch from client failed"
- unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
- errorMessage "git merge from client failed"
+ gitPullFromUpdateServer
where
- pullparams hin hout =
- [ Param "fetch"
- , Param "--progress"
- , Param "--upload-pack"
- , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
- , Param "."
- ]
-
-- When --spin --relay is run, get a privdata file
-- to be relayed to the target host.
privfile = maybe privDataLocal privDataRelay forhost
@@ -336,31 +318,6 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor
, "rm -f " ++ remotetarball
]
--- Shim for git push over the propellor ssh channel.
--- Reads from stdin and sends it to hout;
--- reads from hin and sends it to stdout.
-gitPushHelper :: Fd -> Fd -> IO ()
-gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
- where
- fromstdin = do
- h <- fdToHandle hout
- connect stdin h
- tostdout = do
- h <- fdToHandle hin
- connect h stdout
- connect fromh toh = do
- hSetBinaryMode fromh True
- hSetBinaryMode toh True
- b <- B.hGetSome fromh 40960
- if B.null b
- then do
- hClose fromh
- hClose toh
- else do
- B.hPut toh b
- hFlush toh
- connect fromh toh
-
mergeSpin :: IO ()
mergeSpin = do
branch <- getCurrentBranch
@@ -388,3 +345,56 @@ findLastNonSpinCommit = do
spinCommitMessage :: String
spinCommitMessage = "propellor spin"
+
+-- Stdin and stdout are connected to the updateServer over ssh.
+-- Request that it run git upload-pack, and connect that up to a git fetch
+-- to receive the data.
+gitPullFromUpdateServer :: IO ()
+gitPullFromUpdateServer = reqMarked NeedGitPush gitPushMarker $ \_ -> do
+ -- Note that this relies on data not being buffered in the stdin
+ -- Handle, since such buffered data would not be available in the
+ -- FD passed to git fetch.
+ hin <- dup stdInput
+ hout <- dup stdOutput
+ hClose stdin
+ hClose stdout
+ -- Not using git pull because git 2.5.0 badly
+ -- broke its option parser.
+ unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $
+ errorMessage "git fetch from client failed"
+ unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
+ errorMessage "git merge from client failed"
+ where
+ fetchparams hin hout =
+ [ Param "fetch"
+ , Param "--progress"
+ , Param "--upload-pack"
+ , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
+ , Param "."
+ ]
+
+-- Shim for git push over the propellor ssh channel.
+-- Reads from stdin and sends it to hout;
+-- reads from hin and sends it to stdout.
+gitPushHelper :: Fd -> Fd -> IO ()
+gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
+ where
+ fromstdin = do
+ h <- fdToHandle hout
+ stdin *>* h
+ tostdout = do
+ h <- fdToHandle hin
+ h *>* stdout
+
+-- Forward data from one handle to another.
+(*>*) :: Handle -> Handle -> IO ()
+fromh *>* toh = do
+ b <- B.hGetSome fromh 40960
+ if B.null b
+ then do
+ hClose fromh
+ hClose toh
+ else do
+ B.hPut toh b
+ hFlush toh
+ fromh *>* toh
diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs
index a7a9452e..a8f50ed0 100644
--- a/src/Propellor/Ssh.hs
+++ b/src/Propellor/Ssh.hs
@@ -6,7 +6,7 @@ import Utility.FileSystemEncoding
import System.PosixCompat
import Data.Time.Clock.POSIX
-import qualified Data.Hash.MD5 as MD5
+import Data.Hashable
-- Parameters can be passed to both ssh and scp, to enable a ssh connection
-- caching socket.
@@ -50,24 +50,22 @@ sshCachingParams hn = do
-- 100 bytes. Try to never construct a filename longer than that.
--
-- When space allows, include the full hostname in the socket filename.
--- Otherwise, include at least a partial md5sum of it,
--- to avoid using the same socket file for multiple hosts.
+-- Otherwise, a checksum of the hostname is included in the name, to
+-- avoid using the same socket file for multiple hosts.
socketFile :: FilePath -> HostName -> FilePath
socketFile home hn = selectSocketFile
- [ sshdir </> hn ++ ".sock"
+ [ sshdir </> hn ++ ".sock"
, sshdir </> hn
- , sshdir </> take 10 hn ++ "-" ++ md5
- , sshdir </> md5
- , home </> ".propellor-" ++ md5
+ , sshdir </> take 10 hn ++ "-" ++ checksum
+ , sshdir </> checksum
]
- (".propellor-" ++ md5)
+ (home </> ".propellor-" ++ checksum)
where
sshdir = home </> ".ssh" </> "propellor"
- md5 = take 9 $ MD5.md5s $ MD5.Str hn
+ checksum = take 9 $ show $ abs $ hash hn
selectSocketFile :: [FilePath] -> FilePath -> FilePath
selectSocketFile [] d = d
-selectSocketFile [f] _ = f
selectSocketFile (f:fs) d
| valid_unix_socket_path f = f
| otherwise = selectSocketFile fs d
diff --git a/src/Propellor/Types/Bootloader.hs b/src/Propellor/Types/Bootloader.hs
new file mode 100644
index 00000000..c6953b94
--- /dev/null
+++ b/src/Propellor/Types/Bootloader.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Propellor.Types.Bootloader where
+
+import Propellor.Types.Info
+
+-- | Boot loader installed on a host.
+data BootloaderInstalled = GrubInstalled
+ deriving (Typeable, Show)
+
+instance IsInfo [BootloaderInstalled] where
+ propagateInfo _ = PropagateInfo False
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 8d62e63b..87756d81 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -6,12 +6,12 @@ import Propellor.Types.OS (HostName)
import Propellor.Types.Empty
import Propellor.Types.Info
import Propellor.Types.ConfigurableValue
+import Utility.Split
import Data.Word
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
-import Data.String.Utils (split, replace)
import Data.Monoid
import Prelude
@@ -102,14 +102,14 @@ data Record
type ReverseIP = String
reverseIP :: IPAddr -> ReverseIP
-reverseIP (IPv4 addr) = intercalate "." (reverse $ split "." addr) ++ ".in-addr.arpa"
+reverseIP (IPv4 addr) = intercalate "." (reverse $ splitc '.' addr) ++ ".in-addr.arpa"
reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ val $ canonicalIP addr) ++ ".ip6.arpa"
-- | Converts an IP address (particularly IPv6) to canonical, fully
-- expanded form.
canonicalIP :: IPAddr -> IPAddr
canonicalIP (IPv4 addr) = IPv4 addr
-canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":" $ replaceImplicitGroups addr
+canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ splitc ':' $ replaceImplicitGroups addr
where
canonicalGroup g
| l <= 4 = replicate (4 - l) '0' ++ g
@@ -117,7 +117,7 @@ canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":
where
l = length g
emptyGroups n = iterate (++ ":") "" !! n
- numberOfImplicitGroups a = 8 - length (split ":" $ replace "::" "" a)
+ numberOfImplicitGroups a = 8 - length (splitc ':' $ replace "::" "" a)
replaceImplicitGroups a = concat $ aux $ split "::" a
where
aux [] = []
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 41f839f1..01d777a4 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -59,7 +59,7 @@ data DebianKernel = Linux | KFreeBSD | Hurd
deriving (Show, Eq)
-- | Debian has several rolling suites, and a number of stable releases,
--- such as Stable "jessie".
+-- such as Stable "stretch".
data DebianSuite = Experimental | Unstable | Testing | Stable Release
deriving (Show, Eq)
diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs
index 22b848fa..c68f6ba5 100644
--- a/src/Propellor/Types/ZFS.hs
+++ b/src/Propellor/Types/ZFS.hs
@@ -7,10 +7,10 @@
module Propellor.Types.ZFS where
import Propellor.Types.ConfigurableValue
+import Utility.Split
import Data.String
import qualified Data.Set as Set
-import qualified Data.String.Utils as SU
import Data.List
-- | A single ZFS filesystem.
@@ -46,7 +46,7 @@ instance Show ZDataset where
show = val
instance IsString ZDataset where
- fromString s = ZDataset $ SU.split "/" s
+ fromString s = ZDataset $ splitc '/' s
instance IsString ZPool where
fromString p = ZPool p
diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs
index 6e40932e..a6c9ffcf 100644
--- a/src/Utility/DataUnits.hs
+++ b/src/Utility/DataUnits.hs
@@ -45,6 +45,7 @@ module Utility.DataUnits (
ByteSize,
roughSize,
+ roughSize',
compareSizes,
readSize
) where
@@ -109,7 +110,10 @@ oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
{- approximate display of a particular number of bytes -}
roughSize :: [Unit] -> Bool -> ByteSize -> String
-roughSize units short i
+roughSize units short i = roughSize' units short 2 i
+
+roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String
+roughSize' units short precision i
| i < 0 = '-' : findUnit units' (negate i)
| otherwise = findUnit units' i
where
@@ -123,7 +127,7 @@ roughSize units short i
showUnit x (Unit size abbrev name) = s ++ " " ++ unit
where
v = (fromInteger x :: Double) / fromInteger size
- s = showImprecise 2 v
+ s = showImprecise precision v
unit
| short = abbrev
| s == "1" = name
diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs
index bb3780c6..d9a26944 100644
--- a/src/Utility/FileMode.hs
+++ b/src/Utility/FileMode.hs
@@ -1,6 +1,6 @@
{- File mode utilities.
-
- - Copyright 2010-2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -130,6 +130,21 @@ withUmask umask a = bracket setup cleanup go
withUmask _ a = a
#endif
+getUmask :: IO FileMode
+#ifndef mingw32_HOST_OS
+getUmask = bracket setup cleanup return
+ where
+ setup = setFileCreationMask nullFileMode
+ cleanup = setFileCreationMask
+#else
+getUmask = return nullFileMode
+#endif
+
+defaultFileMode :: IO FileMode
+defaultFileMode = do
+ umask <- getUmask
+ return $ intersectFileModes (complement umask) stdFileMode
+
combineModes :: [FileMode] -> FileMode
combineModes [] = 0
combineModes [m] = m
@@ -162,7 +177,10 @@ writeFileProtected file content = writeFileProtected' file
(\h -> hPutStr h content)
writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()
-writeFileProtected' file writer = withUmask 0o0077 $
+writeFileProtected' file writer = protectedOutput $
withFile file WriteMode $ \h -> do
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
writer h
+
+protectedOutput :: IO a -> IO a
+protectedOutput = withUmask 0o0077
diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs
index be43ace9..444dc4a9 100644
--- a/src/Utility/FileSystemEncoding.hs
+++ b/src/Utility/FileSystemEncoding.hs
@@ -10,8 +10,8 @@
module Utility.FileSystemEncoding (
useFileSystemEncoding,
+ fileEncoding,
withFilePath,
- md5FilePath,
decodeBS,
encodeBS,
decodeW8,
@@ -19,6 +19,10 @@ module Utility.FileSystemEncoding (
encodeW8NUL,
decodeW8NUL,
truncateFilePath,
+ s2w8,
+ w82s,
+ c2w8,
+ w82c,
) where
import qualified GHC.Foreign as GHC
@@ -26,17 +30,15 @@ import qualified GHC.IO.Encoding as Encoding
import Foreign.C
import System.IO
import System.IO.Unsafe
-import qualified Data.Hash.MD5 as MD5
import Data.Word
-import Data.Bits.Utils
import Data.List
-import Data.List.Utils
import qualified Data.ByteString.Lazy as L
#ifdef mingw32_HOST_OS
import qualified Data.ByteString.Lazy.UTF8 as L8
#endif
import Utility.Exception
+import Utility.Split
{- Makes all subsequent Handles that are opened, as well as stdio Handles,
- use the filesystem encoding, instead of the encoding of the current
@@ -63,6 +65,13 @@ useFileSystemEncoding = do
hSetEncoding stderr e
Encoding.setLocaleEncoding e
+fileEncoding :: Handle -> IO ()
+#ifndef mingw32_HOST_OS
+fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
+#else
+fileEncoding h = hSetEncoding h Encoding.utf8
+#endif
+
{- Marshal a Haskell FilePath into a NUL terminated C string using temporary
- storage. The FilePath is encoded using the filesystem encoding,
- reversing the decoding that should have been done when the FilePath
@@ -93,10 +102,6 @@ _encodeFilePath fp = unsafePerformIO $ do
GHC.withCString enc fp (GHC.peekCString Encoding.char8)
`catchNonAsync` (\_ -> return fp)
-{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}
-md5FilePath :: FilePath -> MD5.Str
-md5FilePath = MD5.Str . _encodeFilePath
-
{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
decodeBS :: L.ByteString -> FilePath
#ifndef mingw32_HOST_OS
@@ -137,14 +142,26 @@ decodeW8 = s2w8 . _encodeFilePath
{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}
encodeW8NUL :: [Word8] -> FilePath
-encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul)
+encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul)
where
- nul = ['\NUL']
+ nul = '\NUL'
decodeW8NUL :: FilePath -> [Word8]
-decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul
+decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul
where
- nul = ['\NUL']
+ nul = '\NUL'
+
+c2w8 :: Char -> Word8
+c2w8 = fromIntegral . fromEnum
+
+w82c :: Word8 -> Char
+w82c = toEnum . fromIntegral
+
+s2w8 :: String -> [Word8]
+s2w8 = map c2w8
+
+w82s :: [Word8] -> String
+w82s = map w82c
{- Truncates a FilePath to the given number of bytes (or less),
- as represented on disk.
diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs
index 122f3964..15f82fd1 100644
--- a/src/Utility/LinuxMkLibs.hs
+++ b/src/Utility/LinuxMkLibs.hs
@@ -12,10 +12,10 @@ import Utility.Directory
import Utility.Process
import Utility.Monad
import Utility.Path
+import Utility.Split
import Data.Maybe
import System.FilePath
-import Data.List.Utils
import System.Posix.Files
import Data.Char
import Control.Monad.IfElse
diff --git a/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs
index 55795563..47e98318 100644
--- a/src/Utility/PartialPrelude.hs
+++ b/src/Utility/PartialPrelude.hs
@@ -2,7 +2,7 @@
- bugs.
-
- This exports functions that conflict with the prelude, which avoids
- - them being accidentially used.
+ - them being accidentally used.
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs
index 3ee5ff39..0779d167 100644
--- a/src/Utility/Path.hs
+++ b/src/Utility/Path.hs
@@ -10,7 +10,6 @@
module Utility.Path where
-import Data.String.Utils
import System.FilePath
import Data.List
import Data.Maybe
@@ -25,10 +24,10 @@ import System.Posix.Files
import Utility.Exception
#endif
-import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo
import Utility.Directory
+import Utility.Split
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
@@ -68,18 +67,6 @@ simplifyPath path = dropTrailingPathSeparator $
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom dir path = simplifyPath (combine dir path)
-{- On Windows, this converts the paths to unix-style, in order to run
- - MissingH's absNormPath on them. -}
-absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
-#ifndef mingw32_HOST_OS
-absNormPathUnix dir path = MissingH.absNormPath dir path
-#else
-absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)
- where
- fromdos = replace "\\" "/"
- todos = replace "/" "\\"
-#endif
-
{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
parentDir :: FilePath -> FilePath
parentDir = takeDirectory . dropTrailingPathSeparator
@@ -89,12 +76,13 @@ parentDir = takeDirectory . dropTrailingPathSeparator
upFrom :: FilePath -> Maybe FilePath
upFrom dir
| length dirs < 2 = Nothing
- | otherwise = Just $ joinDrive drive (intercalate s $ init dirs)
+ | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs
where
- -- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
+ -- on Unix, the drive will be "/" when the dir is absolute,
+ -- otherwise ""
(drive, path) = splitDrive dir
- dirs = filter (not . null) $ split s path
s = [pathSeparator]
+ dirs = filter (not . null) $ split s path
prop_upFrom_basics :: FilePath -> Bool
prop_upFrom_basics dir
@@ -149,11 +137,11 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
relPathDirToFileAbs from to
| takeDrive from /= takeDrive to = to
- | otherwise = intercalate s $ dotdots ++ uncommon
+ | otherwise = joinPath $ dotdots ++ uncommon
where
- s = [pathSeparator]
- pfrom = split s from
- pto = split s to
+ pfrom = sp from
+ pto = sp to
+ sp = map dropTrailingPathSeparator . splitPath
common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
@@ -227,6 +215,8 @@ inPath command = isJust <$> searchPath command
-
- The command may be fully qualified already, in which case it will
- be returned if it exists.
+ -
+ - Note that this will find commands in PATH that are not executable.
-}
searchPath :: String -> IO (Maybe FilePath)
searchPath command
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index ed02f49e..6d981cb5 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -174,22 +174,21 @@ createBackgroundProcess p a = a =<< createProcess p
-- returns a transcript combining its stdout and stderr, and
-- whether it succeeded or failed.
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
-processTranscript = processTranscript' id
+processTranscript cmd opts = processTranscript' (proc cmd opts)
-processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool)
-processTranscript' modproc cmd opts input = do
+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
+processTranscript' cp input = do
#ifndef mingw32_HOST_OS
{- This implementation interleves stdout and stderr in exactly the order
- the process writes them. -}
(readf, writef) <- System.Posix.IO.createPipe
readh <- System.Posix.IO.fdToHandle readf
writeh <- System.Posix.IO.fdToHandle writef
- p@(_, _, _, pid) <- createProcess $ modproc $
- (proc cmd opts)
- { std_in = if isJust input then CreatePipe else Inherit
- , std_out = UseHandle writeh
- , std_err = UseHandle writeh
- }
+ p@(_, _, _, pid) <- createProcess $ cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = UseHandle writeh
+ , std_err = UseHandle writeh
+ }
hClose writeh
get <- mkreader readh
@@ -200,12 +199,11 @@ processTranscript' modproc cmd opts input = do
return (transcript, ok)
#else
{- This implementation for Windows puts stderr after stdout. -}
- p@(_, _, _, pid) <- createProcess $ modproc $
- (proc cmd opts)
- { std_in = if isJust input then CreatePipe else Inherit
- , std_out = CreatePipe
- , std_err = CreatePipe
- }
+ p@(_, _, _, pid) <- createProcess $ cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
getout <- mkreader (stdoutHandle p)
geterr <- mkreader (stderrHandle p)
diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs
index 5ce17a84..eb34d3de 100644
--- a/src/Utility/SafeCommand.hs
+++ b/src/Utility/SafeCommand.hs
@@ -11,7 +11,7 @@ module Utility.SafeCommand where
import System.Exit
import Utility.Process
-import Data.String.Utils
+import Utility.Split
import System.FilePath
import Data.Char
import Data.List
@@ -86,7 +86,7 @@ shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
where
-- replace ' with '"'"'
- escaped = intercalate "'\"'\"'" $ split "'" f
+ escaped = intercalate "'\"'\"'" $ splitc '\'' f
-- | Unescapes a set of shellEscaped words or filenames.
shellUnEscape :: String -> [String]
diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs
index d23aaf03..b68ff901 100644
--- a/src/Utility/Scheduled.hs
+++ b/src/Utility/Scheduled.hs
@@ -29,6 +29,7 @@ module Utility.Scheduled (
import Utility.Data
import Utility.PartialPrelude
import Utility.Misc
+import Utility.Tuple
import Data.List
import Data.Time.Clock
@@ -37,7 +38,6 @@ import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.OrdinalDate
import Data.Time.Format ()
-import Data.Tuple.Utils
import Data.Char
import Control.Applicative
import Prelude
diff --git a/src/Utility/Split.hs b/src/Utility/Split.hs
new file mode 100644
index 00000000..decfe7d3
--- /dev/null
+++ b/src/Utility/Split.hs
@@ -0,0 +1,30 @@
+{- split utility functions
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Split where
+
+import Data.List (intercalate)
+import Data.List.Split (splitOn)
+
+-- | same as Data.List.Utils.split
+--
+-- intercalate x . splitOn x === id
+split :: Eq a => [a] -> [a] -> [[a]]
+split = splitOn
+
+-- | Split on a single character. This is over twice as fast as using
+-- split on a list of length 1, while producing identical results. -}
+splitc :: Eq c => c -> [c] -> [[c]]
+splitc c s = case break (== c) s of
+ (i, _c:rest) -> i : splitc c rest
+ (i, []) -> i : []
+
+-- | same as Data.List.Utils.replace
+replace :: Eq a => [a] -> [a] -> [a] -> [a]
+replace old new = intercalate new . split old
diff --git a/src/Utility/Tuple.hs b/src/Utility/Tuple.hs
new file mode 100644
index 00000000..25c6e8f3
--- /dev/null
+++ b/src/Utility/Tuple.hs
@@ -0,0 +1,17 @@
+{- tuple utility functions
+ -
+ - Copyright 2017 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Tuple where
+
+fst3 :: (a,b,c) -> a
+fst3 (a,_,_) = a
+
+snd3 :: (a,b,c) -> b
+snd3 (_,b,_) = b
+
+thd3 :: (a,b,c) -> c
+thd3 (_,_,c) = c