diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,18 @@ +propellor (4.0.5) unstable; urgency=medium + + * Switch cabal file from Extensions to Default-Extensions to fix + new picky hackage rejection. + + -- Joey Hess Sat, 03 Jun 2017 15:07:36 -0400 + +propellor (4.0.4) unstable; urgency=medium + + * Propellor.Property.Restic added for yet another backup program. + Thanks, Félix Sipma. + * Removed dependency on MissingH, instead depends on split and hashable. + + -- Joey Hess Sat, 03 Jun 2017 14:56:44 -0400 + propellor (4.0.3) unstable; urgency=medium * Added Fstab.listed, Fstab.swap, and Mount.swapOn properties. diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,18 @@ +propellor (4.0.5) unstable; urgency=medium + + * Switch cabal file from Extensions to Default-Extensions to fix + new picky hackage rejection. + + -- Joey Hess Sat, 03 Jun 2017 15:07:36 -0400 + +propellor (4.0.4) unstable; urgency=medium + + * Propellor.Property.Restic added for yet another backup program. + Thanks, Félix Sipma. + * Removed dependency on MissingH, instead depends on split and hashable. + + -- Joey Hess Sat, 03 Jun 2017 14:56:44 -0400 + propellor (4.0.3) unstable; urgency=medium * Added Fstab.listed, Fstab.swap, and Mount.swapOn properties. diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -7,7 +7,7 @@ ghc (>= 7.6), cabal-install, libghc-async-dev, - libghc-missingh-dev, + libghc-split-dev, libghc-hslogger-dev, libghc-unix-compat-dev, libghc-ansi-terminal-dev, @@ -18,6 +18,7 @@ libghc-exceptions-dev (>= 0.6), libghc-stm-dev, libghc-text-dev, + libghc-hashable-dev, libghc-concurrent-output-dev, Maintainer: Joey Hess Standards-Version: 3.9.8 @@ -31,7 +32,7 @@ ghc (>= 7.4), cabal-install, libghc-async-dev, - libghc-missingh-dev, + libghc-split-dev, libghc-hslogger-dev, libghc-unix-compat-dev, libghc-ansi-terminal-dev, @@ -42,6 +43,7 @@ libghc-exceptions-dev (>= 0.6), libghc-stm-dev, libghc-text-dev, + libghc-hashable-dev, libghc-concurrent-output-dev, git, Description: property-based host configuration management in haskell diff --git a/joeyconfig.hs b/joeyconfig.hs --- a/joeyconfig.hs +++ b/joeyconfig.hs @@ -48,15 +48,16 @@ hosts = -- (o) ` [ darkstar , gnu + , dragon , clam , mayfly - , oyster , orca , baleen , honeybee , kite , elephant , beaver + , mouse , pell , keysafe ] ++ monsters @@ -86,9 +87,8 @@ & ipv6 "2001:4830:1600:187::2" & Aiccu.hasConfig "T18376" "JHZ2-SIXXS" - & Apt.buildDep ["git-annex"] `period` Daily - & JoeySites.dkimMilter + & JoeySites.postfixSaslPasswordClient & JoeySites.alarmClock "*-*-* 7:30" (User "joey") "/usr/bin/timeout 45m /home/joey/bin/goodmorning" & Ssh.userKeys (User "joey") hostContext @@ -112,13 +112,19 @@ gnu :: Host gnu = host "gnu.kitenet.net" $ props - & Apt.buildDep ["git-annex"] `period` Daily + & Postfix.satellite +dragon :: Host +dragon = host "dragon.kitenet.net" $ props + & ipv6 "2001:4830:1600:187::2" + & JoeySites.dkimMilter + & JoeySites.postfixSaslPasswordClient + clam :: Host clam = host "clam.kitenet.net" $ props & standardSystem Unstable X86_64 ["Unreliable server. Anything here may be lost at any time!" ] - & ipv4 "167.88.41.194" + & ipv4 "64.137.231.62" & CloudAtCost.decruft & Ssh.hostKeys hostContext @@ -157,31 +163,6 @@ & Tor.named "kite3" & Tor.bandwidthRate (Tor.PerMonth "400 GB") -oyster :: Host -oyster = host "oyster.kitenet.net" $ props - & standardSystem Unstable X86_64 - [ "Unreliable server. Anything here may be lost at any time!" ] - & ipv4 "64.137.179.21" - - & CloudAtCost.decruft - & Ssh.hostKeys hostContext - [ (SshEcdsa, "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBP0ws/IxQegVU0RhqnIm5A/vRSPTO70wD4o2Bd1jL970dTetNyXzvWGe1spEbLjIYSLIO7WvOBSE5RhplBKFMUU=") - ] - & Apt.unattendedUpgrades - & Network.ipv6to4 - & Systemd.persistentJournal - & Journald.systemMaxUse "500MiB" - & Apt.serviceInstalledRunning "swapspace" - - & Tor.isRelay - & Tor.named "kite4" - & Tor.bandwidthRate (Tor.PerMonth "400 GB") - - -- Nothing is using http port 80, so listen on - -- that port for ssh, for traveling on bad networks that - -- block 22. - & Ssh.listenPort (Port 80) - baleen :: Host baleen = host "baleen.kitenet.net" $ props & standardSystem Unstable X86_64 [ "New git-annex build box." ] @@ -286,6 +267,8 @@ & Journald.systemMaxUse "500MiB" & Ssh.passwordAuthentication True & Fail2Ban.installed -- since ssh password authentication is allowed + -- Allow ssh -R to forward ports via kite + & Ssh.setSshdConfig "GatewayPorts" "clientspecified" & Apt.serviceInstalledRunning "ntp" & "/etc/timezone" `File.hasContent` ["US/Eastern"] @@ -356,7 +339,9 @@ & JoeySites.oldUseNetServer hosts & alias "ns4.kitenet.net" - & myDnsPrimary True "kitenet.net" [] + & myDnsPrimary True "kitenet.net" + [ (RelDomain "mouse-onion", CNAME $ AbsDomain "htieo6yu2qtcn2j3.onion") + ] & myDnsPrimary True "joeyh.name" [] & myDnsPrimary True "ikiwiki.info" [] & myDnsPrimary True "olduse.net" @@ -366,6 +351,10 @@ & branchableSecondary & Dns.secondaryFor ["animx"] hosts "animx.eu.org" + & alias "debug-me.joeyh.name" + -- debug-me installed manually until package is available + & Systemd.enabled "debug-me" + -- testing & Apache.httpsVirtualHost "letsencrypt.joeyh.name" "/var/www/html" (LetsEncrypt.AgreeTOS (Just "id@joeyh.name")) @@ -450,6 +439,13 @@ & Cron.niceJob "system disk backed up" Cron.Weekly (User "root") "/" "rsync -a -x / /home/joey/lib/backup/beaver.kitenet.net/" +mouse :: Host +mouse = host "mouse.kitenet.net" $ props + & ipv4 "67.223.19.96" + & Apt.installed ["ssh"] + & Tor.installed + & Tor.hiddenServiceAvailable "ssh" (Port 22) + -- Branchable is not completely deployed with propellor yet. pell :: Host pell = host "pell.branchable.com" $ props @@ -650,9 +646,6 @@ & Ssh.hostPubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY=" , host "ns6.gandi.net" $ props & ipv4 "217.70.177.40" - , host "mouse.kitenet.net" $ props - & ipv6 "2001:4830:1600:492::2" - & ipv4 "67.223.19.96" , host "animx" $ props & ipv4 "76.7.162.186" & ipv4 "76.7.162.187" diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,6 +1,6 @@ Name: propellor -Version: 4.0.3 -Cabal-Version: >= 1.8 +Version: 4.0.4 +Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess Author: Joey Hess @@ -36,46 +36,49 @@ It is configured using haskell. Executable propellor + Default-Language: Haskell98 Main-Is: wrapper.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) GHC-Options: -fno-warn-redundant-constraints - Extensions: TypeOperators + Default-Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: -- propellor needs to support the ghc shipped in Debian stable, -- and also only depends on packages in Debian stable. base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Other-Modules: Propellor.DotDir Executable propellor-config + Default-Language: Haskell98 Main-Is: config.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) GHC-Options: -fno-warn-redundant-constraints - Extensions: TypeOperators + Default-Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Library + Default-Language: Haskell98 GHC-Options: -Wall -fno-warn-tabs -O0 if impl(ghc >= 8.0) GHC-Options: -fno-warn-redundant-constraints - Extensions: TypeOperators + Default-Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: base >= 4.5, base < 5, - MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable Exposed-Modules: Propellor @@ -136,6 +139,7 @@ Propellor.Property.PropellorRepo Propellor.Property.Prosody Propellor.Property.Reboot + Propellor.Property.Restic Propellor.Property.Rsync Propellor.Property.Sbuild Propellor.Property.Scheduled @@ -221,10 +225,13 @@ Utility.Process.NonConcurrent Utility.SafeCommand Utility.Scheduled + Utility.Scheduled + Utility.Split Utility.SystemDirectory Utility.Table Utility.ThreadScheduler Utility.Tmp + Utility.Tuple Utility.UserInfo System.Console.Concurrent System.Console.Concurrent.Internal diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -83,7 +83,7 @@ , "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 +94,14 @@ , "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 +112,14 @@ , "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 +131,7 @@ , "haskell-exceptions" , "haskell-stm" , "haskell-text" + , "hashell-hashable" ] installGitCommand :: Maybe System -> ShellCommand diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -2,7 +2,6 @@ import System.IO import Data.Maybe -import Data.List.Utils import Control.Monad import Control.Applicative import Prelude @@ -18,6 +17,7 @@ import Utility.Tmp import Utility.Env import Utility.Directory +import Utility.Split type KeyId = String diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -50,8 +50,8 @@ import Control.Monad.IfElse import "mtl" Control.Monad.RWS.Strict import System.Posix.Files -import qualified Data.Hash.MD5 as MD5 import Data.List +import Data.Hashable import Control.Applicative import Prelude @@ -64,8 +64,8 @@ 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 +228,12 @@ -- 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/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs --- a/src/Propellor/Property/Apt/PPA.hs +++ b/src/Propellor/Property/Apt/PPA.hs @@ -6,10 +6,11 @@ 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/Chroot.hs b/src/Propellor/Property/Chroot.hs --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -33,9 +33,9 @@ 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 diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -59,13 +59,13 @@ 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 diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -3,9 +3,9 @@ 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/Restic.hs b/src/Propellor/Property/Restic.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Restic.hs @@ -0,0 +1,202 @@ +-- | Maintainer: Félix Sipma +-- +-- Support for the restic backup tool + +module Propellor.Property.Restic + ( ResticRepo (..) + , installed + , repoExists + , init + , restored + , backup + , KeepPolicy (..) + ) where + +import Propellor.Base hiding (init) +import Prelude hiding (init) +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.File as File +import Data.List (intercalate) + +type Url = String + +type ResticParam = String + +data ResticRepo + = Direct FilePath + | SFTP User HostName FilePath + | REST Url + +instance ConfigurableValue ResticRepo where + val (Direct fp) = fp + val (SFTP u h fp) = "sftp:" ++ val u ++ "@" ++ val h ++ ":" ++ fp + val (REST url) = "rest:" ++ url + +installed :: Property DebianLike +installed = withOS desc $ \w o -> case o of + (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $ + Apt.installedBackport ["restic"] + _ -> ensureProperty w $ + Apt.installed ["restic"] + where + desc = "installed restic" + +repoExists :: ResticRepo -> IO Bool +repoExists repo = boolSystem "restic" + [ Param "-r" + , File (val repo) + , Param "--password-file" + , File (getPasswordFile repo) + , Param "snapshots" + ] + +passwordFileDir :: FilePath +passwordFileDir = "/etc/restic-keys" + +getPasswordFile :: ResticRepo -> FilePath +getPasswordFile repo = passwordFileDir File.configFileName (val repo) + +passwordFileConfigured :: ResticRepo -> Property (HasInfo + UnixLike) +passwordFileConfigured repo = propertyList "restic password file" $ props + & File.dirExists passwordFileDir + & File.mode passwordFileDir 0O2700 + & getPasswordFile repo `File.hasPrivContent` hostContext + +-- | Inits a new restic repository +init :: ResticRepo -> Property (HasInfo + DebianLike) +init repo = check (not <$> repoExists repo) (cmdProperty "restic" initargs) + `requires` installed + `requires` passwordFileConfigured repo + where + initargs = + [ "-r" + , val repo + , "--password-file" + , getPasswordFile repo + , "init" + ] + +-- | Restores a directory from a restic backup. +-- +-- Only does anything if the directory does not exist, or exists, +-- but is completely empty. +-- +-- The restore is performed atomically; restoring to a temp directory +-- and then moving it to the directory. +restored :: FilePath -> ResticRepo -> Property (HasInfo + DebianLike) +restored dir repo = go + `requires` init repo + where + go :: Property DebianLike + go = property (dir ++ " restored by restic") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "restic-restore" $ \tmpdir -> do + ok <- boolSystem "restic" + [ Param "-r" + , File (val repo) + , Param "--password-file" + , File (getPasswordFile repo) + , Param "restore" + , Param "latest" + , Param "--target" + , File tmpdir + ] + let restoreddir = tmpdir ++ "/" ++ dir + ifM (pure ok <&&> doesDirectoryExist restoreddir) + ( do + void $ tryIO $ removeDirectory dir + renameDirectory restoreddir dir + return MadeChange + , return FailedChange + ) + +-- | Installs a cron job that causes a given directory to be backed +-- up, by running restic with some parameters. +-- +-- If the directory does not exist, or exists but is completely empty, +-- this Property will immediately restore it from an existing backup. +-- +-- So, this property can be used to deploy a directory of content +-- to a host, while also ensuring any changes made to it get backed up. +-- For example: +-- +-- > & Restic.backup "/srv/git" +-- > (Restic.SFTP (User root) (HostName myserver) /mnt/backup/git.restic") +-- > Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Restic.KeepDays 7, Restic.KeepWeeks 4, Restic.KeepMonths 6, Restic.KeepYears 1] +-- +-- Since restic uses a fair amount of system resources, only one restic +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike) +backup dir repo crontimes extraargs kp = backup' dir repo crontimes extraargs kp + `requires` restored dir repo + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike) +backup' dir repo crontimes extraargs kp = cronjob + `describe` desc + `requires` init repo + where + desc = val repo ++ " restic backup" + cronjob = Cron.niceJob ("restic_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd + lockfile = "/var/lock/propellor-restic.lock" + backupcmd = intercalate " && " $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "restic" + , "-r" + , shellEscape (val repo) + , "--password-file" + , shellEscape (getPasswordFile repo) + ] + ++ map shellEscape extraargs ++ + [ "backup" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "restic" + , "-r" + , shellEscape (val repo) + , "--password-file" + , shellEscape (getPasswordFile repo) + , "forget" + , "--prune" + ] + ++ + map keepParam kp + +-- | Constructs a ResticParam that specifies which old backup generations to +-- keep. By default, all generations are kept. However, when this parameter is +-- passed to the `backup` property, they will run restic prune to clean out +-- generations not specified here. +keepParam :: KeepPolicy -> ResticParam +keepParam (KeepLast n) = "--keep-last=" ++ val n +keepParam (KeepHours n) = "--keep-hourly=" ++ val n +keepParam (KeepDays n) = "--keep-daily=" ++ val n +keepParam (KeepWeeks n) = "--keep-weekly=" ++ val n +keepParam (KeepMonths n) = "--keep-monthly=" ++ val n +keepParam (KeepYears n) = "--keep-yearly=" ++ val n + +-- | Policy for backup generations to keep. For example, KeepDays 30 will +-- keep the latest backup for each day when a backup was made, and keep the +-- last 30 such backups. When multiple KeepPolicies are combined together, +-- backups meeting any policy are kept. See restic's man page for details. +data KeepPolicy + = KeepLast Int + | KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs --- a/src/Propellor/Property/Sbuild.hs +++ b/src/Propellor/Property/Sbuild.hs @@ -98,10 +98,10 @@ 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 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -22,10 +22,10 @@ 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 @@ -681,6 +681,10 @@ & 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 @@ 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 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -55,9 +55,9 @@ 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/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs --- 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/Ssh.hs b/src/Propellor/Ssh.hs --- a/src/Propellor/Ssh.hs +++ b/src/Propellor/Ssh.hs @@ -6,7 +6,7 @@ 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 @@ -- 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/Dns.hs b/src/Propellor/Types/Dns.hs --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -6,12 +6,12 @@ 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 @@ 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 @@ 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/ZFS.hs b/src/Propellor/Types/ZFS.hs --- 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 @@ 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 --- a/src/Utility/DataUnits.hs +++ b/src/Utility/DataUnits.hs @@ -45,6 +45,7 @@ ByteSize, roughSize, + roughSize', compareSizes, readSize ) where @@ -109,7 +110,10 @@ {- 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 @@ 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 --- a/src/Utility/FileMode.hs +++ b/src/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2017 Joey Hess - - License: BSD-2-clause -} @@ -130,6 +130,21 @@ 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 @@ (\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 --- 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 @@ encodeW8NUL, decodeW8NUL, truncateFilePath, + s2w8, + w82s, + c2w8, + w82c, ) where import qualified GHC.Foreign as GHC @@ -26,17 +30,15 @@ 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 @@ 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 @@ 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 @@ {- 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 --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -12,10 +12,10 @@ 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 --- 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 --- 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 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 @@ 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 @@ 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 @@ 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 @@ - - 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 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -174,22 +174,21 @@ -- 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 @@ 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 --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -11,7 +11,7 @@ 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 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 --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -29,6 +29,7 @@ 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.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 --- /dev/null +++ b/src/Utility/Split.hs @@ -0,0 +1,30 @@ +{- split utility functions + - + - Copyright 2017 Joey Hess + - + - 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 --- /dev/null +++ b/src/Utility/Tuple.hs @@ -0,0 +1,17 @@ +{- tuple utility functions + - + - Copyright 2017 Joey Hess + - + - 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