Merge pull request #5197 from Mistuke/fix-powershell-transport

Fix powershell transport

appveyor.yml

@@ -1,15 +1,12 @@
 install:
   # Using '-y' and 'refreshenv' as a workaround to:
   # https://github.com/haskell/cabal/issues/3687
+  - choco install -y cabal
   - choco install -y ghc --version 8.0.2
   - refreshenv
   # See http://help.appveyor.com/discussions/problems/6312-curl-command-not-found#comment_42195491
   # NB: Do this after refreshenv, otherwise it will be clobbered!
   - set PATH=%APPDATA%\cabal\bin;C:\Program Files\Git\mingw64\bin;%PATH%
-  # TODO: remove --insecure, this is to workaround haskell.org
-  # failing to send intermediate cert; see https://github.com/haskell/cabal/pull/4172
-  - curl -o cabal.zip --insecure --progress-bar https://www.haskell.org/cabal/release/cabal-install-2.0.0.0/cabal-install-2.0.0.0-x86_64-unknown-mingw32.zip
-  - 7z x -bd cabal.zip
   - cabal --version
   - cabal update
   # Install parsec, text and mtl, also alex and happy
@@ -21,18 +18,18 @@ build_script:
 
   # 'echo "" |' works around an AppVeyor issue:
   # https://github.com/commercialhaskell/stack/issues/1097#issuecomment-145747849
-  - echo "" | ..\appveyor-retry ..\cabal install --only-dependencies --enable-tests
+  - echo "" | ..\appveyor-retry cabal install --only-dependencies --enable-tests
 
   - Setup configure --user --ghc-option=-Werror --enable-tests
   - Setup build
   - Setup test --show-details=streaming --test-option=--hide-successes
   - Setup install
   # hackage-repo-tool doesn't build on Windows:
   # https://github.com/well-typed/hackage-security/issues/175
-  # - echo "" | ..\cabal install hackage-repo-tool --allow-newer=Cabal,time --constraint="Cabal == 2.3.0.0"
+  # - echo "" | cabal install hackage-repo-tool --allow-newer=Cabal,time --constraint="Cabal == 2.3.0.0"
   - cd ..\cabal-testsuite
   - ghc --make -threaded -i Setup.hs -package Cabal-2.3.0.0
-  - echo "" | ..\appveyor-retry ..\cabal install --only-dependencies --enable-tests
+  - echo "" | ..\appveyor-retry cabal install --only-dependencies --enable-tests
   - Setup configure --user --ghc-option=-Werror --enable-tests
   - Setup build
   # Must install the test suite, so that our GHCi invocation picks it up
@@ -44,16 +41,16 @@ build_script:
   # - Setup test --show-details=streaming --test-option=--hide-successes
   - cd ..\cabal-install
   - ghc --make -threaded -i -i. Setup.hs -Wall -Werror
-  - echo "" | ..\appveyor-retry ..\cabal install --only-dependencies --enable-tests -flib
-  - ..\cabal configure --user --ghc-option=-Werror --enable-tests -flib
-  - ..\cabal build
+  - echo "" | ..\appveyor-retry cabal install --only-dependencies --enable-tests -flib
+  - cabal configure --user --ghc-option=-Werror --enable-tests -flib
+  - cabal build
   # update package index again, this time for the cabal under test
-  - dist\build\cabal\cabal.exe update
+  - dist\build\cabal\cabal.exe --http-transport=powershell update -v
   # run cabal-testsuite first as it has better logging
   - cd ..\cabal-testsuite
   - dist\build\cabal-tests\cabal-tests.exe -j3 --skip-setup-tests --with-cabal=..\cabal-install\dist\build\cabal\cabal.exe
   - cd ..\cabal-install
-  - ..\cabal test unit-tests --show-details=streaming --test-option="--pattern=! /FileMonitor/" --test-option=--hide-successes
-  - ..\cabal test integration-tests2 --show-details=streaming --test-option=--hide-successes
-  - ..\cabal test solver-quickcheck --show-details=streaming --test-option=--hide-successes --test-option=--quickcheck-tests=1000
-  - ..\cabal test memory-usage-tests --show-details=streaming
+  - cabal test unit-tests --show-details=streaming --test-option="--pattern=! /FileMonitor/" --test-option=--hide-successes
+  - cabal test integration-tests2 --show-details=streaming --test-option=--hide-successes
+  - cabal test solver-quickcheck --show-details=streaming --test-option=--hide-successes --test-option=--quickcheck-tests=1000
+  - cabal test memory-usage-tests --show-details=streaming

cabal-install/Distribution/Client/HttpUtils.hs

@@ -545,16 +545,37 @@ powershellTransport prog =
     gethttp verbosity uri etag destPath reqHeaders = do
       resp <- runPowershellScript verbosity $
         webclientScript
-          (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))
-          [ "$wc.DownloadFile(" ++ escape (show uri)
-              ++ "," ++ escape destPath ++ ");"
-          , "Write-Host \"200\";"
-          , "Write-Host $wc.ResponseHeaders.Item(\"ETag\");"
+          (escape (show uri))
+          (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")
+          :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)))
+          [ "$response = $request.GetResponse()"
+          , "$responseStream = $response.GetResponseStream()"
+          , "$buffer = new-object byte[] 10KB"
+          , "$count = $responseStream.Read($buffer, 0, $buffer.length)"
+          , "while ($count -gt 0)"
+          , "{"
+          , "    $targetStream.Write($buffer, 0, $count)"
+          , "    $count = $responseStream.Read($buffer, 0, $buffer.length)"
+          , "}"
+          , "Write-Host ($response.StatusCode -as [int]);"
+          , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"
+          ]
+          [ "$targetStream.Flush()"
+          , "$targetStream.Close()"
+          , "$targetStream.Dispose()"
+          , "$responseStream.Dispose()"
           ]
       parseResponse resp
       where
