    {-# 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

    -- | A data type for debootstrap configuration.
    -- mempty is a default debootstrapped system.
    data DebootstrapConfig
    	= DefaultConfig
    	| MinBase
    	| BuilddD
    	| DebootstrapParam String
    	| UseEmulation
    	| DebootstrapProxy Url
    	| DebootstrapMirror Url
    	| UseOldGpgKeyring
    	-- ^ Debootstrap using the keyring of old and removed gpg keys.
    	-- This is needed to debootstrap ancient stable releases of Debian.
    	| DebootstrapConfig :+ DebootstrapConfig
    	deriving (Int -> DebootstrapConfig -> ShowS
    [DebootstrapConfig] -> ShowS
    DebootstrapConfig -> [Char]
    (Int -> DebootstrapConfig -> ShowS)
    -> (DebootstrapConfig -> [Char])
    -> ([DebootstrapConfig] -> ShowS)
    -> Show DebootstrapConfig
    forall a.
    (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> DebootstrapConfig -> ShowS
    showsPrec :: Int -> DebootstrapConfig -> ShowS
    $cshow :: DebootstrapConfig -> [Char]
    show :: DebootstrapConfig -> [Char]
    $cshowList :: [DebootstrapConfig] -> ShowS
    showList :: [DebootstrapConfig] -> ShowS
    Show)

    instance Sem.Semigroup DebootstrapConfig where
    	<> :: DebootstrapConfig -> DebootstrapConfig -> DebootstrapConfig
    (<>) = DebootstrapConfig -> DebootstrapConfig -> DebootstrapConfig
    (:+)

    instance Monoid DebootstrapConfig where
    	mempty :: DebootstrapConfig
    mempty  = DebootstrapConfig
    DefaultConfig
    	mappend :: DebootstrapConfig -> DebootstrapConfig -> DebootstrapConfig
    mappend = DebootstrapConfig -> DebootstrapConfig -> DebootstrapConfig
    forall a. Semigroup a => a -> a -> a
    (Sem.<>)

    toParams :: DebootstrapConfig -> [CommandParam]
    toParams :: DebootstrapConfig -> [CommandParam]
    toParams DebootstrapConfig
    DefaultConfig = []
    toParams DebootstrapConfig
    MinBase = [[Char] -> CommandParam
    Param [Char]
    "--variant=minbase"]
    toParams DebootstrapConfig
    BuilddD = [[Char] -> CommandParam
    Param [Char]
    "--variant=buildd"]
    toParams (DebootstrapParam [Char]
    p) = [[Char] -> CommandParam
    Param [Char]
    p]
    toParams DebootstrapConfig
    UseEmulation = []
    toParams (DebootstrapProxy [Char]
    _) = []
    toParams (DebootstrapMirror [Char]
    _) = []
    toParams DebootstrapConfig
    UseOldGpgKeyring = [[Char] -> CommandParam
    Param [Char]
    "--keyring=/usr/share/keyrings/debian-archive-removed-keys.gpg"]
    toParams (DebootstrapConfig
    c1 :+ DebootstrapConfig
    c2) = DebootstrapConfig -> [CommandParam]
    toParams DebootstrapConfig
    c1 [CommandParam] -> [CommandParam] -> [CommandParam]
    forall a. Semigroup a => a -> a -> a
    <> DebootstrapConfig -> [CommandParam]
    toParams DebootstrapConfig
    c2

    useEmulation :: DebootstrapConfig -> Bool
    useEmulation :: DebootstrapConfig -> Bool
    useEmulation DebootstrapConfig
    UseEmulation = Bool
    True
    useEmulation (DebootstrapConfig
    a :+ DebootstrapConfig
    b) = DebootstrapConfig -> Bool
    useEmulation DebootstrapConfig
    a Bool -> Bool -> Bool
    || DebootstrapConfig -> Bool
    useEmulation DebootstrapConfig
    b
    useEmulation DebootstrapConfig
    _ = Bool
    False

    debootstrapProxy :: DebootstrapConfig -> Maybe Url
    debootstrapProxy :: DebootstrapConfig -> Maybe [Char]
    debootstrapProxy (DebootstrapProxy [Char]
    u) = [Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just [Char]
    u
    debootstrapProxy (DebootstrapConfig
    a :+ DebootstrapConfig
    b) = DebootstrapConfig -> Maybe [Char]
    debootstrapProxy DebootstrapConfig
    a Maybe [Char] -> Maybe [Char] -> Maybe [Char]
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> DebootstrapConfig -> Maybe [Char]
    debootstrapProxy DebootstrapConfig
    b
    debootstrapProxy DebootstrapConfig
    _ = Maybe [Char]
    forall a. Maybe a
    Nothing

    debootstrapMirror :: DebootstrapConfig -> Maybe Url
    debootstrapMirror :: DebootstrapConfig -> Maybe [Char]
    debootstrapMirror (DebootstrapMirror [Char]
    u) = [Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just [Char]
    u
    debootstrapMirror (DebootstrapConfig
    a :+ DebootstrapConfig
    b) = DebootstrapConfig -> Maybe [Char]
    debootstrapMirror DebootstrapConfig
    a Maybe [Char] -> Maybe [Char] -> Maybe [Char]
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> DebootstrapConfig -> Maybe [Char]
    debootstrapMirror DebootstrapConfig
    b
    debootstrapMirror DebootstrapConfig
    _ = Maybe [Char]
    forall a. Maybe a
    Nothing

    -- | Builds a chroot in the given directory using debootstrap.
    --
    -- The System can be any OS and architecture that debootstrap
    -- and the kernel support.
    --
    -- When the System is architecture that the kernel does not support,
    -- it can still be bootstrapped using emulation. This is determined
    -- by checking `supportsArch`, or can be configured with `UseEmulation`.
    built :: FilePath -> System -> DebootstrapConfig -> Property Linux
    built :: [Char] -> System -> DebootstrapConfig -> Property Linux
    built [Char]
    target system :: System
    system@(System Distribution
    _ Architecture
    targetarch) DebootstrapConfig
    config =
    	[Char]
    -> (OuterMetaTypesWitness
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux]
        -> Maybe System -> Propellor Result)
    -> Property Linux
    forall {k} (metatypes :: k).
    SingI metatypes =>
    [Char]
    -> (OuterMetaTypesWitness metatypes
        -> Maybe System -> Propellor Result)
    -> Property (MetaTypes metatypes)
    withOS ([Char]
    "debootstrapped " [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    target) OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Maybe System -> Propellor Result
    go
      where
    	go :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Maybe System -> Propellor Result
    go OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w (Just System
    hostos)
    		| System -> Architecture -> Bool
    supportsArch System
    hostos Architecture
    targetarch Bool -> Bool -> Bool
    && Bool -> Bool
    not (DebootstrapConfig -> Bool
    useEmulation DebootstrapConfig
    config) =
    			OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Property Linux -> Propellor Result
    forall (inner :: [MetaType]) (outer :: [MetaType]).
    EnsurePropertyAllowed inner outer =>
    OuterMetaTypesWitness outer
    -> Property (MetaTypes inner) -> Propellor Result
    ensureProperty OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w (Property Linux -> Propellor Result)
    -> Property Linux -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $
    				Property Linux
    -> [Char] -> System -> DebootstrapConfig -> Property Linux
    built' (RevertableProperty Linux Linux -> Property Linux
    forall setupmetatypes undometatypes.
    RevertableProperty setupmetatypes undometatypes
    -> Property setupmetatypes
    setupRevertableProperty RevertableProperty Linux Linux
    installed)
    					[Char]
    target System
    system DebootstrapConfig
    config
    	go OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w Maybe System
    _ = OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Property Linux -> Propellor Result
    forall (inner :: [MetaType]) (outer :: [MetaType]).
    EnsurePropertyAllowed inner outer =>
    OuterMetaTypesWitness outer
    -> Property (MetaTypes inner) -> Propellor Result
    ensureProperty OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w (Property Linux -> Propellor Result)
    -> Property Linux -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $ do
    		let p :: CombinedType (Property Linux) (Property Linux)
    p = RevertableProperty Linux Linux -> Property Linux
    forall setupmetatypes undometatypes.
    RevertableProperty setupmetatypes undometatypes
    -> Property setupmetatypes
    setupRevertableProperty RevertableProperty Linux Linux
    foreignBinariesEmulated
    			Property Linux
    -> Property Linux -> CombinedType (Property Linux) (Property Linux)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `before` RevertableProperty Linux Linux -> Property Linux
    forall setupmetatypes undometatypes.
    RevertableProperty setupmetatypes undometatypes
    -> Property setupmetatypes
    setupRevertableProperty RevertableProperty Linux Linux
    installed
    		Property Linux
    -> [Char] -> System -> DebootstrapConfig -> Property Linux
    built' Property Linux
    p [Char]
    target System
    system (DebootstrapConfig
    config DebootstrapConfig -> DebootstrapConfig -> DebootstrapConfig
    :+ DebootstrapConfig
    UseEmulation)

    -- | Like `built`,  but uses the provided Property to install debootstrap.
    built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
    built' :: Property Linux
    -> [Char] -> System -> DebootstrapConfig -> Property Linux
    built' Property Linux
    installprop [Char]
    target system :: System
    system@(System Distribution
    _ Architecture
    arch) DebootstrapConfig
    config =
    	CombinedType (Property Linux) (Property Linux)
    Property Linux
    go Property Linux
    -> Property Linux -> CombinedType (Property Linux) (Property Linux)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `before` Property Linux
    oldpermfix
      where
    	go :: CombinedType (Property Linux) (Property Linux)
    go = IO Bool -> Property Linux -> Property Linux
    forall (p :: * -> *) i (m :: * -> *).
    (Checkable p i, LiftPropellor m) =>
    m Bool -> p i -> Property i
    check ([Char] -> IO Bool
    isUnpopulated [Char]
    target IO Bool -> IO Bool -> IO Bool
    forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
    <||> IO Bool
    ispartial) Property Linux
    setupprop
    		Property Linux
    -> Property Linux -> CombinedType (Property Linux) (Property Linux)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `requires` Property Linux
    installprop

    	setupprop :: Property Linux
    	setupprop :: Property Linux
    setupprop = [Char] -> Propellor Result -> Property Linux
    forall {k} (metatypes :: k).
    SingI metatypes =>
    [Char] -> Propellor Result -> Property (MetaTypes metatypes)
    property ([Char]
    "debootstrapped " [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    target) (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ IO Result -> Propellor Result
    forall a. IO a -> Propellor a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $ do
    		Bool -> [Char] -> IO ()
    createDirectoryIfMissing Bool
    True [Char]
    target
    		[Char]
    suite <- case System -> Maybe [Char]
    extractSuite System
    system of
    			Maybe [Char]
    Nothing -> [Char] -> IO [Char]
    forall (m :: * -> *) a. MonadIO m => [Char] -> m a
    errorMessage ([Char] -> IO [Char]) -> [Char] -> IO [Char]
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "don't know how to debootstrap " [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ System -> [Char]
    forall a. Show a => a -> [Char]
    show System
    system
    			Just [Char]
    s -> [Char] -> IO [Char]
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure [Char]
    s
    		let params :: [CommandParam]
    params = DebootstrapConfig -> [CommandParam]
    toParams DebootstrapConfig
    config [CommandParam] -> [CommandParam] -> [CommandParam]
    forall a. [a] -> [a] -> [a]
    ++
    			[ [Char] -> CommandParam
    Param ([Char] -> CommandParam) -> [Char] -> CommandParam
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "--arch=" [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Architecture -> [Char]
    architectureToDebianArchString Architecture
    arch
    			, [Char] -> CommandParam
    Param [Char]
    suite
    			, [Char] -> CommandParam
    Param [Char]
    target
    			] [CommandParam] -> [CommandParam] -> [CommandParam]
    forall a. [a] -> [a] -> [a]
    ++ case DebootstrapConfig -> Maybe [Char]
    debootstrapMirror DebootstrapConfig
    config of
    				Just [Char]
    u -> [[Char] -> CommandParam
    Param [Char]
    u]
    				Maybe [Char]
    Nothing -> []
    		[Char]
    cmd <- [Char] -> Maybe [Char] -> [Char]
    forall a. a -> Maybe a -> a
    fromMaybe [Char]
    "debootstrap" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO (Maybe [Char])
    programPath
    		[([Char], [Char])]
    de <- case DebootstrapConfig -> Maybe [Char]
    debootstrapProxy DebootstrapConfig
    config of
    			Just [Char]
    u -> [Char] -> [Char] -> [([Char], [Char])] -> [([Char], [Char])]
    forall k v. Eq k => k -> v -> [(k, v)] -> [(k, v)]
    addEntry [Char]
    "http_proxy" [Char]
    u ([([Char], [Char])] -> [([Char], [Char])])
    -> IO [([Char], [Char])] -> IO [([Char], [Char])]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO [([Char], [Char])]
    standardPathEnv
    			Maybe [Char]
    Nothing -> IO [([Char], [Char])]
    standardPathEnv
    		IO Bool -> (IO Result, IO Result) -> IO Result
    forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
    ifM ([Char] -> [CommandParam] -> Maybe [([Char], [Char])] -> IO Bool
    boolSystemEnv [Char]
    cmd [CommandParam]
    params ([([Char], [Char])] -> Maybe [([Char], [Char])]
    forall a. a -> Maybe a
    Just [([Char], [Char])]
    de))
    			( Result -> IO Result
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    MadeChange
    			, Result -> IO Result
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    FailedChange
    			)

    	-- A failed debootstrap run will leave a debootstrap directory;
    	-- recover by deleting it and trying again.
    	ispartial :: IO Bool
    ispartial = IO Bool -> (IO Bool, IO Bool) -> IO Bool
    forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
    ifM ([Char] -> IO Bool
    doesDirectoryExist ([Char]
    target [Char] -> ShowS
    </> [Char]
    "debootstrap"))
    		( do
    			[Char] -> IO ()
    removeChroot [Char]
    target
    			Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
    		, Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
    		)

    	-- May want to remove this after some appropriate length of time,
    	-- as it's a workaround for chroots set up with too tight
    	-- permissions.
    	oldpermfix :: Property Linux
    	oldpermfix :: Property Linux
    oldpermfix = [Char] -> Propellor Result -> Property Linux
    forall {k} (metatypes :: k).
    SingI metatypes =>
    [Char] -> Propellor Result -> Property (MetaTypes metatypes)
    property ([Char]
    "fixed old chroot file mode") (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ do
    		IO () -> Propellor ()
    forall a. IO a -> Propellor a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ [Char] -> (FileMode -> FileMode) -> IO ()
    modifyFileMode [Char]
    target ((FileMode -> FileMode) -> IO ())
    -> (FileMode -> FileMode) -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    			[FileMode] -> FileMode -> FileMode
    addModes [FileMode
    otherReadMode, FileMode
    otherExecuteMode]
    		Result -> Propellor Result
    forall a. a -> Propellor a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    NoChange

    extractSuite :: System -> Maybe String
    extractSuite :: System -> Maybe [Char]
    extractSuite (System (Debian DebianKernel
    _ DebianSuite
    s) Architecture
    _) = [Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
    forall a b. (a -> b) -> a -> b
    $ DebianSuite -> [Char]
    Apt.showSuite DebianSuite
    s
    extractSuite (System (Buntish [Char]
    r) Architecture
    _) = [Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just [Char]
    r
    extractSuite (System (Distribution
    ArchLinux) Architecture
    _) = Maybe [Char]
    forall a. Maybe a
    Nothing
    extractSuite (System (FreeBSD FreeBSDRelease
    _) Architecture
    _) = Maybe [Char]
    forall a. Maybe a
    Nothing

    -- | Ensures debootstrap is installed.
    --
    -- When necessary, falls back to installing debootstrap from source.
    -- Note that installation from source is done by downloading the tarball
    -- from a Debian mirror, with no cryptographic verification.
    installed :: RevertableProperty Linux Linux
    installed :: RevertableProperty Linux Linux
    installed = Property Linux
    install Property Linux -> Property Linux -> RevertableProperty Linux Linux
    forall setupmetatypes undometatypes.
    Property setupmetatypes
    -> Property undometatypes
    -> RevertableProperty setupmetatypes undometatypes
    <!> Property Linux
    remove
      where
    	install :: Property Linux
    install = IO Bool -> Property Linux -> Property Linux
    forall (p :: * -> *) i (m :: * -> *).
    (Checkable p i, LiftPropellor m) =>
    m Bool -> p i -> Property i
    check (Maybe [Char] -> Bool
    forall a. Maybe a -> Bool
    isNothing (Maybe [Char] -> Bool) -> IO (Maybe [Char]) -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO (Maybe [Char])
    programPath) (Property Linux -> Property Linux)
    -> Property Linux -> Property Linux
    forall a b. (a -> b) -> a -> b
    $
    		(Property DebianLike
    aptinstall Property DebianLike -> Property Linux -> Property Linux
    forall {k} ka kb (c :: k) (a :: ka) (b :: kb).
    (HasCallStack, SingKind 'KProxy, SingKind 'KProxy,
     DemoteRep 'KProxy ~ [MetaType], DemoteRep 'KProxy ~ [MetaType],
     SingI c) =>
    Property (MetaTypes a)
    -> Property (MetaTypes b) -> Property (MetaTypes c)
    `pickOS` Property Linux
    sourceInstall)
    			Property Linux -> [Char] -> Property Linux
    forall p. IsProp p => p -> [Char] -> p
    `describe` [Char]
    "debootstrap installed"

    	remove :: Property Linux
    remove = (Property DebianLike
    aptremove Property DebianLike -> Property Linux -> Property Linux
    forall {k} ka kb (c :: k) (a :: ka) (b :: kb).
    (HasCallStack, SingKind 'KProxy, SingKind 'KProxy,
     DemoteRep 'KProxy ~ [MetaType], DemoteRep 'KProxy ~ [MetaType],
     SingI c) =>
    Property (MetaTypes a)
    -> Property (MetaTypes b) -> Property (MetaTypes c)
    `pickOS` Property Linux
    sourceRemove)
    		Property Linux -> [Char] -> Property Linux
    forall p. IsProp p => p -> [Char] -> p
    `describe` [Char]
    "debootstrap removed"

    	aptinstall :: Property DebianLike
    aptinstall = [[Char]] -> Property DebianLike
    Apt.installed [[Char]
    "debootstrap"]
    	aptremove :: Property DebianLike
    aptremove = [[Char]] -> Property DebianLike
    Apt.removed [[Char]
    "debootstrap"]

    sourceInstall :: Property Linux
    sourceInstall :: Property Linux
    sourceInstall = Property Linux
    go
    	Property Linux
    -> Property Linux -> CombinedType (Property Linux) (Property Linux)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `requires` Property Linux
    perlInstalled
    	Property Linux
    -> Property Linux -> CombinedType (Property Linux) (Property Linux)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `requires` Property Linux
    arInstalled
      where
    	go :: Property Linux
    	go :: Property Linux
    go = [Char] -> Propellor Result -> Property Linux
    forall {k} (metatypes :: k).
    SingI metatypes =>
    [Char] -> Propellor Result -> Property (MetaTypes metatypes)
    property [Char]
    "debootstrap installed from source" (IO Result -> Propellor Result
    forall a. IO a -> Propellor a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Result
    sourceInstall')

    perlInstalled :: Property Linux
    perlInstalled :: Property Linux
    perlInstalled = IO Bool -> Property Linux -> Property Linux
    forall (p :: * -> *) i (m :: * -> *).
    (Checkable p i, LiftPropellor m) =>
    m Bool -> p i -> Property i
    check (Bool -> Bool
    not (Bool -> Bool) -> IO Bool -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Char] -> IO Bool
    inPath [Char]
    "perl") (Property Linux -> Property Linux)
    -> Property Linux -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ [Char] -> Propellor Result -> Property Linux
    forall {k} (metatypes :: k).
    SingI metatypes =>
    [Char] -> Propellor Result -> Property (MetaTypes metatypes)
    property [Char]
    "perl installed" (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $
    	IO Result -> Propellor Result
    forall a. IO a -> Propellor a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $ Bool -> Result
    forall t. ToResult t => t -> Result
    toResult (Bool -> Result)
    -> (Maybe (IO Bool) -> Bool) -> Maybe (IO Bool) -> Result
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Maybe (IO Bool) -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe (IO Bool) -> Result) -> IO (Maybe (IO Bool)) -> IO Result
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (IO Bool -> IO Bool) -> [IO Bool] -> IO (Maybe (IO Bool))
    forall (m :: * -> *) a.
    Monad m =>
    (a -> m Bool) -> [a] -> m (Maybe a)
    firstM IO Bool -> IO Bool
    forall a. a -> a
    id
    		[ [Char] -> IO Bool
    yumInstall [Char]
    "perl"
    		]

    arInstalled :: Property Linux
    arInstalled :: Property Linux
    arInstalled = IO Bool -> Property Linux -> Property Linux
    forall (p :: * -> *) i (m :: * -> *).
    (Checkable p i, LiftPropellor m) =>
    m Bool -> p i -> Property i
    check (Bool -> Bool
    not (Bool -> Bool) -> IO Bool -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Char] -> IO Bool
    inPath [Char]
    "ar") (Property Linux -> Property Linux)
    -> Property Linux -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ [Char] -> Propellor Result -> Property Linux
    forall {k} (metatypes :: k).
    SingI metatypes =>
    [Char] -> Propellor Result -> Property (MetaTypes metatypes)
    property [Char]
    "ar installed" (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $
    	IO Result -> Propellor Result
    forall a. IO a -> Propellor a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $ Bool -> Result
    forall t. ToResult t => t -> Result
    toResult (Bool -> Result)
    -> (Maybe (IO Bool) -> Bool) -> Maybe (IO Bool) -> Result
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Maybe (IO Bool) -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe (IO Bool) -> Result) -> IO (Maybe (IO Bool)) -> IO Result
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (IO Bool -> IO Bool) -> [IO Bool] -> IO (Maybe (IO Bool))
    forall (m :: * -> *) a.
    Monad m =>
    (a -> m Bool) -> [a] -> m (Maybe a)
    firstM IO Bool -> IO Bool
    forall a. a -> a
    id
    		[ [Char] -> IO Bool
    yumInstall [Char]
    "binutils"
    		]

    yumInstall :: String -> IO Bool
    yumInstall :: [Char] -> IO Bool
    yumInstall [Char]
    p = [Char] -> [CommandParam] -> IO Bool
    boolSystem [Char]
    "yum" [[Char] -> CommandParam
    Param [Char]
    "-y", [Char] -> CommandParam
    Param [Char]
    "install", [Char] -> CommandParam
    Param [Char]
    p]

    sourceInstall' :: IO Result
    sourceInstall' :: IO Result
    sourceInstall' = [Char] -> ([Char] -> IO Result) -> IO Result
    forall (m :: * -> *) a.
    (MonadMask m, MonadIO m) =>
    [Char] -> ([Char] -> m a) -> m a
    withTmpDir [Char]
    "debootstrap" (([Char] -> IO Result) -> IO Result)
    -> ([Char] -> IO Result) -> IO Result
    forall a b. (a -> b) -> a -> b
    $ \[Char]
    tmpd -> do
    	let indexfile :: [Char]
    indexfile = [Char]
    tmpd [Char] -> ShowS
    </> [Char]
    "index.html"
    	IO Bool -> IO () -> IO ()
    forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
    unlessM ([Char] -> [Char] -> IO Bool
    download [Char]
    baseurl [Char]
    indexfile) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    		[Char] -> IO ()
    forall (m :: * -> *) a. MonadIO m => [Char] -> m a
    errorMessage ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Failed to download " [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    baseurl
    	[[Char]]
    urls <- ([Char] -> [Char] -> Ordering) -> [[Char]] -> [[Char]]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (([Char] -> [Char] -> Ordering) -> [Char] -> [Char] -> Ordering
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip [Char] -> [Char] -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare) -- highest version first
    		([[Char]] -> [[Char]])
    -> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([Char] -> Bool) -> [[Char]] -> [[Char]]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ([Char]
    "debootstrap_" [Char] -> [Char] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf`)
    		([[Char]] -> [[Char]])
    -> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([Char] -> Bool) -> [[Char]] -> [[Char]]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ([Char]
    ".tar." [Char] -> [Char] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf`)
    		([[Char]] -> [[Char]])
    -> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> [Char] -> [[Char]]
    extractUrls [Char]
    baseurl ([Char] -> [[Char]]) -> IO [Char] -> IO [[Char]]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>
    		[Char] -> IO [Char]
    readFileStrict [Char]
    indexfile
    	[Char] -> IO ()
    nukeFile [Char]
    indexfile

    	[Char]
    tarfile <- case [[Char]]
    urls of
    		([Char]
    tarurl:[[Char]]
    _) -> do
    			let f :: [Char]
    f = [Char]
    tmpd [Char] -> ShowS
    </> ShowS
    takeFileName [Char]
    tarurl
    			IO Bool -> IO () -> IO ()
    forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
    unlessM ([Char] -> [Char] -> IO Bool
    download [Char]
    tarurl [Char]
    f) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    				[Char] -> IO ()
    forall (m :: * -> *) a. MonadIO m => [Char] -> m a
    errorMessage ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Failed to download " [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    tarurl
    			[Char] -> IO [Char]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Char]
    f
    		[[Char]]
    _ -> [Char] -> IO [Char]
    forall (m :: * -> *) a. MonadIO m => [Char] -> m a
    errorMessage ([Char] -> IO [Char]) -> [Char] -> IO [Char]
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Failed to find any debootstrap tarballs listed on " [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    baseurl

    	Bool -> [Char] -> IO ()
    createDirectoryIfMissing Bool
    True [Char]
    localInstallDir
    	IO [Char]
    -> ([Char] -> IO ()) -> ([Char] -> IO Result) -> IO Result
    forall (m :: * -> *) a c b.
    (HasCallStack, MonadMask m) =>
    m a -> (a -> m c) -> (a -> m b) -> m b
    bracket IO [Char]
    getWorkingDirectory [Char] -> IO ()
    changeWorkingDirectory (([Char] -> IO Result) -> IO Result)
    -> ([Char] -> IO Result) -> IO Result
    forall a b. (a -> b) -> a -> b
    $ \[Char]
    _ -> do
    		[Char] -> IO ()
    changeWorkingDirectory [Char]
    localInstallDir
    		IO Bool -> IO () -> IO ()
    forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
    unlessM ([Char] -> [CommandParam] -> IO Bool
    boolSystem [Char]
    "tar" [[Char] -> CommandParam
    Param [Char]
    "xf", [Char] -> CommandParam
    File [Char]
    tarfile]) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    			[Char] -> IO ()
    forall (m :: * -> *) a. MonadIO m => [Char] -> m a
    errorMessage [Char]
    "Failed to extract debootstrap tar file"
    		[Char] -> IO ()
    nukeFile [Char]
    tarfile
    		[[Char]]
    l <- [Char] -> IO [[Char]]
    dirContents [Char]
    "."
    		case [[Char]]
    l of
    			([Char]
    subdir:[]) -> do
    				[Char] -> IO ()
    changeWorkingDirectory [Char]
    subdir
    				[Char] -> IO ()
    makeWrapperScript ([Char]
    localInstallDir [Char] -> ShowS
    </> [Char]
    subdir)
    				Result -> IO Result
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    MadeChange
    			[[Char]]
    _ -> [Char] -> IO Result
    forall (m :: * -> *) a. MonadIO m => [Char] -> m a
    errorMessage [Char]
    "debootstrap tar file did not contain exactly one directory"

    sourceRemove :: Property Linux
    sourceRemove :: Property Linux
    sourceRemove = [Char] -> Propellor Result -> Property Linux
    forall {k} (metatypes :: k).
    SingI metatypes =>
    [Char] -> Propellor Result -> Property (MetaTypes metatypes)
    property [Char]
    "debootstrap not installed from source" (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ IO Result -> Propellor Result
    forall a. IO a -> Propellor a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $
    	IO Bool -> (IO Result, IO Result) -> IO Result
    forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
    ifM ([Char] -> IO Bool
    doesDirectoryExist [Char]
    sourceInstallDir)
    		( do
    			[Char] -> IO ()
    removeDirectoryRecursive [Char]
    sourceInstallDir
    			Result -> IO Result
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    MadeChange
    		, Result -> IO Result
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    NoChange
    		)

    sourceInstallDir :: FilePath
    sourceInstallDir :: [Char]
    sourceInstallDir = [Char]
    "/usr/local/propellor/debootstrap"

    wrapperScript :: FilePath
    wrapperScript :: [Char]
    wrapperScript = [Char]
    sourceInstallDir [Char] -> ShowS
    </> [Char]
    "debootstrap.wrapper"

    -- | Finds debootstrap in PATH, but fall back to looking for the
    -- wrapper script that is installed, outside the PATH, when debootstrap
    -- is installed from source.
    programPath :: IO (Maybe FilePath)
    programPath :: IO (Maybe [Char])
    programPath = ([Char] -> IO (Maybe [Char])) -> [[Char]] -> IO (Maybe [Char])
    forall (m :: * -> *) a b.
    Monad m =>
    (a -> m (Maybe b)) -> [a] -> m (Maybe b)
    getM [Char] -> IO (Maybe [Char])
    searchPath
    	[ [Char]
    "debootstrap"
    	, [Char]
    wrapperScript
    	]

    makeWrapperScript :: FilePath -> IO ()
    makeWrapperScript :: [Char] -> IO ()
    makeWrapperScript [Char]
    dir = do
    	Bool -> [Char] -> IO ()
    createDirectoryIfMissing Bool
    True (ShowS
    takeDirectory [Char]
    wrapperScript)
    	[Char] -> [Char] -> IO ()
    writeFile [Char]
    wrapperScript ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [[Char]] -> [Char]
    unlines
    		[ [Char]
    "#!/bin/sh"
    		, [Char]
    "set -e"
    		, [Char]
    "DEBOOTSTRAP_DIR=" [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    dir
    		, [Char]
    "export DEBOOTSTRAP_DIR"
    		, [Char]
    dir [Char] -> ShowS
    </> [Char]
    "debootstrap" [Char] -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    " \"$@\""
    		]
    	[Char] -> (FileMode -> FileMode) -> IO ()
    modifyFileMode [Char]
    wrapperScript ([FileMode] -> FileMode -> FileMode
    addModes ([FileMode] -> FileMode -> FileMode)
    -> [FileMode] -> FileMode -> FileMode
    forall a b. (a -> b) -> a -> b
    $ [FileMode]
    readModes [FileMode] -> [FileMode] -> [FileMode]
    forall a. [a] -> [a] -> [a]
    ++ [FileMode]
    executeModes)

    localInstallDir :: FilePath
    localInstallDir :: [Char]
    localInstallDir = [Char]
    "/usr/local/debootstrap"

    -- This http server directory listing is relied on to be fairly sane,
    -- which is one reason why it's using a specific server and not a
    -- round-robin address.
    baseurl :: Url
    baseurl :: [Char]
    baseurl = [Char]
    "http://ftp.debian.org/debian/pool/main/d/debootstrap/"

    download :: Url -> FilePath -> IO Bool
    download :: [Char] -> [Char] -> IO Bool
    download [Char]
    url [Char]
    dest = (IO Bool -> IO Bool) -> [IO Bool] -> IO Bool
    forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
    anyM IO Bool -> IO Bool
    forall a. a -> a
    id
    	[ [Char] -> [CommandParam] -> IO Bool
    boolSystem [Char]
    "curl" [[Char] -> CommandParam
    Param [Char]
    "-o", [Char] -> CommandParam
    File [Char]
    dest, [Char] -> CommandParam
    Param [Char]
    url]
    	, [Char] -> [CommandParam] -> IO Bool
    boolSystem [Char]
    "wget" [[Char] -> CommandParam
    Param [Char]
    "-O", [Char] -> CommandParam
    File [Char]
    dest, [Char] -> CommandParam
    Param [Char]
    url]
    	]

    -- Pretty hackish, but I don't want to pull in a whole html parser
    -- or parsec dependency just for this.
    --
    -- To simplify parsing, lower case everything. This is ok because
    -- the filenames are all lower-case anyway.
    extractUrls :: Url -> String -> [Url]
    extractUrls :: [Char] -> [Char] -> [[Char]]
    extractUrls [Char]
    base = [[Char]] -> [Char] -> [[Char]]
    collect [] ([Char] -> [[Char]]) -> ShowS -> [Char] -> [[Char]]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Char) -> ShowS
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower
      where
    	collect :: [[Char]] -> [Char] -> [[Char]]
    collect [[Char]]
    l [] = [[Char]]
    l
    	collect [[Char]]
    l (Char
    'h':Char
    'r':Char
    'e':Char
    'f':Char
    '=':[Char]
    r) = case [Char]
    r of
    		(Char
    '"':[Char]
    r') -> [[Char]] -> [Char] -> [[Char]]
    findend [[Char]]
    l [Char]
    r'
    		[Char]
    _ -> [[Char]] -> [Char] -> [[Char]]
    findend [[Char]]
    l [Char]
    r
    	collect [[Char]]
    l (Char
    _:[Char]
    cs) = [[Char]] -> [Char] -> [[Char]]
    collect [[Char]]
    l [Char]
    cs

    	findend :: [[Char]] -> [Char] -> [[Char]]
    findend [[Char]]
    l [Char]
    s =
    		let ([Char]
    u, [Char]
    r) = (Char -> Bool) -> [Char] -> ([Char], [Char])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '"') [Char]
    s
    		    u' :: [Char]
    u' = if [Char]
    "http" [Char] -> [Char] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` [Char]
    u
    			then [Char]
    u
    			else [Char]
    base [Char] -> ShowS
    </> [Char]
    u
    		in [[Char]] -> [Char] -> [[Char]]
    collect ([Char]
    u'[Char] -> [[Char]] -> [[Char]]
    forall a. a -> [a] -> [a]
    :[[Char]]
    l) [Char]
    r