    {-# 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
    	| DebootstrapConfig :+ DebootstrapConfig
    	deriving (Int -> DebootstrapConfig -> ShowS
    [DebootstrapConfig] -> ShowS
    DebootstrapConfig -> String
    (Int -> DebootstrapConfig -> ShowS)
    -> (DebootstrapConfig -> String)
    -> ([DebootstrapConfig] -> ShowS)
    -> Show DebootstrapConfig
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [DebootstrapConfig] -> ShowS
    $cshowList :: [DebootstrapConfig] -> ShowS
    show :: DebootstrapConfig -> String
    $cshow :: DebootstrapConfig -> String
    showsPrec :: Int -> DebootstrapConfig -> ShowS
    $cshowsPrec :: Int -> 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 DefaultConfig = []
    toParams MinBase = [String -> CommandParam
    Param "--variant=minbase"]
    toParams BuilddD = [String -> CommandParam
    Param "--variant=buildd"]
    toParams (DebootstrapParam p :: String
    p) = [String -> CommandParam
    Param String
    p]
    toParams UseEmulation = []
    toParams (DebootstrapProxy _) = []
    toParams (DebootstrapMirror _) = []
    toParams (c1 :: DebootstrapConfig
    c1 :+ c2 :: 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 UseEmulation = Bool
    True
    useEmulation (a :: DebootstrapConfig
    a :+ b :: DebootstrapConfig
    b) = DebootstrapConfig -> Bool
    useEmulation DebootstrapConfig
    a Bool -> Bool -> Bool
    || DebootstrapConfig -> Bool
    useEmulation DebootstrapConfig
    b
    useEmulation _ = Bool
    False

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

    debootstrapMirror :: DebootstrapConfig -> Maybe Url
    debootstrapMirror :: DebootstrapConfig -> Maybe String
    debootstrapMirror (DebootstrapMirror u :: String
    u) = String -> Maybe String
    forall a. a -> Maybe a
    Just String
    u
    debootstrapMirror (a :: DebootstrapConfig
    a :+ b :: DebootstrapConfig
    b) = DebootstrapConfig -> Maybe String
    debootstrapMirror DebootstrapConfig
    a Maybe String -> Maybe String -> Maybe String
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> DebootstrapConfig -> Maybe String
    debootstrapMirror DebootstrapConfig
    b
    debootstrapMirror _ = Maybe String
    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`.
    --
    -- When emulation is used, the chroot will have an additional binary
    -- installed in it. To get a completelty clean chroot (eg for producing a
    -- bootable disk image), use the `removeHostEmulationBinary` property.
    built :: FilePath -> System -> DebootstrapConfig -> Property Linux
    built :: String -> System -> DebootstrapConfig -> Property Linux
    built target :: String
    target system :: System
    system@(System _ targetarch :: Architecture
    targetarch) config :: DebootstrapConfig
    config =
    	String
    -> (OuterMetaTypesWitness
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux]
        -> Maybe System -> Propellor Result)
    -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String
    -> (OuterMetaTypesWitness metatypes
        -> Maybe System -> Propellor Result)
    -> Property (MetaTypes metatypes)
    withOS ("debootstrapped " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    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 w :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w (Just hostos :: 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
    -> String -> System -> DebootstrapConfig -> Property Linux
    built' (RevertableProperty Linux Linux -> Property Linux
    forall setupmetatypes undometatypes.
    RevertableProperty setupmetatypes undometatypes
    -> Property setupmetatypes
    setupRevertableProperty RevertableProperty Linux Linux
    installed)
    					String
    target System
    system DebootstrapConfig
    config
    	go w :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w _ = 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
    -> String -> System -> DebootstrapConfig -> Property Linux
    built' Property Linux
    p String
    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
    -> String -> System -> DebootstrapConfig -> Property Linux
    built' installprop :: Property Linux
    installprop target :: String
    target system :: System
    system@(System _ arch :: Architecture
    arch) config :: 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 (String -> IO Bool
    isUnpopulated String
    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 = String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property ("debootstrapped " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    target) (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ IO Result -> Propellor Result
    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 -> String -> IO ()
    createDirectoryIfMissing Bool
    True String
    target
    		String
    suite <- case System -> Maybe String
    extractSuite System
    system of
    			Nothing -> String -> IO String
    forall (m :: * -> *) a. MonadIO m => String -> m a
    errorMessage (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $ "don't know how to debootstrap " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ System -> String
    forall a. Show a => a -> String
    show System
    system
    			Just s :: String
    s -> String -> IO String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure String
    s
    		let params :: [CommandParam]
    params = DebootstrapConfig -> [CommandParam]
    toParams DebootstrapConfig
    config [CommandParam] -> [CommandParam] -> [CommandParam]
    forall a. [a] -> [a] -> [a]
    ++
    			[ String -> CommandParam
    Param (String -> CommandParam) -> String -> CommandParam
    forall a b. (a -> b) -> a -> b
    $ "--arch=" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Architecture -> String
    architectureToDebianArchString Architecture
    arch
    			, String -> CommandParam
    Param String
    suite
    			, String -> CommandParam
    Param String
    target
    			] [CommandParam] -> [CommandParam] -> [CommandParam]
    forall a. [a] -> [a] -> [a]
    ++ case DebootstrapConfig -> Maybe String
    debootstrapMirror DebootstrapConfig
    config of
    				Just u :: String
    u -> [String -> CommandParam
    Param String
    u]
    				Nothing -> []
    		String
    cmd <- if DebootstrapConfig -> Bool
    useEmulation DebootstrapConfig
    config
    			then String -> IO String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure "qemu-debootstrap"
    			else String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe "debootstrap" (Maybe String -> String) -> IO (Maybe String) -> IO String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO (Maybe String)
    programPath
    		[(String, String)]
    de <- case DebootstrapConfig -> Maybe String
    debootstrapProxy DebootstrapConfig
    config of
    			Just u :: String
    u -> String -> String -> [(String, String)] -> [(String, String)]
    forall k v. Eq k => k -> v -> [(k, v)] -> [(k, v)]
    addEntry "http_proxy" String
    u ([(String, String)] -> [(String, String)])
    -> IO [(String, String)] -> IO [(String, String)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO [(String, String)]
    standardPathEnv
    			Nothing -> IO [(String, String)]
    standardPathEnv
    		IO Bool -> (IO Result, IO Result) -> IO Result
    forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
    ifM (String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
    boolSystemEnv String
    cmd [CommandParam]
    params ([(String, String)] -> Maybe [(String, String)]
    forall a. a -> Maybe a
    Just [(String, String)]
    de))
    			( Result -> IO Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    MadeChange
    			, Result -> IO Result
    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 (String -> IO Bool
    doesDirectoryExist (String
    target String -> ShowS
    </> "debootstrap"))
    		( do
    			String -> IO ()
    removeChroot String
    target
    			Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
    		, Bool -> IO Bool
    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 = String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property ("fixed old chroot file mode") (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ do
    		IO () -> Propellor ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ String -> (FileMode -> FileMode) -> IO ()
    modifyFileMode String
    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 (m :: * -> *) a. Monad m => a -> m a
    return Result
    NoChange

    extractSuite :: System -> Maybe String
    extractSuite :: System -> Maybe String
    extractSuite (System (Debian _ s :: DebianSuite
    s) _) = String -> Maybe String
    forall a. a -> Maybe a
    Just (String -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ DebianSuite -> String
    Apt.showSuite DebianSuite
    s
    extractSuite (System (Buntish r :: String
    r) _) = String -> Maybe String
    forall a. a -> Maybe a
    Just String
    r
    extractSuite (System (Distribution
    ArchLinux) _) = Maybe String
    forall a. Maybe a
    Nothing
    extractSuite (System (FreeBSD _) _) = Maybe String
    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 String -> Bool
    forall a. Maybe a -> Bool
    isNothing (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO (Maybe String)
    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 -> String -> Property Linux
    forall p. IsProp p => p -> String -> p
    `describe` "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 -> String -> Property Linux
    forall p. IsProp p => p -> String -> p
    `describe` "debootstrap removed"

    	aptinstall :: Property DebianLike
    aptinstall = [String] -> Property DebianLike
    Apt.installed ["debootstrap"]
    	aptremove :: Property DebianLike
    aptremove = [String] -> Property DebianLike
    Apt.removed ["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 = String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property "debootstrap installed from source" (IO Result -> Propellor Result
    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
    <$> String -> IO Bool
    inPath "perl") (Property Linux -> Property Linux)
    -> Property Linux -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property "perl installed" (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $
    	IO Result -> Propellor Result
    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
    		[ String -> IO Bool
    yumInstall "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
    <$> String -> IO Bool
    inPath "ar") (Property Linux -> Property Linux)
    -> Property Linux -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property "ar installed" (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $
    	IO Result -> Propellor Result
    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
    		[ String -> IO Bool
    yumInstall "binutils"
    		]

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

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

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

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

    sourceRemove :: Property Linux
    sourceRemove :: Property Linux
    sourceRemove = String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property "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 (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 (String -> IO Bool
    doesDirectoryExist String
    sourceInstallDir)
    		( do
    			String -> IO ()
    removeDirectoryRecursive String
    sourceInstallDir
    			Result -> IO Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    MadeChange
    		, Result -> IO Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    NoChange
    		)

    sourceInstallDir :: FilePath
    sourceInstallDir :: String
    sourceInstallDir = "/usr/local/propellor/debootstrap"

    wrapperScript :: FilePath
    wrapperScript :: String
    wrapperScript = String
    sourceInstallDir String -> ShowS
    </> "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 String)
    programPath = (String -> IO (Maybe String)) -> [String] -> IO (Maybe String)
    forall (m :: * -> *) a b.
    Monad m =>
    (a -> m (Maybe b)) -> [a] -> m (Maybe b)
    getM String -> IO (Maybe String)
    searchPath
    	[ "debootstrap"
    	, String
    wrapperScript
    	]

    makeWrapperScript :: FilePath -> IO ()
    makeWrapperScript :: String -> IO ()
    makeWrapperScript dir :: String
    dir = do
    	Bool -> String -> IO ()
    createDirectoryIfMissing Bool
    True (ShowS
    takeDirectory String
    wrapperScript)
    	String -> String -> IO ()
    writeFile String
    wrapperScript (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
    		[ "#!/bin/sh"
    		, "set -e"
    		, "DEBOOTSTRAP_DIR=" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    dir
    		, "export DEBOOTSTRAP_DIR"
    		, String
    dir String -> ShowS
    </> "debootstrap" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " \"$@\""
    		]
    	String -> (FileMode -> FileMode) -> IO ()
    modifyFileMode String
    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 :: String
    localInstallDir = "/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 :: String
    baseurl = "http://ftp.debian.org/debian/pool/main/d/debootstrap/"

    download :: Url -> FilePath -> IO Bool
    download :: String -> String -> IO Bool
    download url :: String
    url dest :: String
    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
    	[ String -> [CommandParam] -> IO Bool
    boolSystem "curl" [String -> CommandParam
    Param "-o", String -> CommandParam
    File String
    dest, String -> CommandParam
    Param String
    url]
    	, String -> [CommandParam] -> IO Bool
    boolSystem "wget" [String -> CommandParam
    Param "-O", String -> CommandParam
    File String
    dest, String -> CommandParam
    Param String
    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 :: String -> String -> [String]
    extractUrls base :: String
    base = [String] -> String -> [String]
    collect [] (String -> [String]) -> ShowS -> String -> [String]
    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 :: [String] -> String -> [String]
    collect l :: [String]
    l [] = [String]
    l
    	collect l :: [String]
    l ('h':'r':'e':'f':'=':r :: String
    r) = case String
    r of
    		('"':r' :: String
    r') -> [String] -> String -> [String]
    findend [String]
    l String
    r'
    		_ -> [String] -> String -> [String]
    findend [String]
    l String
    r
    	collect l :: [String]
    l (_:cs :: String
    cs) = [String] -> String -> [String]
    collect [String]
    l String
    cs

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