summaryrefslogtreecommitdiff
path: root/src/Propellor/Property.hs
diff options
context:
space:
mode:
authorJoey Hess2016-03-28 02:28:08 -0400
committerJoey Hess2016-03-28 02:28:08 -0400
commit67f4a35f08caff9efd5ec930943a02217188cc79 (patch)
tree5b1a9a5ba2dbdcd7897d65ccfeb8fd702f54266f /src/Propellor/Property.hs
parentaf7b2d61c0c7f9b4fe53d8f5d18b5426a93cbd7b (diff)
implemented pickOS
Fell down the fromSing rabbit hole, followed by the OMH ghc doesh't work rabbit hole. Suboptimal.
Diffstat (limited to 'src/Propellor/Property.hs')
-rw-r--r--src/Propellor/Property.hs77
1 files changed, 61 insertions, 16 deletions
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 29a8ec0f..10730710 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -1,8 +1,11 @@
{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Propellor.Property (
-- * Property combinators
@@ -24,6 +27,7 @@ module Propellor.Property (
, property'
, OuterMetaTypesWitness
, ensureProperty
+ , pickOS
, withOS
, unsupportedOS
, makeChange
@@ -49,6 +53,7 @@ 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 Control.Applicative
import Prelude
@@ -56,6 +61,7 @@ import Propellor.Types
import Propellor.Types.Core
import Propellor.Types.ResultCheck
import Propellor.Types.MetaTypes
+import Propellor.Types.Singletons
import Propellor.Info
import Propellor.EnsureProperty
import Utility.Exception
@@ -244,28 +250,60 @@ isNewerThan x y = do
where
mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f
-{-
-
-- | Picks one of the two input properties to use,
-- depending on the targeted OS.
--
-- If both input properties support the targeted OS, then the
-- first will be used.
+--
+-- The resulting property will use the description of the first property
+-- no matter which property is used in the end. So, it's often a good
+-- idea to change the description to something clearer.
+--
+-- For example:
+--
+-- > upgraded :: UnixLike
+-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded)
+-- > `describe` "OS upgraded"
+--
+-- If neither input property supports the targeted OS, calls
+-- `unsupportedOS`. Using the example above on a Fedora system would
+-- fail that way.
+--
+-- (It would be better if this constrained its return type to the Union
+-- of the targets of the inputs, but that does not seems to currently
+-- be possible with ghc.)
+{- For some reason, ghc does not like this type signature, or indeed the
+ - version of this that it emits. But this does compile! Until a type
+ - signature can be written down, cannot add the Union constraint.
+ - http://stackoverflow.com/questions/36256557/what-is-the-type-of-matches-m-s-m-fromsing-s
pickOS
::
- ( combined ~ Union a b
- , SingI combined
+ ( Union a b ~ c
+ , SingI c
+ , DemoteRep 'KProxy ~ [MetaType]
)
=> Property (MetaTypes a)
-> Property (MetaTypes b)
- -> Property (MetaTypes combined)
-pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io
- where
- -- TODO pick with of ioa or iob to use based on final OS of
- -- system being run on.
- io = undefined
-
+ -> Property (MetaTypes c)
-}
+pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
+ where
+ -- This use of getSatisfy is safe, because both a and b
+ -- are added as children, so their info will propigate.
+ --c :: (SingI c, Union a b ~ c) => Property (MetaTypes a) -> Property (MetaTypes b) -> Property (MetaTypes c)
+ c = withOS (getDesc a) $ \_ o ->
+ if matching o a
+ then getSatisfy a
+ else if matching o b
+ then getSatisfy b
+ else unsupportedOS
+ matching Nothing _ = False
+ matching (Just o) p =
+ Targeting (systemToTargetOS o)
+ `elem`
+ fromSing (proptype p)
+ proptype (Property t _ _ _ _) = t
-- | Makes a property that is satisfied differently depending on specifics
-- of the host's operating system.
@@ -291,13 +329,20 @@ withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
dummyoutermetatypes :: OuterMetaTypesWitness ('[])
dummyoutermetatypes = OuterMetaTypesWitness sing
+class UnsupportedOS a where
+ unsupportedOS :: a
+
-- | Throws an error, for use in `withOS` when a property is lacking
-- support for an OS.
-unsupportedOS :: Propellor a
-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
+instance UnsupportedOS (Propellor a) where
+ 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