ef4fc5aeebf14cbefd25be3cf7084052eeac4025
[dead/lwn-epub.git] / src / LWN / HTTP.hs
1 {-# LANGUAGE DoAndIfThenElse #-}
2
3 module LWN.HTTP
4 where
5
6 import Control.Concurrent.ParallelIO (parallel)
7 import qualified Data.ByteString as B (hPut)
8 import qualified Data.Map as Map (Map, empty, insert)
9 import Data.Maybe (fromJust, isNothing)
10 import Network.Curl (
11 CurlCode(..),
12 CurlOption(..),
13 CurlResponse,
14 do_curl_,
15 initialize,
16 respBody,
17 respCurlCode,
18 withCurlDo
19 )
20 import Network.Curl.Download (openURI)
21 import System.Directory (doesFileExist, getTemporaryDirectory)
22 import System.IO (hClose, hPutStrLn, stderr)
23 import qualified System.IO.UTF8 as Utf8 (readFile)
24 import System.IO.Temp (openBinaryTempFile, openTempFile)
25
26 import qualified Configuration as C (Cfg(..))
27 import LWN.Article (real_article_path)
28 import LWN.URI (URL, filename)
29
30 login_url :: URL
31 login_url = "https://lwn.net/login"
32
33 username_field :: String
34 username_field = "Username"
35
36 password_field :: String
37 password_field = "Password"
38
39 submit_field :: String
40 submit_field = "submit"
41
42
43 default_curl_opts :: [CurlOption]
44 default_curl_opts =
45 [ -- The Global cache is not thread-friendly.
46 CurlDNSUseGlobalCache False,
47
48 -- And we don't want to use a DNS cache anyway.
49 CurlDNSCacheTimeout 0,
50
51 -- Follow redirects.
52 CurlFollowLocation True,
53
54 -- Give it a little time...
55 CurlTimeout 45 ]
56
57
58 make_cookie_jar :: IO FilePath
59 make_cookie_jar = do
60 temp_dir <- getTemporaryDirectory
61 let file_name_template = "lwn-epub-cookies.txt"
62 (out_path, out_handle) <- openTempFile temp_dir file_name_template
63 hClose out_handle -- We just want to create it for now.
64 return out_path
65
66 get_page :: Maybe FilePath -> URL -> IO (Either String String)
67 get_page cookie_file url =
68 withCurlDo $ do
69 -- Create a curl instance.
70 curl <- initialize
71
72 -- Perform the request, and get back a CurlResponse object.
73 -- The cast is needed to specify how we would like our headers
74 -- and body returned (Strings).
75 resp <- do_curl_ curl url curl_opts :: IO CurlResponse
76
77 -- Pull out the response code as a CurlCode.
78 let code = respCurlCode resp
79
80 return $
81 case code of
82 CurlOK -> Right (respBody resp)
83 error_code -> Left ("HTTP Error: " ++ (show error_code))
84 -- If an error occurred, we want to dump as much information as
85 -- possible. If this becomes a problem, we can use respGetInfo to
86 -- query the response object for more information
87 where
88 get_opts =
89 case cookie_file of
90 Nothing -> []
91 Just cookies -> [ CurlCookieFile cookies ]
92
93 curl_opts = default_curl_opts ++ get_opts
94
95
96 -- | Log in using curl. Store the resulting session cookies in the
97 -- supplied file.
98 log_in :: FilePath -> String -> String -> IO (Either String String)
99 log_in cookie_jar username password =
100 withCurlDo $ do
101 -- Create a curl instance.
102 curl <- initialize
103
104 -- Perform the request, and get back a CurlResponse object.
105 -- The cast is needed to specify how we would like our headers
106 -- and body returned (Strings).
107 resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
108
109 -- Pull out the response code as a CurlCode.
110 let code = respCurlCode resp
111
112 return $
113 case code of
114 CurlOK -> Right (respBody resp)
115 error_code -> Left $ "HTTP Error: " ++ (show error_code)
116 -- If an error occurred, we want to dump as much information as
117 -- possible. If this becomes a problem, we can use respGetInfo to
118 -- query the response object for more information
119 where
120 post_submit :: String
121 post_submit = submit_field ++ "=Log+In"
122
123 post_username :: String
124 post_username = username_field ++ "=" ++ username
125
126 post_password :: String
127 post_password = password_field ++ "=" ++ password
128
129 post_data :: [String]
130 post_data = [post_username, post_password, post_submit]
131
132 post_opts :: [CurlOption]
133 post_opts =
134 [ CurlCookieSession True,
135 CurlCookieJar cookie_jar,
136 CurlPost True,
137 CurlPostFields post_data ]
138
139 curl_opts :: [CurlOption]
140 curl_opts = default_curl_opts ++ post_opts
141
142
143 -- | Save the image at 'url'. Saves to a temporary file, and
144 -- returns the path to that file if successful. Otherwise,
145 -- returns 'Nothing'.
146 --
147 -- We need to be able to parse the filename out of the URL
148 -- so that when we stick our image in the document, the reader
149 -- knows that type (jpg, png, etc.) it is.
150 save_image :: URL -> IO (Maybe FilePath)
151 save_image url = do
152 it_exists <- doesFileExist url
153 if it_exists then do
154 -- It's local, just use it.
155 return $ Just url
156 else do
157 let fn = filename url
158 case fn of
159 Nothing -> return Nothing
160 Just file -> do
161 temp_dir <- getTemporaryDirectory
162 (out_path, out_handle) <- openBinaryTempFile temp_dir file
163 result <- openURI url
164 case result of
165 Left err -> do
166 hPutStrLn stderr ("HTTP Error: " ++ err)
167 return Nothing
168 Right bs -> do
169 B.hPut out_handle bs
170 return $ Just out_path
171
172
173
174
175 -- | Map absolute image URLs to local system file paths where the
176 -- image referenced by the URL is stored.
177 type ImageMap = Map.Map URL FilePath
178
179 download_image_urls :: [URL] -> IO ImageMap
180 download_image_urls image_urls = do
181 files <- parallel $ map save_image image_urls
182 let pairs = zip image_urls files
183 return $ foldl my_insert empty_map pairs
184 where
185 empty_map = Map.empty :: ImageMap
186
187 my_insert :: ImageMap -> (URL, Maybe FilePath) -> ImageMap
188 my_insert dict (_, Nothing) = dict
189 my_insert dict (k, Just v) = Map.insert k v dict
190
191
192
193
194
195 get_login_cookie :: C.Cfg -> IO C.Cfg
196 get_login_cookie cfg
197 | isNothing (C.username cfg) = return cfg
198 | isNothing (C.password cfg) = return cfg
199 | otherwise = do
200 let uname = fromJust $ C.username cfg
201 let pword = fromJust $ C.password cfg
202 cj <- make_cookie_jar
203 li_result <- log_in cj uname pword
204
205 case li_result of
206 Left err -> do
207 let msg = "Failed to log in. " ++ err
208 hPutStrLn stderr msg
209 Right response_body -> do
210 hPutStrLn stderr response_body
211
212 return $ cfg { C.cookie_jar = Just cj }
213
214
215 -- | Try to parse the given article using HXT. We try a few different
216 -- methods; if none of them work, we return 'Nothing'.
217 get_article_contents :: C.Cfg -> URL -> IO (Maybe String)
218 get_article_contents cfg article_name = do
219 my_article <- real_article_path article_name
220 is_file <- doesFileExist my_article
221 case is_file of
222 True -> do
223 contents <- Utf8.readFile my_article
224 return $ Just $ contents
225 False -> do
226 -- Download the URL and try to parse it.
227 html <- get_page (C.cookie_jar cfg) my_article
228
229 case html of
230 Left err -> do
231 let msg = "Failed to retrieve page. " ++ err
232 hPutStrLn stderr msg
233 return Nothing
234 Right h -> return $ Just h