path: root/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
    , download
    , hostedSources
    , remoteFileExists
    , responseBodySource
    , sinkFileAndHash
    , sinkHash
    , updateSlackBuildVersion
    , uploadSource
    ) where

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.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(..))
import qualified Text.URI as URI
import Network.HTTP.Req
    ( useHttpsURI
    , HEAD(..)
    , NoReqBody(..)
    , req
    , runReq
    , defaultHttpConfig
    , ignoreResponse
    , responseStatusCode
    , HttpConfig(..)
    , GET(..)
    , reqBr, MonadHttp
    )
import Data.Functor ((<&>))
import Network.HTTP.Client (BodyReader, Response(..), brRead)
import Conduit
    ( ConduitT
    , yield
    , runConduitRes
    , sinkFile
    , (.|)
    , ZipSink(..)
    , await
    , sourceFile, MonadResource
    )
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(..))
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 :: Text -> SlackBuilderT URI
hostedSources absoluteURL = SlackBuilderT (asks downloadURL)
    >>= liftIO . URI.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

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)

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

    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 $ HttpsUrlExpected 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

-- | 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' ->
                            (Lzma.decompress Nothing, 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
    | Just (httpsURI, httpsOptions) <- useHttpsURI uri =
        reqBr GET httpsURI NoReqBody httpsOptions bodyReader
    | otherwise = throwM $ HttpsUrlExpected uri