add UrlOptions sum type
This commit is contained in:
Joey Hess
parent
fdc7200b25
commit
003fc2b7e1
14 changed files with 78 additions and 65 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue