From 67f4a35f08caff9efd5ec930943a02217188cc79 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 02:28:08 -0400 Subject: implemented pickOS Fell down the fromSing rabbit hole, followed by the OMH ghc doesh't work rabbit hole. Suboptimal. --- src/Propellor/Property.hs | 77 +++++++++++++++++++++++++++++++-------- src/Propellor/Types/MetaTypes.hs | 10 ++++- src/Propellor/Types/OS.hs | 8 +++- src/Propellor/Types/Singletons.hs | 36 +++++++++++++++++- 4 files changed, 111 insertions(+), 20 deletions(-) (limited to 'src/Propellor') 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 -- cgit v1.2.3