diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,20 @@ +propellor (2.14.0) unstable; urgency=medium + + * Add Propellor.Property.PropellorRepo.hasOriginUrl, an explicit way to + set the git repository url normally implicitly set when using --spin. + * Added Chroot.noServices property. + * DiskImage creation automatically uses Chroot.noServices. + * Removed the (unused) dependency on quickcheck. + * DebianMirror: Added a DebianMirror type for configuration (API change) + Thanks, Félix Sipma. + * DebianMirror: Add RsyncExtra to configuration. + Thanks, Félix Sipma. + * Added Git.repoConfigured and Git.repoAcceptsNonFFs properties. + Thanks, Sean Whitton + * Added User.hasDesktopGroups property. + + -- Joey Hess Tue, 24 Nov 2015 16:03:55 -0400 + propellor (2.13.0) unstable; urgency=medium * RevertableProperty used to be assumed to contain info, but this is diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -80,6 +80,8 @@ & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter + & JoeySites.alarmClock "*-*-* 7:30" (User "joey") + "/usr/bin/timeout 45m /home/joey/bin/goodmorning" & imageBuilt "/tmp/img" c MSDOS (grubBooted PC) [ partition EXT2 `mountedAt` "/boot" diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,20 @@ +propellor (2.14.0) unstable; urgency=medium + + * Add Propellor.Property.PropellorRepo.hasOriginUrl, an explicit way to + set the git repository url normally implicitly set when using --spin. + * Added Chroot.noServices property. + * DiskImage creation automatically uses Chroot.noServices. + * Removed the (unused) dependency on quickcheck. + * DebianMirror: Added a DebianMirror type for configuration (API change) + Thanks, Félix Sipma. + * DebianMirror: Add RsyncExtra to configuration. + Thanks, Félix Sipma. + * Added Git.repoConfigured and Git.repoAcceptsNonFFs properties. + Thanks, Sean Whitton + * Added User.hasDesktopGroups property. + + -- Joey Hess Tue, 24 Nov 2015 16:03:55 -0400 + propellor (2.13.0) unstable; urgency=medium * RevertableProperty used to be assumed to contain info, but this is diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -13,7 +13,6 @@ libghc-ansi-terminal-dev, libghc-ifelse-dev, libghc-network-dev, - libghc-quickcheck2-dev, libghc-mtl-dev, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), @@ -37,7 +36,6 @@ libghc-ansi-terminal-dev, libghc-ifelse-dev, libghc-network-dev, - libghc-quickcheck2-dev, libghc-mtl-dev, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 2.13.0 +Version: 2.14.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess @@ -35,37 +35,28 @@ Executable propellor Main-Is: wrapper.hs GHC-Options: -threaded -Wall -fno-warn-tabs - Hs-Source-Dirs: src + Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions (>= 0.6), stm, text - - if (! os(windows)) - Build-Depends: unix + containers (>= 0.5), network, async, time, mtl, transformers, + exceptions (>= 0.6), stm, text, unix Executable propellor-config Main-Is: config.hs GHC-Options: -threaded -Wall -fno-warn-tabs - Hs-Source-Dirs: src + Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions, stm, text - - if (! os(windows)) - Build-Depends: unix + containers (>= 0.5), network, async, time, mtl, transformers, + exceptions (>= 0.6), stm, text, unix Library GHC-Options: -Wall -fno-warn-tabs - Hs-Source-Dirs: src + Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions, stm, text - - if (! os(windows)) - Build-Depends: unix + containers (>= 0.5), network, async, time, mtl, transformers, + exceptions (>= 0.6), stm, text, unix Exposed-Modules: Propellor @@ -109,6 +100,7 @@ Propellor.Property.Parted Propellor.Property.Partition Propellor.Property.Postfix + Propellor.Property.PropellorRepo Propellor.Property.Prosody Propellor.Property.Reboot Propellor.Property.Rsync @@ -183,7 +175,6 @@ Utility.ThreadScheduler Utility.Tmp Utility.UserInfo - Utility.QuickCheck System.Console.Concurrent System.Console.Concurrent.Internal System.Process.Concurrent diff --git a/src/Propellor.hs b/src/Propellor.hs --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -31,7 +31,6 @@ Host(..) , Property , RevertableProperty - , () , module Propellor.Types -- * Config file , defaultMain diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -77,7 +77,6 @@ , "libghc-ansi-terminal-dev" , "libghc-ifelse-dev" , "libghc-network-dev" - , "libghc-quickcheck2-dev" , "libghc-mtl-dev" , "libghc-transformers-dev" , "libghc-exceptions-dev" 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 @@ -8,6 +8,7 @@ ChrootBootstrapper(..), Debootstrapped(..), ChrootTarball(..), + noServices, inChroot, -- * Internal use provisioned', @@ -27,6 +28,7 @@ import qualified Propellor.Property.File as File import qualified Propellor.Shim as Shim import Propellor.Property.Mount +import Utility.FileMode import qualified Data.Map as M import Data.List.Utils @@ -246,6 +248,24 @@ chrootDesc :: Chroot -> String -> String chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc + +-- | Adding this property to a chroot prevents daemons and other services +-- from being started, which is often something you want to prevent when +-- building a chroot. +-- +-- This is accomplished by installing a script +-- that does not let any daemons be started by packages that use +-- invoke-rc.d. Reverting the property removes the script. +noServices :: RevertableProperty NoInfo +noServices = setup teardown + where + f = "/usr/sbin/policy-rc.d" + script = [ "#!/bin/sh", "exit 101" ] + setup = combineProperties "no services started" + [ File.hasContent f script + , File.mode f (combineModes (readModes ++ executeModes)) + ] + teardown = File.notPresent f -- | Check if propellor is currently running within a chroot. -- diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -1,10 +1,22 @@ -- | Maintainer: Félix Sipma module Propellor.Property.DebianMirror - ( DebianPriority(..) + ( DebianPriority (..) , showPriority , mirror - , mirrorCdn + , RsyncExtra (..) + , Method (..) + , DebianMirror + , debianMirrorHostName + , debianMirrorSuites + , debianMirrorArchitectures + , debianMirrorSections + , debianMirrorSourceBool + , debianMirrorPriorities + , debianMirrorMethod + , debianMirrorKeyring + , debianMirrorRsyncExtra + , mkDebianMirror ) where import Propellor.Base @@ -27,8 +39,88 @@ showPriority Optional = "optional" showPriority Extra = "extra" -mirror :: Apt.Url -> FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo -mirror url dir suites archs sections source priorities crontimes = propertyList +data RsyncExtra = Doc | Indices | Tools | Trace + deriving (Show, Eq) + +showRsyncExtra :: RsyncExtra -> String +showRsyncExtra Doc = "doc" +showRsyncExtra Indices = "indices" +showRsyncExtra Tools = "tools" +showRsyncExtra Trace = "trace" + +data Method = Ftp | Http | Https | Rsync | MirrorFile + +showMethod :: Method -> String +showMethod Ftp = "ftp" +showMethod Http = "http" +showMethod Https = "https" +showMethod Rsync = "rsync" +showMethod MirrorFile = "file" + +-- | To get a new DebianMirror and set options, use: +-- +-- > mkDebianMirror mymirrordir mycrontimes +-- > . debianMirrorHostName "otherhostname" +-- > . debianMirrorSourceBool True + +data DebianMirror = DebianMirror + { _debianMirrorHostName :: HostName + , _debianMirrorDir :: FilePath + , _debianMirrorSuites :: [DebianSuite] + , _debianMirrorArchitectures :: [Architecture] + , _debianMirrorSections :: [Apt.Section] + , _debianMirrorSourceBool :: Bool + , _debianMirrorPriorities :: [DebianPriority] + , _debianMirrorMethod :: Method + , _debianMirrorKeyring :: FilePath + , _debianMirrorRsyncExtra :: [RsyncExtra] + , _debianMirrorCronTimes :: Cron.Times + } + +mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror +mkDebianMirror dir crontimes = DebianMirror + { _debianMirrorHostName = "httpredir.debian.org" + , _debianMirrorDir = dir + , _debianMirrorSuites = [] + , _debianMirrorArchitectures = [] + , _debianMirrorSections = [] + , _debianMirrorSourceBool = False + , _debianMirrorPriorities = [] + , _debianMirrorMethod = Http + , _debianMirrorKeyring = "/usr/share/keyrings/debian-archive-keyring.gpg" + , _debianMirrorRsyncExtra = [Trace] + , _debianMirrorCronTimes = crontimes + } + +debianMirrorHostName :: HostName -> DebianMirror -> DebianMirror +debianMirrorHostName hn m = m { _debianMirrorHostName = hn } + +debianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror +debianMirrorSuites s m = m { _debianMirrorSuites = s } + +debianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror +debianMirrorArchitectures a m = m { _debianMirrorArchitectures = a } + +debianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror +debianMirrorSections s m = m { _debianMirrorSections = s } + +debianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror +debianMirrorSourceBool s m = m { _debianMirrorSourceBool = s } + +debianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror +debianMirrorPriorities p m = m { _debianMirrorPriorities = p } + +debianMirrorMethod :: Method -> DebianMirror -> DebianMirror +debianMirrorMethod me m = m { _debianMirrorMethod = me } + +debianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror +debianMirrorKeyring k m = m { _debianMirrorKeyring = k } + +debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror +debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r } + +mirror :: DebianMirror -> Property NoInfo +mirror mirror' = propertyList ("Debian mirror " ++ dir) [ Apt.installed ["debmirror"] , User.accountFor (User "debmirror") @@ -36,28 +128,30 @@ , File.ownerGroup dir (User "debmirror") (Group "debmirror") , check (not . and <$> mapM suitemirrored suites) $ cmdProperty "debmirror" args `describe` "debmirror setup" - , Cron.niceJob ("debmirror_" ++ dir) crontimes (User "debmirror") "/" $ + , Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $ unwords ("/usr/bin/debmirror" : args) ] where + dir = _debianMirrorDir mirror' + suites = _debianMirrorSuites mirror' suitemirrored suite = doesDirectoryExist $ dir "dists" Apt.showSuite suite architecturearg = intercalate "," suitearg = intercalate "," $ map Apt.showSuite suites priorityRegex pp = "(" ++ intercalate "|" (map showPriority pp) ++ ")" + rsyncextraarg [] = "none" + rsyncextraarg res = intercalate "," $ map showRsyncExtra res args = [ "--dist" , suitearg - , "--arch", architecturearg archs - , "--section", intercalate "," sections - , "--limit-priority", "\"" ++ priorityRegex priorities ++ "\"" + , "--arch", architecturearg $ _debianMirrorArchitectures mirror' + , "--section", intercalate "," $ _debianMirrorSections mirror' + , "--limit-priority", "\"" ++ priorityRegex (_debianMirrorPriorities mirror') ++ "\"" ] ++ - (if source then [] else ["--nosource"]) + (if _debianMirrorSourceBool mirror' then [] else ["--nosource"]) ++ - [ "--host", url - , "--method", "http" - , "--keyring", "/usr/share/keyrings/debian-archive-keyring.gpg" + [ "--host", _debianMirrorHostName mirror' + , "--method", showMethod $ _debianMirrorMethod mirror' + , "--rsync-extra", rsyncextraarg $ _debianMirrorRsyncExtra mirror' + , "--keyring", _debianMirrorKeyring mirror' , dir ] - -mirrorCdn :: FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo -mirrorCdn = mirror "http://httpredir.debian.org/debian" 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 @@ -1,8 +1,6 @@ -- | Disk image generation. -- -- This module is designed to be imported unqualified. --- --- TODO avoid starting services while populating chroot and running final module Propellor.Property.DiskImage ( -- * Partition specification @@ -54,21 +52,30 @@ -- > import Propellor.Property.DiskImage -- -- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d --- > & Apt.installed ["linux-image-amd64"] --- > & ... +-- > & Apt.installed ["linux-image-amd64"] +-- > & User.hasPassword (User "root") +-- > & User.accountFor (User "demo") +-- > & User.hasPassword (User "demo") +-- > & User.hasDesktopGroups (User "demo") +-- > & ... -- > in imageBuilt "/srv/images/foo.img" chroot --- > MSDOS (grubBooted PC) --- > [ partition EXT2 `mountedAt` "/boot" --- > `setFlag` BootFlag --- > , partition EXT4 `mountedAt` "/" --- > `addFreeSpace` MegaBytes 100 --- > `mountOpt` errorReadonly --- > , swapPartition (MegaBytes 256) --- > ] +-- > MSDOS (grubBooted PC) +-- > [ partition EXT2 `mountedAt` "/boot" +-- > `setFlag` BootFlag +-- > , partition EXT4 `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 100 +-- > `mountOpt` errorReadonly +-- > , swapPartition (MegaBytes 256) +-- > ] -- -- 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, -- so its contents are undefined during the build process. +-- +-- Note that the `Chroot.noServices` property is automatically added to the +-- 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 imageBuilt = imageBuilt' False @@ -93,6 +100,9 @@ | otherwise = doNothing chrootdir = img ++ ".chroot" chroot = mkchroot chrootdir + -- Before ensuring any other properties of the chroot, avoid + -- starting services. Reverted by imageFinalized. + &^ Chroot.noServices -- First stage finalization. & fst final -- Avoid wasting disk image space on the apt cache @@ -227,6 +237,7 @@ go top = do liftIO $ mountall top liftIO $ writefstab top + liftIO $ allowservices top ensureProperty $ final top devs -- Ordered lexographically by mount point, so / comes before /usr @@ -259,6 +270,8 @@ writeFile fstab $ unlines $ new ++ old -- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM" unconfigured s = "UNCONFIGURED" `isInfixOf` s + + allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d") noFinalization :: Finalization noFinalization = (doNothing, \_ _ -> doNothing) diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -114,3 +114,23 @@ ] where isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo']) + +-- | Set a key value pair in a git repo's configuration. +repoConfigured :: FilePath -> (String, String) -> Property NoInfo +repo `repoConfigured` (key, value) = + trivial $ userScriptProperty (User "root") + [ "cd " ++ repo + , "git config " ++ key ++ " " ++ value + ] + `describe` ("git repo at " ++ repo + ++ " config setting " ++ key ++ " set to " ++ value) + +-- | Whether a repo accepts non-fast-forward pushes. +repoAcceptsNonFFs :: FilePath -> RevertableProperty NoInfo +repoAcceptsNonFFs repo = accepts refuses + where + accepts = repoConfigured repo ("receive.denyNonFastForwards", "false") + `describe` desc "accepts" + refuses = repoConfigured repo ("receive.denyNonFastForwards", "true") + `describe` desc "rejects" + desc s = "git repo " ++ repo ++ " " ++ s ++ " non-fast-forward pushes" diff --git a/src/Propellor/Property/PropellorRepo.hs b/src/Propellor/Property/PropellorRepo.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/PropellorRepo.hs @@ -0,0 +1,19 @@ +module Propellor.Property.PropellorRepo where + +import Propellor.Base +import Propellor.Git + +-- | Sets the url to use as the origin of propellor's git repository. +-- +-- When propellor --spin is used to update a host, the url is taken from +-- the repository that --spin is run in, and passed to the host. So, you +-- don't need to specifiy this property then. +-- +-- This property is useful when hosts are being updated without using +-- --spin, eg when using the `Propellor.Property.Cron.runPropellor` cron job. +hasOriginUrl :: String -> Property NoInfo +hasOriginUrl u = property ("propellor repo url " ++ u) $ do + curru <- liftIO getRepoUrl + if curru == Just u + then return NoChange + else makeChange $ setRepoUrl u 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 @@ -6,6 +6,7 @@ import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.File as File +import qualified Propellor.Property.ConfFile as ConfFile import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Git as Git @@ -929,3 +930,43 @@ munge = replace "public_html" "html" conf = "/etc/apache2/mods-available/userdir.conf" +-- Alarm clock: see +-- +-- +-- oncalendar example value: "*-*-* 7:30" +alarmClock :: String -> User -> String -> Property NoInfo +alarmClock oncalendar (User user) command = combineProperties + "goodmorning timer installed" + [ "/etc/systemd/system/goodmorning.timer" `File.hasContent` + [ "[Unit]" + , "Description=good morning" + , "" + , "[Timer]" + , "Unit=goodmorning.service" + , "OnCalendar=" ++ oncalendar + , "WakeSystem=true" + , "Persistent=false" + , "" + , "[Install]" + , "WantedBy=multi-user.target" + ] + `onChange` (Systemd.daemonReloaded + `before` Systemd.restarted "goodmorning.timer") + , "/etc/systemd/system/goodmorning.service" `File.hasContent` + [ "[Unit]" + , "Description=good morning" + , "RefuseManualStart=true" + , "RefuseManualStop=true" + , "ConditionACPower=true" + , "StopWhenUnneeded=yes" + , "" + , "[Service]" + , "Type=oneshot" + , "ExecStart=/bin/systemd-inhibit --what=handle-lid-switch --why=goodmorning /bin/su " ++ user ++ " -c \"" ++ command ++ "\"" + ] + `onChange` Systemd.daemonReloaded + , Systemd.enabled "goodmorning.timer" + , Systemd.started "goodmorning.timer" + , "/etc/systemd/logind.conf" `ConfFile.containsIniSetting` + ("Login", "LidSwitchIgnoreInhibited", "no") + ] diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -107,6 +107,29 @@ where test = not . elem group' . words <$> readProcess "groups" [user] +-- | Gives a user access to the secondary groups, including audio and +-- video, that the OS installer normally gives a desktop user access to. +hasDesktopGroups :: User -> Property NoInfo +hasDesktopGroups user@(User u) = combineProperties desc $ + map (hasGroup user . Group) desktopgroups + where + desc = "user " ++ u ++ " is in standard desktop groups" + -- This list comes from user-setup's debconf + -- template named "passwd/user-default-groups" + desktopgroups = + [ "audio" + , "cdrom" + , "dip" + , "floppy" + , "video" + , "plugdev" + , "netdev" + , "scanner" + , "bluetooth" + , "debian-tor" + , "lpadmin" + ] + -- | Controls whether shadow passwords are enabled or not. shadowConfig :: Bool -> Property NoInfo shadowConfig True = check (not <$> shadowExists) $ diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -23,10 +23,11 @@ , propertyDesc , propertyChildren , RevertableProperty(..) - , () + , MkRevertableProperty(..) , IsProp(..) , Combines(..) , CombinedType + , ResultCombiner , Propellor(..) , LiftPropellor(..) , EndAction(..) diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs deleted file mode 100644 --- a/src/Utility/QuickCheck.hs +++ /dev/null @@ -1,53 +0,0 @@ -{- QuickCheck with additional instances - - - - Copyright 2012-2014 Joey Hess - - - - License: BSD-2-clause - -} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Utility.QuickCheck - ( module X - , module Utility.QuickCheck - ) where - -import Test.QuickCheck as X -import Data.Time.Clock.POSIX -import System.Posix.Types -import qualified Data.Map as M -import qualified Data.Set as S -import Control.Applicative -import Prelude - -instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where - arbitrary = M.fromList <$> arbitrary - -instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where - arbitrary = S.fromList <$> arbitrary - -{- Times before the epoch are excluded. -} -instance Arbitrary POSIXTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - -instance Arbitrary EpochTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - -{- Pids are never negative, or 0. -} -instance Arbitrary ProcessID where - arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) - -{- Inodes are never negative. -} -instance Arbitrary FileID where - arbitrary = nonNegative arbitrarySizedIntegral - -{- File sizes are never negative. -} -instance Arbitrary FileOffset where - arbitrary = nonNegative arbitrarySizedIntegral - -nonNegative :: (Num a, Ord a) => Gen a -> Gen a -nonNegative g = g `suchThat` (>= 0) - -positive :: (Num a, Ord a) => Gen a -> Gen a -positive g = g `suchThat` (> 0) diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -23,12 +23,10 @@ toRecurrance, toSchedule, parseSchedule, - prop_schedule_roundtrips, prop_past_sane, ) where import Utility.Data -import Utility.QuickCheck import Utility.PartialPrelude import Utility.Misc @@ -38,6 +36,7 @@ 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 @@ -336,41 +335,6 @@ (rws, tws) = separate (== "at") (words s) recurrance = unwords rws scheduledtime = unwords tws - -instance Arbitrary Schedule where - arbitrary = Schedule <$> arbitrary <*> arbitrary - -instance Arbitrary ScheduledTime where - arbitrary = oneof - [ pure AnyTime - , SpecificTime - <$> choose (0, 23) - <*> choose (1, 59) - ] - -instance Arbitrary Recurrance where - arbitrary = oneof - [ pure Daily - , Weekly <$> arbday - , Monthly <$> arbday - , Yearly <$> arbday - , Divisible - <$> positive arbitrary - <*> oneof -- no nested Divisibles - [ pure Daily - , Weekly <$> arbday - , Monthly <$> arbday - , Yearly <$> arbday - ] - ] - where - arbday = oneof - [ Just <$> nonNegative arbitrary - , pure Nothing - ] - -prop_schedule_roundtrips :: Schedule -> Bool -prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s prop_past_sane :: Bool prop_past_sane = and