propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

Bootstrap.hs (5348B)


      1 -- | This module contains properties that configure how Propellor
      2 -- bootstraps to run itself on a Host.
      3 
      4 module Propellor.Property.Bootstrap (
      5 	Bootstrapper(..),
      6 	Builder(..),
      7 	bootstrapWith,
      8 	RepoSource(..),
      9 	bootstrappedFrom,
     10 	clonedFrom
     11 ) where
     12 
     13 import Propellor.Base
     14 import Propellor.Bootstrap
     15 import Propellor.Types.Info
     16 import Propellor.Types.Container
     17 import Propellor.Property.Chroot
     18 import Propellor.PrivData.Paths
     19 
     20 import Data.List
     21 import qualified Data.ByteString as B
     22 
     23 -- | This property can be used to configure the `Bootstrapper` that is used
     24 -- to bootstrap propellor on a Host. For example, if you want to use
     25 -- stack:
     26 --
     27 -- > host "example.com" $ props
     28 -- > 	& bootstrapWith (Robustly Stack)
     29 --
     30 -- When `bootstrappedFrom` is used in a `Chroot` or other `Container`, 
     31 -- this property can also be added to the chroot to configure it.
     32 bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike)
     33 bootstrapWith b = pureInfoProperty desc (InfoVal b)
     34   where
     35 	desc = "propellor bootstrapped with " ++ case b of
     36 		Robustly Stack -> "stack"
     37 		Robustly Cabal -> "cabal"
     38 		OSOnly -> "OS packages only"
     39 
     40 -- | Where a propellor repository should be bootstrapped from.
     41 data RepoSource
     42 	= GitRepoUrl String
     43 	| GitRepoOutsideChroot
     44 	-- ^ When used in a chroot, this copies the git repository from
     45 	-- outside the chroot, including its configuration.
     46 
     47 -- | Bootstraps a propellor installation into
     48 -- /usr/local/propellor/
     49 --
     50 -- Normally, propellor is bootstrapped by eg, using propellor --spin,
     51 -- and so this property is not generally needed.
     52 --
     53 -- This property only does anything when used inside a Chroot or other
     54 -- Container. This is particularly useful inside a chroot used to build a
     55 -- disk image, to make the disk image have propellor installed.
     56 --
     57 -- The git repository is cloned (or pulled to update if it already exists).
     58 --
     59 -- All build dependencies are installed, using distribution packages
     60 -- or falling back to using cabal or stack.
     61 bootstrappedFrom :: RepoSource -> Property Linux
     62 bootstrappedFrom reposource = check (hasContainerCapability FilesystemContained) $
     63 	go `requires` clonedFrom reposource
     64   where
     65 	go :: Property Linux
     66 	go = property "Propellor bootstrapped" $ do
     67 		system <- getOS
     68 		-- gets Host value representing the chroot this is run in
     69 		chroothost <- ask
     70 		-- load privdata from outside the chroot, and filter
     71 		-- to only the privdata needed inside the chroot.
     72 		privdata <- liftIO $ filterPrivData chroothost
     73 			<$> readPrivDataFile privDataLocal
     74 		bootstrapper <- getBootstrapper
     75 		assumeChange $ exposeTrueLocaldir $ const $ do
     76 			liftIO $ createDirectoryIfMissing True $
     77 				takeDirectory privDataLocal
     78 			liftIO $ writeFileProtected privDataLocal $
     79 				show privdata
     80 			runShellCommand $ buildShellCommand
     81 				[ "cd " ++ localdir
     82 				, checkDepsCommand bootstrapper system
     83 				, buildCommand bootstrapper
     84 				]
     85 
     86 -- | Clones the propellor repository into /usr/local/propellor/
     87 --
     88 -- If the propellor repo has already been cloned, pulls to get it
     89 -- up-to-date.
     90 clonedFrom :: RepoSource -> Property Linux
     91 clonedFrom reposource = case reposource of
     92 	GitRepoOutsideChroot -> go `onChange` copygitconfig
     93 	_ -> go
     94   where
     95 	go :: Property Linux
     96 	go = property ("Propellor repo cloned from " ++ sourcedesc) $
     97 		ifM needclone (makeclone, updateclone)
     98 	
     99 	makeclone = do
    100 		let tmpclone = localdir ++ ".tmpclone"
    101 		system <- getOS
    102 		assumeChange $ exposeTrueLocaldir $ \sysdir -> do
    103 			let originloc = case reposource of
    104 				GitRepoUrl s -> s
    105 				GitRepoOutsideChroot -> sysdir
    106 			runShellCommand $ buildShellCommand
    107 				[ installGitCommand system
    108 				, "rm -rf " ++ tmpclone
    109 				, "git clone " ++ shellEscape originloc ++ " " ++ tmpclone
    110 				, "mkdir -p " ++ localdir
    111 				-- This is done rather than deleting
    112 				-- the old localdir, because if it is bound
    113 				-- mounted from outside the chroot, deleting
    114 				-- it after unmounting in unshare will remove
    115 				-- the bind mount outside the unshare.
    116 				, "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)"
    117 				, "rm -rf " ++ tmpclone
    118 				]
    119 	
    120 	updateclone = assumeChange $ exposeTrueLocaldir $ const $
    121 		runShellCommand $ buildShellCommand
    122 			[ "cd " ++ localdir
    123 			, "git pull"
    124 			]
    125 	
    126 	-- Copy the git config of the repo outside the chroot into the
    127 	-- chroot. This way it has the same remote urls, and other git
    128 	-- configuration.
    129 	copygitconfig :: Property Linux
    130 	copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do
    131 		let gitconfig = localdir </> ".git" </> "config"
    132 		cfg <- liftIO $ B.readFile gitconfig
    133 		exposeTrueLocaldir $ const $
    134 			liftIO $ B.writeFile gitconfig cfg
    135 		return MadeChange
    136 
    137 	needclone = (hasContainerCapability FilesystemContained <&&> truelocaldirisempty)
    138 		<||> (liftIO (not <$> doesDirectoryExist localdir))
    139 	
    140 	truelocaldirisempty = exposeTrueLocaldir $ const $
    141 		runShellCommand ("test ! -d " ++ localdir ++ "/.git")
    142 
    143 	sourcedesc = case reposource of
    144 		GitRepoUrl s -> s
    145 		GitRepoOutsideChroot -> localdir ++ " outside the chroot"
    146 
    147 assumeChange :: Propellor Bool -> Propellor Result
    148 assumeChange a = do
    149 	ok <- a
    150 	return (cmdResult ok <> MadeChange)
    151 
    152 buildShellCommand :: [String] -> String
    153 buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")")
    154 
    155 runShellCommand :: String -> Propellor Bool
    156 runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s]