{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Stack.Upload
(
upload
, uploadBytes
, uploadRevision
, HackageCreds
, loadCreds
, writeFilePrivate
) where
import Stack.Prelude
import Data.Aeson (FromJSON (..),
ToJSON (..),
decode', toEncoding, fromEncoding,
object, 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 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 System.Directory (createDirectoryIfMissing,
removeFile, renameFile)
import System.FilePath ((</>), takeFileName, takeDirectory)
import System.IO (stdout, putStrLn, putStr, print)
import System.PosixCompat.Files (setFileMode)
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 >>= \lbs -> (lbs, ) <$> decode' lbs of
Nothing -> fromPrompt fp
Just (lbs, mkCreds) -> do
writeFilePrivate fp $ lazyByteString lbs
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
writeFilePrivate fp $ fromEncoding $ toEncoding hc
putStrLn "Saved!"
hFlush stdout
return hc
writeFilePrivate :: MonadIO m => FilePath -> Builder -> m ()
writeFilePrivate fp builder = liftIO $ withTempFile (takeDirectory fp) (takeFileName fp) $ \fpTmp h -> do
hPutBuilder h builder
hClose h
void $ tryIO $ setFileMode fp 0o600
renameFile fpTmp fp
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@(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 <- applyCreds creds req1
void $ httpNoBody req2