diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,16 @@ +propellor (3.0.2) unstable; urgency=medium + + * Added Apt.periodicUpdates. + Thanks, Félix Sipma. + * Apt.unattendedUpgrades: Enable mailing problem reports to root. + Thanks, Félix Sipma. + * Added Propellor.Property.Fstab, and moved the fstabbed property to there. + * Attic module added for the backup system. + Thanks, Félix Sipma. + * Fix build with directory-1.2.6.2. + + -- Joey Hess Sat, 30 Apr 2016 15:46:50 -0400 + propellor (3.0.1) unstable; urgency=medium * propellor --init now runs cabal sandbox init if cabal has been diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,16 @@ +propellor (3.0.2) unstable; urgency=medium + + * Added Apt.periodicUpdates. + Thanks, Félix Sipma. + * Apt.unattendedUpgrades: Enable mailing problem reports to root. + Thanks, Félix Sipma. + * Added Propellor.Property.Fstab, and moved the fstabbed property to there. + * Attic module added for the backup system. + Thanks, Félix Sipma. + * Fix build with directory-1.2.6.2. + + -- Joey Hess Sat, 30 Apr 2016 15:46:50 -0400 + propellor (3.0.1) unstable; urgency=medium * propellor --init now runs cabal sandbox init if cabal has been diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 3.0.1 +Version: 3.0.2 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess @@ -53,7 +53,7 @@ GHC-Options: -threaded -Wall -fno-warn-tabs -O0 Extensions: TypeOperators Hs-Source-Dirs: src - Build-Depends: + Build-Depends: base >= 4.5, base < 5, MissingH, directory, filepath, IfElse, process, bytestring, hslogger, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, @@ -63,7 +63,7 @@ GHC-Options: -Wall -fno-warn-tabs -O0 Extensions: TypeOperators Hs-Source-Dirs: src - Build-Depends: + Build-Depends: base >= 4.5, base < 5, MissingH, directory, filepath, IfElse, process, bytestring, hslogger, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, @@ -78,6 +78,7 @@ Propellor.Property.Apache Propellor.Property.Apt Propellor.Property.Apt.PPA + Propellor.Property.Attic Propellor.Property.Cmd Propellor.Property.Concurrent Propellor.Property.Conductor @@ -98,6 +99,7 @@ Propellor.Property.FreeBSD Propellor.Property.FreeBSD.Pkg Propellor.Property.FreeBSD.Poudriere + Propellor.Property.Fstab Propellor.Property.Git Propellor.Property.Gpg Propellor.Property.Group diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs --- a/src/Propellor/Debug.hs +++ b/src/Propellor/Debug.hs @@ -2,7 +2,6 @@ import Control.Monad.IfElse import System.IO -import System.Directory import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter) @@ -14,6 +13,7 @@ import Utility.Env import Utility.Exception import Utility.Process +import Utility.Directory debug :: [String] -> IO () debug = debugM "propellor" . unwords diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs --- a/src/Propellor/DotDir.hs +++ b/src/Propellor/DotDir.hs @@ -15,6 +15,7 @@ import Utility.Process import Utility.SafeCommand import Utility.Exception +import Utility.Directory import Utility.Path -- This module is autogenerated by the build system. import qualified Paths_propellor as Package @@ -24,7 +25,6 @@ import Data.Version import Control.Monad import Control.Monad.IfElse -import System.Directory import System.FilePath import System.Posix.Directory import System.IO diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -17,7 +17,6 @@ import System.PosixCompat import System.Posix.IO import System.FilePath -import System.Directory import Control.Applicative import Prelude @@ -28,6 +27,7 @@ import Propellor.Exception import Propellor.Info import Utility.Exception +import Utility.Directory -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs --- a/src/Propellor/Git.hs +++ b/src/Propellor/Git.hs @@ -2,8 +2,8 @@ import Utility.Process import Utility.Exception +import Utility.Directory -import System.Directory import Control.Applicative import Prelude diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -1,7 +1,6 @@ module Propellor.Gpg where import System.IO -import System.Directory import Data.Maybe import Data.List.Utils import Control.Monad @@ -19,6 +18,7 @@ import Utility.Tmp import Utility.FileSystemEncoding import Utility.Env +import Utility.Directory type KeyId = String diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -26,7 +26,6 @@ ) where import System.IO -import System.Directory import Data.Maybe import Data.List import Data.Typeable @@ -59,6 +58,7 @@ import Utility.Env import Utility.Table import Utility.FileSystemEncoding +import Utility.Directory -- | Allows a Property to access the value of a specific PrivDataField, -- for use in a specific Context or HostContext. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -44,7 +44,6 @@ , assume ) where -import System.Directory import System.FilePath import Control.Monad import Data.Monoid @@ -66,6 +65,7 @@ import Utility.Exception import Utility.Monad import Utility.Misc +import Utility.Directory -- | Makes a perhaps non-idempotent Property be idempotent by using a flag -- file to indicate whether it has run before. diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -117,6 +117,7 @@ , ("APT_LISTCHANGES_FRONTEND", "none") ] +-- | Have apt update its lists of packages, but without upgrading anything. update :: Property DebianLike update = combineProperties ("apt update") $ props & pendingConfigured @@ -124,7 +125,7 @@ `assume` MadeChange -- | Have apt upgrade packages, adding new packages and removing old as --- necessary. +-- necessary. Often used in combination with the `update` property. upgrade :: Property DebianLike upgrade = upgrade' "dist-upgrade" @@ -248,16 +249,32 @@ | otherwise = "false" configure :: Property DebianLike - configure = withOS "unattended upgrades configured" $ \w o -> - case o of - -- the package defaults to only upgrading stable - (Just (System (Debian suite) _)) - | not (isStable suite) -> ensureProperty w $ - "/etc/apt/apt.conf.d/50unattended-upgrades" - `File.containsLine` - ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") - _ -> noChange + configure = propertyList "unattended upgrades configured" $ props + & enableupgrading + & unattendedconfig `File.containsLine` "Unattended-Upgrade::Mail \"root\";" + where + enableupgrading :: Property DebianLike + enableupgrading = withOS "unattended upgrades configured" $ \w o -> + case o of + -- the package defaults to only upgrading stable + (Just (System (Debian suite) _)) + | not (isStable suite) -> ensureProperty w $ + unattendedconfig + `File.containsLine` + ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") + _ -> noChange + unattendedconfig = "/etc/apt/apt.conf.d/50unattended-upgrades" +-- | Enable periodic updates (but not upgrades), including download +-- of packages. +periodicUpdates :: Property DebianLike +periodicUpdates = tightenTargets $ "/etc/apt/apt.conf.d/02periodic" `File.hasContent` + [ "APT::Periodic::Enable \"1\";" + , "APT::Periodic::Update-Package-Lists \"1\";" + , "APT::Periodic::Download-Upgradeable-Packages \"1\";" + , "APT::Periodic::Verbose \"1\";" + ] + type DebconfTemplate = String type DebconfTemplateType = String type DebconfTemplateValue = String @@ -265,8 +282,8 @@ -- | Preseeds debconf values and reconfigures the package so it takes -- effect. reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike -reConfigure package vals = tightenTargets $ - reconfigure +reConfigure package vals = tightenTargets $ + reconfigure `requires` setselections `describe` ("reconfigure " ++ package) where diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Attic.hs @@ -0,0 +1,147 @@ +-- | Maintainer: Félix Sipma + +module Propellor.Property.Attic + ( 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 Data.List (intercalate) + +type AtticParam = String + +type AtticRepo = FilePath + +installed :: Property DebianLike +installed = Apt.installed ["attic"] + +repoExists :: AtticRepo -> IO Bool +repoExists repo = boolSystem "attic" [Param "list", File repo] + +-- | Inits a new attic repository +init :: AtticRepo -> Property DebianLike +init backupdir = check (not <$> repoExists backupdir) (cmdProperty "attic" initargs) + `requires` installed + where + initargs = + [ "init" + , backupdir + ] + +-- | Restores a directory from an attic 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 -> AtticRepo -> Property DebianLike +restored dir backupdir = go `requires` installed + where + go :: Property DebianLike + go = property (dir ++ " restored by attic") $ ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "attic-restore" $ \tmpdir -> do + ok <- boolSystem "attic" $ + [ Param "extract" + , Param backupdir + , Param 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 attic 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: +-- +-- > & Attic.backup "/srv/git" "root@myserver:/mnt/backup/git.attic" Cron.Daily +-- > ["--exclude=/srv/git/tobeignored"] +-- > [Attic.KeepDays 7, Attic.KeepWeeks 4, Attic.KeepMonths 6, Attic.KeepYears 1] +-- +-- Note that this property does not make attic encrypt the backup +-- repository. +-- +-- Since attic uses a fair amount of system resources, only one attic +-- backup job will be run at a time. Other jobs will wait their turns to +-- run. +backup :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike +backup dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp + `requires` restored dir backupdir + +-- | Does a backup, but does not automatically restore. +backup' :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike +backup' dir backupdir crontimes extraargs kp = cronjob + `describe` desc + `requires` installed + where + desc = backupdir ++ " attic backup" + cronjob = Cron.niceJob ("attic_backup" ++ dir) crontimes (User "root") "/" $ + "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + lockfile = "/var/lock/propellor-attic.lock" + backupcmd = intercalate ";" $ + createCommand + : if null kp then [] else [pruneCommand] + createCommand = unwords $ + [ "attic" + , "create" + , "--stats" + ] + ++ map shellEscape extraargs ++ + [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)" + , shellEscape dir + ] + pruneCommand = unwords $ + [ "attic" + , "prune" + , shellEscape backupdir + ] + ++ + map keepParam kp + +-- | Constructs an AtticParam 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 attic prune to clean out +-- generations not specified here. +keepParam :: KeepPolicy -> AtticParam +keepParam (KeepHours n) = "--keep-hourly=" ++ show n +keepParam (KeepDays n) = "--keep-daily=" ++ show n +keepParam (KeepWeeks n) = "--keep-daily=" ++ show n +keepParam (KeepMonths n) = "--keep-monthly=" ++ show n +keepParam (KeepYears n) = "--keep-yearly=" ++ show 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 attic's man page for details. +data KeepPolicy + = KeepHours Int + | KeepDays Int + | KeepWeeks Int + | KeepMonths Int + | KeepYears Int diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs --- a/src/Propellor/Property/Chroot/Util.hs +++ b/src/Propellor/Property/Chroot/Util.hs @@ -6,7 +6,6 @@ import Utility.Env import Utility.Directory -import System.Directory import Control.Applicative import Prelude diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -30,6 +30,7 @@ import qualified Propellor.Property.Apt as Apt import Propellor.Property.Parted import Propellor.Property.Mount +import Propellor.Property.Fstab (SwapPartition(..), genFstab) import Propellor.Property.Partition import Propellor.Property.Rsync import Propellor.Container diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Fstab.hs @@ -0,0 +1,111 @@ +module Propellor.Property.Fstab ( + FsType, + Source, + MountPoint, + MountOpts(..), + module Propellor.Property.Fstab, +) where + +import Propellor.Base +import qualified Propellor.Property.File as File +import Propellor.Property.Mount + +import Data.Char +import Data.List +import Utility.Table + +-- | Ensures that contains a line mounting the specified +-- `Source` on the specified `MountPoint`, and that it's currently mounted. +-- +-- For example: +-- +-- > mounted "auto" "/dev/sdb1" "/srv" mempty +-- +-- Note that if anything else is already mounted at the `MountPoint`, it +-- will be left as-is by this property. +mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux +mounted fs src mnt opts = tightenTargets $ + "/etc/fstab" `File.containsLine` l + `describe` (mnt ++ " mounted by fstab") + `onChange` mountnow + where + l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] + dump = "0" + passno = "2" + -- This use of mountPoints, which is linux-only, is why this + -- property currently only supports linux. + mountnow = check (notElem mnt <$> mountPoints) $ + cmdProperty "mount" [mnt] + +newtype SwapPartition = SwapPartition FilePath + +-- | Replaces with a file that should cause the currently +-- mounted partitions to be re-mounted the same way on boot. +-- +-- For each specified MountPoint, the UUID of each partition +-- (or if there is no UUID, its label), its filesystem type, +-- and its mount options are all automatically probed. +-- +-- The SwapPartitions are also included in the generated fstab. +fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux +fstabbed mnts swaps = property' "fstabbed" $ \o -> do + fstab <- liftIO $ genFstab mnts swaps id + ensureProperty o $ + "/etc/fstab" `File.hasContent` fstab + +genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String] +genFstab mnts swaps mnttransform = do + fstab <- liftIO $ mapM getcfg (sort mnts) + swapfstab <- liftIO $ mapM getswapcfg swaps + return $ header ++ formatTable (legend : fstab ++ swapfstab) + where + header = + [ "# /etc/fstab: static file system information. See fstab(5)" + , "# " + ] + legend = ["# ", "", "", "", "", ""] + getcfg mnt = sequence + [ fromMaybe (error $ "unable to find mount source for " ++ mnt) + <$> getM (\a -> a mnt) + [ uuidprefix getMountUUID + , sourceprefix getMountLabel + , getMountSource + ] + , pure (mnttransform mnt) + , fromMaybe "auto" <$> getFsType mnt + , formatMountOpts <$> getFsMountOpts mnt + , pure "0" + , pure (if mnt == "/" then "1" else "2") + ] + getswapcfg (SwapPartition swap) = sequence + [ fromMaybe swap <$> getM (\a -> a swap) + [ uuidprefix getSourceUUID + , sourceprefix getSourceLabel + ] + , pure "none" + , pure "swap" + , pure (formatMountOpts mempty) + , pure "0" + , pure "0" + ] + prefix s getter m = fmap (s ++) <$> getter m + uuidprefix = prefix "UUID=" + sourceprefix = prefix "LABEL=" + +-- | Checks if is not configured. +-- This is the case if it doesn't exist, or +-- consists entirely of blank lines or comments. +-- +-- So, if you want to only replace the fstab once, and then never touch it +-- again, allowing local modifications: +-- +-- > check noFstab (fstabbed mnts []) +noFstab :: IO Bool +noFstab = ifM (doesFileExist "/etc/fstab") + ( null . filter iscfg . lines <$> readFile "/etc/fstab" + , return True + ) + where + iscfg l + | null l = False + | otherwise = not $ "#" `isPrefixOf` dropWhile isSpace l diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -1,14 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-} +-- | Properties in this module ensure that things are currently mounted, +-- but without making the mount persistent. Use `Propellor.Property.Fstab` +-- to configure persistent mounts. + module Propellor.Property.Mount where import Propellor.Base -import qualified Propellor.Property.File as File import Utility.Path -import Data.Char import Data.List -import Utility.Table -- | type of filesystem to mount ("auto" to autodetect) type FsType = String @@ -20,6 +21,8 @@ type MountPoint = FilePath -- | Filesystem mount options. Eg, MountOpts ["errors=remount-ro"] +-- +-- For default mount options, use `mempty`. newtype MountOpts = MountOpts [String] deriving Monoid @@ -36,7 +39,7 @@ formatMountOpts (MountOpts []) = "defaults" formatMountOpts (MountOpts l) = intercalate "," l --- | Mounts a device. +-- | Mounts a device, without listing it in . mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike mounted fs src mnt opts = property (mnt ++ " mounted") $ toResult <$> liftIO (mount fs src mnt opts) @@ -57,79 +60,6 @@ , Param mnt ] -newtype SwapPartition = SwapPartition FilePath - --- | Replaces with a file that should cause the currently --- mounted partitions to be re-mounted the same way on boot. --- --- For each specified MountPoint, the UUID of each partition --- (or if there is no UUID, its label), its filesystem type, --- and its mount options are all automatically probed. --- --- The SwapPartitions are also included in the generated fstab. -fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux -fstabbed mnts swaps = property' "fstabbed" $ \o -> do - fstab <- liftIO $ genFstab mnts swaps id - ensureProperty o $ - "/etc/fstab" `File.hasContent` fstab - -genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String] -genFstab mnts swaps mnttransform = do - fstab <- liftIO $ mapM getcfg (sort mnts) - swapfstab <- liftIO $ mapM getswapcfg swaps - return $ header ++ formatTable (legend : fstab ++ swapfstab) - where - header = - [ "# /etc/fstab: static file system information. See fstab(5)" - , "# " - ] - legend = ["# ", "", "", "", "", ""] - getcfg mnt = sequence - [ fromMaybe (error $ "unable to find mount source for " ++ mnt) - <$> getM (\a -> a mnt) - [ uuidprefix getMountUUID - , sourceprefix getMountLabel - , getMountSource - ] - , pure (mnttransform mnt) - , fromMaybe "auto" <$> getFsType mnt - , formatMountOpts <$> getFsMountOpts mnt - , pure "0" - , pure (if mnt == "/" then "1" else "2") - ] - getswapcfg (SwapPartition swap) = sequence - [ fromMaybe swap <$> getM (\a -> a swap) - [ uuidprefix getSourceUUID - , sourceprefix getSourceLabel - ] - , pure "none" - , pure "swap" - , pure (formatMountOpts mempty) - , pure "0" - , pure "0" - ] - prefix s getter m = fmap (s ++) <$> getter m - uuidprefix = prefix "UUID=" - sourceprefix = prefix "LABEL=" - --- | Checks if is not configured. --- This is the case if it doesn't exist, or --- consists entirely of blank lines or comments. --- --- So, if you want to only replace the fstab once, and then never touch it --- again, allowing local modifications: --- --- > check noFstab (fstabbed mnts []) -noFstab :: IO Bool -noFstab = ifM (doesFileExist "/etc/fstab") - ( null . filter iscfg . lines <$> readFile "/etc/fstab" - , return True - ) - where - iscfg l - | null l = False - | otherwise = not $ "#" `isPrefixOf` dropWhile isSpace l - -- | Lists all mount points of the system. mountPoints :: IO [MountPoint] mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -34,7 +34,6 @@ import qualified Data.Text.IO as T import Control.Applicative import Prelude -import System.Log.Logger import Utility.Monad import Utility.Exception @@ -290,30 +289,18 @@ r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock registerOutputThread - debug ["fgProcess", showProc p] -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h unregisterOutputThread dropOutputLock - debug ["fgProcess done", showProc p] return (toConcurrentProcessHandle r) - -debug :: [String] -> IO () -debug = debugM "concurrent-output" . unwords -showProc :: P.CreateProcess -> String -showProc = go . P.cmdspec - where - go (P.ShellCommand s) = s - go (P.RawCommand c ps) = show (c, ps) - #ifndef mingw32_HOST_OS bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) bgProcess p = do (toouth, fromouth) <- pipe (toerrh, fromerrh) <- pipe - debug ["bgProcess", showProc p] let p' = p { P.std_out = rediroutput (P.std_out p) toouth , P.std_err = rediroutput (P.std_err p) toerrh diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs --- a/src/Utility/Directory.hs +++ b/src/Utility/Directory.hs @@ -6,12 +6,15 @@ -} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} +{-# OPTIONS_GHC -fno-warn-tabs -w #-} -module Utility.Directory where +module Utility.Directory ( + module Utility.Directory, + module System.Directory +) where import System.IO.Error -import System.Directory +import System.Directory hiding (isSymbolicLink) import Control.Monad import System.FilePath import Control.Applicative @@ -134,11 +137,13 @@ _ <- tryIO $ removeFile tmp throwM e' +#ifndef mingw32_HOST_OS isdir f = do r <- tryIO $ getFileStatus f case r of (Left _) -> return False (Right s) -> return $ isDirectory s +#endif {- Removes a file, which may or may not exist, and does not have to - be a regular file. diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -14,7 +14,6 @@ import Utility.Path import Data.Maybe -import System.Directory import System.FilePath import Data.List.Utils import System.Posix.Files diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -12,7 +12,6 @@ import Data.String.Utils import System.FilePath -import System.Directory import Data.List import Data.Maybe import Data.Char @@ -29,6 +28,7 @@ import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo +import Utility.Directory {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -60,7 +60,7 @@ {- Makes a path absolute. - - The first parameter is a base directory (ie, the cwd) to use if the path - - is not already absolute. + - is not already absolute, and should itsef be absolute. - - Does not attempt to deal with edge cases or ensure security with - untrusted inputs. @@ -252,15 +252,21 @@ where f = takeFileName file -{- Converts a DOS style path to a Cygwin style path. Only on Windows. - - Any trailing '\' is preserved as a trailing '/' -} -toCygPath :: FilePath -> FilePath +{- Converts a DOS style path to a msys2 style path. Only on Windows. + - Any trailing '\' is preserved as a trailing '/' + - + - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i + - + - The virtual filesystem contains: + - /c, /d, ... mount points for Windows drives + -} +toMSYS2Path :: FilePath -> FilePath #ifndef mingw32_HOST_OS -toCygPath = id +toMSYS2Path = id #else -toCygPath p +toMSYS2Path p | null drive = recombine parts - | otherwise = recombine $ "/cygdrive" : driveletter drive : parts + | otherwise = recombine $ "/" : driveletter drive : parts where (drive, p') = splitDrive p parts = splitDirectories p' diff --git a/src/wrapper.hs b/src/wrapper.hs --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -13,10 +13,10 @@ import Propellor.Message import Propellor.Bootstrap import Utility.Monad +import Utility.Directory import Utility.Process import Utility.Process.NonConcurrent -import System.Directory import System.Environment (getArgs) import System.Exit import System.Posix.Directory