{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

-- | Deal with downloading, cloning, or whatever else is necessary for
-- getting a 'PackageLocation' into something Stack can work with.
module Stack.PackageLocation
  ( resolveSinglePackageLocation
  , resolveMultiPackageLocation
  , parseSingleCabalFile
  , parseSingleCabalFileIndex
  , parseMultiCabalFiles
  , parseMultiCabalFilesIndex
  ) where

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Zip as Zip
import qualified Codec.Compression.GZip as GZip
import Stack.Prelude
import           Crypto.Hash (hashWith, SHA256(..))
import qualified Data.ByteArray as Mem (convert)
import qualified Data.ByteString as S
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Distribution.PackageDescription (GenericPackageDescription)
import Network.HTTP.Client (parseUrlThrow)
import Network.HTTP.Download.Verified
import Path
import Path.Extra
import Path.IO
import Stack.Package
import Stack.Types.BuildPlan
import Stack.Types.Config
import Stack.Types.PackageIdentifier
import qualified System.Directory as Dir
import System.Process.Read
import System.Process.Run

-- | Same as 'resolveMultiPackageLocation', but works on a
-- 'SinglePackageLocation'.
resolveSinglePackageLocation
    :: HasConfig env
    => Path Abs Dir -- ^ project root
    -> PackageLocation FilePath
    -> RIO env (Path Abs Dir)
resolveSinglePackageLocation projRoot (PLFilePath fp) = resolveDir projRoot fp
resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do
    workDir <- view workDirL

        -- TODO: dedupe with code for snapshot hash?
    let name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 url
        root = projRoot </> workDir </> $(mkRelDir "downloaded")
        fileExtension' = ".http-archive"

    fileRel <- parseRelFile $ name ++ fileExtension'
    dirRel <- parseRelDir name
    dirRelTmp <- parseRelDir $ name ++ ".tmp"
    let fileDownload = root </> fileRel
        dir = root </> dirRel

    exists <- doesDirExist dir
    unless exists $ do
        liftIO $ ignoringAbsence (removeDirRecur dir)

        let dirTmp = root </> dirRelTmp
        liftIO $ ignoringAbsence (removeDirRecur dirTmp)

        urlExists <- liftIO $ Dir.doesFileExist $ T.unpack url
        file <-
          if urlExists
            then do
              file <- liftIO $ Dir.canonicalizePath (T.unpack url) >>= parseAbsFile
              case msha of
                Nothing -> return ()
                Just sha -> do
                  actualSha <- mkStaticSHA256FromFile file
                  when (sha /= actualSha) $ error $ concat
                    [ "Invalid SHA256 found for local archive "
                    , show file
                    , "\nExpected: "
                    , T.unpack $ staticSHA256ToText sha
                    , "\nActual:   "
                    , T.unpack $ staticSHA256ToText actualSha
                    ]
              return file
            else do
              req <- parseUrlThrow $ T.unpack url
              let dreq = DownloadRequest
                    { drRequest = req
                    , drHashChecks =
                        case msha of
                          Nothing -> []
                          Just sha ->
                            [HashCheck
                              { hashCheckAlgorithm = SHA256
                              , hashCheckHexDigest = CheckHexDigestByteString $ staticSHA256ToBase16 sha
                              }]
                    , drLengthCheck = Nothing -- TODO add length info?
                    , drRetryPolicy = drRetryPolicyDefault
                    }
              _ <- verifiedDownload dreq fileDownload (const $ return ())
              return fileDownload

        let fp = toFilePath file

        let tryTar = do
                logDebug $ "Trying to untar " <> T.pack fp
                liftIO $ withBinaryFile fp ReadMode $ \h -> do
                    lbs <- L.hGetContents h
                    let entries = Tar.read $ GZip.decompress lbs
                    Tar.unpack (toFilePath dirTmp) entries
            tryZip = do
                logDebug $ "Trying to unzip " <> T.pack fp
                archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp
                liftIO $  Zip.extractFilesFromArchive [Zip.OptDestination
                                                       (toFilePath dirTmp)] archive
            err = throwM $ UnableToExtractArchive url file

            catchAnyLog goodpath handler =
                catchAny goodpath $ \e -> do
                    logDebug $ "Got exception: " <> T.pack (show e)
                    handler

        tryTar `catchAnyLog` tryZip `catchAnyLog` err
        renameDir dirTmp dir

    x <- listDir dir
    case x of
        ([dir'], []) -> resolveDir dir' subdir
        (dirs, files) -> liftIO $ do
            ignoringAbsence (removeFile fileDownload)
            ignoringAbsence (removeDirRecur dir)
            throwIO $ UnexpectedArchiveContents dirs files
resolveSinglePackageLocation projRoot (PLRepo (Repo url commit repoType' subdir)) =
    cloneRepo projRoot url commit repoType' >>= flip resolveDir subdir

-- | Resolve a PackageLocation into a path, downloading and cloning as
-- necessary.
--
-- Returns the updated PackageLocation value with just a single subdir
-- (if relevant).
resolveMultiPackageLocation
    :: HasConfig env
    => Path Abs Dir -- ^ project root
    -> PackageLocation Subdirs
    -> RIO env [(Path Abs Dir, PackageLocation FilePath)]
resolveMultiPackageLocation y (PLFilePath fp) = do
  dir <- resolveSinglePackageLocation y (PLFilePath fp)
  return [(dir, PLFilePath fp)]
resolveMultiPackageLocation y (PLArchive (Archive url subdirs msha)) = do
  dir <- resolveSinglePackageLocation y (PLArchive (Archive url "." msha))
  let subdirs' =
        case subdirs of
          DefaultSubdirs -> ["."]
          ExplicitSubdirs subs -> subs
  forM subdirs' $ \subdir -> do
    dir' <- resolveDir dir subdir
    return (dir', PLArchive (Archive url subdir msha))
resolveMultiPackageLocation projRoot (PLRepo (Repo url commit repoType' subdirs)) = do
  dir <- cloneRepo projRoot url commit repoType'

  let subdirs' =
        case subdirs of
          DefaultSubdirs -> ["."]
          ExplicitSubdirs subs -> subs
  forM subdirs' $ \subdir -> do
    dir' <- resolveDir dir subdir
    return (dir', PLRepo $ Repo url commit repoType' subdir)

cloneRepo
    :: HasConfig env
    => Path Abs Dir -- ^ project root
    -> Text -- ^ URL
    -> Text -- ^ commit
    -> RepoType
    -> RIO env (Path Abs Dir)
cloneRepo projRoot url commit repoType' = do
    workDir <- view workDirL
    let nameBeforeHashing = case repoType' of
            RepoGit -> T.unwords [url, commit]
            RepoHg -> T.unwords [url, commit, "hg"]
        -- TODO: dedupe with code for snapshot hash?
        name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing
        root = projRoot </> workDir </> $(mkRelDir "downloaded")

    dirRel <- parseRelDir name
    let dir = root </> dirRel

    exists <- doesDirExist dir
    unless exists $ do
        liftIO $ ignoringAbsence (removeDirRecur dir)
        menv <- getMinimalEnvOverride

        let cloneAndExtract commandName cloneArgs resetCommand = do
                ensureDir root
                logInfo $ "Cloning " <> commit <> " from " <> url
                callProcessInheritStderrStdout Cmd
                    { cmdDirectoryToRunIn = Just root
                    , cmdCommandToRun = commandName
                    , cmdEnvOverride = menv
                    , cmdCommandLineArguments =
                        "clone" :
                        cloneArgs ++
                        [ T.unpack url
                        , toFilePathNoTrailingSep dir
                        ]
                    }
                created <- doesDirExist dir
                unless created $ throwM $ FailedToCloneRepo commandName
                readProcessNull (Just dir) menv commandName
                    (resetCommand ++ [T.unpack commit, "--"])
                    `catch` \case
                        ex@ProcessFailed{} -> do
                            logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url
                            throwM ex
                        ex -> throwM ex

        case repoType' of
            RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"]
            RepoHg  -> cloneAndExtract "hg"  []              ["--repository", ".", "update", "-C"]

    return dir

-- | Parse the cabal files present in the given
-- 'PackageLocationIndex FilePath'.
parseSingleCabalFileIndex
  :: forall env.
     HasConfig env
  => (PackageIdentifierRevision -> IO ByteString) -- ^ lookup in index
  -> Path Abs Dir -- ^ project root, used for checking out necessary files
  -> PackageLocationIndex FilePath
  -> RIO env GenericPackageDescription
-- Need special handling of PLIndex for efficiency (just read from the
-- index tarball) and correctness (get the cabal file from the index,
-- not the package tarball itself, yay Hackage revisions).
parseSingleCabalFileIndex loadFromIndex _ (PLIndex pir) = readPackageUnresolvedIndex loadFromIndex pir
parseSingleCabalFileIndex _ root (PLOther loc) = lpvGPD <$> parseSingleCabalFile root False loc

parseSingleCabalFile
  :: forall env. HasConfig env
  => Path Abs Dir -- ^ project root, used for checking out necessary files
  -> Bool -- ^ print warnings?
  -> PackageLocation FilePath
  -> RIO env LocalPackageView
parseSingleCabalFile root printWarnings loc = do
  dir <- resolveSinglePackageLocation root loc
  (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings
  return LocalPackageView
    { lpvCabalFP = cabalfp
    , lpvGPD = gpd
    , lpvLoc = loc
    }

-- | Load and parse cabal files into 'GenericPackageDescription's
parseMultiCabalFiles
  :: forall env. HasConfig env
  => Path Abs Dir -- ^ project root, used for checking out necessary files
  -> Bool -- ^ print warnings?
  -> PackageLocation Subdirs
  -> RIO env [LocalPackageView]
parseMultiCabalFiles root printWarnings loc0 =
  resolveMultiPackageLocation root loc0 >>=
  mapM (\(dir, loc1) -> do
    (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings
    return LocalPackageView
      { lpvCabalFP = cabalfp
      , lpvGPD = gpd
      , lpvLoc = loc1
      })

-- | 'parseMultiCabalFiles' but supports 'PLIndex'
parseMultiCabalFilesIndex
  :: forall env. HasConfig env
  => (PackageIdentifierRevision -> IO ByteString)
  -> Path Abs Dir -- ^ project root, used for checking out necessary files
  -> PackageLocationIndex Subdirs
  -> RIO env [(GenericPackageDescription, PackageLocationIndex FilePath)]
parseMultiCabalFilesIndex loadFromIndex _root (PLIndex pir) =
  (pure . (, PLIndex pir)) <$>
  readPackageUnresolvedIndex loadFromIndex pir
parseMultiCabalFilesIndex _ root (PLOther loc0) =
  map (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv)) <$>
  parseMultiCabalFiles root False loc0