slackbuilder/lib/SlackBuilder/Download.hs

{- 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/. -}

-- | Contains routines for downloading, cloning and uploading sources.
module SlackBuilder.Download
    ( cloneAndUpload
    , extractRemote
    , commit
    , createLzmaTarball
    , download
    , hostedSources
    , remoteFileExists
    , responseBodySource
    , sinkFileAndHash
    , sinkHash
    , updateSlackBuildVersion
    , uploadSource
    ) where

import qualified Codec.Compression.Lzma as Lzma
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.NonNull (toNullable)
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, removePathForcibly)
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, void)
import Text.URI (URI(..))
import qualified Text.URI as URI
import Network.HTTP.Req
    ( useHttpsURI
    , useURI
    , HEAD(..)
    , NoReqBody(..)
    , req
    , runReq
    , defaultHttpConfig
    , ignoreResponse
    , responseStatusCode
    , MonadHttp
    , HttpConfig(..)
    , GET(..)
    , reqBr
    )
import Data.Functor ((<&>))
import Network.HTTP.Client (BodyReader, Response(..), brRead)
import Conduit
    ( ConduitT
    , MonadResource
    , yield
    , runConduitRes
    , sinkFile
    , (.|)
    , ZipSink(..)
    , await
    , sourceFile
    , leftover, awaitNonNull
    )
import Data.Conduit.Tar (FileInfo(..), tarFilePath, untar)
import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
import Data.Void (Void)
import qualified Data.Conduit.Zlib as Zlib
import Control.Monad.Catch (MonadThrow(..))
import Data.Maybe (fromMaybe)

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 :: NonEmpty Text -> SlackBuilderT URI
hostedSources urlPathPieces = do
        downloadURL' <- SlackBuilderT (asks downloadURL) >>= URI.mkURI
        urlPathPieces' <- traverse URI.mkPathPiece urlPathPieces

        let updatedPath = case URI.uriPath downloadURL' of
                Just (_, existingPath) ->
                    NonEmpty.append existingPath urlPathPieces'
                Nothing -> urlPathPieces'
        pure $ downloadURL'{ uriPath = Just (False, updatedPath) }

remoteFileExists :: NonEmpty Text -> SlackBuilderT Bool
remoteFileExists urlPathPieces = hostedSources urlPathPieces
    >>= 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

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
        $ removePathForcibly 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"
            ]
        >> createLzmaTarball repositoryTarballPath repositoryArchivePath
        >> removePathForcibly repositoryTarballPath

-- | Takes a directory as input and a file name as output and creates a tar.xz
-- archive from the given directory.
createLzmaTarball :: FilePath -> FilePath -> IO (Digest MD5)
createLzmaTarball input output = runConduitRes $ yield input
    .| void tarFilePath
    .| compressLzma
    .| sinkFileAndHash output

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)

cloneAndUpload :: Text -> FilePath -> Text -> SlackBuilderT (URI, Digest MD5)
cloneAndUpload repo tarballPath tagPrefix = do
    let tarballFileName = takeFileName tarballPath <.> "tar.xz"
        packageName = takeFileName $ takeDirectory tarballPath
        remoteArchivePath = Text.pack $ packageName </> tarballFileName
        urlPathPieces = Text.pack <$> packageName :| [tarballFileName]

    localPath <- relativeToRepository tarballFileName
    remoteResultURI <- hostedSources urlPathPieces
    remoteFileExists' <- remoteFileExists urlPathPieces

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

