summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2016-03-28 04:46:21 -0400
committerJoey Hess2016-03-28 04:46:21 -0400
commit5f41492d8afe6ac6ee3cc280c3e2f252bcc91817 (patch)
tree6c9d91f7a13f35514f98564954273051ecc6a641 /src
parent67a1bb6d9915a0c36b71d984cf0ef4c89dd59607 (diff)
propellor spin
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property.hs18
-rw-r--r--src/Propellor/Property/Apt.hs6
-rw-r--r--src/Propellor/Property/Debootstrap.hs19
-rw-r--r--src/Propellor/Property/Grub.hs2
-rw-r--r--src/Propellor/Property/OS.hs2
-rw-r--r--src/Propellor/Property/Ssh.hs2
6 files changed, 19 insertions, 30 deletions
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 7878912b..55c39ee2 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -28,6 +28,7 @@ module Propellor.Property (
, pickOS
, withOS
, unsupportedOS
+ , unsupportedOS'
, makeChange
, noChange
, doNothing
@@ -292,7 +293,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
then getSatisfy a
else if matching o b
then getSatisfy b
- else unsupportedOS
+ else unsupportedOS'
matching Nothing _ = False
matching (Just o) p =
Targeting (systemToTargetOS o)
@@ -307,7 +308,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
-- > myproperty = withOS "foo installed" $ \w o -> case o of
-- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ...
-- > (Just (System (Debian suite) arch)) -> ensureProperty w ...
--- > _ -> unsupportedOS
+-- > _ -> unsupportedOS'
--
-- Note that the operating system specifics may not be declared for all hosts,
-- which is where Nothing comes in.
@@ -324,21 +325,18 @@ withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
dummyoutermetatypes :: OuterMetaTypesWitness ('[])
dummyoutermetatypes = OuterMetaTypesWitness sing
-class UnsupportedOS a where
- unsupportedOS :: a
+-- | A property that always fails with an unsupported OS error.
+unsupportedOS :: Property UnixLike
+unsupportedOS = property "unsupportedOS" unsupportedOS'
-- | Throws an error, for use in `withOS` when a property is lacking
-- support for an OS.
-instance UnsupportedOS (Propellor a) where
- unsupportedOS = go =<< getOS
+unsupportedOS' :: Propellor Result
+unsupportedOS' = go =<< getOS
where
go Nothing = error "Unknown host OS is not supported by this property."
go (Just o) = error $ "This property is not implemented for " ++ show o
--- | A property that always fails with an unsupported OS error.
-instance UnsupportedOS (Property UnixLike) where
- unsupportedOS = property "unsupportedOS" unsupportedOS
-
-- | Undoes the effect of a RevertableProperty.
revert :: RevertableProperty setup undo -> RevertableProperty undo setup
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 2199d950..1a15f72c 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -84,7 +84,7 @@ stdSourcesList :: Property Debian
stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
(Just (System (Debian suite) _)) ->
ensureProperty w $ stdSourcesListFor suite
- _ -> unsupportedOS
+ _ -> unsupportedOS'
stdSourcesListFor :: DebianSuite -> Property Debian
stdSourcesListFor suite = stdSourcesList' suite []
@@ -160,11 +160,11 @@ installed' params ps = robustly $ check (isInstallable ps) go
installedBackport :: [Package] -> Property Debian
installedBackport ps = withOS desc $ \w o -> case o of
(Just (System (Debian suite) _)) -> case backportSuite suite of
- Nothing -> unsupportedOS
+ Nothing -> unsupportedOS'
Just bs -> ensureProperty w $
runApt (["install", "-t", bs, "-y"] ++ ps)
`changesFile` dpkgStatus
- _ -> unsupportedOS
+ _ -> unsupportedOS'
where
desc = unwords ("apt installed backport":ps)
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index fd5f6c96..e0c56966 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -101,21 +101,12 @@ extractSuite (System (FreeBSD _) _) = Nothing
installed :: RevertableProperty Linux Linux
installed = install <!> remove
where
- install = withOS "debootstrap installed" $ \w o ->
- ifM (liftIO $ isJust <$> programPath)
- ( return NoChange
- , ensureProperty w (installon o)
- )
-
- installon (Just (System (Debian _) _)) = aptinstall
- installon (Just (System (Buntish _) _)) = aptinstall
- installon _ = sourceInstall
+ install = check (isJust <$> programPath) $
+ (aptinstall `pickOS` sourceInstall)
+ `describe` "debootstrap installed"
- remove = withOS "debootstrap removed" $ \w o ->
- ensureProperty w (removefrom o)
- removefrom (Just (System (Debian _) _)) = aptremove
- removefrom (Just (System (Buntish _) _)) = aptremove
- removefrom _ = sourceRemove
+ remove = (aptremove `pickOS` sourceRemove)
+ `describe` "debootstrap removed"
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 85d098ed..a03fc5a0 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -30,7 +30,7 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" []
-- | Installs grub; does not run update-grub.
installed' :: BIOS -> Property Linux
-installed' bios = (aptinstall `pickOS` aptinstall)
+installed' bios = (aptinstall `pickOS` unsupportedOS)
`describe` "grub package installed"
where
aptinstall :: Property DebianLike
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index 72753248..7d0a10ca 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -89,7 +89,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
debootstrap d
(Just u@(System (Buntish _) _)) -> ensureProperty w $
debootstrap u
- _ -> unsupportedOS
+ _ -> unsupportedOS'
debootstrap :: System -> Property Linux
debootstrap targetos =
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 7048de3b..369999b7 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -53,7 +53,7 @@ installed = withOS "ssh installed" $ \w o ->
in case o of
(Just (System (Debian _) _)) -> aptinstall
(Just (System (Buntish _) _)) -> aptinstall
- _ -> unsupportedOS
+ _ -> unsupportedOS'
restarted :: Property DebianLike
restarted = Service.restarted "ssh"