summaryrefslogtreecommitdiff
path: root/src
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
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')
-rw-r--r--src/Propellor/Property.hs77
-rw-r--r--src/Propellor/Types/MetaTypes.hs10
-rw-r--r--src/Propellor/Types/OS.hs8
-rw-r--r--src/Propellor/Types/Singletons.hs36
4 files changed, 111 insertions, 20 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
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index 39d6e725..e064d76f 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -23,6 +23,7 @@ module Propellor.Types.MetaTypes (
type (&&),
Not,
EqT,
+ Union,
) where
import Propellor.Types.Singletons
@@ -31,6 +32,7 @@ import Propellor.Types.OS
data MetaType
= Targeting TargetOS -- ^ A target OS of a Property
| WithInfo -- ^ Indicates that a Property has associated Info
+ deriving (Show, Eq, Ord)
-- | Any unix-like system
type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ]
@@ -50,7 +52,7 @@ type instance IncludesInfo (MetaTypes l) = Elem 'WithInfo l
type MetaTypes = Sing
--- This boilerplatw would not be needed if the singletons library were
+-- This boilerplate would not be needed if the singletons library were
-- used. However, we're targeting too old a version of ghc to use it yet.
data instance Sing (x :: MetaType) where
OSDebianS :: Sing ('Targeting 'OSDebian)
@@ -61,6 +63,12 @@ instance SingI ('Targeting 'OSDebian) where sing = OSDebianS
instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS
instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS
instance SingI 'WithInfo where sing = WithInfoS
+instance SingKind ('KProxy :: KProxy MetaType) where
+ type DemoteRep ('KProxy :: KProxy MetaType) = MetaType
+ fromSing OSDebianS = Targeting OSDebian
+ fromSing OSBuntishS = Targeting OSBuntish
+ fromSing OSFreeBSDS = Targeting OSFreeBSD
+ fromSing WithInfoS = WithInfo
-- | Convenience type operator to combine two `MetaTypes` lists.
--
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 84c9d87b..d7df5490 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -17,6 +17,7 @@ module Propellor.Types.OS (
userGroup,
Port(..),
fromPort,
+ systemToTargetOS,
) where
import Network.BSD (HostName)
@@ -39,7 +40,12 @@ data TargetOS
= OSDebian
| OSBuntish
| OSFreeBSD
- deriving (Show, Eq)
+ deriving (Show, Eq, Ord)
+
+systemToTargetOS :: System -> TargetOS
+systemToTargetOS (System (Debian _) _) = OSDebian
+systemToTargetOS (System (Buntish _) _) = OSBuntish
+systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD
-- | Debian has several rolling suites, and a number of stable releases,
-- such as Stable "jessie".
diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs
index be777ecb..f2089ee8 100644
--- a/src/Propellor/Types/Singletons.hs
+++ b/src/Propellor/Types/Singletons.hs
@@ -1,6 +1,17 @@
-{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs #-}
+{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, UndecidableInstances #-}
-module Propellor.Types.Singletons where
+-- | Simple implementation of singletons, portable back to ghc 7.6.3
+
+module Propellor.Types.Singletons (
+ module Propellor.Types.Singletons,
+ KProxy(..)
+) where
+
+#if __GLASGOW_HASKELL__ > 707
+import Data.Proxy (KProxy(..))
+#else
+data KProxy (a :: *) = KProxy
+#endif
-- | The data family of singleton types.
data family Sing (x :: k)
@@ -15,3 +26,24 @@ data instance Sing (x :: [k]) where
Cons :: Sing x -> Sing xs -> Sing (x ': xs)
instance (SingI x, SingI xs) => SingI (x ': xs) where sing = Cons sing sing
instance SingI '[] where sing = Nil
+
+data instance Sing (x :: Bool) where
+ TrueS :: Sing 'True
+ FalseS :: Sing 'False
+instance SingI 'True where sing = TrueS
+instance SingI 'False where sing = FalseS
+
+class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where
+ type DemoteRep kparam :: *
+ -- | From singleton to value.
+ fromSing :: Sing (a :: k) -> DemoteRep kparam
+
+instance SingKind ('KProxy :: KProxy a) => SingKind ('KProxy :: KProxy [a]) where
+ type DemoteRep ('KProxy :: KProxy [a]) = [DemoteRep ('KProxy :: KProxy a)]
+ fromSing Nil = []
+ fromSing (Cons x xs) = fromSing x : fromSing xs
+
+instance SingKind ('KProxy :: KProxy Bool) where
+ type DemoteRep ('KProxy :: KProxy Bool) = Bool
+ fromSing FalseS = False
+ fromSing TrueS = True