module Stack.Upload
(
nopUploader
, mkUploader
, Uploader
, upload
, uploadBytes
, UploadSettings
, defaultUploadSettings
, setUploadUrl
, setCredsSource
, setSaveCreds
, HackageCreds
, loadCreds
, saveCreds
, FromFile
, HackageCredsSource
, fromAnywhere
, fromPrompt
, fromFile
, fromMemory
) where
import Control.Applicative
import Control.Exception (bracket)
import qualified Control.Exception as E
import Control.Monad (when)
import Data.Aeson (FromJSON (..),
ToJSON (..),
eitherDecode', 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 Data.Typeable (Typeable)
import Network.HTTP.Client (Response,
RequestBody(RequestBodyLBS))
import Network.HTTP.Simple (withResponse,
getResponseStatusCode,
getResponseBody,
setRequestHeader,
parseRequest)
import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody)
import Network.HTTP.Client.TLS (getGlobalManager,
applyDigestAuth,
displayDigestAuthException)
import Path (toFilePath)
import Prelude
import Stack.Types.Config
import System.Directory (createDirectoryIfMissing,
removeFile)
import System.FilePath ((</>), takeFileName)
import System.IO (hFlush, hGetEcho, hSetEcho,
stdin, stdout)
data HackageCreds = HackageCreds
{ hcUsername :: !Text
, hcPassword :: !Text
}
deriving Show
instance ToJSON HackageCreds where
toJSON (HackageCreds u p) = object
[ "username" .= u
, "password" .= p
]
instance FromJSON HackageCreds where
parseJSON = withObject "HackageCreds" $ \o -> HackageCreds
<$> o .: "username"
<*> o .: "password"
newtype HackageCredsSource = HackageCredsSource
{ getCreds :: IO (HackageCreds, FromFile)
}
type FromFile = Bool
loadCreds :: HackageCredsSource -> IO (HackageCreds, FromFile)
loadCreds = getCreds
saveCreds :: Config -> HackageCreds -> IO ()
saveCreds config creds = do
fp <- credsFile config
L.writeFile fp $ encode creds
fromPrompt :: HackageCredsSource
fromPrompt = HackageCredsSource $ do
putStr "Hackage username: "
hFlush stdout
username <- TIO.getLine
password <- promptPassword
return (HackageCreds
{ hcUsername = username
, hcPassword = password
}, False)
credsFile :: Config -> IO FilePath
credsFile config = do
let dir = toFilePath (configStackRoot config) </> "upload"
createDirectoryIfMissing True dir
return $ dir </> "credentials.json"
fromFile :: Config -> HackageCredsSource
fromFile config = HackageCredsSource $ do
fp <- credsFile config
lbs <- L.readFile fp
case eitherDecode' lbs of
Left e -> E.throwIO $ Couldn'tParseJSON fp e
Right creds -> return (creds, True)
fromMemory :: Text -> Text -> HackageCredsSource
fromMemory u p = HackageCredsSource $ return (HackageCreds
{ hcUsername = u
, hcPassword = p
}, False)
data HackageCredsExceptions = Couldn'tParseJSON FilePath String
deriving (Show, Typeable)
instance E.Exception HackageCredsExceptions
fromAnywhere :: Config -> HackageCredsSource
fromAnywhere config = HackageCredsSource $
getCreds (fromFile config) `E.catches`
[ E.Handler $ \(_ :: E.IOException) -> getCreds fromPrompt
, E.Handler $ \(_ :: HackageCredsExceptions) -> getCreds fromPrompt
]
promptPassword :: IO Text
promptPassword = do
putStr "Hackage password: "
hFlush stdout
passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do
hSetEcho stdin False
fmap T.pack getLine
putStrLn ""
return passwd
nopUploader :: Config -> UploadSettings -> IO Uploader
nopUploader _ _ = return (Uploader nop)
where nop :: String -> L.ByteString -> IO ()
nop _ _ = return ()
mkUploader :: Config -> UploadSettings -> IO Uploader
mkUploader config us = do
(creds, fromFile') <- loadCreds $ usCredsSource us config
when (not fromFile' && usSaveCreds us) $ saveCreds config creds
req0 <- parseRequest $ usUploadUrl us
let req1 = setRequestHeader "Accept" ["text/plain"] req0
return Uploader
{ upload_ = \tarName bytes -> do
let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
req2 <- formDataBody formData req1
manager <- getGlobalManager
ereq3 <- applyDigestAuth
(encodeUtf8 $ hcUsername creds)
(encodeUtf8 $ hcPassword creds)
req2
manager
req3 <-
case ereq3 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 req2
Right req3 -> return req3
putStr $ "Uploading " ++ tarName ++ "... "
hFlush stdout
withResponse req3 $ \res ->
case getResponseStatusCode res of
200 -> putStrLn "done!"
401 -> do
putStrLn "authentication failure"
cfp <- credsFile config
handleIO (const $ return ()) (removeFile cfp)
error "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
error $ "Upload failed on " ++ tarName
}
printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()
printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout
newtype Uploader = Uploader
{ upload_ :: String -> L.ByteString -> IO ()
}
upload :: Uploader -> FilePath -> IO ()
upload uploader fp = upload_ uploader (takeFileName fp) =<< L.readFile fp
uploadBytes :: Uploader -> String -> L.ByteString -> IO ()
uploadBytes = upload_
data UploadSettings = UploadSettings
{ usUploadUrl :: !String
, usCredsSource :: !(Config -> HackageCredsSource)
, usSaveCreds :: !Bool
}
defaultUploadSettings :: UploadSettings
defaultUploadSettings = UploadSettings
{ usUploadUrl = "https://hackage.haskell.org/packages/"
, usCredsSource = fromAnywhere
, usSaveCreds = True
}
setUploadUrl :: String -> UploadSettings -> UploadSettings
setUploadUrl x us = us { usUploadUrl = x }
setCredsSource :: (Config -> HackageCredsSource) -> UploadSettings -> UploadSettings
setCredsSource x us = us { usCredsSource = x }
setSaveCreds :: Bool -> UploadSettings -> UploadSettings
setSaveCreds x us = us { usSaveCreds = x }
handleIO :: (E.IOException -> IO a) -> IO a -> IO a
handleIO = E.handle