{-# 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 Network.HTTP.StackClient (Request, RequestBody(RequestBodyLBS), Response, withResponse, httpNoBody, getGlobalManager, getResponseStatusCode,
getResponseBody,
setRequestHeader,
parseRequest,
formDataBody, partFileRequestBody,
partBS, partLBS,
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, print)
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
username <- prompt "Hackage username: "
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]? "
putStrLn "NOTE: Avoid this prompt in the future by using: save-hackage-creds: false"
when shouldSave $ do
L.writeFile fp (encode hc)
putStrLn "Saved!"
hFlush stdout
return hc
credsFile :: Config -> IO FilePath
credsFile config = do
let dir = toFilePath (view stackRootL config) </> "upload"
createDirectoryIfMissing True dir
return $ dir </> "credentials.json"
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 :: String
-> HackageCreds
-> String
-> L.ByteString
-> IO ()
uploadBytes baseUrl creds tarName bytes = do
let req1 = setRequestHeader "Accept" ["text/plain"]
(fromString $ baseUrl <> "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 :: String
-> HackageCreds
-> FilePath
-> IO ()
upload baseUrl creds fp = uploadBytes baseUrl creds (takeFileName fp) =<< L.readFile fp
uploadRevision :: String
-> HackageCreds
-> PackageIdentifier
-> L.ByteString
-> IO ()
uploadRevision baseUrl creds ident cabalFile = do
req0 <- parseRequest $ concat
[ baseUrl
, "package/"
, packageIdentifierString ident
, "/"
, packageNameString $ packageIdentifierName ident
, ".cabal/edit"
]
req1 <- formDataBody
[ partLBS "cabalfile" cabalFile
, partBS "publish" "on"
]
req0
req2 <- applyCreds creds req1
void $ httpNoBody req2