{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Upload
(
upload
, uploadBytes
, uploadRevision
, HackageCreds
, loadCreds
) where
import Stack.Prelude
import Data.Aeson (FromJSON (..),
ToJSON (..),
decode', encode,
object, withObject,
(.:), (.=))
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 Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.IO as TIO
import Network.HTTP.Client (Response,
RequestBody(RequestBodyLBS),
Request)
import Network.HTTP.StackClient (withResponse, httpNoBody)
import Network.HTTP.Simple (getResponseStatusCode,
getResponseBody,
setRequestHeader,
parseRequest)
import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody,
partBS, partLBS)
import Network.HTTP.Client.TLS (getGlobalManager,
applyDigestAuth,
displayDigestAuthException)
import Stack.Types.Config
import Stack.Types.PackageIdentifier (PackageIdentifier, packageIdentifierString,
packageIdentifierName)
import Stack.Types.PackageName (packageNameString)
import System.Directory (createDirectoryIfMissing,
removeFile)
import System.FilePath ((</>), takeFileName)
import System.IO (stdout, putStrLn, putStr, getLine, print)
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
putStr "Hackage username: "
hFlush stdout
username <- TIO.getLine
password <- promptPassword
let hc = HackageCreds
{ hcUsername = username
, hcPassword = password
, hcCredsFile = fp
}
when (configSaveHackageCreds config) $ do
let prompt = "Save hackage credentials to file at " ++ fp ++ " [y/n]? "
putStr prompt
input <- loopPrompt prompt
putStrLn "NOTE: Avoid this prompt in the future by using: save-hackage-creds: false"
hFlush stdout
case input of
"y" -> do
L.writeFile fp (encode hc)
putStrLn "Saved!"
hFlush stdout
_ -> return ()
return hc
loopPrompt :: String -> IO String
loopPrompt p = do
input <- TIO.getLine
case input of
"y" -> return "y"
"n" -> return "n"
_ -> do
putStr p
loopPrompt p
credsFile :: Config -> IO FilePath
credsFile config = do
let dir = toFilePath (view stackRootL 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 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