Merge pull request #1018 from nickburlett/fix-upload-time-parse

Fix parsing of ISO times

Author: gbaz

Distribution/Server/Features/Mirror.hs

@@ -221,11 +221,15 @@ mirrorFeature ServerEnv{serverBlobStore = store}
     -- curl -H 'Content-Type: text/plain' -u admin:admin -X PUT -d "Tue Oct 18 20:54:28 UTC 2010" http://localhost:8080/package/edit-distance-0.2.1/upload-time
     uploadTimePut :: DynamicPath -> ServerPartE Response
     uploadTimePut dpath = do
+        let altParseTimeMaybe timeStr = (
+                parseTimeMaybe "%c" timeStr
+                <|>  parseTimeMaybe "%Y-%m-%dT%H:%M:%SZ" timeStr
+                )
         guardAuthorised_ [InGroup mirrorGroup]
         pkgid <- packageInPath dpath
         timeContent <- expectTextPlain
-        case parseTimeMaybe "%c" (unpackUTF8 timeContent) of
-          Nothing -> errBadRequest "Could not parse upload time" []
+        case altParseTimeMaybe (unpackUTF8 timeContent) of
+          Nothing -> errBadRequest "Could not parse upload time" [MText $ show timeContent]
           Just t  -> do
             existed <- updateSetPackageUploadTime pkgid t
             if existed

tests/HackageClientUtils.hs

@@ -269,6 +269,29 @@ mkPostReq url vals =
   setRequestBody (postRequest (mkUrl url))
                  ("application/x-www-form-urlencoded", urlEncodeVars vals)
 
+mkPutReq :: RelativeURL -> [(String, String)] -> Request_String
+mkPutReq url vals =
+  setRequestBody (putRequest (mkUrl url))
+                 ("application/x-www-form-urlencoded", urlEncodeVars vals)
+
+-- Like mkPutReq, but posts the given body text directly as text/plain
+mkPutTextReq :: RelativeURL -> String -> Request_String
+mkPutTextReq url body =
+    setRequestBody (putRequest (mkUrl url))
+             ("text/plain", body)
+
+-- | A convenience constructor for a PUT 'Request'.
+--
+-- If the URL isn\'t syntactically valid, the function raises an error.
+putRequest
+    :: String                   -- ^URL to POST to
+    -> Request_String           -- ^The constructed request
+putRequest urlString =
+  case parseURI urlString of
+    Nothing -> error ("putRequest: Not a valid URL - " ++ urlString)
+    Just u  -> mkRequest PUT u
+
+
 getUrl :: Authorization -> RelativeURL -> IO String
 getUrl auth url = Http.execRequest auth (mkGetReq url)
 
@@ -313,6 +336,18 @@ post auth url vals = void $
   where
     expectedCode code = isOk code || isSeeOther code || isAccepted code
 
+put :: Authorization -> RelativeURL -> [(String, String)] -> IO ()
+put auth url vals = void $
+    Http.execRequest' auth (mkPutReq url vals) expectedCode
+  where
+    expectedCode code = isOk code || isSeeOther code || isAccepted code
+
+putText :: Authorization -> RelativeURL -> String -> IO ()
+putText auth url body = void $
+    Http.execRequest' auth (mkPutTextReq url body) expectedCode
+  where
+    expectedCode code = isOk code || isSeeOther code || isAccepted code
+
 postFile :: ExpectedCode
          -> Authorization -> RelativeURL
          -> String -> (FilePath, String)

tests/HighLevelTest.hs

@@ -162,9 +162,34 @@ runPackageUploadTests = do
                 (Auth "HackageTestUser1" "testpass1")
                 "/packages/" "package"
                 (testpackageTarFilename, testpackageTarFileContent)
+    do info "Adding HackageTestUser1 to mirrorers"
+       post (Auth "admin" "admin") "/packages/mirrorers/" [
+           ("user", "HackageTestUser1")
+         ]
+    do info "Checking Package Exists"
+       xs <- validate NoAuth "/package/testpackage-1.0.0.0"
+       unless (">testpackage</a>: <small>test package testpackage</small></h1>" `isInfixOf` xs) $
+           die ("Bad package info: " ++ show xs)
+    do info "Setting upload time"
+       putText (Auth "HackageTestUser1" "testpass1")
+           "/package/testpackage-1.0.0.0/upload-time"
+           uploadTime
+       xs <- getUrl NoAuth "/package/testpackage-1.0.0.0/upload-time"
+       unless (xs == uploadTimeISO) $
+            die ("Bad upload time: " ++ show xs)
+    do info "Setting upload time (ISO)"
+       putText (Auth "HackageTestUser1" "testpass1")
+           "/package/testpackage-1.0.0.0/upload-time"
+           uploadTimeISO2
+       xs <- getUrl NoAuth "/package/testpackage-1.0.0.0/upload-time"
+       unless (xs == uploadTimeISO2) $
+            die ("Bad upload time: " ++ show xs)
   where
     (testpackageTarFilename, testpackageTarFileContent, _, _, _, _) =
       testpackage
+    uploadTime = "Tue Oct 18 20:54:28 UTC 2010"
+    uploadTimeISO = "2010-10-18T20:54:28Z"
+    uploadTimeISO2 = "2020-10-18T20:54:28Z"
 
 runPackageTests :: IO ()
 runPackageTests = do