summaryrefslogtreecommitdiff
path: root/Remote/Helper/Url.hs
blob: af1fee8f04f4bd2b9e448507338f4103ab838a81 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
{- 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
	-- 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 ()