{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}

-- | Types and functions related to Stack's @upload@ command.
module Stack.Upload
  ( -- * Upload
    UploadOpts (..)
  , SDistOpts (..)
  , UploadVariant (..)
  , uploadCmd
  , upload
  , uploadBytes
  , uploadRevision
    -- * Credentials
  , HackageCreds
  , HackageAuth (..)
  , HackageKey (..)
  , loadAuth
  , writeFilePrivate
    -- * Internal
  , maybeGetHackageKey
  ) where

import           Conduit ( mapOutput, sinkList )
import           Data.Aeson
                   ( FromJSON (..), ToJSON (..), (.:), (.=), decode'
                   , fromEncoding, object, toEncoding, withObject
                   )
import           Data.ByteString.Builder ( lazyByteString )
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Conduit.Binary as CB
import qualified Data.Text as T
import           Network.HTTP.StackClient
                   ( Request, RequestBody (RequestBodyLBS), Response
                   , applyDigestAuth, displayDigestAuthException, formDataBody
                   , getGlobalManager, getResponseBody, getResponseStatusCode
                   , httpNoBody, parseRequest, partBS, partFileRequestBody
                   , partLBS, setRequestHeader, setRequestHeaders, withResponse
                   )
import           Path ( (</>), addExtension, parseRelFile )
import           Path.IO ( resolveDir', resolveFile' )
import qualified Path.IO as Path
import           Stack.Constants ( isStackUploadDisabled )
import           Stack.Constants.Config ( distDirFromDir )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.SDist
                   ( SDistOpts (..), checkSDistTarball, checkSDistTarball'
                   , getSDistTarball, readLocalPackage
                   )
import           Stack.Types.Config ( Config (..), configL, stackRootL )
import           Stack.Types.EnvConfig ( HasEnvConfig )
import           Stack.Types.Package ( LocalPackage (..), packageIdentifier )
import           Stack.Types.Runner ( Runner )
import           System.Directory
                   ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
                   , removeFile, renameFile
                   )
import           System.Environment ( lookupEnv )
import qualified System.FilePath as FP
import           System.PosixCompat.Files ( setFileMode )
import Stack.Types.PvpBounds (PvpBounds)

-- | Type representing \'pretty\' exceptions thrown by functions exported by the
-- "Stack.Upload" module.
data UploadPrettyException
  = AuthenticationFailure
  | ArchiveUploadFailure Int [String] String
  deriving (Show, Typeable)

instance Pretty UploadPrettyException where
  pretty AuthenticationFailure =
       "[S-2256]"
    <> line
    <> flow "authentification failure"
    <> line
    <> flow "Authentication failure uploading to server"
  pretty (ArchiveUploadFailure code res tarName) =
       "[S-6108]"
    <> line
    <> flow "unhandled status code:" <+> fromString (show code)
    <> line
    <> flow "Upload failed on" <+> style File (fromString tarName)
    <> line
    <> vsep (map string res)

instance Exception UploadPrettyException

-- | Type representing forms of content for upload to Hackage.
data UploadContent
  = SDist
  | DocArchive

-- | Type representing variants for uploading to Hackage.
data UploadVariant
  = Publishing
    -- ^ Publish the package/a published package.
  | Candidate
    -- ^ Create a package candidate/a package candidate.

-- | Type representing command line options for the @stack upload@ command.
data UploadOpts = UploadOpts
  { uoItemsToWorkWith :: ![String]
  , uoDocumentation :: !Bool
  , uoPvpBounds :: !(Maybe PvpBounds)
  , uoCheck :: !Bool
  , uoBuildPackage :: !Bool
  , uoTarPath :: !(Maybe FilePath)
  , uoUploadVariant :: !UploadVariant
  }

-- | Function underlying the @stack upload@ command. Upload to Hackage.
uploadCmd :: UploadOpts -> RIO Runner ()
uploadCmd (UploadOpts [] uoDocumentation _ _ _ _ _) = do
  let subject = if uoDocumentation
        then "documentation for the current package,"
        else "the current package,"
  prettyErrorL
    [ flow "An item must be specified. To upload"
    , flow subject
    , flow "please run"
    , style Shell "stack upload ."
    , flow "(with the period at the end)"
    ]
  liftIO exitFailure
