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