src/LWN/HTTP.hs

   1 module LWN.HTTP
   2 where
   3
   4 import qualified Data.ByteString as B (hPut)
   5 import Network.Curl (
   6   CurlCode(..),
   7   CurlOption(..),
   8   CurlResponse,
   9   URLString,
  10   do_curl_,
  11   initialize,
  12   respBody,
  13   respCurlCode,
  14   withCurlDo
  15   )
  16 import Network.Curl.Download (openURI)
  17 import System.Directory (getTemporaryDirectory)
  18 import System.IO (hPutStrLn, stderr)
  19 import System.IO.Temp (openBinaryTempFile)
  20
  21 import LWN.URI (filename)
  22
  23 login_url :: URLString
  24 login_url = "https://lwn.net/login"
  25
  26 username_field :: String
  27 username_field = "Username"
  28
  29 password_field :: String
  30 password_field = "Password"
  31
  32 submit_field :: String
  33 submit_field = "submit"
  34
  35
  36 default_curl_opts :: [CurlOption]
  37 default_curl_opts =
  38   [ -- The Global cache is not thread-friendly.
  39     CurlDNSUseGlobalCache False,
  40
  41     -- And we don't want to use a DNS cache anyway.
  42     CurlDNSCacheTimeout 0,
  43
  44     -- Give it a little time...
  45     CurlTimeout 45,
  46
  47     -- And let us know when things go wrong.
  48     CurlVerbose True ]
  49
  50
  51
  52 get_page :: Maybe FilePath -> URLString -> IO (Maybe String)
  53 get_page cookie_jar url =
  54   withCurlDo $ do
  55     -- Create a curl instance.
  56     curl <- initialize
  57
  58     -- Perform the request, and get back a CurlResponse object.
  59     -- The cast is needed to specify how we would like our headers
  60     -- and body returned (Strings).
  61     resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
  62
  63     -- Pull out the response code as a CurlCode.
  64     let code = respCurlCode resp
  65
  66     case code of
  67       CurlOK -> return $ Just (respBody resp)
  68       error_code -> do
  69         hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
  70         -- If an error occurred, we want to dump as much information as
  71         -- possible. If this becomes a problem, we can use respGetInfo to
  72         -- query the response object for more information
  73         return Nothing
  74   where
  75     get_opts =
  76       case cookie_jar of
  77         Nothing -> []
  78         Just cookies -> [ CurlCookieJar cookies ]
  79
  80     curl_opts = default_curl_opts ++ get_opts
  81
  82
  83 log_in :: FilePath -> String -> String -> IO Bool
  84 log_in cookie_jar username password =
  85   withCurlDo $ do
  86     -- Create a curl instance.
  87     curl <- initialize
  88
  89     -- Perform the request, and get back a CurlResponse object.
  90     -- The cast is needed to specify how we would like our headers
  91     -- and body returned (Strings).
  92     resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
  93
  94     -- Pull out the response code as a CurlCode.
  95     let code = respCurlCode resp
  96
  97     case code of
  98       CurlOK -> return True
  99       error_code -> do
 100         hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
 101         -- If an error occurred, we want to dump as much information as
 102         -- possible. If this becomes a problem, we can use respGetInfo to
 103         -- query the response object for more information
 104         return False
 105   where
 106     post_submit :: String
 107     post_submit = submit_field ++ "=Log+In"
 108
 109     post_username :: String
 110     post_username = username_field ++ "=" ++ username
 111
 112     post_password :: String
 113     post_password = password_field ++ "=" ++ password
 114
 115     post_data :: [String]
 116     post_data = [post_username, post_password]
 117
 118     post_opts :: [CurlOption]
 119     post_opts =
 120       [ CurlCookieSession True,
 121         CurlCookieJar cookie_jar,
 122         CurlPost True,
 123         CurlPostFields post_data ]
 124
 125     curl_opts :: [CurlOption]
 126     curl_opts = default_curl_opts ++ post_opts
 127
 128
 129 -- | Save the image at 'url'. Saves to a temporary file, and
 130 --   returns the path to that file if successful. Otherwise,
 131 --   returns 'Nothing'.
 132 --
 133 --   We need to be able to parse the filename out of the URL
 134 --   so that when we stick our image in the document, the reader
 135 --   knows that type (jpg, png, etc.) it is.
 136 save_image :: URLString -> IO (Maybe FilePath)
 137 save_image url = do
 138   let fn = filename url
 139   case fn of
 140     Nothing -> return Nothing
 141     Just file -> do
 142       temp_dir <- getTemporaryDirectory
 143       (out_path, out_handle) <- openBinaryTempFile temp_dir file
 144       result <- openURI url
 145       case result of
 146         Left err -> do
 147           hPutStrLn stderr ("HTTP Error: " ++ err)
 148           return Nothing
 149         Right bs -> do
 150           B.hPut out_handle bs
 151           return $ Just out_path