module Stack.Upload
(
upload
, uploadBytes
, uploadRevision
, 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
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)
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"
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"
promptPassword :: IO Text
promptPassword = do
putStr "Hackage password: "
hFlush stdout
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
uploadBytes :: HackageCreds
-> String
-> L.ByteString
-> 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 :: 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