split out generic url stuff into a helper library from Remote.Web

This commit is contained in:
Joey Hess 2011-08-16 20:49:04 -04:00
parent 07f2e7ee72
commit 4545a0e78c
3 changed files with 77 additions and 34 deletions

View file

@ -14,6 +14,7 @@ import System.Directory
import Command
import qualified Backend
import qualified Remote.Helper.Url
import qualified Remote.Web
import qualified Command.Add
import qualified Annex
@ -52,7 +53,7 @@ download url file = do
let dummykey = Backend.URL.fromUrl url
let tmp = gitAnnexTmpLocation g dummykey
liftIO $ createDirectoryIfMissing True (parentDir tmp)
ok <- Remote.Web.download [url] tmp
ok <- Remote.Helper.Url.download url tmp
if ok
then do
[(_, backend)] <- Backend.chooseBackends [file]

66
Remote/Helper/Url.hs Normal file
View file

@ -0,0 +1,66 @@
{- Url downloading for remotes.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Helper.Url (
exists,
download,
get
) where
import Control.Monad (liftM)
import Control.Monad.State (liftIO)
import qualified Network.Browser as Browser
import Network.HTTP
import Network.URI
import Types
import Messages
import Utility
type URLString = String
{- Checks that an url exists and could be successfully downloaded. -}
exists :: URLString -> IO Bool
exists url =
case parseURI url of
Nothing -> return False
Just u -> do
r <- request u HEAD
case rspCode r of
(2,_,_) -> return True
_ -> return False
{- Used to download large files, such as the contents of keys.
- Uses curl program for its progress bar. -}
download :: URLString -> FilePath -> Annex Bool
download url file = do
showOutput -- make way for curl progress bar
liftIO $ boolSystem "curl" [Params "-L -C - -# -o", File file, File url]
{- Downloads a small file. -}
get :: URLString -> IO String
get url =
case parseURI url of
Nothing -> error "url parse error"
Just u -> do
r <- request u GET
case rspCode r of
(2,_,_) -> return $ rspBody r
_ -> error $ rspReason r
{- Makes a http request of an url. For example, HEAD can be used to
- check if the url exists, or GET used to get the url content (best for
- small urls). -}
request :: URI -> RequestMethod -> IO (Response String)
request url requesttype = Browser.browse $ do
Browser.setErrHandler ignore
Browser.setOutHandler ignore
Browser.setAllowRedirects True
liftM snd $ Browser.request
(mkRequest requesttype url :: Request_String)
where
ignore = const $ return ()

View file

@ -7,28 +7,24 @@
module Remote.Web (
remote,
setUrl,
download
setUrl
) where
import Control.Monad.State (liftIO)
import Control.Exception
import System.FilePath
import Network.Browser
import Network.HTTP
import Network.URI
import Types
import Types.Remote
import qualified Git
import qualified Annex
import Messages
import Utility
import UUID
import Config
import PresenceLog
import LocationLog
import Locations
import qualified Remote.Helper.Url as Url
type URLString = String
@ -90,9 +86,12 @@ setUrl key url status = do
logChange g key webUUID (if null us then InfoMissing else InfoPresent)
downloadKey :: Key -> FilePath -> Annex Bool
downloadKey key file = do
us <- getUrls key
download us file
downloadKey key file = iter =<< getUrls key
where
iter [] = return False
iter (url:urls) = do
ok <- Url.download url file
if ok then return ok else iter urls
uploadKey :: Key -> Annex Bool
uploadKey _ = do
@ -114,28 +113,5 @@ checkKey' :: [URLString] -> Annex Bool
checkKey' [] = return False
checkKey' (u:us) = do
showAction $ "checking " ++ u
e <- liftIO $ urlexists u
e <- liftIO $ Url.exists u
if e then return e else checkKey' us
urlexists :: URLString -> IO Bool
urlexists url =
case parseURI url of
Nothing -> return False
Just u -> do
(_, r) <- Network.Browser.browse $ do
setErrHandler ignore
setOutHandler ignore
setAllowRedirects True
request (mkRequest HEAD u :: Request_String)
case rspCode r of
(2,_,_) -> return True
_ -> return False
where
ignore = const $ return ()
download :: [URLString] -> FilePath -> Annex Bool
download [] _ = return False
download (url:us) file = do
showOutput -- make way for curl progress bar
ok <- liftIO $ boolSystem "curl" [Params "-L -C - -# -o", File file, File url]
if ok then return ok else download us file