cabal-install/src/Distribution/Client/Upload.hs

   1 module Distribution.Client.Upload (upload, uploadDoc, report) where
   2
   3 import Distribution.Client.Compat.Prelude
   4 import qualified Prelude as Unsafe (read)
   5
   6 import Distribution.Client.HttpUtils
   7   ( HttpTransport (..)
   8   , remoteRepoTryUpgradeToHttps
   9   )
  10 import Distribution.Client.Setup
  11   ( IsCandidate (..)
  12   , RepoContext (..)
  13   )
  14 import Distribution.Client.Types.Credentials
  15   ( Auth
  16   , Password (..)
  17   , Token (..)
  18   , Username (..)
  19   )
  20 import Distribution.Client.Types.Repo (RemoteRepo (..), Repo, maybeRepoRemote)
  21 import Distribution.Client.Types.RepoName (unRepoName)
  22
  23 import Distribution.Client.Config
  24 import Distribution.Simple.Utils (dieWithException, info, notice, toUTF8BS, warn)
  25 import Distribution.Utils.String (trim)
  26
  27 import Distribution.Client.BuildReports.Anonymous (parseBuildReport)
  28 import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
  29 import qualified Distribution.Client.BuildReports.Upload as BuildReport
  30 import Distribution.Client.Errors
  31 import Network.HTTP (Header (..), HeaderName (..))
  32 import Network.URI (URI (uriAuthority, uriPath), URIAuth (uriRegName))
  33 import System.Directory
  34 import System.FilePath (dropExtension, takeExtension, takeFileName, (</>))
  35 import qualified System.FilePath.Posix as FilePath.Posix ((</>))
  36 import System.IO (hFlush, stdout)
  37 import System.IO.Echo (withoutInputEcho)
  38
  39 -- > stripExtensions ["tar", "gz"] "foo.tar.gz"
  40 -- Just "foo"
  41 -- > stripExtensions ["tar", "gz"] "foo.gz.tar"
  42 -- Nothing
  43 stripExtensions :: [String] -> FilePath -> Maybe String
  44 stripExtensions exts path = foldM f path (reverse exts)
  45   where
  46     f p e
  47       | takeExtension p == '.' : e = Just (dropExtension p)
  48       | otherwise = Nothing
  49
  50 upload
  51   :: Verbosity
  52   -> RepoContext
  53   -> Maybe Token
  54   -> Maybe Username
  55   -> Maybe Password
  56   -> IsCandidate
  57   -> [FilePath]
  58   -> IO ()
  59 upload verbosity repoCtxt mToken mUsername mPassword isCandidate paths = do
  60   let repos :: [Repo]
  61       repos = repoContextRepos repoCtxt
  62   transport <- repoContextGetTransport repoCtxt
  63   targetRepo <-
  64     case [remoteRepo | Just remoteRepo <- map maybeRepoRemote repos] of
  65       [] -> dieWithException verbosity NoRemoteRepositories
  66       (r : rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r :| rs))
  67   let targetRepoURI :: URI
  68       targetRepoURI = remoteRepoURI targetRepo
  69       domain :: String
  70       domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI
  71       rootIfEmpty x = if null x then "/" else x
  72       uploadURI :: URI
  73       uploadURI =
  74         targetRepoURI
  75           { uriPath =
  76               rootIfEmpty (uriPath targetRepoURI)
  77                 FilePath.Posix.</> case isCandidate of
  78                   IsCandidate -> "packages/candidates"
  79                   IsPublished -> "upload"
  80           }
  81       packageURI pkgid =
  82         targetRepoURI
  83           { uriPath =
  84               rootIfEmpty (uriPath targetRepoURI)
  85                 FilePath.Posix.</> concat
  86                   [ "package/"
  87                   , pkgid
  88                   , case isCandidate of
  89                       IsCandidate -> "/candidate"
  90                       IsPublished -> ""
  91                   ]
  92           }
  93   auth <- Just <$> createAuth domain mToken mUsername mPassword
  94   for_ paths $ \path -> do
  95     notice verbosity $ "Uploading " ++ path ++ "... "
  96     case fmap takeFileName (stripExtensions ["tar", "gz"] path) of
  97       Just pkgid ->
  98         handlePackage
  99           transport
 100           verbosity
 101           uploadURI
 102           (packageURI pkgid)
 103           auth
 104           isCandidate
 105           path
 106       -- This case shouldn't really happen, since we check in Main that we
 107       -- only pass tar.gz files to upload.
 108       Nothing -> dieWithException verbosity $ NotATarDotGzFile path
 109
 110 uploadDoc
 111   :: Verbosity
 112   -> RepoContext
 113   -> Maybe Token
 114   -> Maybe Username
 115   -> Maybe Password
 116   -> IsCandidate
 117   -> FilePath
 118   -> IO ()
 119 uploadDoc verbosity repoCtxt mToken mUsername mPassword isCandidate path = do
 120   let repos = repoContextRepos repoCtxt
 121   transport <- repoContextGetTransport repoCtxt
 122   targetRepo <-
 123     case [remoteRepo | Just remoteRepo <- map maybeRepoRemote repos] of
 124       [] -> dieWithException verbosity NoRemoteRepositories
 125       (r : rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r :| rs))
 126   let targetRepoURI = remoteRepoURI targetRepo
 127       domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI
 128       rootIfEmpty x = if null x then "/" else x
 129       uploadURI =
 130         targetRepoURI
 131           { uriPath =
 132               rootIfEmpty (uriPath targetRepoURI)
 133                 FilePath.Posix.</> concat
 134                   [ "package/"
 135                   , pkgid
 136                   , case isCandidate of
 137                       IsCandidate -> "/candidate"
 138                       IsPublished -> ""
 139                   , "/docs"
 140                   ]
 141           }
 142       packageUri =
 143         targetRepoURI
 144           { uriPath =
 145               rootIfEmpty (uriPath targetRepoURI)
 146                 FilePath.Posix.</> concat
 147                   [ "package/"
 148                   , pkgid
 149                   , case isCandidate of
 150                       IsCandidate -> "/candidate"
 151                       IsPublished -> ""
 152                   ]
 153           }
 154       (reverseSuffix, reversePkgid) =
 155         break
 156           (== '-')
 157           (reverse (takeFileName path))
 158       pkgid = reverse $ drop 1 reversePkgid
 159   when
 160     ( reverse reverseSuffix /= "docs.tar.gz"
 161         || ( case reversePkgid of
 162               [] -> True
 163               (c : _) -> c /= '-'
 164            )
 165     )
 166     $ dieWithException verbosity ExpectedMatchingFileName
 167
 168   auth <- Just <$> createAuth domain mToken mUsername mPassword
 169
 170   let headers =
 171         [ Header HdrContentType "application/x-tar"
 172         , Header HdrContentEncoding "gzip"
 173         ]
 174   notice verbosity $ "Uploading documentation " ++ path ++ "... "
 175   resp <- putHttpFile transport verbosity uploadURI path auth headers
 176   case resp of
 177     -- Hackage responds with 204 No Content when docs are uploaded
 178     -- successfully.
 179     (code, _) | code `elem` [200, 204] -> do
 180       notice verbosity $ okMessage packageUri
 181     (code, err) -> do
 182       notice verbosity $
 183         "Error uploading documentation "
 184           ++ path
 185           ++ ": "
 186           ++ "http code "
 187           ++ show code
 188           ++ "\n"
 189           ++ err
 190       exitFailure
 191   where
 192     okMessage packageUri = case isCandidate of
 193       IsCandidate ->
 194         "Documentation successfully uploaded for package candidate. "
 195           ++ "You can now preview the result at '"
 196           ++ show packageUri
 197           ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'."
 198       IsPublished ->
 199         "Package documentation successfully published. You can now view it at '"
 200           ++ show packageUri
 201           ++ "'."
 202
 203 promptUsername :: String -> IO Username
 204 promptUsername domain = do
 205   putStr $ domain ++ " username: "
 206   hFlush stdout
 207   fmap Username getLine
 208
 209 promptPassword :: String -> IO Password
 210 promptPassword domain = do
 211   putStr $ domain ++ " password: "
 212   hFlush stdout
 213   -- save/restore the terminal echoing status (no echoing for entering the password)
 214   passwd <- withoutInputEcho $ fmap Password getLine
 215   putStrLn ""
 216   return passwd
 217
 218 report :: Verbosity -> RepoContext -> Maybe Token -> Maybe Username -> Maybe Password -> IO ()
 219 report verbosity repoCtxt mToken mUsername mPassword = do
 220   let repos :: [Repo]
 221       repos = repoContextRepos repoCtxt
 222       remoteRepos :: [RemoteRepo]
 223       remoteRepos = mapMaybe maybeRepoRemote repos
 224   for_ remoteRepos $ \remoteRepo -> do
 225     let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo)
 226     auth <- createAuth domain mToken mUsername mPassword
 227
 228     reportsDir <- defaultReportsDir
 229     let srcDir :: FilePath
 230         srcDir = reportsDir </> unRepoName (remoteRepoName remoteRepo)
 231     -- We don't want to bomb out just because we haven't built any packages
 232     -- from this repo yet.
 233     srcExists <- doesDirectoryExist srcDir
 234     when srcExists $ do
 235       contents <- getDirectoryContents srcDir
 236       for_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->
 237         do
 238           inp <- readFile (srcDir </> logFile)
 239           let (reportStr, buildLog) = Unsafe.read inp :: (String, String) -- TODO: eradicateNoParse
 240           case parseBuildReport (toUTF8BS reportStr) of
 241             Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME
 242             Right report' ->
 243               do
 244                 info verbosity $
 245                   "Uploading report for "
 246                     ++ prettyShow (BuildReport.package report')
 247                 BuildReport.uploadReports
 248                   verbosity
 249                   repoCtxt
 250                   auth
 251                   (remoteRepoURI remoteRepo)
 252                   [(report', Just buildLog)]
 253                 return ()
 254
 255 handlePackage
 256   :: HttpTransport
 257   -> Verbosity
 258   -> URI
 259   -> URI
 260   -> Maybe Auth
 261   -> IsCandidate
 262   -> FilePath
 263   -> IO ()
 264 handlePackage transport verbosity uri packageUri auth isCandidate path =
 265   do
 266     resp <- postHttpFile transport verbosity uri path auth
 267     case resp of
 268       (code, warnings)
 269         | code `elem` [200, 204] ->
 270             notice verbosity $
 271               okMessage isCandidate
 272                 ++ if null warnings then "" else "\n" ++ formatWarnings (trim warnings)
 273       (code, err) -> do
 274         notice verbosity $
 275           "Error uploading "
 276             ++ path
 277             ++ ": "
 278             ++ "http code "
 279             ++ show code
 280             ++ "\n"
 281             ++ err
 282         exitFailure
 283   where
 284     okMessage :: IsCandidate -> String
 285     okMessage IsCandidate =
 286       "Package successfully uploaded as candidate. "
 287         ++ "You can now preview the result at '"
 288         ++ show packageUri
 289         ++ "'. To publish the candidate, use 'cabal upload --publish'."
 290     okMessage IsPublished =
 291       "Package successfully published. You can now view it at '"
 292         ++ show packageUri
 293         ++ "'."
 294
 295 formatWarnings :: String -> String
 296 formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x
 297
 298 createAuth
 299   :: String
 300   -> Maybe Token
 301   -> Maybe Username
 302   -> Maybe Password
 303   -> IO Auth
 304 createAuth domain mToken mUsername mPassword = case mToken of
 305   Just token -> return $ Right $ unToken token
 306   -- Use username and password if no token is provided
 307   Nothing -> do
 308     Username username <- maybe (promptUsername domain) return mUsername
 309     Password password <- maybe (promptPassword domain) return mPassword
 310     return $ Left (username, password)