Commit 22f05445 authored by Duncan Coutts's avatar Duncan Coutts

Further work, refactoring and reformatting of new http transport code

Move utils into other Util modules.
Reformat all code to 80 cols.
Reorder code and add more comments.
Use long form style program args, e.g. --silent rather than -s
Finish implementation of form upload with wget
Fix reporting of server error messages for upload (curl & builtin)
Implement collecting of ETags for curl and wget.
Fix wget for case of 304 not modified response (wget uses exit code 8).
Rework transport configuration phase.
parent b780cc77
......@@ -43,7 +43,7 @@ postBuildReport :: Verbosity -> (String, String) -> URI -> BuildReport -> IO Bui
postBuildReport verbosity auth uri buildReport = do
let fullURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }
transport <- configureTransport verbosity Nothing
res <- postHttp transport fullURI (BuildReport.show buildReport) (Just auth)
res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth)
case res of
(303, redir) -> return $ undefined redir --TODO parse redir
_ -> die "unrecognized response" -- give response
......@@ -84,7 +84,7 @@ putBuildLog :: Verbosity -> (String, String)
putBuildLog verbosity auth reportId buildLog = do
let fullURI = reportId {uriPath = uriPath reportId </> "log"}
transport <- configureTransport verbosity Nothing
res <- postHttp transport fullURI buildLog (Just auth)
res <- postHttp transport verbosity fullURI buildLog (Just auth)
case res of
(200, _) -> return ()
_ -> die "unrecognized response" -- give response
......@@ -294,7 +294,7 @@ globalCommand commands = CommandUI {
trueArg
,option [] ["http-transport"]
"Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'insecure-http'. (default: 'curl')"
"Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
globalConfigFile (\v flags -> flags { globalHttpTransport = v })
(reqArgFlag "HttpTransport")
......
......@@ -97,10 +97,10 @@ check transport verbosity paths = do
handlePackage :: HttpTransport -> Verbosity -> URI -> Auth
-> FilePath -> IO ()
handlePackage transport verbosity uri auth path =
do resp <- putHttpFile transport uri path auth
do resp <- postHttpFile transport verbosity uri path auth
case resp of
(200,_) -> do notice verbosity "Ok"
(code,err) -> do notice verbosity $ "Error: " ++ path ++ ": "
++ show code ++ " "
(code,err) -> do notice verbosity $ "Error uploading " ++ path ++ ": "
++ "http code " ++ show code ++ "\n"
++ err
......@@ -2,8 +2,10 @@
module Distribution.Client.Utils ( MergeResult(..)
, mergeBy, duplicates, duplicatesBy
, readMaybe
, inDir, determineNumJobs, numberOfProcessors
, removeExistingFile
, withTempFileName
, makeAbsoluteToCwd, filePathToByteString
, byteStringToFilePath, tryCanonicalizePath
, canonicalizePathNoThrow
......@@ -24,20 +26,24 @@ import Data.Bits
( (.|.), shiftL, shiftR )
import Data.Char
( ord, chr )
#if MIN_VERSION_base(4,6,0)
import Text.Read
( readMaybe )
#endif
import Data.List
( isPrefixOf, sortBy, groupBy )
import Data.Word
( Word8, Word32)
import Foreign.C.Types ( CInt(..) )
import qualified Control.Exception as Exception
( finally )
( finally, bracket )
import System.Directory
( canonicalizePath, doesFileExist, getCurrentDirectory
, removeFile, setCurrentDirectory )
import System.FilePath
( (</>), isAbsolute )
import System.IO
( Handle
( Handle, hClose, openTempFile
#if MIN_VERSION_base(4,4,0)
, hGetEncoding, hSetEncoding
#endif
......@@ -87,6 +93,14 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
moreThanOne (_:_:_) = True
moreThanOne _ = False
#if !MIN_VERSION_base(4,6,0)
-- | An implementation of readMaybe, for compatability with older base versions.
readMaybe :: Read a => String -> Maybe a
readMaybe s = case reads s of
[(x,"")] -> Just x
_ -> Nothing
#endif
-- | Like 'removeFile', but does not throw an exception when the file does not
-- exist.
removeExistingFile :: FilePath -> IO ()
......@@ -95,6 +109,19 @@ removeExistingFile path = do
when exists $
removeFile path
-- | A variant of 'withTempFile' that only gives us the file name, and while
-- it will clean up the file afterwards, it's lenient if the file is
-- moved\/deleted.
--
withTempFileName :: FilePath
-> String
-> (FilePath -> IO a) -> IO a
withTempFileName tmpDir template action =
Exception.bracket
(openTempFile tmpDir template)
(\(name, _) -> removeExistingFile name)
(\(name, h) -> hClose h >> action name)
-- | Executes the action in the specified directory.
inDir :: Maybe FilePath -> IO a -> IO a
inDir Nothing m = m
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment