summaryrefslogtreecommitdiff
path: root/src/Propellor/Property.hs
AgeCommit message (Collapse)Author
2016-03-28propellor spinJoey Hess
2016-03-28slayed the type dragonJoey Hess
2016-03-28updateJoey Hess
2016-03-28implemented pickOSJoey Hess
Fell down the fromSing rabbit hole, followed by the OMH ghc doesh't work rabbit hole. Suboptimal.
2016-03-27improve haddocks and move code around to make them more clearJoey Hess
2016-03-27ported DiskImageJoey Hess
Unfortunately, DiskImage needs to add properties to the Chroot it's presented with, and the metatypes are not included in the Chroot, so it can't guarantee that the properties it's adding match the OS in the Chroot. I partially worked around this by making the properties that DiskImage adds check the OS, so they don't assume Debian. It would be nicer to parameterize the Chroot type with the metatypes of the inner OS. I worked for several hours on a patch along those lines, but it doesn't quite compile. Failed at the final hurdle :/ The patch is below for later.. --- src/Propellor/Property/Chroot.hs 2016-03-27 16:06:44.285464820 -0400 +++ /home/joey/Chroot.hs 2016-03-27 15:32:29.073416143 -0400 @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DataKinds #-} module Propellor.Property.Chroot ( debootstrapped, bootstrapped, - provisioned, + --provisioned, Chroot(..), ChrootBootstrapper(..), Debootstrapped(..), @@ -11,7 +11,7 @@ noServices, inChroot, -- * Internal use - provisioned', + --provisioned', propagateChrootInfo, propellChroot, chain, @@ -20,6 +20,7 @@ import Propellor.Base import Propellor.Container +import Propellor.Types.MetaTypes import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info @@ -38,27 +39,29 @@ -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. -data Chroot where - Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot - -instance IsContainer Chroot where - containerProperties (Chroot _ _ h) = containerProperties h - containerInfo (Chroot _ _ h) = containerInfo h - setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) +-- +-- The inner and outer type variables are the metatypes of the inside of +-- the chroot and the system it runs in. +data Chroot inner outer where + Chroot :: ChrootBootstrapper b inner outer => FilePath -> b -> Host -> (inner, outer) -> Chroot inner outer + +instance IsContainer (Chroot inner outer) where + containerProperties (Chroot _ _ h _) = containerProperties h + containerInfo (Chroot _ _ h _) = containerInfo h -chrootSystem :: Chroot -> Maybe System +chrootSystem :: Chroot inner outer -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo -instance Show Chroot where - show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) +instance Show (Chroot inner outer) where + show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. -class ChrootBootstrapper b where +class ChrootBootstrapper b inner outer where -- | Do initial bootstrapping of an operating system in a chroot. -- If the operating System is not supported, return -- Left error message. - buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux) + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property outer) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -68,9 +71,8 @@ -- detect automatically. data ChrootTarball = ChrootTarball FilePath -instance ChrootBootstrapper ChrootTarball where - buildchroot (ChrootTarball tb) _ loc = Right $ - tightenTargets $ extractTarball loc tb +instance ChrootBootstrapper ChrootTarball UnixLike UnixLike where + buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb extractTarball :: FilePath -> FilePath -> Property UnixLike extractTarball target src = check (unpopulated target) $ @@ -88,7 +90,7 @@ -- | Use this to bootstrap a chroot with debootstrap. data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig -instance ChrootBootstrapper Debootstrapped where +instance ChrootBootstrapper Debootstrapped DebianLike Linux where buildchroot (Debootstrapped cf) system loc = case system of (Just s@(System (Debian _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s @@ -107,13 +109,22 @@ -- > & osDebian Unstable "amd64" -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... -debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot +-- debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot DebianLike +debootstrapped + :: (SingI inner, SingI outer, ChrootBootstrapper Debootstrapped (MetaTypes inner) (MetaTypes outer)) + => Debootstrap.DebootstrapConfig + -> FilePath + -> Chroot (MetaTypes inner) (MetaTypes outer) debootstrapped conf = bootstrapped (Debootstrapped conf) -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper. -bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot -bootstrapped bootstrapper location = Chroot location bootstrapper h +bootstrapped + :: (SingI inner, SingI outer, ChrootBootstrapper b (MetaTypes inner) (MetaTypes outer)) + => b + -> FilePath + -> Chroot (MetaTypes inner) (MetaTypes outer) +bootstrapped bootstrapper location = Chroot location bootstrapper h (sing, sing) where h = Host location [] mempty @@ -123,45 +134,79 @@ -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. -provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux +-- provisioned :: SingI outer => Chroot inner outer -> RevertableProperty (HasInfo + MetaTypes outer) Linux +provisioned + :: + ( SingI outer + , SingI metatypes + , Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + , (HasInfo + outer) ~ MetaTypes metatypes + , CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer + , IncludesInfo (MetaTypes metatypes) ~ 'True) + => Chroot inner outer -> RevertableProperty (HasInfo + outer) Linux provisioned c = provisioned' (propagateChrootInfo c) c False provisioned' - :: (Property Linux -> Property (HasInfo + Linux)) - -> Chroot + :: + ( Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + , CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer + , SingI outer + ) + => (Property outer -> Property (HasInfo + outer)) + -> Chroot inner outer -> Bool - -> RevertableProperty (HasInfo + Linux) Linux -provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = - (propigator $ setup `describe` chrootDesc c "exists") + -> RevertableProperty (HasInfo + outer) Linux +provisioned' propigator c systemdonly = + (propigator $ setup c systemdonly `describe` chrootDesc c "exists") <!> - (teardown `describe` chrootDesc c "removed") - where - setup :: Property Linux - setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly - `requires` built - - built = case buildchroot bootstrapper (chrootSystem c) loc of - Right p -> p - Left e -> cantbuild e - - cantbuild e = property (chrootDesc c "built") (error e) - - teardown :: Property Linux - teardown = check (not <$> unpopulated loc) $ - property ("removed " ++ loc) $ - makeChange (removeChroot loc) - -propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) -propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `addInfoProperty` chrootInfo c + (teardown c `describe` chrootDesc c "removed") -chrootInfo :: Chroot -> Info -chrootInfo (Chroot loc _ h) = mempty `addInfo` +-- chroot removal code is currently linux specific.. +teardown :: Chroot inner outer -> Property Linux +teardown (Chroot loc _ _ _) = check (not <$> unpopulated loc) $ + property ("removed " ++ loc) $ + makeChange (removeChroot loc) + +setup + :: + ( SingI outer + , Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + ) + => Chroot inner outer + -> Bool + -> CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) +setup c systemdonly = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly + `requires` built c + +built :: (SingI outer, ChrootBootstrapper b inner outer) => Chroot inner outer -> Property (MetaTypes outer) +built c@(Chroot loc bootstrapper _ _) = + case buildchroot bootstrapper (chrootSystem c) loc of + Right p -> error "FOO" -- p + Left e -> error "FOO" -- cantbuild c e + +cantbuild :: Chroot inner outer -> String -> Property UnixLike +cantbuild c e = property (chrootDesc c "built") (error e) + +propagateChrootInfo + :: + ( SingI metatypes + , (HasInfo + outer) ~ MetaTypes metatypes + , IncludesInfo (MetaTypes metatypes) ~ 'True + ) + => Chroot inner outer + -> Property outer + -> Property (MetaTypes metatypes) +propagateChrootInfo c@(Chroot location _ _ _) p = + propagateContainer location c $ + p `addInfoProperty` chrootInfo c + +chrootInfo :: Chroot inner outer -> Info +chrootInfo (Chroot loc _ h _) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. -propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike -propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do +propellChroot :: SingI outer => Chroot inner outer -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property (MetaTypes outer) +propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir </> shimdir c let me = localdir </> "propellor" shim <- liftIO $ ifM (doesDirectoryExist d) @@ -199,8 +244,8 @@ liftIO cleanup return r -toChain :: HostName -> Chroot -> Bool -> IO CmdLine -toChain parenthost (Chroot loc _ _) systemdonly = do +toChain :: HostName -> Chroot inner outer -> Bool -> IO CmdLine +toChain parenthost (Chroot loc _ _ _) systemdonly = do onconsole <- isConsole <$> getMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole @@ -224,8 +269,8 @@ putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" -inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) -inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do +inChrootProcess :: Bool -> Chroot inner outer -> [String] -> IO (CreateProcess, IO ()) +inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do mountproc return (proc "chroot" (loc:cmd), cleanup) where @@ -244,26 +289,24 @@ provisioningLock :: FilePath -> FilePath provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock" -shimdir :: Chroot -> FilePath -shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim" +shimdir :: Chroot inner outer -> FilePath +shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim" mungeloc :: FilePath -> String mungeloc = replace "/" "_" -chrootDesc :: Chroot -> String -> String -chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc +chrootDesc :: Chroot inner outer -> String -> String +chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc
2016-03-25cleanup warningsJoey Hess
2016-03-25ported Property.AptJoey Hess
2016-03-25finished porting Property.UserJoey Hess
2016-03-25ported Property.ListJoey Hess
I wanted to keep propertyList [foo, bar] working, but had some difficulty making the type class approach work. Anyway, that's unlikely to be useful, since foo and bar probably have different types, or could easiy have their types updated breaking it.
2016-03-25fix warningsJoey Hess
2016-03-25add type alias for Sing to be less confusing for usersJoey Hess
2016-03-24add tightenTargets, ported Network properties (DebinLike only)Joey Hess
2016-03-24convert ensurePropertyJoey Hess
Moved to its own module to keep everything related in one place.
2016-03-24partially converted; a few things commented out for nowJoey Hess
2016-03-07add unsupportedOSJoey Hess
2016-02-25FooBuntu -> BuntishJoey Hess
Seems that Canonical have trademarked numerous words ending in "buntu", and would like to trademark anything ending in that to the extent their lawyers can make that happen.
2016-02-19trademark nonsenseJoey Hess
Removed references to *buntu from code and documentation because of an unfortunate trademark use policy. http://joeyh.name/blog/entry/trademark_nonsense/ That included changing a data constructor to "FooBuntu", an API change.
2015-12-19Clean build with ghc 7.10.Joey Hess
Import Prelude after modules that cause warnings due to AMP change
2015-12-06allow using `check` on a UncheckedProperty, which yields a PropertyJoey Hess
2015-12-06add isNewerThan and use it to avoid unnecessary running of newaliasesJoey Hess
2015-12-06setting the same sasl password updates the mtime of the file, but the ↵Joey Hess
contents remain the same Don't much like using Data.Hash.MD5, but it's available in dependencies and pulling in a real hash library would be overkill. And md5 is a perfectly ok hash to use here.
2015-12-05remove trivialJoey Hess
2015-12-05UncheckedProperty for cmdProperty et alJoey Hess
* Properties that run an arbitrary command, such as cmdProperty and scriptProperty are converted to use UncheckedProperty, since they cannot tell on their own if the command truely made a change or not. (API Change) Transition guide: - When GHC complains about an UncheckedProperty, add: `assume` MadeChange - Since these properties used to always return MadeChange, that change is always safe to make. - Or, if you know that the command should modifiy a file, use: `changesFile` filename * A few properties have had their Result improved, for example Apt.buldDep and Apt.autoRemove now check if a change was made or not.
2015-12-05Added UncheckedProperty type, along with unchecked to indicate a Property ↵Joey Hess
needs its result checked, and checkResult and changesFile to check for changes.
2015-11-26Added changesFile property combinator.Joey Hess
2015-10-27Explicit Info/NoInfo for RevertableProperty (API change)Joey Hess
RevertableProperty used to be assumed to contain info, but this is now made explicit, with RevertableProperty HasInfo or RevertableProperty NoInfo. Transition guide: - If you define a RevertableProperty, expect some type check failures like: "Expecting one more argument to ‘RevertableProperty’". - Change it to "RevertableProperty NoInfo" - The compiler will then tell you if it needs "HasInfo" instead. - If you have code that uses the RevertableProperty constructor that fails to type check, use the more powerful <!> operator
2015-10-24improve RevertableProperty combiningJoey Hess
* Various property combinators that combined a RevertableProperty with a non-revertable property used to yield a RevertableProperty. This was a bug, because the combined property could not be fully reverted in many cases. Fixed by making the combined property instead be a Property HasInfo. * combineWith now takes an addional parameter to control how revert actions are combined (API change).
2015-10-23generalize checkJoey Hess
Hmm, do I really need my own type class for LiftPropellor? This seems like a general problem so I am probably reinventing the wheel.
2015-10-10example for withOSJoey Hess
2015-10-10improve docs in Propellor.PropertyJoey Hess
2015-10-10propellor spinJoey Hess
2015-10-10tighten focus of Propellor module, adding Propellor.Base for all the exportsJoey Hess
2015-10-10Improved documentation, particularly of the Propellor module.Joey Hess
This involved some code changes, including some renaming of instance methods. (ABI change)
2015-09-13Follow some hlint suggestions.Mario Lang
2015-07-21languageJoey Hess
2015-07-21fix layout to meet styleJoey Hess
2015-07-21remove caution commentJoey Hess
I think this was inherited from flagFile, but the reasons to use caution when using flagFile (that it makes code to satisfy a property only run once) don't apply when using onChangeFlagOnFail.
2015-07-21Add operator onChangeFlagOnFail.Antoine Eiche
It seems like `onChange` except that if property y fails, a flag file is generated. On next runs, if the flag file is present, property y is executed even if property x doesn't change. With `onChange`, if y fails, the property x `onChange` y returns `FailedChange`. But if this property is applied again, it returns `NoChange`. This behavior can cause trouble...
2015-01-25improve docsJoey Hess
2015-01-24fix typoJoey Hess
2015-01-24GADT properties seem to work (untested)Joey Hess
* Property has been converted to a GADT, and will be Property NoInfo or Property HasInfo. This was done to make sure that ensureProperty is only used on properties that do not have Info. Transition guide: - Change all "Property" to "Property NoInfo" or "Property WithInfo" (The compiler can tell you if you got it wrong!) - To construct a RevertableProperty, it is useful to use the new (<!>) operator - Constructing a list of properties can be problimatic, since Property NoInto and Property WithInfo are different types and cannot appear in the same list. To deal with this, "props" has been added, and can built up a list of properties of different types, using the same (&) and (!) operators that are used to build up a host's properties.
2015-01-24added GADT to determine between a property with info and withoutJoey Hess
Not yet used
2015-01-19Fix info propigation from fallback combinator's second Property.Joey Hess
2015-01-18Property treeJoey Hess
Properties now form a tree, instead of the flat list used before. This simplifies propigation of Info from the Properties used inside a container to the outer host; the Property that docks the container on the host can just have as child properties all the inner Properties, and their Info can then be gathered recursively. (Although in practice it still needs to be filtered, since not all Info should propigate out of a container.) Note that there is no change to how Properties are actually satisfied. Just because a Property lists some child properties, this does not mean they always have their propertySatisfy actions run. It's still up to the parent property to run those actions. That's necessary so that a container's properties can be satisfied inside it, not outside. It also allows property combinators to add the combined Properties to their childProperties list, even if, like onChange, they don't always run the child properties at all. Testing: I tested that the exact same Info is calculated before and after this change, for every Host in my config file.
2015-01-04DNS WIPJoey Hess
2014-12-08propellor spinJoey Hess
(cherry picked from commit 1d02d589c79781cc4b0bd82467edbdf64c40f34d)
2014-12-06Reboot.atEndJoey Hess
2014-12-06endAction can be used to register an action to run once propellor has ↵Joey Hess
successfully run on a host.
2014-11-20incomplete systemd container supportJoey Hess