{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Provide ability to upload tarballs to Hackage.
module Stack.Upload
    ( -- * Upload
      upload
    , uploadBytes
    , uploadRevision
      -- * Credentials
    , HackageCreds
    , loadCreds
    ) where

import           Control.Applicative
import           Control.Exception.Safe                (handleIO, tryIO)
import qualified Control.Exception                     as E
import           Control.Monad                         (void, when, unless)
import           Data.Aeson                            (FromJSON (..),
                                                        ToJSON (..),
                                                        decode', encode,
                                                        object, withObject,
                                                        (.:), (.=))
import qualified Data.ByteString.Char8                 as S
import qualified Data.ByteString.Lazy                  as L
import           Data.Conduit                          (ConduitM, runConduit, (.|))
import qualified Data.Conduit.Binary                   as CB
import           Data.Text                             (Text)
import qualified Data.Text                             as T
import           Data.Text.Encoding                    (encodeUtf8)
import qualified Data.Text.IO                          as TIO
import           Network.HTTP.Client                   (Response,
                                                        RequestBody(RequestBodyLBS),
                                                        Request)
import           Network.HTTP.Simple                   (withResponse,
                                                        getResponseStatusCode,
                                                        getResponseBody,
                                                        setRequestHeader,
                                                        parseRequest,
                                                        httpNoBody)
import           Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody,
                                                        partBS, partLBS)
import           Network.HTTP.Client.TLS               (getGlobalManager,
                                                        applyDigestAuth,
                                                        displayDigestAuthException)
import           Path                                  (toFilePath)
import           Prelude -- Fix redundant import warnings
import           Stack.Types.Config
import           Stack.Types.PackageIdentifier         (PackageIdentifier, packageIdentifierString,
                                                        packageIdentifierName)
import           Stack.Types.PackageName               (packageNameString)
import           Stack.Types.StringError
import           System.Directory                      (createDirectoryIfMissing,
                                                        removeFile)
import           System.FilePath                       ((</>), takeFileName)
import           System.IO                             (hFlush, stdout)
import           System.IO.Echo                        (withoutInputEcho)

-- | Username and password to log into Hackage.
--
-- Since 0.1.0.0
data HackageCreds = HackageCreds
    { hcUsername :: !Text
    , hcPassword :: !Text
    , hcCredsFile :: !FilePath
    }
    deriving 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"

-- | Load Hackage credentials, either from a save file or the command
-- line.
--
-- Since 0.1.0.0
loadCreds :: Config -> IO HackageCreds
loadCreds config = do
  fp <- credsFile config
  elbs <- tryIO $ L.readFile fp
  case either (const Nothing) Just elbs >>= decode' of
    Nothing -> fromPrompt fp
    Just mkCreds -> do
      unless (configSaveHackageCreds config) $ do
        putStrLn "WARNING: You've set save-hackage-creds to false"
        putStrLn "However, credentials were found at:"
        putStrLn $ "  " ++ fp
      return $ mkCreds fp
  where
    fromPrompt fp = do
      when (configSaveHackageCreds config) $ do
        putStrLn "NOTE: Username and password will be saved in a local file"
        putStrLn "You can modify this behavior with the save-hackage-creds config option"
      putStr "Hackage username: "
      hFlush stdout
      username <- TIO.getLine
      password <- promptPassword
      let hc = HackageCreds
            { hcUsername = username
            , hcPassword = password
            , hcCredsFile = fp
            }
      L.writeFile fp (encode hc)
      return hc

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

-- | Lifted from cabal-install, Distribution.Client.Upload
promptPassword :: IO Text
promptPassword = do
  putStr "Hackage password: "
  hFlush stdout
  -- save/restore the terminal echoing status (no echoing for entering the password)
  passwd <- withoutInputEcho $ fmap T.pack getLine
  putStrLn ""
  return passwd

applyCreds :: HackageCreds -> Request -> IO Request
applyCreds creds req0 = do
  manager <- getGlobalManager
  ereq <- applyDigestAuth
    (encodeUtf8 $ hcUsername creds)
    (encodeUtf8 $ hcPassword creds)
    req0
    manager
  case ereq of
      Left e -> do
          putStrLn "WARNING: No HTTP digest prompt found, this will probably fail"
          case E.fromException e of
              Just e' -> putStrLn $ displayDigestAuthException e'
              Nothing -> print e
          return req0
      Right req -> return 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 :: HackageCreds
            -> String -- ^ tar file name
            -> L.ByteString -- ^ tar file contents
            -> IO ()
uploadBytes creds tarName bytes = do
    let req1 = setRequestHeader "Accept" ["text/plain"]
               "https://hackage.haskell.org/packages/"
        formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
    req2 <- formDataBody formData req1
    req3 <- applyCreds creds req2
    putStr $ "Uploading " ++ tarName ++ "... "
    hFlush stdout
    withResponse req3 $ \res ->
        case getResponseStatusCode res of
            200 -> putStrLn "done!"
            401 -> do
                putStrLn "authentication failure"
                handleIO (const $ return ()) (removeFile (hcCredsFile creds))
                throwString "Authentication failure uploading to server"
            403 -> do
                putStrLn "forbidden upload"
                putStrLn "Usually means: you've already uploaded this package/version combination"
                putStrLn "Ignoring error and continuing, full message from Hackage below:\n"
                printBody res
            503 -> do
                putStrLn "service unavailable"
                putStrLn "This error some times gets sent even though the upload succeeded"
                putStrLn "Check on Hackage to see if your pacakge is present"
                printBody res
            code -> do
                putStrLn $ "unhandled status code: " ++ show code
                printBody res
                throwString $ "Upload failed on " ++ 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 :: HackageCreds -> FilePath -> IO ()
upload creds fp = uploadBytes creds (takeFileName fp) =<< L.readFile fp

uploadRevision :: HackageCreds
               -> PackageIdentifier
               -> L.ByteString
               -> IO ()
uploadRevision creds ident cabalFile = do
  req0 <- parseRequest $ concat
    [ "https://hackage.haskell.org/package/"
    , packageIdentifierString ident
    , "/"
    , packageNameString $ packageIdentifierName ident
    , ".cabal/edit"
    ]
  req1 <- formDataBody
    [ partLBS "cabalfile" cabalFile
    , partBS "publish" "on"
    ]
    req0
  req2 <- applyCreds creds req1
  void $ httpNoBody req2