-- | Given a path to a local file and a remote path uploads the file using
-- the settings given in the configuration file.
--
-- The remote path is given relative to the path in the configuration.
uploadSource :: FilePath -> Text -> SlackBuilderT ()
uploadSource localPath remotePath' = do
    uploadCommand' :| uploadArguments <- SlackBuilderT $ asks uploadCommand
    let uploadArguments' = Text.unpack
            . Text.replace "%s" (Text.pack localPath)
            . Text.replace "%c" remotePath'
            <$> uploadArguments

    liftIO $ callProcess (Text.unpack uploadCommand') uploadArguments'

-- | Downlaods a file into the directory. Returns name of the downloaded file
-- and checksum.
--
-- The filename is read from the disposition header or from the URL if the
-- Content-Disposition is missing.
download :: URI -> FilePath -> SlackBuilderT (FilePath, Digest MD5)
download uri packagePath = runReq defaultHttpConfig go
  where
    go
        | Just uriPath <- URI.uriPath uri =
            reqGet uri
                $ readResponse
                $ Text.unpack
                $ URI.unRText
                $ NonEmpty.last
                $ snd uriPath
        | otherwise = throwM $ UnsupportedUrlType uri
    readResponse :: FilePath -> Response BodyReader -> IO (FilePath, Digest MD5)
    readResponse downloadFileName response = do
        let attachmentName = dispositionAttachment response
            targetFileName = fromMaybe downloadFileName attachmentName
            target = packagePath </> fromMaybe downloadFileName attachmentName
        digest <- runConduitRes
            $ responseBodySource response
            .| sinkFileAndHash target
        pure (targetFileName, digest)

-- | Writes a file to the destination path and accumulates its MD5 checksum.
sinkFileAndHash :: MonadResource m => FilePath -> ConduitT ByteString Void m (Digest MD5)
sinkFileAndHash target = getZipSink
    $ ZipSink (sinkFile target) *> ZipSink sinkHash

compressLzma :: MonadIO m => ConduitT ByteString ByteString m ()
compressLzma = liftIO (Lzma.compressIO Lzma.defaultCompressParams) >>= go
  where
    go (Lzma.CompressInputRequired flush supplyInput) = do
        next <- await
        result <- case next of
            Just input
                | ByteString.null input -> liftIO flush
                | otherwise -> liftIO $ supplyInput input
            Nothing -> liftIO $ supplyInput mempty
        go result
    go (Lzma.CompressOutputAvailable output stream) = yield output
        >> liftIO stream >>= go
    go Lzma.CompressStreamEnd = pure ()

decompressLzma :: (MonadThrow m, MonadIO m) => ConduitT ByteString ByteString m ()
decompressLzma = liftIO (Lzma.decompressIO Lzma.defaultDecompressParams) >>= go
  where
    go (Lzma.DecompressInputRequired processor) = do
        next <- awaitNonNull
        result <- case next of
            Just input -> liftIO $ processor (toNullable input)
            Nothing -> liftIO $ processor mempty
        go result
    go (Lzma.DecompressOutputAvailable output stream) = yield output
        >> liftIO stream
        >>= go
    go (Lzma.DecompressStreamEnd output) = leftover output
    go (Lzma.DecompressStreamError lzmaReturn) = throwM
        $ LzmaDecompressionFailed lzmaReturn

-- | 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 -> FilePath -> SlackBuilderT (Maybe FilePath)
extractRemote uri' packagePath =
    runReq defaultHttpConfig $ go packagePath
  where
    go toTarget = reqGet uri' $ readResponse toTarget
    readResponse :: FilePath -> Response BodyReader -> IO (Maybe FilePath)
    readResponse toTarget response = do
        let attachmentName = dispositionAttachment response
            (decompress, attachmentDirectory) =
                case attachmentName of
                    Just attachmentName'
                        | Just directoryName' <- stripExtension ".tar.gz" attachmentName' ->
                            (Zlib.ungzip, Just directoryName')
                        | Just directoryName' <- stripExtension ".tar.xz" attachmentName' ->
                            (decompressLzma, Just directoryName')
                    _ -> (pure (), Nothing)
        runConduitRes $ responseBodySource response
            .| decompress
            .| untar (withDecompressedFile toTarget)
        pure attachmentDirectory
    withDecompressedFile toTarget FileInfo{..}
        | Char8.last filePath /= '/' =
            sinkFile (toTarget </> Char8.unpack filePath)
        | otherwise = liftIO (createDirectory (toTarget </> Char8.unpack filePath))

dispositionAttachment :: Response BodyReader -> Maybe FilePath
dispositionAttachment response
    = fmap (Char8.unpack . snd . Char8.breakEnd (== '=') . snd)
    $ find ((== "Content-Disposition") . fst)
    $ responseHeaders response

reqGet :: (MonadThrow m, MonadHttp m)
    => URI
    -> (Response BodyReader -> IO a)
    -> m a
reqGet uri bodyReader =
    case useURI uri of
        Just urlWithOptions
            | Left (httpsURI, httpsOptions) <- urlWithOptions ->
                reqBr GET httpsURI NoReqBody httpsOptions bodyReader
            | Right (httpsURI, httpsOptions) <- urlWithOptions ->
                reqBr GET httpsURI NoReqBody httpsOptions bodyReader
        _ -> throwM $ UnsupportedUrlType uri