summaryrefslogtreecommitdiff
path: root/Utility/Url.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-08-20 16:11:42 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-08-20 16:11:42 -0400
commit737b5d14c91101d46e20999e33461e9059dd9f28 (patch)
tree109fb64986ec03679c8ea3c85362eff19aae1ce3 /Utility/Url.hs
parentec746c511f5666fc214eba1a477d1ababfe9d367 (diff)
moved files around
Diffstat (limited to 'Utility/Url.hs')
-rw-r--r--Utility/Url.hs70
1 files changed, 70 insertions, 0 deletions
diff --git a/Utility/Url.hs b/Utility/Url.hs
new file mode 100644
index 000000000..5954e0ff7
--- /dev/null
+++ b/Utility/Url.hs
@@ -0,0 +1,70 @@
+{- Url downloading.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.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
+ -- Uses the -# progress display, because the normal one is very
+ -- confusing when resuming, showing the remainder to download
+ -- as the whole file, and not indicating how much percent was
+ -- downloaded before the resume.
+ 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 ()