module Propellor.Property.Qemu where

import Propellor.Base
import qualified Propellor.Property.Apt as Apt

-- | Installs qemu user mode emulation binaries, built statically,
-- which allow foreign binaries to run directly.
--
-- Note that this is not necessary after qemu 2.12~rc3+dfsg-1.
-- See http://bugs.debian.org/868030
-- It's currently always done to support older versions, but
-- could be skipped with the newer version.
foreignBinariesEmulated :: RevertableProperty Linux Linux
foreignBinariesEmulated :: RevertableProperty Linux Linux
foreignBinariesEmulated = (Property Linux
setup Property Linux -> Property Linux -> RevertableProperty Linux Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
cleanup)
	RevertableProperty Linux Linux
-> Desc -> RevertableProperty Linux Linux
forall p. IsProp p => p -> Desc -> p
`describe` Desc
"foreign binary emulation"
  where
	setup :: Property Linux
setup = [Desc] -> Property DebianLike
Apt.installed [Desc]
p Property DebianLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> 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
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
unsupportedOS
	cleanup :: Property Linux
cleanup = [Desc] -> Property DebianLike
Apt.removed [Desc]
p Property DebianLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> 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
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
unsupportedOS
	p :: [Desc]
p = [Desc
"qemu-user-static"]

-- | Removes qemu user mode emulation binary for the host CPU.
-- This binary is copied into a chroot by qemu-debootstrap, and is not
-- part of any package.
--
-- Note that removing the binary will prevent using the chroot on the host
-- system.
--
-- The FilePath is the path to the top of the chroot.
removeHostEmulationBinary :: FilePath -> Property Linux
removeHostEmulationBinary :: Desc -> Property Linux
removeHostEmulationBinary Desc
top = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property Linux
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
 -> Property Linux)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Property Linux
forall a b. (a -> b) -> a -> b
$ 
	[Desc]
-> UncheckedProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
scriptProperty [Desc
"rm -f " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
top Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
"/usr/bin/qemu-*-static"]
		UncheckedProperty
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange

-- | Check if the given System supports an Architecture.
--
-- For example, on Debian, X86_64 supports X86_32, and vice-versa.
supportsArch :: System -> Architecture -> Bool
supportsArch :: System -> Architecture -> Bool
supportsArch (System Distribution
os Architecture
a) Architecture
b
	| Architecture
a Architecture -> Architecture -> Bool
forall a. Eq a => a -> a -> Bool
== Architecture
b = Bool
True
	| Bool
otherwise = case Distribution
os of
		Debian DebianKernel
_ DebianSuite
_ -> Bool
debianlike
		Buntish Desc
_ -> Bool
debianlike
		-- don't know about other OS's
		Distribution
_ -> Bool
False
  where
	debianlike :: Bool
debianlike =
		let l :: [(Architecture, Architecture)]
l = 
			[ (Architecture
X86_64, Architecture
X86_32)
			, (Architecture
ARMHF, Architecture
ARMEL)
			, (Architecture
PPC, Architecture
PPC64)
			, (Architecture
SPARC, Architecture
SPARC64)
			, (Architecture
S390, Architecture
S390X)
			]
		in (Architecture, Architecture)
-> [(Architecture, Architecture)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Architecture
a, Architecture
b) [(Architecture, Architecture)]
l Bool -> Bool -> Bool
|| (Architecture, Architecture)
-> [(Architecture, Architecture)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Architecture
b, Architecture
a) [(Architecture, Architecture)]
l