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

-- | 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'
                   , 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, withResponse
                   )
import           Stack.Options.UploadParser ( UploadVariant (..) )
import           Stack.Prelude
import           Stack.Types.Config ( Config (..), stackRootL )
import           System.Directory
                   ( createDirectoryIfMissing, removeFile, renameFile )
import           System.Environment ( lookupEnv )
import           System.FilePath ( (</>), takeDirectory, takeFileName )
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, HasTerm 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, 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 :: 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:
--
-- * #issuecomment-477948928
--
-- * 
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:
    -- -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) = 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 <- 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 :: (HasLogFunc m, HasTerm 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 ()
        prettyThrowIO 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
        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
       -> FilePath
       -> UploadVariant
       -> RIO m ()
upload baseUrl auth fp uploadVariant =
  uploadBytes baseUrl auth (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
  void $ httpNoBody req2

# LANGUAGE OverloadedStrings   #
 | Provide ability to upload tarballs to Hackage.
 * Upload
 * Credentials
 * Internal

 | Load Hackage credentials, either from a save file or the command
 line.

 didn't do this
 | Write contents to a file which is always private.

 For history of this function, see:

 * #issuecomment-477948928

 * 
 Temp file is created such that only current user can read and write it.
 See docs for openTempFile:
 -13.14/base-4.12.0.0/System-IO.html#v:openTempFile
 Write to the file and close the handle.
 Make sure the destination file, if present, is writeable
 And atomically move
 | 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
 ^ Hackage base URL
 ^ tar file name
 ^ tar file contents
 | Upload a single tarball with the given @Uploader@.

 ^ Hackage base URL
 ^ Hackage base URL
# LANGUAGE NoImplicitPrelude    #

module Stack.Upload
    upload
  , uploadBytes
  , uploadRevision
  , HackageCreds
  , HackageAuth (..)
  , HackageKey (..)
  , loadAuth
  , writeFilePrivate
  , 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, withResponse
                   )
import           Stack.Options.UploadParser ( UploadVariant (..) )
import           Stack.Prelude
import           Stack.Types.Config ( Config (..), stackRootL )
import           System.Directory
                   ( createDirectoryIfMissing, removeFile, renameFile )
import           System.Environment ( lookupEnv )
import           System.FilePath ( (</>), takeDirectory, takeFileName )
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, HasTerm 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

  Since 0.1.0.0
loadUserAndPassword ::
     (HasLogFunc m, 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
      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 :: 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

writeFilePrivate :: MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate fp builder =
  liftIO $ withTempFile (takeDirectory fp) (takeFileName fp) $ \fpTmp h -> do

    hPutBuilder h builder
    hClose h

    void $ tryIO $ setFileMode fp 0o600

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

uploadBytes :: (HasLogFunc m, HasTerm m)
            -> HackageAuth
            -> UploadVariant
            -> 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 ()
        prettyThrowIO 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
        prettyThrowIO (ArchiveUploadFailure code resBody' tarName)

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

  Since 0.1.0.0
upload :: (HasLogFunc m, HasTerm m)
       -> HackageAuth
       -> FilePath
       -> UploadVariant
       -> RIO m ()
upload baseUrl auth fp uploadVariant =
  uploadBytes baseUrl auth (takeFileName fp) uploadVariant
    =<< liftIO (L.readFile fp)

uploadRevision :: (HasLogFunc m, HasTerm m)
               -> 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
