Upload.hs

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

-- | Types and functions related to Stack's @upload@ command.
module Stack.Upload
  ( -- * Upload
    UploadOpts (..)
  , 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, withResponse
                   )
import           Path.IO ( resolveDir', resolveFile' )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.SDist
                   ( SDistOpts (..), checkSDistTarball, checkSDistTarball'
                   , getSDistTarball
                   )
import           Stack.Types.Config ( Config (..), configL, stackRootL )
import           Stack.Types.Runner ( Runner )
import           System.Directory
                   ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
                   , 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

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

-- | Type representing command line options for the @stack upload@ command.
data UploadOpts = UploadOpts
  { uoptsSDistOpts :: SDistOpts
  , uoptsUploadVariant :: UploadVariant
  -- ^ Says whether to publish the package or upload as a release candidate
  }

-- | Function underlying the @stack upload@ command. Upload to Hackage.
uploadCmd :: UploadOpts -> RIO Runner ()
uploadCmd (UploadOpts (SDistOpts [] _ _ _ _) _) = do
  prettyErrorL
    [ flow "To upload the current package, please run"
    , style Shell "stack upload ."
    , flow "(with the period at the end)"
    ]
  liftIO exitFailure
uploadCmd uploadOpts = do
  let 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)
      sdistOpts = uoptsSDistOpts uploadOpts
  (files, nonFiles) <-
    liftIO $ partitionM doesFileExist (sdoptsDirsToWorkWith sdistOpts)
  (dirs, invalid) <- liftIO $ partitionM doesDirectoryExist nonFiles
  withConfig YesReexec $ withDefaultEnvConfig $ do
    unless (null invalid) $ do
      let invalidList = bulletedList $ map (style File . fromString) invalid
      prettyErrorL
        [ style Shell "stack upload"
        , flow "expects a list of sdist tarballs or package directories."
        , flow "Can't find:"
        , line <> invalidList
        ]
      exitFailure
    when (null files && null dirs) $ do
      prettyErrorL
        [ style Shell "stack upload"
        , flow "expects a list of sdist tarballs or package directories, but none were specified."
        ]
      exitFailure
    config <- view configL
    let hackageUrl = T.unpack $ configHackageBaseUrl config
        uploadVariant = uoptsUploadVariant uploadOpts
    getCreds <- memoizeRef $ loadAuth config
    mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files
    forM_ files $ \file -> do
      tarFile <- resolveFile' file
      creds <- runMemoized getCreds
      upload hackageUrl creds (toFilePath tarFile) uploadVariant
    forM_ dirs $ \dir -> do
      pkgDir <- resolveDir' dir
      (tarName, tarBytes, mcabalRevision) <-
        getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir
      checkSDistTarball' sdistOpts tarName tarBytes
      creds <- runMemoized getCreds
      uploadBytes hackageUrl creds tarName uploadVariant tarBytes
      forM_ mcabalRevision $ uncurry $ uploadRevision hackageUrl creds

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 (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) = 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 :: 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
  prettyInfoL
    [ "Uploading"
    , style Current (fromString tarName) <> "..."
    ]
  hFlush stdout
  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
       -> 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