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
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
foreignBinariesEmulated = (Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
setup Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
cleanup)
	RevertableProperty
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Desc
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall p. IsProp p => p -> Desc -> p
`describe` Desc
"foreign binary emulation"
  where
	setup :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
setup = [Desc] -> Property DebianLike
Apt.installed [Desc]
p Property DebianLike
-> Property UnixLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
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 UnixLike
unsupportedOS
	cleanup :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
cleanup = [Desc] -> Property DebianLike
Apt.removed [Desc]
p Property DebianLike
-> Property UnixLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
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 UnixLike
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
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
removeHostEmulationBinary Desc
top = Property UnixLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property UnixLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ 
	[Desc] -> UncheckedProperty UnixLike
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 UnixLike -> Result -> Property UnixLike
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