summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-08-16 20:49:04 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-08-16 20:49:44 -0400
commit4545a0e78cf675c6bbbcdd86b5c06bf99bb0c7e9 (patch)
tree37ee27fd0a852aafb741be4b85b4d48a96f295e2 /Remote
parent07f2e7ee726f3d7f60cd478e928afc69db60c0c8 (diff)
split out generic url stuff into a helper library from Remote.Web
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Helper/Url.hs66
-rw-r--r--Remote/Web.hs42
2 files changed, 75 insertions, 33 deletions
diff --git a/Remote/Helper/Url.hs b/Remote/Helper/Url.hs
new file mode 100644
index 000000000..d3aea5622
--- /dev/null
+++ b/Remote/Helper/Url.hs
@@ -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 ()
diff --git a/Remote/Web.hs b/Remote/Web.hs
index cd028a06d..cc96d5306 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -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