-        parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of
-          Just i  -> return (i, Nothing) -- TODO extract real etag
+        parseResponse :: String -> IO (HttpCode, Maybe ETag)
+        parseResponse x =
+          case lines $ trim x of
+            (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x
+            (code:      _) -> fmap (\c -> (c, Nothing  )) $ parseCode code x
+            _              -> statusParseFail verbosity uri x
+        parseCode :: String -> String -> IO HttpCode
+        parseCode code x = case readMaybe code of
+          Just i  -> return i
           Nothing -> statusParseFail verbosity uri x
         etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]
 
@@ -571,15 +592,19 @@ powershellTransport prog =
         let contentHeader = Header HdrContentType
               ("multipart/form-data; boundary=" ++ boundary)
         resp <- runPowershellScript verbosity $ webclientScript
+          (escape (show uri))
           (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)
           (uploadFileAction "POST" uri fullPath)
+          uploadFileCleanup
         parseUploadResponse verbosity uri resp
 
     puthttpfile verbosity uri path auth headers = do
       fullPath <- canonicalizePath path
       resp <- runPowershellScript verbosity $ webclientScript
+        (escape (show uri))
         (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)
         (uploadFileAction "PUT" uri fullPath)
+        uploadFileCleanup
       parseUploadResponse verbosity uri resp
 
     runPowershellScript verbosity script = do
@@ -591,6 +616,7 @@ powershellTransport prog =
             , "-NoProfile", "-NonInteractive"
             , "-Command", "-"
             ]
+      debug verbosity script
       getProgramInvocationOutput verbosity (programInvocation prog args)
         { progInvokeInput = Just (script ++ "\nExit(0);")
         }
@@ -601,31 +627,74 @@ powershellTransport prog =
     extraHeaders = [Header HdrAccept "text/plain", useragentHeader]
 
     setupHeaders headers =
-      [ "$wc.Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
+      [ "$request." ++ addHeader name value
       | Header name value <- headers
       ]
+      where
+        addHeader header value
+          = case header of
+              HdrAccept           -> "Accept = "           ++ escape value
+              HdrUserAgent        -> "UserAgent = "        ++ escape value
+              HdrConnection       -> "Connection = "       ++ escape value
+              HdrContentLength    -> "ContentLength = "    ++ escape value
+              HdrContentType      -> "ContentType = "      ++ escape value
+              HdrDate             -> "Date = "             ++ escape value
+              HdrExpect           -> "Expect = "           ++ escape value
+              HdrHost             -> "Host = "             ++ escape value
+              HdrIfModifiedSince  -> "IfModifiedSince = "  ++ escape value
+              HdrReferer          -> "Referer = "          ++ escape value
+              HdrTransferEncoding -> "TransferEncoding = " ++ escape value
+              HdrRange            -> let (start, _:end) =
+                                          if "bytes=" `isPrefixOf` value
+                                             then break (== '-') value'
+                                             else error $ "Could not decode range: " ++ value
+                                         value' = drop 6 value
+                                     in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
+              name                -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
 
     setupAuth auth =
-      [ "$wc.Credentials = new-object System.Net.NetworkCredential("
+      [ "$request.Credentials = new-object System.Net.NetworkCredential("
           ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"
       | (uname,passwd) <- maybeToList auth
       ]
 
-    uploadFileAction method uri fullPath =
-      [ "$fileBytes = [System.IO.File]::ReadAllBytes(" ++ escape fullPath ++ ");"
-      , "$bodyBytes = $wc.UploadData(" ++ escape (show uri) ++ ","
-        ++ show method ++ ", $fileBytes);"
-      , "Write-Host \"200\";"
-      , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));"
+    uploadFileAction method _uri fullPath =
+      [ "$request.Method = " ++ show method
+      , "$requestStream = $request.GetRequestStream()"
+      , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")"
+      , "$bufSize=10000"
+      , "$chunk = New-Object byte[] $bufSize"
+      , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )"
+      , "{"
+      , "  $requestStream.write($chunk, 0, $bytesRead)"
+      , "  $requestStream.Flush()"
+      , "}"
+      , ""
+      , "$responseStream = $request.getresponse()"
+      , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()"
+      , "$code = $response.StatusCode -as [int]"
+      , "if ($code -eq 0) {"
+      , "  $code = 200;"
+      , "}"
+      , "Write-Host $code"
+      , "Write-Host $responseReader.ReadToEnd()"
+      ]
+
+    uploadFileCleanup =
+      [ "$fileStream.Close()"
+      , "$requestStream.Close()"
+      , "$responseStream.Close()"
       ]
 
     parseUploadResponse verbosity uri resp = case lines (trim resp) of
       (codeStr : message)
         | Just code <- readMaybe codeStr -> return (code, unlines message)
       _ -> statusParseFail verbosity uri resp
 
-    webclientScript setup action = unlines
-      [ "$wc = new-object system.net.webclient;"
+    webclientScript uri setup action cleanup = unlines
+      [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""
+      , "$uri = New-Object \"System.Uri\" " ++ uri
+      , "$request = [System.Net.HttpWebRequest]::Create($uri)"
       , unlines setup
       , "Try {"
       , unlines (map ("  " ++) action)
@@ -643,6 +712,8 @@ powershellTransport prog =
       , "  }"
       , "} Catch {"
       , "  Write-Host $_.Exception.Message;"
+      , "} finally {"
+      , unlines (map ("  " ++) cleanup)
       , "}"
       ]