Merge remote-tracking branch 'wzhd/archlinux'

10 files changed, 90 insertions, 18 deletions

diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index db114e01..e21bcdff 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -96,6 +96,7 @@ built' installprop target system@(System _ arch) config =
 extractSuite :: System -> Maybe String
 extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s
 extractSuite (System (Buntish r) _) = Just r
+extractSuite (System (ArchLinux) _) = Nothing
 extractSuite (System (FreeBSD _) _) = Nothing
 
 -- | Ensures debootstrap is installed.
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 06dfa69c..c828211b 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -81,16 +81,16 @@ type DiskImage = FilePath
 -- chroot while the disk image is being built, which should prevent any
 -- daemons that are included from being started on the system that is
 -- building the disk image.
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [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 + Linux) Linux
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux
 imageRebuilt = imageBuilt' True
 
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux
 imageBuilt' rebuild img mkchroot tabletype final partspec =
 	imageBuiltFrom img chrootdir tabletype final partspec
 		`requires` Chroot.provisioned chroot
@@ -124,7 +124,7 @@ cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit)
 	skipit = doNothing :: Property UnixLike
 
 -- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) UnixLike
 imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
   where
 	desc = img ++ " built from " ++ chrootdir
@@ -150,7 +150,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
 		imageFinalized final mnts mntopts devs parttable
 	rmimg = File.notPresent img
 
-partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike
 partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
 	mconcat $ zipWith3 (go w) mnts mntopts devs
   where
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 2ef97438..0bfcc781 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -55,6 +55,7 @@ import Propellor.Container
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Cmd as Cmd
+import qualified Propellor.Property.Pacman as Pacman
 import qualified Propellor.Shim as Shim
 import Utility.Path
 import Utility.ThreadScheduler
@@ -68,8 +69,8 @@ import Data.List.Utils
 import qualified Data.Map as M
 import System.Console.Concurrent
 
-installed :: Property DebianLike
-installed = Apt.installed ["docker.io"]
+installed :: Property (DebianLike + ArchLinux)
+installed = Apt.installed ["docker.io"] `pickOS` Pacman.installed ["docker"]
 
 -- | Configures docker with an authentication file, so that images can be
 -- pushed to index.docker.io. Optional.
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index d974cfbc..10d7afc0 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -64,7 +64,7 @@ import Control.Exception (throw)
 -- > & User.accountFor "joey"
 -- > & User.hasSomePassword "joey"
 -- > -- rest of system properties here
-cleanInstallOnce :: Confirmation -> Property Linux
+cleanInstallOnce :: Confirmation -> Property DebianLike
 cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
 	go `requires` confirmed "clean install confirmed" confirmation
   where
diff --git a/src/Propellor/Property/Pacman.hs b/src/Propellor/Property/Pacman.hs
new file mode 100644
index 00000000..60ed4bea
--- /dev/null
+++ b/src/Propellor/Property/Pacman.hs
@@ -0,0 +1,68 @@
+-- | Maintainer: Zihao Wang <dev@wzhd.org>
+--
+-- Support for the Pacman package manager <https://www.archlinux.org/pacman/>
+
+module Propellor.Property.Pacman where
+
+import Propellor.Base
+
+runPacman :: [String] -> UncheckedProperty ArchLinux
+runPacman ps = tightenTargets $ cmdProperty "pacman" ps
+
+-- | Have pacman update its lists of packages, but without upgrading anything.
+update :: Property ArchLinux
+update =  combineProperties ("pacman update") $ props
+	& runPacman ["-Sy", "--noconfirm"]
+		`assume` MadeChange
+
+upgrade :: Property ArchLinux
+upgrade = combineProperties ("pacman upgrade") $ props
+	& runPacman ["-Syu", "--noconfirm"]
+		`assume` MadeChange
+
+type Package = String
+
+installed :: [Package] -> Property ArchLinux
+installed = installed' ["--noconfirm"]
+
+installed' :: [String] -> [Package] -> Property ArchLinux
+installed' params ps = check (not <$> isInstalled' ps) go
+	`describe` unwords ("pacman installed":ps)
+  where
+	go = runPacman (params ++ ["-S"] ++ ps)
+
+removed :: [Package] -> Property ArchLinux
+removed ps = check (any (== IsInstalled) <$> getInstallStatus ps)
+	(runPacman (["-R", "--noconfirm"] ++ ps))
+	`describe` unwords ("pacman removed":ps)
+
+isInstalled :: Package -> IO Bool
+isInstalled p = isInstalled' [p]
+
+isInstalled' :: [Package] -> IO Bool
+isInstalled' ps = all (== IsInstalled) <$> getInstallStatus ps
+
+data InstallStatus = IsInstalled | NotInstalled
+	deriving (Show, Eq)
+
+{- Returns the InstallStatus of packages that are installed
+ - or known and not installed. If a package is not known at all to apt
+ - or dpkg, it is not included in the list. -}
+getInstallStatus :: [Package] -> IO [InstallStatus]
+getInstallStatus ps = mapMaybe id <$> mapM status ps
+  where
+	status :: Package -> IO (Maybe InstallStatus)
+	status p = do
+	  ifM (succeeds "pacman" ["-Q", p])
+	    (return (Just IsInstalled),
+	      ifM (succeeds "pacman" ["-Sp", p])
+	        (return (Just NotInstalled),
+	         return Nothing))
+
+succeeds :: String -> [String] -> IO Bool
+succeeds cmd args = (quietProcess >> return True)
+	`catchIO` (\_ -> return False)
+  where
+	quietProcess :: IO ()
+	quietProcess = withQuietOutput createProcessSuccess p
+	p = (proc cmd args)
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index bc8a256d..40af3357 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -23,6 +23,7 @@ module Propellor.Property.Parted (
 
 import Propellor.Base
 import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Pacman as Pacman
 import qualified Propellor.Property.Partition as Partition
 import Utility.DataUnits
 import Data.Char
@@ -192,12 +193,12 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
 --
 -- Parted is run in script mode, so it will never prompt for input.
 -- It is asked to use cylinder alignment for the disk.
-parted :: Eep -> FilePath -> [String] -> Property DebianLike
+parted :: Eep -> FilePath -> [String] -> Property (DebianLike + ArchLinux)
 parted YesReallyDeleteDiskContents disk ps = p `requires` installed
   where
 	p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)
 		`assume` MadeChange
 
 -- | Gets parted installed.
