{-# LANGUAGE TypeFamilies #-}
module Propellor.Property.Debootstrap (
Url,
DebootstrapConfig(..),
built,
built',
extractSuite,
installed,
sourceInstall,
) where
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Chroot.Util
import Propellor.Property.Qemu
import Utility.Path
import Utility.FileMode
import Data.List
import Data.Char
import qualified Data.Semigroup as Sem
import System.Posix.Directory
import System.Posix.Files
type Url = String
data DebootstrapConfig
= DefaultConfig
| MinBase
| BuilddD
| DebootstrapParam String
| UseEmulation
| DebootstrapConfig :+ DebootstrapConfig
deriving (Show)
instance Sem.Semigroup DebootstrapConfig where
(<>) = (:+)
instance Monoid DebootstrapConfig where
mempty = DefaultConfig
mappend = (Sem.<>)
toParams :: DebootstrapConfig -> [CommandParam]
toParams DefaultConfig = []
toParams MinBase = [Param "--variant=minbase"]
toParams BuilddD = [Param "--variant=buildd"]
toParams (DebootstrapParam p) = [Param p]
toParams UseEmulation = []
toParams (c1 :+ c2) = toParams c1 <> toParams c2
useEmulation :: DebootstrapConfig -> Bool
useEmulation UseEmulation = True
useEmulation (a :+ b) = useEmulation a || useEmulation b
useEmulation _ = False
built :: FilePath -> System -> DebootstrapConfig -> Property Linux
built target system@(System _ targetarch) config =
withOS ("debootstrapped " ++ target) go
where
go w (Just hostos)
| supportsArch hostos targetarch && not (useEmulation config) =
ensureProperty w $
built' (setupRevertableProperty installed)
target system config
go w _ = ensureProperty w $ do
let p = setupRevertableProperty foreignBinariesEmulated
`before` setupRevertableProperty installed
built' p target system (config :+ UseEmulation)
built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
built' installprop target system@(System _ arch) config =
go `before` oldpermfix
where
go = check (isUnpopulated target <||> ispartial) setupprop
`requires` installprop
setupprop :: Property Linux
setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
createDirectoryIfMissing True target
suite <- case extractSuite system of
Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system
Just s -> pure s
let params = toParams config ++
[ Param $ "--arch=" ++ architectureToDebianArchString arch
, Param suite
, Param target
]
cmd <- if useEmulation config
then pure "qemu-debootstrap"
else fromMaybe "debootstrap" <$> programPath
de <- standardPathEnv
ifM (boolSystemEnv cmd params (Just de))
( return MadeChange
, return FailedChange
)
ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
( do
removeChroot target
return True
, return False
)
oldpermfix :: Property Linux
oldpermfix = property ("fixed old chroot file mode") $ do
liftIO $ modifyFileMode target $
addModes [otherReadMode, otherExecuteMode]
return NoChange
extractSuite :: System -> Maybe String
extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s
extractSuite (System (Buntish r) _) = Just r
extractSuite (System (ArchLinux) _) = Nothing
extractSuite (System (FreeBSD _) _) = Nothing
installed :: RevertableProperty Linux Linux
installed = install <!> remove
where
install = check (isNothing <$> programPath) $
(aptinstall `pickOS` sourceInstall)
`describe` "debootstrap installed"
remove = (aptremove `pickOS` sourceRemove)
`describe` "debootstrap removed"
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
sourceInstall :: Property Linux
sourceInstall = go
`requires` perlInstalled
`requires` arInstalled
where
go :: Property Linux
go = property "debootstrap installed from source" (liftIO sourceInstall')
perlInstalled :: Property Linux
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "perl"
]
arInstalled :: Property Linux
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "binutils"
]
yumInstall :: String -> IO Bool
yumInstall p = boolSystem "yum" [Param "-y", Param "install", Param p]
sourceInstall' :: IO Result
sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
let indexfile = tmpd </> "index.html"
unlessM (download baseurl indexfile) $
errorMessage $ "Failed to download " ++ baseurl
urls <- sortBy (flip compare)
. filter ("debootstrap_" `isInfixOf`)
. filter (".tar." `isInfixOf`)
. extractUrls baseurl <$>
readFileStrict indexfile
nukeFile indexfile
tarfile <- case urls of
(tarurl:_) -> do
let f = tmpd </> takeFileName tarurl
unlessM (download tarurl f) $
errorMessage $ "Failed to download " ++ tarurl
return f
_ -> errorMessage $ "Failed to find any debootstrap tarballs listed on " ++ baseurl
createDirectoryIfMissing True localInstallDir
bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do
changeWorkingDirectory localInstallDir
unlessM (boolSystem "tar" [Param "xf", File tarfile]) $
errorMessage "Failed to extract debootstrap tar file"
nukeFile tarfile
l <- dirContents "."
case l of
(subdir:[]) -> do
changeWorkingDirectory subdir
makeWrapperScript (localInstallDir </> subdir)
return MadeChange
_ -> errorMessage "debootstrap tar file did not contain exactly one directory"
sourceRemove :: Property Linux
sourceRemove = property "debootstrap not installed from source" $ liftIO $
ifM (doesDirectoryExist sourceInstallDir)
( do
removeDirectoryRecursive sourceInstallDir
return MadeChange
, return NoChange
)
sourceInstallDir :: FilePath
sourceInstallDir = "/usr/local/propellor/debootstrap"
wrapperScript :: FilePath
wrapperScript = sourceInstallDir </> "debootstrap.wrapper"
programPath :: IO (Maybe FilePath)
programPath = getM searchPath
[ "debootstrap"
, wrapperScript
]
makeWrapperScript :: FilePath -> IO ()
makeWrapperScript dir = do
createDirectoryIfMissing True (takeDirectory wrapperScript)
writeFile wrapperScript $ unlines
[ "#!/bin/sh"
, "set -e"
, "DEBOOTSTRAP_DIR=" ++ dir
, "export DEBOOTSTRAP_DIR"
, dir </> "debootstrap" ++ " \"$@\""
]
modifyFileMode wrapperScript (addModes $ readModes ++ executeModes)
localInstallDir :: FilePath
localInstallDir = "/usr/local/debootstrap"
baseurl :: Url
baseurl = "http://ftp.debian.org/debian/pool/main/d/debootstrap/"
download :: Url -> FilePath -> IO Bool
download url dest = anyM id
[ boolSystem "curl" [Param "-o", File dest, Param url]
, boolSystem "wget" [Param "-O", File dest, Param url]
]
extractUrls :: Url -> String -> [Url]
extractUrls base = collect [] . map toLower
where
collect l [] = l
collect l ('h':'r':'e':'f':'=':r) = case r of
('"':r') -> findend l r'
_ -> findend l r
collect l (_:cs) = collect l cs
findend l s =
let (u, r) = break (== '"') s
u' = if "http" `isPrefixOf` u
then u
else base </> u
in collect (u':l) r