uploadCmd (UploadOpts {..}) = withConfig YesReexec $ withDefaultEnvConfig $ do
  config <- view configL
  let hackageUrl = T.unpack $ configHackageBaseUrl config
  if uoDocumentation
    then do
      (dirs, invalid) <-
        liftIO $ partitionM doesDirectoryExist uoItemsToWorkWith
      unless (null invalid) $ do
        let invalidList =
              bulletedList $ map (style Current . fromString) invalid
        prettyError $
          flow "For documentation upload, Stack expects a list of relative \
               \paths to package directories. Stack can't find:"
          <> line
          <> invalidList
        exitFailure
      (failed, items) <- partitionEithers <$> forM dirs checkDocsTarball
      unless (null failed) $ do
        let invalidItem (pkgIdName, tarGzFile) = fillSep
              [ pretty tarGzFile
              , "for"
              , style Current (fromString pkgIdName) <> "."
              ]
            invalidList = bulletedList $ map invalidItem failed
        prettyError $
          flow "Stack can't find:"
          <> line
          <> invalidList
        exitFailure
      getCreds <- memoizeRef $ loadAuth config
      forM_ items $ \(pkgIdName, tarGzFile) -> do
        creds <- runMemoized getCreds
        upload
          hackageUrl
          creds
          DocArchive
          (Just pkgIdName)
          (toFilePath tarGzFile)
          uoUploadVariant
    else do
      (files, nonFiles) <- liftIO $ partitionM doesFileExist uoItemsToWorkWith
      (dirs, invalid) <- liftIO $ partitionM doesDirectoryExist nonFiles
      unless (null invalid) $ do
        let invalidList = bulletedList $ map (style File . fromString) invalid
        prettyError $
             flow "For package upload, Stack expects a list of relative paths \
                  \to tosdist tarballs or package directories. Stack can't \
                  \find:"
          <> line
          <> invalidList
        exitFailure
      let sdistOpts = SDistOpts
            uoItemsToWorkWith
            uoPvpBounds
            uoCheck
            uoBuildPackage
            uoTarPath
      getCreds <- memoizeRef $ loadAuth config
      mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files
      forM_ files $ \file -> do
        tarFile <- resolveFile' file
        creds <- runMemoized getCreds
        upload
          hackageUrl
          creds
          SDist
          Nothing
          (toFilePath tarFile)
          uoUploadVariant
      forM_ dirs $ \dir -> do
        pkgDir <- resolveDir' dir
        (tarName, tarBytes, mcabalRevision) <- getSDistTarball uoPvpBounds pkgDir
        checkSDistTarball' sdistOpts tarName tarBytes
        creds <- runMemoized getCreds
        uploadBytes
          hackageUrl
          creds
          SDist
          Nothing
          tarName
          uoUploadVariant
          tarBytes
        forM_ mcabalRevision $ uncurry $ uploadRevision hackageUrl creds
   where
    checkDocsTarball ::
         HasEnvConfig env
      => FilePath
      -> RIO env (Either (String, Path Abs File) (String, Path Abs File))
    checkDocsTarball dir = do
      pkgDir <- resolveDir' dir
      distDir <- distDirFromDir pkgDir
      lp <- readLocalPackage pkgDir
      let pkgId = packageIdentifier (lpPackage lp)
          pkgIdName = packageIdentifierString pkgId
          name = pkgIdName <> "-docs"
          tarGzFileName = fromMaybe
            (error "impossible")
            ( do nameRelFile <- parseRelFile name
                 addExtension ".gz" =<< addExtension ".tar" nameRelFile
            )
          tarGzFile = distDir Path.</> tarGzFileName
      isFile <- Path.doesFileExist tarGzFile
      pure $ (if isFile then Right else Left) (pkgIdName, tarGzFile)
    partitionM _ [] = pure ([], [])
    partitionM f (x:xs) = do
      r <- f x
      (as, bs) <- partitionM f xs
      pure $ if r then (x:as, bs) else (as, x:bs)

newtype HackageKey = HackageKey Text
  deriving (Eq, Show)

-- | Username and password to log into Hackage.
--
-- Since 0.1.0.0
data HackageCreds = HackageCreds
  { hcUsername :: !Text
  , hcPassword :: !Text
  , hcCredsFile :: !FilePath
  }
  deriving (Eq, Show)

data HackageAuth
  = HAKey HackageKey
  | HACreds HackageCreds
  deriving (Eq, Show)

instance ToJSON HackageCreds where
  toJSON (HackageCreds u p _) = object
    [ "username" .= u
    , "password" .= p
    ]

instance FromJSON (FilePath -> HackageCreds) where
  parseJSON = withObject "HackageCreds" $ \o -> HackageCreds
    <$> o .: "username"
    <*> o .: "password"

withEnvVariable :: Text -> IO Text -> IO Text
withEnvVariable varName fromPrompt =
  lookupEnv (T.unpack varName) >>= maybe fromPrompt (pure . T.pack)

maybeGetHackageKey :: RIO m (Maybe HackageKey)
maybeGetHackageKey =
  liftIO $ fmap (HackageKey . T.pack) <$> lookupEnv "HACKAGE_KEY"

