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)
  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 (Either String String)
  66 get_page cookie_file url =
  67   withCurlDo $ do
  68     -- Create a curl instance.
  69     curl <- initialize
  70
  71     -- Perform the request, and get back a CurlResponse object.
  72     -- The cast is needed to specify how we would like our headers
  73     -- and body returned (Strings).
  74     resp <- do_curl_ curl url curl_opts :: IO CurlResponse
  75
  76     -- Pull out the response code as a CurlCode.
  77     let code = respCurlCode resp
  78
  79     return $
  80       case code of
  81         CurlOK -> Right (respBody resp)
  82         error_code -> Left ("HTTP Error: " ++ (show error_code))
  83         -- If an error occurred, we want to dump as much information as
  84         -- possible. If this becomes a problem, we can use respGetInfo to
  85         -- query the response object for more information
  86   where
  87     get_opts =
  88       case cookie_file of
  89         Nothing -> []
  90         Just cookies -> [ CurlCookieFile cookies ]
  91
  92     curl_opts = default_curl_opts ++ get_opts
  93
  94
  95 -- | Log in using curl. Store the resulting session cookies in the
  96 --   supplied file.Warning: This returns an error if the function
  97 --   fails!
  98 log_in :: FilePath -> String -> String -> IO (Maybe 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 -> Nothing
 115         error_code -> Just $ "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 :: URLString -> 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