| Age | Commit message (Collapse) | Author |
|---|
|
|
|
added mising method in docker
|
|
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
|
|
|
|
Also, implemented modifyHostProps to add properties to an existing host.
Using it bypasses some type safety. Its use in docker is safe though.
But, in Conductor, the use of it was not really safe, because it was used
with a DebianLike property. Fixed that by making Ssh.installed
target all unix's, although it will fail on non-DebianLike ones.
|
|
It ended up specialized to Linux for a few reasons, including
inChrootProcess's use of umountLazy which is linux specific.
The ChrootBootstrapper type class is specialized to Linux for no good
reason. Future work: Support other unix's.
|
|
Renamed several utility functions along the way.
|
|
|
|
Conductor WIP
|
|
|
|
The new properties let the type checker know what the target OS is.
|
|
|
|
|
|
|
|
|
|
Ssh is WIP and failing to compile quite badly
|
|
|
|
and note that it's not meant to be used by regular users
|
|
|
|
|
|
|
|
|
|
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.
|
|
Assuming DebianLike for all these properties until I hear otherwise.
|
|
|
|
|
|
Moved to its own module to keep everything related in one place.
|
|
A few parts using ensureProperty need more work to compile
|
|
|
|
|
|
time, though retrying succeeded.
May have only been a problem on debian stable, the /var/lib/tor/keys/ was
not created by installing the package.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
We were using checkResult instead of check, and we weren't parsing the
output of `jail -l -q` properly. Now it handles respins perfectly.
|
|
|
|
|
|
|
|
where blocks involve lest nesting than let in, and are more idiomatic
in propellor properties
|
|
|
|
Made some code a little faster..
|
|
for some reason I asked the author to put the copyright in there, but
Propellor doesn't do per-file copyrights; it's all BSD. Also, make the
maintainer show up in haddock.
|
|
This is so, when a user adds a new OS, ghc tells them everywhere they
need to look to add it.
Also, avoid throwing error from pure function..
|
|
Rather than having the property fail when the Host has no OS defined,
I made bootstrapPropellorCommand not install deps in this situation.
The cron job will (probably) still work, unless a system upgrade causes
deps to be removed.
|
|
|
|
|
|
(cherry picked from commit df40046fd65bc07eced41adb73c7e227d2b54cd1)
|