loadAuth :: (HasLogFunc m, HasTerm m) => Config -> RIO m HackageAuth
loadAuth config = do
  maybeHackageKey <- maybeGetHackageKey
  case maybeHackageKey of
    Just key -> do
      prettyInfoS
        "HACKAGE_KEY environment variable found, using that for credentials."
      pure $ HAKey key
    Nothing -> HACreds <$> loadUserAndPassword config

-- | Load Hackage credentials, either from a save file or the command
-- line.
--
-- Since 0.1.0.0
loadUserAndPassword :: HasTerm m => Config -> RIO m HackageCreds
loadUserAndPassword config = do
  fp <- liftIO $ credsFile config
  elbs <- liftIO $ tryIO $ L.readFile fp
  case either (const Nothing) Just elbs >>= \lbs -> (lbs, ) <$> decode' lbs of
    Nothing -> fromPrompt fp
    Just (lbs, mkCreds) -> do
      -- Ensure privacy, for cleaning up old versions of Stack that
      -- didn't do this
      writeFilePrivate fp $ lazyByteString lbs

      unless (configSaveHackageCreds config) $ do
        prettyWarnL
          [ flow "You've set save-hackage-creds to false. However, credentials \
                 \ were found at:"
          , style File (fromString fp) <> "."
          ]
      pure $ mkCreds fp
 where
  fromPrompt :: HasTerm m => FilePath -> RIO m HackageCreds
  fromPrompt fp = do
    username <- liftIO $ withEnvVariable "HACKAGE_USERNAME" (prompt "Hackage username: ")
    password <- liftIO $ withEnvVariable "HACKAGE_PASSWORD" (promptPassword "Hackage password: ")
    let hc = HackageCreds
          { hcUsername = username
          , hcPassword = password
          , hcCredsFile = fp
          }

    when (configSaveHackageCreds config) $ do
      shouldSave <- promptBool $ T.pack $
        "Save Hackage credentials to file at " ++ fp ++ " [y/n]? "
      prettyNoteL
        [ flow "Avoid this prompt in the future by using the configuration \
               \file option"
        , style Shell (flow "save-hackage-creds: false") <> "."
        ]
      when shouldSave $ do
        writeFilePrivate fp $ fromEncoding $ toEncoding hc
        prettyInfoS "Saved!"
        hFlush stdout

    pure hc

-- | Write contents to a file which is always private.
--
-- For history of this function, see:
--
-- * https://github.com/commercialhaskell/stack/issues/2159#issuecomment-477948928
--
-- * https://github.com/commercialhaskell/stack/pull/4665
writeFilePrivate :: MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate fp builder =
  liftIO $ withTempFile (FP.takeDirectory fp) (FP.takeFileName fp) $ \fpTmp h -> do
    -- Temp file is created such that only current user can read and write it.
    -- See docs for openTempFile:
    -- https://www.stackage.org/haddock/lts-13.14/base-4.12.0.0/System-IO.html#v:openTempFile

    -- Write to the file and close the handle.
    hPutBuilder h builder
    hClose h

    -- Make sure the destination file, if present, is writeable
    void $ tryIO $ setFileMode fp 0o600

    -- And atomically move
    renameFile fpTmp fp

credsFile :: Config -> IO FilePath
credsFile config = do
  let dir = toFilePath (view stackRootL config) FP.</> "upload"
  createDirectoryIfMissing True dir
  pure $ dir FP.</> "credentials.json"

addAPIKey :: HackageKey -> Request -> Request
addAPIKey (HackageKey key) = setRequestHeader
  "Authorization"
  [fromString $ "X-ApiKey" ++ " " ++ T.unpack key]

applyAuth ::
     (HasLogFunc m, HasTerm m)
  => HackageAuth
  -> Request
  -> RIO m Request
applyAuth haAuth req0 =
  case haAuth of
    HAKey key -> pure (addAPIKey key req0)
    HACreds creds -> applyCreds creds req0

applyCreds ::
     (HasLogFunc m, HasTerm m)
  => HackageCreds
  -> Request
  -> RIO m Request
applyCreds creds req0 = do
  manager <- liftIO getGlobalManager
  ereq <- if isStackUploadDisabled
    then do
      debugRequest "applyCreds" req0
      pure (Left $ toException ExitSuccess )
    else
      liftIO $ applyDigestAuth
        (encodeUtf8 $ hcUsername creds)
        (encodeUtf8 $ hcPassword creds)
        req0
        manager
  case ereq of
    Left e -> do
      prettyWarn $
           flow "No HTTP digest prompt found, this will probably fail."
        <> blankLine
        <> string
             ( case fromException e of
                 Just e' -> displayDigestAuthException e'
                 Nothing -> displayException e
             )
      pure req0
    Right req -> pure req

