summaryrefslogtreecommitdiff
path: root/src/Propellor/Types
AgeCommit message (Collapse)Author
2016-06-20add DeriveDataTypeable extension to ExceptionFélix Sipma
2016-06-13add DebianKernel datatypeFélix Sipma
(cherry picked from commit 3590a1241580ddcdd153e2619a3c02ce18a8db8c but without the changes to src/Propellor/Precompiled.hs)
2016-06-13remove ANDROID in architectureToDebianArchStringFélix Sipma
(cherry picked from commit 39966bc40c7a15543601e417e35fbb5c6bc1d5c4)
2016-06-13remove ANDROIDJoey Hess
(cherry picked from commit d5d42f4fb51fee4e5eb2e17d82f1339876c8fc03)
2016-06-13reformat Architecture definitionFélix Sipma
(cherry picked from commit 1f036a1448c7a7332080c28c5074d9c06e69806b)
2016-06-13add several ArchitecturesJoey Hess
Cherry-picked from aa8e99c305a07d99cc63e17ca3461f421859bdc5, but without changes to a module that is being added on the precompiled branch.
2016-06-13convert Architecture to a sumtypeFélix Sipma
TODO: remove ANDROID (used in GitAnnexBuilder) TODO: add other architectures TODO: rename ARMHF TODO: rename ARMEL (cherry picked from commit 6f36f6cade4e1d8b15c714565e223562c6573099)
2016-06-13add stopPropellorMessageJoey Hess
2016-05-07Compiling propellor on GHC 8.0.1-rc4davean
ConstrainedClassMethods was added in GHC 7.6.1.3 so I think its sufficiently backwards compatible for you?
2016-05-01Remove Propellor.DotDir from the propellor library, as its use of ↵Joey Hess
Paths_propellor prevents use of the module out of propellor's tree. Failure looked like: /home/lukas/.propellor/.cabal-sandbox/lib/x86_64-linux-ghc-7.10.3/propellor-3.0. 1-0JokOieT9kY9W7enKSzFHh/libHSpropellor-3.0.1-0JokOieT9kY9W7enKSzFHh.a(DotDir.o) :(.text+0x591): undefined reference to `propezu0JokOieT9kY9W7enKSzzFHh_Pathszupropellor_getLibDir_closure' This module is only needed for the wrapper program anyway, which handles --init. This does mean that ./propellor --init in propellor's tree will fail even though the help shows --init as an option.
2016-04-01separate propellor --initJoey Hess
2016-03-30show childProperty same as propertyJoey 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-27split out singletons libJoey 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-27refactorJoey Hess
2016-03-26ported propagateContainerJoey Hess
Renamed several utility functions along the way.
2016-03-25cleanup warningsJoey Hess
2016-03-25continued portingJoey Hess
2016-03-25ported Property.AptJoey Hess
2016-03-25fix CheckCombinableJoey Hess
Was wrong when there was a non-target in the MetaTypes list. Also, rework to improve type checker errors.
2016-03-25use MetaTypes moreJoey Hess
2016-03-25add type alias for Sing to be less confusing for usersJoey Hess
2016-03-24fix combineWith to only accept properties that have common targetsJoey Hess
2016-03-24fix bug in NonTargets implJoey Hess
2016-03-24convert ensurePropertyJoey Hess
Moved to its own module to keep everything related in one place.
2016-03-24IncludesInfoJoey Hess
2016-03-24refactorJoey Hess
2016-03-241st stage integrating MetaTypesJoey Hess
2016-03-24renameJoey Hess
2016-03-24temporarily remove UsedPortJoey Hess
This can come back later as a full Resource data type. For now, I want to focus on merging what I have working.
2016-03-24fix exportJoey Hess
2016-03-20flip to modern versionJoey Hess
2016-03-20rename for consistency with singletons libraryJoey Hess
2016-03-20really bad implementation of type level OS detectionJoey Hess
2016-03-20use + rather than :+: type operatorJoey Hess
This seems to not overlap with the + function and is nicer to read and write
2016-03-20rename moduleJoey Hess
2016-03-20renameJoey Hess
2016-03-20fix tick warningJoey Hess
2016-03-20cleanupJoey Hess
2016-03-20finished conversion to singletonsJoey Hess
2016-03-20fix tightenTargetsJoey Hess
2016-03-19wipJoey Hess
2016-03-19wipJoey Hess
2016-03-19typoJoey Hess
2016-03-19haddockJoey Hess
2016-03-19fix type errorJoey Hess
2016-03-18wipJoey Hess
2016-03-18wipJoey Hess
Converted to singletons. Type level functions not updated yet.