{-# 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 Utility.FileMode

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
        | DebootstrapConfig :+ DebootstrapConfig
        deriving (Show)

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

instance Monoid DebootstrapConfig where
        mempty  = DefaultConfig
        mappend = (Sem.<>)

toParams :: DebootstrapConfig -> [CommandParam]
toParams DefaultConfig = []
toParams MinBase = [Param "--variant=minbase"]
toParams BuilddD = [Param "--variant=buildd"]
toParams (DebootstrapParam p) = [Param p]
toParams UseEmulation = []
toParams (c1 :+ c2) = toParams c1 <> toParams c2

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

-- | 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 target system@(System _ targetarch) config =
        withOS ("debootstrapped " ++ target) go
  where
        go w (Just hostos)
                | supportsArch hostos targetarch && not (useEmulation config) =
                        ensureProperty w $
                                built' (setupRevertableProperty installed)
                                        target system config
        go w _ = ensureProperty w $ do
                let p = setupRevertableProperty foreignBinariesEmulated
                        `before` setupRevertableProperty installed
                built' p target system (config :+ UseEmulation)

-- | Like `built`,  but uses the provided Property to install debootstrap.
built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
built' installprop target system@(System _ arch) config =
        go `before` oldpermfix
  where
        go = check (isUnpopulated target <||> ispartial) setupprop
                `requires` installprop

        setupprop :: Property Linux
        setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
                createDirectoryIfMissing True target
                suite <- case extractSuite system of
                        Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system
                        Just s -> pure s
                let params = toParams config ++
                        [ Param $ "--arch=" ++ architectureToDebianArchString arch
                        , Param suite
                        , Param target
                        ]
                cmd <- if useEmulation config
                        then pure "qemu-debootstrap"
                        else fromMaybe "debootstrap" <$> programPath
                de <- standardPathEnv
                ifM (boolSystemEnv cmd params (Just de))
                        ( return MadeChange
                        , return FailedChange
                        )

        -- A failed debootstrap run will leave a debootstrap directory;
        -- recover by deleting it and trying again.
        ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
                ( do
                        removeChroot target
                        return True
                , return 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 ("fixed old chroot file mode") $ do
                liftIO $ modifyFileMode target $
                        addModes [otherReadMode, otherExecuteMode]
                return NoChange

extractSuite :: System -> Maybe String
extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s
extractSuite (System (Buntish r) _) = Just r
extractSuite (System (ArchLinux) _) = Nothing
extractSuite (System (FreeBSD _) _) = 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 = install <!> remove
  where
        install = check (isNothing <$> programPath) $
                (aptinstall `pickOS` sourceInstall)
                        `describe` "debootstrap installed"

        remove = (aptremove `pickOS` sourceRemove)
                `describe` "debootstrap removed"

        aptinstall = Apt.installed ["debootstrap"]
        aptremove = Apt.removed ["debootstrap"]

sourceInstall :: Property Linux
sourceInstall = go
        `requires` perlInstalled
        `requires` arInstalled
  where
        go :: Property Linux
        go = property "debootstrap installed from source" (liftIO sourceInstall')

perlInstalled :: Property Linux
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
        liftIO $ toResult . isJust <$> firstM id
                [ yumInstall "perl"
                ]

arInstalled :: Property Linux
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
        liftIO $ toResult . isJust <$> firstM id
                [ yumInstall "binutils"
                ]

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

sourceInstall' :: IO Result
sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
        let indexfile = tmpd </> "index.html"
        unlessM (download baseurl indexfile) $
                errorMessage $ "Failed to download " ++ baseurl
        urls <- sortBy (flip compare) -- highest version first
                . filter ("debootstrap_" `isInfixOf`)
                . filter (".tar." `isInfixOf`)
                . extractUrls baseurl <$>
                readFileStrict indexfile
        nukeFile indexfile

        tarfile <- case urls of
                (tarurl:_) -> do
                        let f = tmpd </> takeFileName tarurl
                        unlessM (download tarurl f) $
                                errorMessage $ "Failed to download " ++ tarurl
                        return f
                _ -> errorMessage $ "Failed to find any debootstrap tarballs listed on " ++ baseurl

        createDirectoryIfMissing True localInstallDir
        bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do
                changeWorkingDirectory localInstallDir
                unlessM (boolSystem "tar" [Param "xf", File tarfile]) $
                        errorMessage "Failed to extract debootstrap tar file"
                nukeFile tarfile
                l <- dirContents "."
                case l of
                        (subdir:[]) -> do
                                changeWorkingDirectory subdir
                                makeWrapperScript (localInstallDir </> subdir)
                                return MadeChange
                        _ -> errorMessage "debootstrap tar file did not contain exactly one directory"

sourceRemove :: Property Linux
sourceRemove = property "debootstrap not installed from source" $ liftIO $
        ifM (doesDirectoryExist sourceInstallDir)
                ( do
                        removeDirectoryRecursive sourceInstallDir
                        return MadeChange
                , return NoChange
                )

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

wrapperScript :: FilePath
wrapperScript = sourceInstallDir </> "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 = getM searchPath
        [ "debootstrap"
        , wrapperScript
        ]

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

localInstallDir :: FilePath
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 = "http://ftp.debian.org/debian/pool/main/d/debootstrap/"

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

        findend l s =
                let (u, r) = break (== '"') s
                    u' = if "http" `isPrefixOf` u
                        then u
                        else base </> u
                in collect (u':l) r