src/LWN/HTTP.hs

   1 module LWN.HTTP
   2 where
   3
   4 import Network.Curl (
   5   CurlCode(..),
   6   CurlOption(..),
   7   CurlResponse,
   8   URLString,
   9   do_curl_,
  10   initialize,
  11   respBody,
  12   respCurlCode,
  13   withCurlDo
  14   )
  15 import System.IO (hPutStrLn, stderr)
  16
  17 login_url :: URLString
  18 login_url = "https://lwn.net/login"
  19
  20 username_field :: String
  21 username_field = "Username"
  22
  23 password_field :: String
  24 password_field = "Password"
  25
  26 submit_field :: String
  27 submit_field = "submit"
  28
  29
  30 default_curl_opts :: [CurlOption]
  31 default_curl_opts =
  32   [ -- The Global cache is not thread-friendly.
  33     CurlDNSUseGlobalCache False,
  34
  35     -- And we don't want to use a DNS cache anyway.
  36     CurlDNSCacheTimeout 0,
  37
  38     -- Give it a little time...
  39     CurlTimeout 45,
  40
  41     -- And let us know when things go wrong.
  42     CurlVerbose True ]
  43
  44
  45
  46 get_page :: Maybe FilePath -> URLString -> IO (Maybe String)
  47 get_page cookie_jar url =
  48   withCurlDo $ do
  49     -- Create a curl instance.
  50     curl <- initialize
  51
  52     -- Perform the request, and get back a CurlResponse object.
  53     -- The cast is needed to specify how we would like our headers
  54     -- and body returned (Strings).
  55     resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
  56
  57     -- Pull out the response code as a CurlCode.
  58     let code = respCurlCode resp
  59
  60     case code of
  61       CurlOK -> return $ Just (respBody resp)
  62       error_code -> do
  63         hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
  64         -- If an error occurred, we want to dump as much information as
  65         -- possible. If this becomes a problem, we can use respGetInfo to
  66         -- query the response object for more information
  67         return Nothing
  68   where
  69     get_opts =
  70       case cookie_jar of
  71         Nothing -> []
  72         Just cookies -> [ CurlCookieJar cookies ]
  73
  74     curl_opts = default_curl_opts ++ get_opts
  75
  76
  77 log_in :: FilePath -> String -> String -> IO Bool
  78 log_in cookie_jar username password =
  79   withCurlDo $ do
  80     -- Create a curl instance.
  81     curl <- initialize
  82
  83     -- Perform the request, and get back a CurlResponse object.
  84     -- The cast is needed to specify how we would like our headers
  85     -- and body returned (Strings).
  86     resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
  87
  88     -- Pull out the response code as a CurlCode.
  89     let code = respCurlCode resp
  90
  91     case code of
  92       CurlOK -> return True
  93       error_code -> do
  94         hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
  95         -- If an error occurred, we want to dump as much information as
  96         -- possible. If this becomes a problem, we can use respGetInfo to
  97         -- query the response object for more information
  98         return False
  99   where
 100     post_submit :: String
 101     post_submit = submit_field ++ "=Log+In"
 102
 103     post_username :: String
 104     post_username = username_field ++ "=" ++ username
 105
 106     post_password :: String
 107     post_password = password_field ++ "=" ++ password
 108
 109     post_data :: [String]
 110     post_data = [post_username, post_password]
 111
 112     post_opts :: [CurlOption]
 113     post_opts =
 114       [ CurlCookieSession True,
 115         CurlCookieJar cookie_jar,
 116         CurlPost True,
 117         CurlPostFields post_data ]
 118
 119     curl_opts :: [CurlOption]
 120     curl_opts = default_curl_opts ++ post_opts