{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

-- | Provide ability to upload tarballs to Hackage.
module Stack.Upload
  ( -- * Upload
    upload
  , uploadBytes
  , uploadRevision
    -- * Credentials
  , HackageCreds
  , HackageAuth (..)
  , HackageKey (..)
  , loadAuth
  , writeFilePrivate
    -- * Internal
  , maybeGetHackageKey
  ) where

import           Conduit ( mapOutput, sinkList )
import           Data.Aeson
                   ( FromJSON (..), ToJSON (..), decode', toEncoding
                   , fromEncoding, object, 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
                   , withResponse, httpNoBody, getGlobalManager
                   , getResponseStatusCode, getResponseBody, setRequestHeader
                   , parseRequest, formDataBody, partFileRequestBody, partBS
                   , partLBS, applyDigestAuth, displayDigestAuthException
                   )
import           Stack.Options.UploadParser
import           Stack.Prelude
import           Stack.Types.Config
import           System.Directory
                   ( createDirectoryIfMissing, removeFile, renameFile )
import           System.Environment ( lookupEnv )
import           System.FilePath ( (</>), takeFileName, takeDirectory )
import           System.PosixCompat.Files ( setFileMode )

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

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 => Config -> RIO m HackageAuth
loadAuth config = do
  maybeHackageKey <- maybeGetHackageKey
  case maybeHackageKey of
    Just key -> do
      logInfo "HACKAGE_KEY found in env, 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 :: HasLogFunc 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
        logWarn "WARNING: You've set save-hackage-creds to false"
        logWarn "However, credentials were found at:"
        logWarn $ "  " <> fromString fp
      pure $ mkCreds fp
  where
    fromPrompt :: HasLogFunc 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]? "
        logInfo "NOTE: Avoid this prompt in the future by using: save-hackage-creds: false"
        when shouldSave $ do
          writeFilePrivate fp $ fromEncoding $ toEncoding hc
          logInfo "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 (takeDirectory 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) </> "upload"
    createDirectoryIfMissing True dir
    pure $ dir </> "credentials.json"

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

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

applyCreds :: HasLogFunc m => HackageCreds -> Request -> RIO m Request
applyCreds creds req0 = do
  manager <- liftIO getGlobalManager
  ereq <- liftIO $ applyDigestAuth
    (encodeUtf8 $ hcUsername creds)
    (encodeUtf8 $ hcPassword creds)
    req0
    manager
  case ereq of
      Left e -> do
          logWarn "WARNING: No HTTP digest prompt found, this will probably fail"
          case fromException e of
              Just e' -> logWarn $ fromString $ displayDigestAuthException e'
              Nothing -> logWarn $ fromString $ 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 :: HasLogFunc m
            => String -- ^ Hackage base URL
            -> HackageAuth
            -> String -- ^ tar file name
            -> UploadVariant
            -> L.ByteString -- ^ tar file contents
            -> RIO m ()
uploadBytes baseUrl auth tarName uploadVariant bytes = do
    let req1 = setRequestHeader "Accept" ["text/plain"]
               (fromString $ baseUrl
                          <> "packages/"
                          <> case uploadVariant of
                               Publishing -> ""
                               Candidate -> "candidates/"
               )
        formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
    req2 <- liftIO $ formDataBody formData req1
    req3 <- applyAuth auth req2
    logInfo $ "Uploading " <> fromString tarName <> "... "
    hFlush stdout
    withRunInIO $ \runInIO -> withResponse req3 (runInIO . inner)
 where
    inner :: HasLogFunc m => Response (ConduitM () S.ByteString IO ()) -> RIO m ()
    inner res =
        case getResponseStatusCode res of
            200 -> logInfo "done!"
            401 -> do
                case auth of
                  HACreds creds -> handleIO (const $ pure ()) (liftIO $ removeFile (hcCredsFile creds))
                  _ -> pure ()
                throwIO $ PrettyException AuthenticationFailure
            403 -> do
                logError "Error: [S-2804]"
                logError "forbidden upload"
                logError "Usually means: you've already uploaded this package/version combination"
                logError "Ignoring error and continuing, full message from Hackage below:\n"
                liftIO $ printBody res
            503 -> do
                logError "Error: [S-4444]"
                logError "service unavailable"
                logError "This error some times gets sent even though the upload succeeded"
                logError "Check on Hackage to see if your package is present"
                liftIO $ printBody res
            code -> do
                let resBody = mapOutput show (getResponseBody res)
                resBody' <- liftIO $ runConduit $ resBody .| sinkList
                throwIO $ PrettyException (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
       => String -- ^ Hackage base URL
       -> HackageAuth
       -> FilePath
       -> UploadVariant
       -> RIO m ()
upload baseUrl auth fp uploadVariant =
  uploadBytes baseUrl auth (takeFileName fp) uploadVariant =<< liftIO (L.readFile fp)

uploadRevision :: HasLogFunc 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
  void $ httpNoBody req2