{- This Source Code Form is subject to the terms of the Mozilla Public License,
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

module SlackBuilder.Download
    ( cloneAndUpload
    , extractRemote
    , commit
    , download
    , hostedSources
    , remoteFileExists
    , responseBodySource
    , sinkHash
    , updateSlackBuildVersion
    , uploadCommand
    ) where

import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8
import Data.Foldable (find)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import SlackBuilder.Config
import SlackBuilder.Trans
import Control.Monad.Trans.Reader (asks)
import Control.Monad.IO.Class (MonadIO(liftIO))
import System.Directory (createDirectory)
import System.IO (IOMode(..), withFile)
import System.FilePath ((</>), (<.>), takeFileName, takeDirectory, stripExtension)
import System.Process
    ( CreateProcess(..)
    , StdStream(..)
    , proc
    , readCreateProcessWithExitCode
    , callProcess
    )
import System.Exit (ExitCode(..))
import Control.Monad (unless)
import Text.URI (URI(..), mkURI)
import Network.HTTP.Req
    ( useHttpsURI
    , HEAD(..)
    , NoReqBody(..)
    , req
    , runReq
    , defaultHttpConfig
    , ignoreResponse
    , responseStatusCode
    , HttpConfig(..)
    , GET(..)
    , reqBr
    )
import Data.Functor ((<&>))
import Network.HTTP.Client (BodyReader, Response(..), brRead)
import Conduit
    ( ConduitT
    , yield
    , runConduitRes
    , sinkFile
    , (.|)
    , ZipSink(..)
    , await
    , sourceFile
    )
import Data.Conduit.Tar (untar, FileInfo(..))
import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
import Data.Void (Void)
import qualified Data.Conduit.Lzma as Lzma
import qualified Data.Conduit.Zlib as Zlib
import Control.Monad.Catch (MonadThrow(..))

updateSlackBuildVersion :: Text -> Text -> Map Text Text -> SlackBuilderT ()
updateSlackBuildVersion packagePath version additionalDownloads = do
    repository' <- SlackBuilderT $ asks repository
    let name = Text.unpack $ snd $ Text.breakOnEnd "/" packagePath
        slackbuildFilename = repository'
            </> Text.unpack packagePath
            </> (name <.> "SlackBuild")
    slackbuildContents <- liftIO $ Text.IO.readFile slackbuildFilename
    let slackbuildLines = replaceLine . updateLineVariable "VERSION" version
            <$> Text.lines slackbuildContents
 
    liftIO $ Text.IO.writeFile slackbuildFilename $ Text.unlines slackbuildLines
  where
    replaceLine line = Map.foldrWithKey updateLineDependencyVersion line additionalDownloads
    updateLineDependencyVersion dependencyName = updateLineVariable
        $ dependencyName <> "_VERSION"
    updateLineVariable variableName variableValue line
        | Text.isPrefixOf (variableName <> "=") line =
            variableName <> "=${" <> variableName <> ":-" <> variableValue <> "}"
        | otherwise = line

commit :: Text -> Text -> SlackBuilderT ()
commit packagePath version = do
    branch' <- SlackBuilderT $ Text.unpack <$> asks branch
    repository' <- SlackBuilderT $ asks repository
    signature' <- SlackBuilderT $ asks $ signature . maintainer
    let message = Text.unpack
            $ packagePath <> ": Updated for version " <> version
        mainCommitArguments = ["-C", repository', "commit", "-m", message]
        commitArguments =
            if signature'
            then mainCommitArguments <> ["-S"]
            else mainCommitArguments

    (checkoutExitCode, _, _) <- liftIO
        $ withFile "/dev/null" WriteMode
        $ testCheckout repository' branch'
 
    unless (checkoutExitCode == ExitSuccess)
        $ liftIO
        $ callProcess "git" ["-C", repository', "checkout", "-b", branch', "master"]
    liftIO
        $ callProcess "git" ["-C", repository', "add", Text.unpack packagePath]
        >> callProcess "git" commitArguments
  where
    testCheckout repository' branch' nullHandle =
        let createCheckoutProcess = (proc "git" ["-C", repository', "checkout", branch'])
                { std_in = NoStream
                , std_err = UseHandle nullHandle
                }
         in readCreateProcessWithExitCode createCheckoutProcess ""

hostedSources :: Text -> SlackBuilderT URI
hostedSources absoluteURL = SlackBuilderT (asks downloadURL)
    >>= liftIO . mkURI . (<> absoluteURL)

remoteFileExists :: Text -> SlackBuilderT Bool
remoteFileExists url = hostedSources url
    >>= traverse (runReq httpConfig . go . fst) . useHttpsURI
    <&> maybe False ((== 200) . responseStatusCode)
  where
    httpConfig = defaultHttpConfig
        { httpConfigCheckResponse = const $ const $ const Nothing
        }
    go uri = req HEAD uri NoReqBody ignoreResponse mempty

uploadCommand :: FilePath -> Text -> SlackBuilderT ()
uploadCommand localPath remotePath' = do
    remoteRoot <- SlackBuilderT $ asks remotePath
    localPathFromRepository <- relativeToRepository localPath

    liftIO $ callProcess "scp"
        [ localPathFromRepository
        , Text.unpack $ remoteRoot <> remotePath'
        ]

cloneAndArchive :: Text -> FilePath -> Text -> SlackBuilderT ()
cloneAndArchive repo tarballPath tagPrefix = do
    let version = snd $ Text.breakOnEnd "-"
            $ Text.pack $ takeFileName tarballPath 

    repositoryTarballPath <- relativeToRepository tarballPath
    repositoryArchivePath <- relativeToRepository $ tarballPath <.> "tar.xz"
    liftIO
        $ callProcess "rm" ["-rf", repositoryTarballPath]
        >> callProcess "git"
            [ "clone"
            , Text.unpack repo
            , repositoryTarballPath
            ]
        >> callProcess "git"
            [ "-C"
            , repositoryTarballPath
            , "checkout"
            , Text.unpack $ tagPrefix <> version
            ]
        >> callProcess "git"
            [ "-C"
            , repositoryTarballPath
            , "submodule"
            , "update"
            , "--init"
            , "--recursive"
            ]
        >> callProcess "tar"
            ["Jcvf"
            , repositoryArchivePath
            , repositoryTarballPath
            ]
        >> callProcess "rm" ["-rf", repositoryTarballPath]

responseBodySource :: MonadIO m => Response BodyReader -> ConduitT i ByteString m ()
responseBodySource = bodyReaderSource . responseBody
  where
    bodyReaderSource br = liftIO (brRead br) >>= go br
    go br bs = unless (ByteString.null bs) $ yield bs >> bodyReaderSource br

sinkHash :: Monad m => ConduitT ByteString Void m (Digest MD5)
sinkHash = sink hashInit
  where
    sink ctx = await
        >>= maybe (pure $ hashFinalize ctx) (sink . hashUpdate ctx)

download :: URI -> FilePath -> SlackBuilderT (Maybe (Digest MD5))
download uri target = traverse (runReq defaultHttpConfig . go . fst)
    $ useHttpsURI uri
  where
    go uri' = reqBr GET uri' NoReqBody mempty readResponse
    readResponse :: Response BodyReader -> IO (Digest MD5)
    readResponse response = runConduitRes
        $ responseBodySource response
        .| getZipSink (ZipSink (sinkFile target) *> ZipSink sinkHash)

cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (Maybe (URI, Digest MD5))
cloneAndUpload repo tarballPath tagPrefix = do
    localPath <- relativeToRepository $ tarballPath <.> "tar.xz"
    let packageName = takeFileName $ takeDirectory tarballPath
        remoteArchivePath = Text.cons '/' $ Text.pack
            $ packageName </> takeFileName tarballPath <.> "tar.xz"
    remoteResultURI <- hostedSources remoteArchivePath
    remoteFileExists' <- remoteFileExists remoteArchivePath

    if remoteFileExists'
    then fmap (remoteResultURI,) <$> download remoteResultURI localPath
    else
        let go = sourceFile localPath .| sinkHash
         in cloneAndArchive repo tarballPath tagPrefix
            >> uploadCommand localPath remoteArchivePath
            >> liftIO (runConduitRes go) <&> Just . (remoteResultURI,)

-- | Downloads a compressed tar archive and extracts its contents on the fly to
-- a directory.
--
-- If the download contains the disposition header and the attachment type was
-- recognized as tar archive, returns the attachment name from the
-- disposition header without the extension. So if the disposition header
-- is "attachment; filename=package-1.2.3.tar.gz", returns "package-1.2.3".
extractRemote :: URI -> Text -> SlackBuilderT (Maybe Text)
extractRemote uri' packagePath = do
    repository' <- SlackBuilderT $ asks repository
    let localToRepository = repository' </> Text.unpack packagePath
    case useHttpsURI uri' of
        Just (httpsURI, _httpsOptions) ->
            runReq defaultHttpConfig $ go localToRepository httpsURI
        Nothing -> throwM $ HttpsUrlExpected uri'
  where
    go toTarget url' = reqBr GET url' NoReqBody mempty $ readResponse toTarget
    readResponse :: FilePath -> Response BodyReader -> IO (Maybe Text)
    readResponse toTarget response = do
        let attachmentName
                = fmap (Char8.unpack . snd . Char8.breakEnd (== '=') . snd)
                $ find ((== "Content-Disposition") . fst)
                $ responseHeaders response
            (decompress, attachmentDirectory) =
                case attachmentName of
                    Just attachmentName'
                        | Just directoryName' <- stripExtension ".tar.gz" attachmentName' ->
                            (Zlib.ungzip, Just directoryName')
                        | Just directoryName' <- stripExtension ".tar.xz" attachmentName' ->
                            (Lzma.decompress Nothing, Just directoryName')
                    _ -> (pure (), Nothing)
        runConduitRes $ responseBodySource response
            .| decompress
            .| untar (withDecompressedFile toTarget)
        pure $ Text.pack <$> attachmentDirectory
    withDecompressedFile toTarget FileInfo{..}
        | Char8.last filePath /= '/' =
            sinkFile (toTarget </> Char8.unpack filePath)
        | otherwise = liftIO (createDirectory (toTarget </> Char8.unpack filePath))