-- | Upload a single tarball with the given @Uploader@. Instead of sending a
-- file like 'upload', this sends a lazy bytestring.
--
-- Since 0.1.2.1
uploadBytes ::
     HasTerm m
  => String -- ^ Hackage base URL
  -> HackageAuth
  -> UploadContent
     -- ^ Form of the content to be uploaded.
  -> Maybe String
     -- ^ Optional package identifier name, applies only to the upload of
     -- documentation.
  -> String -- ^ tar file name
  -> UploadVariant
  -> L.ByteString -- ^ tar file contents
  -> RIO m ()
uploadBytes baseUrl auth contentForm mPkgIdName tarName uploadVariant bytes = do
  (url, headers) <- case contentForm of
    SDist -> do
      unless (isNothing mPkgIdName) $
        error "uploadBytes: package identified specified"
      let variant = case uploadVariant of
            Publishing -> ""
            Candidate -> "candidates/"
      pure
        ( baseUrl <> "packages/" <> variant
        , [("Accept", "text/plain")]
        )
    DocArchive -> case mPkgIdName of
      Nothing -> error "uploadBytes: package identified not specified"
      Just pkgIdName -> do
        let variant = case uploadVariant of
              Publishing -> ""
              Candidate -> "candidate/"
        pure
          ( baseUrl <> "package/" <> pkgIdName <> "/" <> variant <> "docs"
          , [ ("Accept", "application/x-tar")
            , ("Accept-Encoding", "gzip")
            ]
          )
  let req1 = setRequestHeaders headers (fromString url)
      formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
  req2 <- liftIO $ formDataBody formData req1
  req3 <- applyAuth auth req2
  prettyInfoL
    [ "Uploading"
    , style Current (fromString tarName) <> "..."
    ]
  hFlush stdout
  if isStackUploadDisabled
    then
      debugRequest "uploadBytes" req3
    else
      withRunInIO $ \runInIO -> withResponse req3 (runInIO . inner)
 where
  inner :: HasTerm m => Response (ConduitM () S.ByteString IO ()) -> RIO m ()
  inner res =
    case getResponseStatusCode res of
      200 -> prettyInfoS "done!"
      401 -> do
        case auth of
          HACreds creds ->
            handleIO
              (const $ pure ())
              (liftIO $ removeFile (hcCredsFile creds))
          _ -> pure ()
        prettyThrowIO AuthenticationFailure
      403 -> do
        prettyError $
          "[S-2804]"
          <> line
          <> flow "forbidden upload"
          <> line
          <> flow "Usually means: you've already uploaded this package/version \
                  \combination. Ignoring error and continuing. The full \
                  \message from Hackage is below:"
          <> blankLine
        liftIO $ printBody res
      503 -> do
        prettyError $
          "[S-4444]"
          <> line
          <> flow "service unavailable"
          <> line
          <> flow "This error some times gets sent even though the upload \
                  \succeeded. Check on Hackage to see if your package is \
                  \present. The full message form Hackage is below:"
          <> blankLine
        liftIO $ printBody res
      code -> do
        let resBody = mapOutput show (getResponseBody res)
        resBody' <- liftIO $ runConduit $ resBody .| sinkList
        prettyThrowIO (ArchiveUploadFailure code resBody' tarName)

printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()
printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout

-- | Upload a single tarball with the given @Uploader@.
--
-- Since 0.1.0.0
upload ::
     (HasLogFunc m, HasTerm m)
  => String -- ^ Hackage base URL
  -> HackageAuth
  -> UploadContent
  -> Maybe String
     -- ^ Optional package identifier name, applies only to the upload of
     -- documentation.
  -> FilePath
     -- ^ Path to archive file.
  -> UploadVariant
  -> RIO m ()
upload baseUrl auth contentForm mPkgIdName fp uploadVariant =
  uploadBytes
    baseUrl auth contentForm mPkgIdName (FP.takeFileName fp) uploadVariant
      =<< liftIO (L.readFile fp)

uploadRevision ::
     (HasLogFunc m, HasTerm m)
  => String -- ^ Hackage base URL
  -> HackageAuth
  -> PackageIdentifier
  -> L.ByteString
  -> RIO m ()
uploadRevision baseUrl auth ident@(PackageIdentifier name _) cabalFile = do
  req0 <- parseRequest $ concat
    [ baseUrl
    , "package/"
    , packageIdentifierString ident
    , "/"
    , packageNameString name
    , ".cabal/edit"
    ]
  req1 <- formDataBody
    [ partLBS "cabalfile" cabalFile
    , partBS "publish" "on"
    ]
    req0
  req2 <- applyAuth auth req1
  if isStackUploadDisabled
    then
      debugRequest "uploadRevision" req2
    else
      void $ httpNoBody req2

debugRequest :: HasTerm env => String -> Request -> RIO env ()
debugRequest callSite req = prettyInfo $
     fillSep
       [ fromString callSite <> ":"
       , flow "When enabled, would apply the following request:"
       ]
  <> line
  <> fromString (show req)