module Configuration (
Cfg(..),
+ cj_empty,
get_cfg,
use_account
)
where
-import Control.Monad (mplus)
import Data.ConfigFile
import Data.Maybe (isJust)
import Data.Monoid (Monoid(..))
+import Network.HTTP.Conduit (CookieJar, createCookieJar, destroyCookieJar)
import System.Directory (
doesFileExist,
getAppUserDataDirectory
-- | Contains all of our configurable options.
data Cfg = Cfg {
article :: String,
- cookie_jar :: Maybe FilePath,
+ cookie_jar :: CookieJar,
full_stories :: Bool,
output :: FilePath,
password :: Maybe String,
username :: Maybe String }
+-- An empty CookieJar. See cj_append for rationale.
+cj_empty :: CookieJar
+cj_empty = createCookieJar []
+
+
+-- Defined for convenience; I would really like to use mappend but GHC
+-- bitches about the orphan instance.
+cj_append :: CookieJar -> CookieJar -> CookieJar
+cj_append cj1 cj2 =
+ createCookieJar (cookies1 ++ cookies2)
+ where
+ -- Decompose the cookie jars into lists.
+ cookies1 = destroyCookieJar cj1
+ cookies2 = destroyCookieJar cj2
+
instance Monoid Cfg where
- mempty = Cfg { article = "",
- cookie_jar = Nothing,
+ mempty = Cfg { article = mempty,
+ cookie_jar = cj_empty,
full_stories = False,
- output = "",
+ output = mempty,
password = Nothing,
username = Nothing }
mappend c1 c2 =
let article' = (if null article1 then article2 else article1)
- cookie_jar' = cookie_jar1 `mplus` cookie_jar2
+ cookie_jar' = cookie_jar1 `cj_append` cookie_jar2
full_stories' = full_stories1 || full_stories2
output' = (if null output1 then output2 else output1)
- password' = password1 `mplus` password2
- username' = username1 `mplus` username2
+ password' = password1 `mappend` password2
+ username' = username1 `mappend` username2
in
Cfg { article = article',
cookie_jar = cookie_jar',
where
import Control.Concurrent.ParallelIO (parallel)
-import qualified Data.ByteString as B (hPut)
+import qualified Data.ByteString.Char8 as C (ByteString, pack)
+import qualified Data.ByteString.Lazy as L (ByteString, hPut)
+import Data.ByteString.Lazy.UTF8 (toString)
import qualified Data.Map as Map (Map, empty, insert)
import Data.Maybe (fromJust, isNothing)
-import Network.Curl (
- CurlCode(..),
- CurlOption(..),
- CurlResponse,
- do_curl_,
- initialize,
- respBody,
- respCurlCode,
- withCurlDo
+import Data.Time (getCurrentTime)
+import Network.HTTP.Conduit (
+ CookieJar,
+ Response(..),
+ Request(..),
+ httpLbs,
+ insertCookiesIntoRequest,
+ parseUrl,
+ updateCookieJar,
+ urlEncodedBody,
+ withManager
)
-import Network.Curl.Download (openURI)
+import Network.HTTP.Types (status200, status302)
+import Network.HTTP.Types.Method (methodPost)
import System.Directory (doesFileExist, getTemporaryDirectory)
-import System.IO (hClose, hPutStrLn, stderr)
+import System.IO (hPutStrLn, stderr)
import qualified System.IO.UTF8 as Utf8 (readFile)
-import System.IO.Temp (openBinaryTempFile, openTempFile)
+import System.IO.Temp (openBinaryTempFile)
-import qualified Configuration as C (Cfg(..))
+-- Also grab the empty cookie jar from Configuration since we'll
+-- use it in a few places.
+import qualified Configuration as C (Cfg(..), cj_empty)
import LWN.Article (real_article_path)
import LWN.URI (URL, filename)
-login_url :: URL
-login_url = "https://lwn.net/login"
-
-username_field :: String
-username_field = "Username"
-
-password_field :: String
-password_field = "Password"
-
-submit_field :: String
-submit_field = "submit"
-
-
-default_curl_opts :: [CurlOption]
-default_curl_opts =
- [ -- The Global cache is not thread-friendly.
- CurlDNSUseGlobalCache False,
-
- -- And we don't want to use a DNS cache anyway.
- CurlDNSCacheTimeout 0,
+-- | The type of response we get back from http-conduit's httpLbs.
+type LBSResponse = Response L.ByteString
- -- Follow redirects.
- CurlFollowLocation True,
-
- -- Give it a little time...
- CurlTimeout 45 ]
+login_url :: URL
+login_url = "https://lwn.net/login"
-make_cookie_jar :: IO FilePath
-make_cookie_jar = do
- temp_dir <- getTemporaryDirectory
- let file_name_template = "lwn-epub-cookies.txt"
- (out_path, out_handle) <- openTempFile temp_dir file_name_template
- hClose out_handle -- We just want to create it for now.
- return out_path
+username_field :: C.ByteString
+username_field = C.pack "Username"
-get_page :: Maybe FilePath -> URL -> IO (Either String String)
-get_page cookie_file url =
- withCurlDo $ do
- -- Create a curl instance.
- curl <- initialize
+password_field :: C.ByteString
+password_field = C.pack "Password"
- -- Perform the request, and get back a CurlResponse object.
- -- The cast is needed to specify how we would like our headers
- -- and body returned (Strings).
- resp <- do_curl_ curl url curl_opts :: IO CurlResponse
+submit_field :: C.ByteString
+submit_field = C.pack "submit"
- -- Pull out the response code as a CurlCode.
- let code = respCurlCode resp
- return $
- case code of
- CurlOK -> Right (respBody resp)
- error_code -> Left ("HTTP Error: " ++ (show error_code))
- -- If an error occurred, we want to dump as much information as
- -- possible. If this becomes a problem, we can use respGetInfo to
- -- query the response object for more information
- where
- get_opts =
- case cookie_file of
- Nothing -> []
- Just cookies -> [ CurlCookieFile cookies ]
+-- | Get the requested URL as a L.ByteString, or return the response
+-- as an error. Use the given cookie jar for the request.
+get_page :: CookieJar -> URL -> IO (Either LBSResponse L.ByteString)
+get_page cj url = do
+ init_req <- parseUrl url
+ let req' = init_req { checkStatus = \_ _ -> Nothing }
+ now <- getCurrentTime
+ let (req, _) = insertCookiesIntoRequest req' cj now
+ resp <- withManager $ httpLbs req
- curl_opts = default_curl_opts ++ get_opts
+ return $ if (responseStatus resp) == status200 then
+ Right (responseBody resp)
+ else
+ Left resp
-- | Log in using curl. Store the resulting session cookies in the
-- supplied file.
-log_in :: FilePath -> String -> String -> IO (Either String String)
-log_in cookie_jar username password =
- withCurlDo $ do
- -- Create a curl instance.
- curl <- initialize
-
- -- Perform the request, and get back a CurlResponse object.
- -- The cast is needed to specify how we would like our headers
- -- and body returned (Strings).
- resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
-
- -- Pull out the response code as a CurlCode.
- let code = respCurlCode resp
-
- return $
- case code of
- CurlOK -> Right (respBody resp)
- error_code -> Left $ "HTTP Error: " ++ (show error_code)
- -- If an error occurred, we want to dump as much information as
- -- possible. If this becomes a problem, we can use respGetInfo to
- -- query the response object for more information
+log_in :: String -> String -> IO (Either LBSResponse CookieJar)
+log_in username password = do
+ init_req <- parseUrl login_url
+ let req' = init_req { method = methodPost,
+ checkStatus = \_ _ -> Nothing,
+ redirectCount = 0 }
+ let req = urlEncodedBody post_data req'
+
+ resp <- withManager $ httpLbs req
+
+ -- The login page redirects. If we follow it, we lose our cookies.
+ if (responseStatus resp) == status302 then do
+ now <- getCurrentTime
+ let (cj,_) = updateCookieJar resp req now C.cj_empty
+ return $ Right cj
+ else do
+ return $ Left resp
+
where
- post_submit :: String
- post_submit = submit_field ++ "=Log+In"
+ post_submit :: (C.ByteString, C.ByteString)
+ post_submit = (submit_field, C.pack "Log+In")
- post_username :: String
- post_username = username_field ++ "=" ++ username
+ post_username :: (C.ByteString, C.ByteString)
+ post_username = (username_field, C.pack username)
- post_password :: String
- post_password = password_field ++ "=" ++ password
+ post_password :: (C.ByteString, C.ByteString)
+ post_password = (password_field, C.pack password)
- post_data :: [String]
+ post_data :: [(C.ByteString, C.ByteString)]
post_data = [post_username, post_password, post_submit]
- post_opts :: [CurlOption]
- post_opts =
- [ CurlCookieSession True,
- CurlCookieJar cookie_jar,
- CurlPost True,
- CurlPostFields post_data ]
-
- curl_opts :: [CurlOption]
- curl_opts = default_curl_opts ++ post_opts
-- | Save the image at 'url'. Saves to a temporary file, and
Just file -> do
temp_dir <- getTemporaryDirectory
(out_path, out_handle) <- openBinaryTempFile temp_dir file
- result <- openURI url
+ -- We don't need to be logged in to get the images, so use an
+ -- empty cookie jar.
+ result <- get_page C.cj_empty url
case result of
Left err -> do
- hPutStrLn stderr ("HTTP Error: " ++ err)
+ hPutStrLn stderr $ "Failed to retrieve image. " ++
+ "Server response:\n" ++ (show err)
return Nothing
Right bs -> do
- B.hPut out_handle bs
+ L.hPut out_handle bs
return $ Just out_path
| otherwise = do
let uname = fromJust $ C.username cfg
let pword = fromJust $ C.password cfg
- cj <- make_cookie_jar
- li_result <- log_in cj uname pword
+ li_result <- log_in uname pword
case li_result of
Left err -> do
- let msg = "Failed to log in. " ++ err
+ let msg = "Failed to log in. Server response:\n" ++ (show err)
hPutStrLn stderr msg
- Right response_body -> do
- hPutStrLn stderr response_body
-
- return $ cfg { C.cookie_jar = Just cj }
+ return cfg
+ Right cj -> return $ cfg { C.cookie_jar = cj }
-- | Try to parse the given article using HXT. We try a few different
contents <- Utf8.readFile my_article
return $ Just $ contents
False -> do
- -- Download the URL and try to parse it.
+ -- Download the URL.
html <- get_page (C.cookie_jar cfg) my_article
case html of
Left err -> do
- let msg = "Failed to retrieve page. " ++ err
+ let msg = "Failed to retrieve article. " ++
+ "Server response:\n" ++ (show err)
hPutStrLn stderr msg
return Nothing
- Right h -> return $ Just h
+ Right lbs_article ->
+ return $ Just (toString lbs_article)
projects / dead / lwn-epub.git / commitdiff