1 {-# LANGUAGE DoAndIfThenElse #-}
6 import Control.Concurrent.ParallelIO (parallel)
7 import qualified Data.ByteString.Char8 as C (ByteString, pack)
8 import qualified Data.ByteString.Lazy as L (ByteString, hPut)
9 import Data.ByteString.Lazy.UTF8 (toString)
10 import qualified Data.Map as Map (Map, empty, insert)
11 import Data.Maybe (fromJust, isNothing)
12 import Data.Time (getCurrentTime)
13 import Network.HTTP.Conduit (
18 insertCookiesIntoRequest,
24 import Network.HTTP.Types (status200, status302)
25 import Network.HTTP.Types.Method (methodPost)
26 import System.Directory (doesFileExist, getTemporaryDirectory)
27 import System.IO (hPutStrLn, stderr)
28 import qualified System.IO.UTF8 as Utf8 (readFile)
29 import System.IO.Temp (openBinaryTempFile)
31 -- Also grab the empty cookie jar from Configuration since we'll
32 -- use it in a few places.
33 import qualified Configuration as C (Cfg(..), cj_empty)
34 import LWN.Article (real_article_path)
35 import LWN.URI (URL, filename)
37 -- | The type of response we get back from http-conduit's httpLbs.
38 type LBSResponse = Response L.ByteString
42 login_url = "https://lwn.net/login"
44 username_field :: C.ByteString
45 username_field = C.pack "Username"
47 password_field :: C.ByteString
48 password_field = C.pack "Password"
50 submit_field :: C.ByteString
51 submit_field = C.pack "submit"
54 -- | Get the requested URL as a L.ByteString, or return the response
55 -- as an error. Use the given cookie jar for the request.
56 get_page :: CookieJar -> URL -> IO (Either LBSResponse L.ByteString)
58 init_req <- parseUrl url
59 let req' = init_req { checkStatus = \_ _ -> Nothing }
61 let (req, _) = insertCookiesIntoRequest req' cj now
62 resp <- withManager $ httpLbs req
64 return $ if (responseStatus resp) == status200 then
65 Right (responseBody resp)
70 -- | Log in using curl. Store the resulting session cookies in the
72 log_in :: String -> String -> IO (Either LBSResponse CookieJar)
73 log_in username password = do
74 init_req <- parseUrl login_url
75 let req' = init_req { method = methodPost,
76 checkStatus = \_ _ -> Nothing,
78 let req = urlEncodedBody post_data req'
80 resp <- withManager $ httpLbs req
82 -- The login page redirects. If we follow it, we lose our cookies.
83 if (responseStatus resp) == status302 then do
85 let (cj,_) = updateCookieJar resp req now C.cj_empty
91 post_submit :: (C.ByteString, C.ByteString)
92 post_submit = (submit_field, C.pack "Log+In")
94 post_username :: (C.ByteString, C.ByteString)
95 post_username = (username_field, C.pack username)
97 post_password :: (C.ByteString, C.ByteString)
98 post_password = (password_field, C.pack password)
100 post_data :: [(C.ByteString, C.ByteString)]
101 post_data = [post_username, post_password, post_submit]
105 -- | Save the image at 'url'. Saves to a temporary file, and
106 -- returns the path to that file if successful. Otherwise,
107 -- returns 'Nothing'.
109 -- We need to be able to parse the filename out of the URL
110 -- so that when we stick our image in the document, the reader
111 -- knows that type (jpg, png, etc.) it is.
112 save_image :: URL -> IO (Maybe FilePath)
114 it_exists <- doesFileExist url
116 -- It's local, just use it.
119 let fn = filename url
121 Nothing -> return Nothing
123 temp_dir <- getTemporaryDirectory
124 (out_path, out_handle) <- openBinaryTempFile temp_dir file
125 -- We don't need to be logged in to get the images, so use an
127 result <- get_page C.cj_empty url
130 hPutStrLn stderr $ "Failed to retrieve image. " ++
131 "Server response:\n" ++ (show err)
135 return $ Just out_path
140 -- | Map absolute image URLs to local system file paths where the
141 -- image referenced by the URL is stored.
142 type ImageMap = Map.Map URL FilePath
144 download_image_urls :: [URL] -> IO ImageMap
145 download_image_urls image_urls = do
146 files <- parallel $ map save_image image_urls
147 let pairs = zip image_urls files
148 return $ foldl my_insert empty_map pairs
150 empty_map = Map.empty :: ImageMap
152 my_insert :: ImageMap -> (URL, Maybe FilePath) -> ImageMap
153 my_insert dict (_, Nothing) = dict
154 my_insert dict (k, Just v) = Map.insert k v dict
160 get_login_cookie :: C.Cfg -> IO C.Cfg
162 | isNothing (C.username cfg) = return cfg
163 | isNothing (C.password cfg) = return cfg
165 let uname = fromJust $ C.username cfg
166 let pword = fromJust $ C.password cfg
167 li_result <- log_in uname pword
171 let msg = "Failed to log in. Server response:\n" ++ (show err)
174 Right cj -> return $ cfg { C.cookie_jar = cj }
177 -- | Try to parse the given article using HXT. We try a few different
178 -- methods; if none of them work, we return 'Nothing'.
179 get_article_contents :: C.Cfg -> URL -> IO (Maybe String)
180 get_article_contents cfg article_name = do
181 my_article <- real_article_path article_name
182 is_file <- doesFileExist my_article
185 contents <- Utf8.readFile my_article
186 return $ Just $ contents
189 html <- get_page (C.cookie_jar cfg) my_article
193 let msg = "Failed to retrieve article. " ++
194 "Server response:\n" ++ (show err)
198 return $ Just (toString lbs_article)