Add trailing slashes to URLs.
[dead/lwn-epub.git] / src / LWN / HTTP.hs
1 {-# LANGUAGE DoAndIfThenElse #-}
2
3 module LWN.HTTP
4 where
5
6 import qualified Data.ByteString as B (hPut)
7
8 import Network.Curl (
9 CurlCode(..),
10 CurlOption(..),
11 CurlResponse,
12 URLString,
13 do_curl_,
14 initialize,
15 respBody,
16 respCurlCode,
17 withCurlDo
18 )
19 import Network.Curl.Download (openURI)
20 import System.Directory (doesFileExist, getTemporaryDirectory)
21 import System.IO (hClose, hPutStrLn, stderr, stdout)
22 import System.IO.Temp (openBinaryTempFile, openTempFile)
23
24 import LWN.URI (filename)
25
26 login_url :: URLString
27 login_url = "https://lwn.net/login"
28
29 username_field :: String
30 username_field = "Username"
31
32 password_field :: String
33 password_field = "Password"
34
35 submit_field :: String
36 submit_field = "submit"
37
38
39 default_curl_opts :: [CurlOption]
40 default_curl_opts =
41 [ -- The Global cache is not thread-friendly.
42 CurlDNSUseGlobalCache False,
43
44 -- And we don't want to use a DNS cache anyway.
45 CurlDNSCacheTimeout 0,
46
47 -- Follow redirects.
48 CurlFollowLocation True,
49
50 -- Give it a little time...
51 CurlTimeout 45,
52
53 -- For debugging.
54 CurlVerbose True ]
55
56
57 make_cookie_jar :: IO FilePath
58 make_cookie_jar = do
59 temp_dir <- getTemporaryDirectory
60 let file_name_template = "lwn-epub-cookies.txt"
61 (out_path, out_handle) <- openTempFile temp_dir file_name_template
62 hClose out_handle -- We just want to create it for now.
63 return out_path
64
65 get_page :: Maybe FilePath -> URLString -> IO (Maybe String)
66 get_page cookie_file url =
67 withCurlDo $ do
68 hPutStrLn stdout ("Getting page: " ++ url ++ "...")
69
70 -- Create a curl instance.
71 curl <- initialize
72
73 -- Perform the request, and get back a CurlResponse object.
74 -- The cast is needed to specify how we would like our headers
75 -- and body returned (Strings).
76 putStrLn "Curl options:"
77 print curl_opts
78
79 resp <- do_curl_ curl url curl_opts :: IO CurlResponse
80
81 -- Pull out the response code as a CurlCode.
82 let code = respCurlCode resp
83
84 case code of
85 CurlOK -> return $ Just (respBody resp)
86 error_code -> do
87 hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
88 -- If an error occurred, we want to dump as much information as
89 -- possible. If this becomes a problem, we can use respGetInfo to
90 -- query the response object for more information
91 return Nothing
92 where
93 get_opts =
94 case cookie_file of
95 Nothing -> []
96 Just cookies -> [ CurlCookieFile cookies ]
97
98 curl_opts = default_curl_opts ++ get_opts
99
100
101 log_in :: FilePath -> String -> String -> IO Bool
102 log_in cookie_jar username password =
103 withCurlDo $ do
104 hPutStrLn stdout ("Logging " ++ username ++ " in...")
105
106 -- Create a curl instance.
107 curl <- initialize
108
109 -- Perform the request, and get back a CurlResponse object.
110 -- The cast is needed to specify how we would like our headers
111 -- and body returned (Strings).
112 resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
113
114 -- Pull out the response code as a CurlCode.
115 let code = respCurlCode resp
116
117 case code of
118 CurlOK -> return True
119 error_code -> do
120 hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
121 -- If an error occurred, we want to dump as much information as
122 -- possible. If this becomes a problem, we can use respGetInfo to
123 -- query the response object for more information
124 return False
125 where
126 post_submit :: String
127 post_submit = submit_field ++ "=Log+In"
128
129 post_username :: String
130 post_username = username_field ++ "=" ++ username
131
132 post_password :: String
133 post_password = password_field ++ "=" ++ password
134
135 post_data :: [String]
136 post_data = [post_username, post_password, post_submit]
137
138 post_opts :: [CurlOption]
139 post_opts =
140 [ CurlCookieSession True,
141 CurlCookieJar cookie_jar,
142 CurlPost True,
143 CurlPostFields post_data ]
144
145 curl_opts :: [CurlOption]
146 curl_opts = default_curl_opts ++ post_opts
147
148
149 -- | Save the image at 'url'. Saves to a temporary file, and
150 -- returns the path to that file if successful. Otherwise,
151 -- returns 'Nothing'.
152 --
153 -- We need to be able to parse the filename out of the URL
154 -- so that when we stick our image in the document, the reader
155 -- knows that type (jpg, png, etc.) it is.
156 save_image :: URLString -> IO (Maybe FilePath)
157 save_image url = do
158 it_exists <- doesFileExist url
159 if it_exists then do
160 -- It's local, just use it.
161 return $ Just url
162 else do
163 let fn = filename url
164 case fn of
165 Nothing -> return Nothing
166 Just file -> do
167 temp_dir <- getTemporaryDirectory
168 (out_path, out_handle) <- openBinaryTempFile temp_dir file
169 result <- openURI url
170 case result of
171 Left err -> do
172 hPutStrLn stderr ("HTTP Error: " ++ err)
173 return Nothing
174 Right bs -> do
175 B.hPut out_handle bs
176 return $ Just out_path