    {-# 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