upload: provide plain text response API

This adds an API to upload a package and get a plain text response with errors or warnings. Previously, this was only available through a legacy url for packages and not available at all for candidates. The plain text API is useful for command line tools, such as cabal-install, for example.
haskell · Oct 3, 2015 · 0939b25 · 0939b25
1 parent 9a051d2
commit 0939b25
Show file tree

Hide file tree

Showing 2 changed files with 19 additions and 2 deletions.
diff --git a/Distribution/Server/Features/PackageCandidates.hs b/Distribution/Server/Features/PackageCandidates.hs
@@ -192,7 +192,9 @@ candidatesFeature ServerEnv{serverBlobStore = store}
 
     candidatesCoreResource = fix $ \r -> CoreResource {
 -- TODO: There is significant overlap between this definition and the one in Core
-        corePackagesPage = resourceAt "/packages/candidates/.:format"
+        corePackagesPage = (resourceAt "/packages/candidates/.:format") {
+            resourcePost = [("txt", \_ -> postCandidatePlain)]
+          }
       , corePackagePage = resourceAt "/package/:package/candidate.:format"
       , coreCabalFile = (resourceAt "/package/:package/candidate/:cabal.cabal") {
             resourceDesc = [(GET, "Candidate .cabal file")]
@@ -245,6 +247,11 @@ candidatesFeature ServerEnv{serverBlobStore = store}
         pkgInfo <- uploadCandidate (const True)
         seeOther (corePackageIdUri candidatesCoreResource "" $ packageId pkgInfo) (toResponse ())
 
+    postCandidatePlain :: ServerPartE Response
+    postCandidatePlain = do
+        pkgInfo <- uploadCandidate (const True)
+        ok $ toResponse $ unlines $ candWarnings pkgInfo
+
     -- POST to /:package/candidates/
     postPackageCandidate :: DynamicPath -> ServerPartE Response
     postPackageCandidate dpath = do

diff --git a/Distribution/Server/Features/Upload.hs b/Distribution/Server/Features/Upload.hs
@@ -222,7 +222,11 @@ uploadFeature ServerEnv{serverBlobStore = store}
       }
 
     uploadResource = UploadResource
-          { uploadIndexPage      = (extendResource (corePackagesPage coreResource)) { resourcePost = [] }
+          { uploadIndexPage      = (extendResource (corePackagesPage coreResource)) {
+              resourcePost =
+                [ ("txt", \_ -> uploadPlain)
+                ]
+            }
           , deletePackagePage    = (extendResource (corePackagePage coreResource))  { resourceDelete = [] }
           , maintainersGroupResource = maintainersGroupResource
           , trusteesGroupResource    = trusteesGroupResource
@@ -234,6 +238,12 @@ uploadFeature ServerEnv{serverBlobStore = store}
           , uploaderUri = \format -> renderResource (groupResource uploadersGroupResource) [format]
           }
 
+
+    uploadPlain :: ServerPartE Response
+    uploadPlain = nullDir >> do
+      upResult <- uploadPackage
+      ok $ toResponse $ unlines $ uploadWarnings upResult
+
     --------------------------------------------------------------------------------
     -- User groups and authentication
     trusteesGroupDescription :: UserGroup