diff options
author | Joey Hess <joey@kitenet.net> | 2014-02-24 22:00:25 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2014-02-24 22:00:25 -0400 |
commit | 9f9f1decca4a06d81ce97b64ef1a06fda3b8efad (patch) | |
tree | 1f207862430497549281d510837dfcd9782f69af /Utility | |
parent | ba6f7e1e38063e4b338d6a7537b575411193b2b6 (diff) |
add UrlOptions sum type
Diffstat (limited to 'Utility')
-rw-r--r-- | Utility/Url.hs | 59 |
1 files changed, 36 insertions, 23 deletions
diff --git a/Utility/Url.hs b/Utility/Url.hs index 49f25c371..3ab14ebe4 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -10,6 +10,7 @@ module Utility.Url ( URLString, UserAgent, + UrlOptions(..), check, checkBoth, exists, @@ -23,6 +24,7 @@ import Network.URI import qualified Network.Browser as Browser import Network.HTTP import Data.Either +import Data.Default import qualified Build.SysConfig @@ -32,14 +34,24 @@ type Headers = [String] type UserAgent = String +data UrlOptions = UrlOptions + { userAgent :: Maybe UserAgent + , reqHeaders :: Headers + , reqParams :: [CommandParam] + } + +instance Default UrlOptions + where + def = UrlOptions Nothing [] [] + {- Checks that an url exists and could be successfully downloaded, - also checking that its size, if available, matches a specified size. -} -checkBoth :: URLString -> Headers -> [CommandParam] -> Maybe Integer -> Maybe UserAgent -> IO Bool -checkBoth url headers options expected_size ua = do - v <- check url headers options expected_size ua +checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO Bool +checkBoth url expected_size uo = do + v <- check url expected_size uo return (fst v && snd v) -check :: URLString -> Headers -> [CommandParam] -> Maybe Integer -> Maybe UserAgent -> IO (Bool, Bool) -check url headers options expected_size = handle <$$> exists url headers options +check :: URLString -> Maybe Integer -> UrlOptions -> IO (Bool, Bool) +check url expected_size = handle <$$> exists url where handle (False, _) = (False, False) handle (True, Nothing) = (True, True) @@ -55,8 +67,8 @@ check url headers options expected_size = handle <$$> exists url headers options - Uses curl otherwise, when available, since curl handles https better - than does Haskell's Network.Browser. -} -exists :: URLString -> Headers -> [CommandParam] -> Maybe UserAgent -> IO (Bool, Maybe Integer) -exists url headers options ua = case parseURIRelaxed url of +exists :: URLString -> UrlOptions -> IO (Bool, Maybe Integer) +exists url uo = case parseURIRelaxed url of Just u | uriScheme u == "file:" -> do s <- catchMaybeIO $ getFileStatus (unEscapeString $ uriPath u) @@ -70,7 +82,7 @@ exists url headers options ua = case parseURIRelaxed url of Just ('2':_:_) -> return (True, extractsize output) _ -> dne else do - r <- request u headers HEAD ua + r <- request u HEAD uo case rspCode r of (2,_,_) -> return (True, size r) _ -> return (False, Nothing) @@ -78,12 +90,12 @@ exists url headers options ua = case parseURIRelaxed url of where dne = return (False, Nothing) - curlparams = addUserAgent ua $ + curlparams = addUserAgent uo $ [ Param "-s" , Param "--head" , Param "-L", Param url , Param "-w", Param "%{http_code}" - ] ++ concatMap (\h -> [Param "-H", Param h]) headers ++ options + ] ++ concatMap (\h -> [Param "-H", Param h]) (reqHeaders uo) ++ (reqParams uo) extractsize s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of Just l -> case lastMaybe $ words l of @@ -94,9 +106,10 @@ exists url headers options ua = case parseURIRelaxed url of size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders -- works for both wget and curl commands -addUserAgent :: Maybe UserAgent -> [CommandParam] -> [CommandParam] -addUserAgent Nothing ps = ps -addUserAgent (Just ua) ps = ps ++ [Param "--user-agent", Param ua] +addUserAgent :: UrlOptions -> [CommandParam] -> [CommandParam] +addUserAgent uo ps = case userAgent uo of + Nothing -> ps + Just ua -> ps ++ [Param "--user-agent", Param ua] {- Used to download large files, such as the contents of keys. - @@ -105,15 +118,15 @@ addUserAgent (Just ua) ps = ps ++ [Param "--user-agent", Param ua] - would not be appropriate to test at configure time and build support - for only one in. -} -download :: URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool +download :: URLString -> FilePath -> UrlOptions -> IO Bool download = download' False {- No output, even on error. -} -downloadQuiet :: URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool +downloadQuiet :: URLString -> FilePath -> UrlOptions -> IO Bool downloadQuiet = download' True -download' :: Bool -> URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool -download' quiet url headers options file ua = +download' :: Bool -> URLString -> FilePath -> UrlOptions -> IO Bool +download' quiet url file uo = case parseURIRelaxed url of Just u | uriScheme u == "file:" -> do @@ -124,7 +137,7 @@ download' quiet url headers options file ua = | otherwise -> ifM (inPath "wget") (wget , curl) _ -> return False where - headerparams = map (\h -> Param $ "--header=" ++ h) headers + headerparams = map (\h -> Param $ "--header=" ++ h) (reqHeaders uo) wget = go "wget" $ headerparams ++ quietopt "-q" ++ wgetparams {- Regular wget needs --clobber to continue downloading an existing - file. On Android, busybox wget is used, which does not @@ -142,7 +155,7 @@ download' quiet url headers options file ua = curl = go "curl" $ headerparams ++ quietopt "-s" ++ [Params "-f -L -C - -# -o"] go cmd opts = boolSystem cmd $ - addUserAgent ua $ options++opts++[File file, File url] + addUserAgent uo $ reqParams uo++opts++[File file, File url] quietopt s | quiet = [Param s] | otherwise = [] @@ -157,14 +170,14 @@ download' quiet url headers options file ua = - Unfortunately, does not handle https, so should only be used - when curl is not available. -} -request :: URI -> Headers -> RequestMethod -> Maybe UserAgent -> IO (Response String) -request url headers requesttype ua = go 5 url +request :: URI -> RequestMethod -> UrlOptions -> IO (Response String) +request url requesttype uo = go 5 url where go :: Int -> URI -> IO (Response String) go 0 _ = error "Too many redirects " go n u = do rsp <- Browser.browse $ do - maybe noop Browser.setUserAgent ua + maybe noop Browser.setUserAgent (userAgent uo) Browser.setErrHandler ignore Browser.setOutHandler ignore Browser.setAllowRedirects False @@ -174,7 +187,7 @@ request url headers requesttype ua = go 5 url (3,0,x) | x /= 5 -> redir (n - 1) u rsp _ -> return rsp addheaders req = setHeaders req (rqHeaders req ++ userheaders) - userheaders = rights $ map parseHeader headers + userheaders = rights $ map parseHeader (reqHeaders uo) ignore = const noop redir n u rsp = case retrieveHeaders HdrLocation rsp of [] -> return rsp |