-installed :: Property DebianLike
-installed = Apt.installed ["parted"]
+installed :: Property (DebianLike + ArchLinux)
+installed = Apt.installed ["parted"] `pickOS` Pacman.installed ["parted"]
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index 31731dc2..3781cd7b 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -59,7 +59,7 @@ atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
 -- See 'Propellor.Property.HostingProvider.DigitalOcean'
 -- for an example of how to do this.
 toDistroKernel :: Property DebianLike
-toDistroKernel = check (not <$> runningInstalledKernel) now
+toDistroKernel = tightenTargets $ check (not <$> runningInstalledKernel) now
 	`describe` "running installed kernel"
 
 -- | Given a kernel version string @v@, reboots immediately if the running
diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index b40396de..53baa74e 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -2,6 +2,7 @@ module Propellor.Property.Rsync where
 
 import Propellor.Base
 import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Pacman as Pacman
 
 type Src = FilePath
 type Dest = FilePath
@@ -16,7 +17,7 @@ filesUnder d = Pattern (d ++ "/*")
 
 -- | Ensures that the Dest directory exists and has identical contents as
 -- the Src directory.
-syncDir :: Src -> Dest -> Property DebianLike
+syncDir :: Src -> Dest -> Property (DebianLike + ArchLinux)
 syncDir = syncDirFiltered []
 
 data Filter 
@@ -43,7 +44,7 @@ newtype Pattern = Pattern String
 -- Rsync checks each name to be transferred against its list of Filter
 -- rules, and the first matching one is acted on. If no matching rule
 -- is found, the file is processed.
-syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike
+syncDirFiltered :: [Filter] -> Src -> Dest -> Property (DebianLike + ArchLinux)
 syncDirFiltered filters src dest = rsync $
 	[ "-av"
 	-- Add trailing '/' to get rsync to sync the Dest directory,
@@ -56,7 +57,7 @@ syncDirFiltered filters src dest = rsync $
 	, "--quiet"
 	] ++ map toRsync filters
 
-rsync :: [String] -> Property DebianLike
+rsync :: [String] -> Property (DebianLike + ArchLinux)
 rsync ps = cmdProperty "rsync" ps
 	`assume` MadeChange
-	`requires` Apt.installed ["rsync"]
+	`requires` Apt.installed ["rsync"] `pickOS` Pacman.installed ["rsync"]
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 4f8b48af..445bce07 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -892,7 +892,7 @@ userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
 -- <http://joeyh.name/blog/entry/a_programmable_alarm_clock_using_systemd/>
 --
 -- oncalendar example value: "*-*-* 7:30"
-alarmClock :: String -> User -> String -> Property DebianLike
+alarmClock :: String -> User -> String -> Property Linux
 alarmClock oncalendar (User user) command = combineProperties "goodmorning timer installed" $ props
 	& "/etc/systemd/system/goodmorning.timer" `File.hasContent`
 		[ "[Unit]"
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index 76eae647..0c7e48f2 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -43,7 +43,7 @@ systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go
 		]
 
 -- | Removes user home directory!! Use with caution.
-nuked :: User -> Eep -> Property DebianLike
+nuked :: User -> Eep -> Property Linux
 nuked user@(User u) _ = tightenTargets $ check hashomedir go
 	`describe` ("nuked user " ++ u)
   where