{-# 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 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
| DebootstrapProxy Url
| DebootstrapMirror Url
| 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 (DebootstrapProxy _) = []
toParams (DebootstrapMirror _) = []
toParams (c1 :+ c2) = toParams c1 <> toParams c2
useEmulation :: DebootstrapConfig -> Bool
useEmulation UseEmulation = True
useEmulation (a :+ b) = useEmulation a || useEmulation b
useEmulation _ = False
debootstrapProxy :: DebootstrapConfig -> Maybe Url
debootstrapProxy (DebootstrapProxy u) = Just u
debootstrapProxy (a :+ b) = debootstrapProxy a <|> debootstrapProxy b
debootstrapProxy _ = Nothing
debootstrapMirror :: DebootstrapConfig -> Maybe Url
debootstrapMirror (DebootstrapMirror u) = Just u
debootstrapMirror (a :+ b) = debootstrapMirror a <|> debootstrapMirror b
debootstrapMirror _ = Nothing
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
] ++ case debootstrapMirror config of
Just u -> [Param u]
Nothing -> []
cmd <- if useEmulation config
then pure "qemu-debootstrap"
else fromMaybe "debootstrap" <$> programPath
de <- case debootstrapProxy config of
Just u -> addEntry "http_proxy" u <$> standardPathEnv
Nothing -> 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