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

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