{-# 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 (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
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)
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
)
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
)
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
(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
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)
([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"
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"
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]
]
extractUrls :: Url -> String -> [Url]
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