HTTP 请求：request 库¶

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}

import Network.HTTP.Request

main :: IO ()
main = do
  resp <- get "https://httpbin.org/get" :: IO (Response String)
  print resp.status
  mapM_ print resp.headers
  putStrLn resp.body

get :: FromResponseBody a => String -> IO (Response a)

data Method = DELETE | GET | HEAD | OPTIONS | PATCH | POST | PUT | TRACE | Method String

type Header  = (ByteString, ByteString)
type Headers = [Header]

data Request a = Request
  { method  :: Method
  , url     :: String
  , headers :: Headers
  , body    :: a
  }

data Response a = Response
  { status  :: Int
  , headers :: Headers
  , body    :: a
  }

send :: (ToRequestBody a, FromResponseBody b) => Request a -> IO (Response b)

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}

import Network.HTTP.Request
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

main :: IO ()
main = do
  let req = Request
        { method  = GET
        , url     = "https://httpbin.org/headers"
        , headers = [("User-Agent", "a-byte-of-haskell/1.0"), ("Accept", "application/json")]
        , body    = ()
        }
  resp <- send req :: IO (Response T.Text)
  print resp.status
  TIO.putStrLn resp.body

import Network.HTTP.Request

main :: IO ()
main = do
  resp <- send (Request GET "https://httpbin.org/get" [] ()) :: IO (Response String)
  print (responseStatus resp)
  putStrLn (responseBody resp)

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}

import Network.HTTP.Request
import Data.Aeson (FromJSON, ToJSON, Value, encode)
import Data.Text (Text)
import GHC.Generics (Generic)
import qualified Data.ByteString.Lazy.Char8 as BL

-- httpbin.org/uuid 返回 {"uuid": "..."}
newtype UUID = UUID { uuid :: Text }
  deriving (Show, Generic)

instance FromJSON UUID

-- 要发送的数据
data NewUser = NewUser
  { name :: Text
  , age  :: Int
  } deriving (Show, Generic)

instance ToJSON NewUser
instance FromJSON NewUser

-- httpbin.org/post 会把收到的 JSON 原样放在 "json" 字段里返回
newtype Echo = Echo { json :: NewUser }
  deriving (Show, Generic)

instance FromJSON Echo

main :: IO ()
main = do
  -- 响应体直接解码成记录
  r1 <- get "https://httpbin.org/uuid" :: IO (Response UUID)
  print r1.status
  print r1.body.uuid

  -- 请求体是 ToJSON 类型，自动编码并设置 Content-Type: application/json
  r2 <- post "https://httpbin.org/post" (NewUser "Alice" 30) :: IO (Response Echo)
  print r2.status
  print r2.body.json

  -- 不清楚结构时，先解码成 Value 看一看
  r3 <- get "https://httpbin.org/json" :: IO (Response Value)
  BL.putStrLn (encode r3.body)

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}

import Network.HTTP.Request

main :: IO ()
main = do
  -- 表单提交，Content-Type 为 application/x-www-form-urlencoded
  r1 <- post "https://httpbin.org/post"
             (Form [("username", "alice"), ("password", "s3cret")])
          :: IO (Response String)
  print r1.status

  -- HTTP Basic 认证
  let req = basicAuth "alice" "s3cret"
              (Request GET "https://httpbin.org/basic-auth/alice/s3cret" [] ())
  r2 <- send req :: IO (Response String)
  print r2.status

  -- Bearer Token
  let req' = bearerAuth "my-token" (Request GET "https://httpbin.org/bearer" [] ())
  r3 <- send req' :: IO (Response String)
  print r3.status
  putStrLn r3.body

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}

import Network.HTTP.Request
import Control.Exception (try, SomeException)
import Data.Aeson (Value)

main :: IO ()
main = do
  -- 1. 非 2xx 状态码不会抛异常，需要自己检查
  r1 <- get "https://httpbin.org/status/404" :: IO (Response String)
  if r1.status == 200
    then putStrLn "成功"
    else putStrLn ("服务器返回 " ++ show r1.status)

  -- 2. 连接失败、域名不存在等网络错误会抛异常
  r2 <- try (get "https://no-such-host.invalid/" :: IO (Response String))
  case r2 of
    Left (e :: SomeException) -> putStrLn ("请求失败: " ++ takeWhile (/= '\n') (show e))
    Right resp -> print resp.status

  -- 3. 响应不是合法 JSON 时，解码失败也会抛异常
  r3 <- try (get "https://httpbin.org/html" :: IO (Response Value))
  case r3 of
    Left (e :: SomeException) -> putStrLn ("解码失败: " ++ take 60 (show e))
    Right resp -> print resp.status

data StreamBody a = StreamBody
  { readNext    :: IO (Maybe a)   -- 下一块数据，流结束时返回 Nothing
  , closeStream :: IO ()          -- 关闭连接
  }

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}

import Network.HTTP.Request
import qualified Data.ByteString as BS
import System.IO

main :: IO ()
main = do
  resp <- get "https://httpbin.org/bytes/100000" :: IO (Response (StreamBody BS.ByteString))
  print resp.status
  withFile "download.bin" WriteMode $ \h -> do
    let loop total = do
          chunk <- resp.body.readNext
          case chunk of
            Nothing -> return total
            Just bs -> do
              BS.hPut h bs
              loop (total + BS.length bs)
    n <- loop (0 :: Int)
    putStrLn ("已写入 " ++ show n ++ " 字节")
  resp.body.closeStream

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}

import Network.HTTP.Request
import Data.Aeson (FromJSON, eitherDecode)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)

-- 字段名与 GitHub API 返回的 JSON 键一致，不需要额外配置
data Repo = Repo
  { full_name        :: Text
  , description      :: Maybe Text
  , stargazers_count :: Int
  , language         :: Maybe Text
  } deriving (Show, Generic)

instance FromJSON Repo

-- 先取回原始字节，根据状态码决定是否解码
fetchRepo :: String -> IO (Either String Repo)
fetchRepo name = do
  resp <- send Request
    { method  = GET
    , url     = "https://api.github.com/repos/" ++ name
    , headers = [("User-Agent", "a-byte-of-haskell")]   -- GitHub 要求带 User-Agent
    , body    = ()
    } :: IO (Response BL.ByteString)
  return $ if resp.status == 200
    then eitherDecode resp.body
    else Left ("GitHub 返回 " ++ show resp.status ++ ": " ++ BLC.unpack resp.body)

main :: IO ()
main = do
  args <- getArgs
  case args of
    [name] -> do
      result <- fetchRepo name
      case result of
        Left err -> do
          hPutStrLn stderr err
          exitFailure
        Right repo -> do
          putStrLn ("仓库: " ++ T.unpack repo.full_name)
          putStrLn ("简介: " ++ maybe "(无)" T.unpack repo.description)
          putStrLn ("语言: " ++ maybe "(未知)" T.unpack repo.language)
          putStrLn ("Star: " ++ show repo.stargazers_count)
    _ -> do
      prog <- getProgName
      hPutStrLn stderr ("用法: " ++ prog ++ " owner/repo")
      exitFailure