{-# 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 (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 (DebootstrapProxy _) = []
toParams (DebootstrapMirror _) = []
toParams (c1 :+ c2) = toParams c1 <> toParams c2

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

debootstrapProxy :: DebootstrapConfig -> Maybe Url
debootstrapProxy (DebootstrapProxy u) = Just u
debootstrapProxy (a :+ b) = debootstrapProxy a <|> debootstrapProxy b
debootstrapProxy _ = Nothing

debootstrapMirror :: DebootstrapConfig -> Maybe Url
debootstrapMirror (DebootstrapMirror u) = Just u
debootstrapMirror (a :+ b) = debootstrapMirror a <|> debootstrapMirror b
debootstrapMirror _ = 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 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
                        ] ++ case debootstrapMirror config of
                                Just u -> [Param u]
                                Nothing -> []
                cmd <- if useEmulation config
                        then pure "qemu-debootstrap"
                        else fromMaybe "debootstrap" <$> programPath
                de <- case debootstrapProxy config of
                        Just u -> addEntry "http_proxy" u <$> standardPathEnv
                        Nothing -> 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