第二十二章：擴展示例 —— Web 客戶端編程 · Real World Haskell 中文版

# 第二十二章：擴展示例 —— Web 客戶端編程到目前為止，我們已經了解過如何與數據庫進行交互、如何進行語法分析（parse）以及如何處理錯誤。接下來，讓我們更進一步，通過引入一個 web 客戶端庫來將這些知識結合在一起。在這一章，我們將要構建一個實際的程序：一個播客下載器（podcast downloader），或者叫“播客抓取器”（podcatcher）。這個博客抓取器的概念非常簡單，它接受一系列 URL 作為輸入，通過下載這些 URL 來得到一些 RSS 格式的 XML 文件，然后在這些 XML 文件里面找到下載音頻文件所需的 URL 。播客抓取器常常會讓用戶通過將 RSS URL 添加到配置文件里面的方法來訂閱播客，之后用戶就可以定期地進行更新操作：播客抓取器會下載 RSS 文檔，對它們進行檢查以尋找音頻文件的下載鏈接，并為用戶下載所有目前尚未存在的音頻文件。 Tip 用戶通常將 RSS 文件稱之為“廣播”（podcast）或是“廣播源”（podcast feed），而每個單獨的音頻文件則是播客的其中一集（episode）。為了實現具有類似功能的播客抓取器，我們需要以下幾樣東西： - 一個用于下載文件的 HTTP 客戶端庫； - 一個 XML 分析器； - 一種能夠記錄我們感興趣的廣播，并將這些記錄永久地儲存起來的方法； - 一種能夠永久地記錄已下載廣播分集（episodes）的方法。這個列表的后兩樣可以通過使用 HDBC 設置的數據庫來完成，而前兩樣則可以通過本章介紹的其他庫模塊來完成。 Tip 本章的代碼是專為本書而寫的，但這些代碼實際上是基于 hpodder —— 一個使用 Haskell 編寫的播客抓取器來編寫的。hpodder 擁有的特性比本書展示的播客抓取器要多得多，因此本書不太可能詳細地對它進行介紹。如果讀者對 hpodder 感興趣的話，可以在 [http://software.complete.org/hpodder](http://software.complete.org/hpodder) 找到 hpodder 的源代碼。本章的所有代碼都是以自成一體的方式來編寫的，每段代碼都是一個獨立的 Haskell 模塊，讀者可以通過 **ghci** 獨立地運行這些模塊。本章的最后會寫出一段代碼，將這些模塊全部結合起來，構成一個完整的程序。我們首先要做的就是寫出構建博客抓取器需要用到的基本類型。 ## 基本類型為了構建播客抓取器，我們首先需要思考抓取器需要引入（important）的基本信息有那些。一般來說，抓取器關心的都是記錄用戶感興趣的博客的信息，以及那些記錄了用戶已經看過和處理過的分集的信息。在有需要的時候改變這些信息并不困難，但是因為我們在整個抓取器里面都要用到這些信息，所以我們最好還是先定義它們： ~~~ -- file: ch22/PodTypes.hs module PodTypes where data Podcast = Podcast {castId :: Integer, -- ^ 這個播客的數字 ID castURL :: String -- ^ 這個播客的源 URL } deriving (Eq, Show, Read) data Episode = Episode {epId :: Integer, -- ^ 這個分集的數字 ID epCast :: Podcast, -- ^ 這個分集所屬播客的 ID epURL :: String, -- ^ 下載這一集所使用的 URL epDone :: Bool -- ^ 記錄用戶是否已經看過這一集 } deriving (Eq, Show, Read) ~~~ 這些信息將被儲存到數據庫里面。通過為每個播客和博客的每一集都創建一個獨一無二的 ID ，程序可以更容易找到分集所屬的播客，也可以更容易地從一個特定的播客或者分集里面載入信息，并且更好地應對將來可能會出現的“博客 URL 改變”這類情況。 ## 數據庫接下來，我們需要編寫代碼，以便將信息永久地儲存到數據庫里面。我們最感興趣的，就是通過數據庫，將 PodTypes.hs 文件定義的 Haskell 結構中的數據儲存到硬盤里面。并在用戶首次運行程序的時候，創建儲存數據所需的數據庫表。我們將使用 21 章介紹過的 HDBC 與 Sqlite 數據庫進行交互。Sqlite 非常輕量，并且是自包含的（self-contained），因此它對于這個小項目來說簡直是再合適不過了。HDBC 和 Sqlite 的安裝方法可以在 21 章的《安裝 HDBC 和驅動》一節看到。 ~~~ -- file: ch22/PodDB.hs module PodDB where import Database.HDBC import Database.HDBC.Sqlite3 import PodTypes import Control.Monad(when) import Data.List(sort) -- | Initialize DB and return database Connection connect :: FilePath -> IO Connection connect fp = do dbh <- connectSqlite3 fp prepDB dbh return dbh {- | 對數據庫進行設置，做好儲存數據的準備。這個程序會創建兩個表，并要求數據庫引擎為我們檢查某些數據的一致性： * castid 和 epid 都是獨一無二的主鍵（unique primary keys），它們的值不能重復 * castURL 的值也應該是獨一無二的 * 在記錄分集的表里面，對于一個給定的播客（epcast)，每個給定的 URL 或者分集 ID 只能出現一次 -} prepDB :: IConnection conn => conn -> IO () prepDB dbh = do tables <- getTables dbh when (not ("podcasts" `elem` tables)) $ do run dbh "CREATE TABLE podcasts (\ \castid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\ \castURL TEXT NOT NULL UNIQUE)" [] return () when (not ("episodes" `elem` tables)) $ do run dbh "CREATE TABLE episodes (\ \epid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\ \epcastid INTEGER NOT NULL,\ \epurl TEXT NOT NULL,\ \epdone INTEGER NOT NULL,\ \UNIQUE(epcastid, epurl),\ \UNIQUE(epcastid, epid))" [] return () commit dbh {- | 將一個新的播客添加到數據庫里面。在創建播客時忽略播客的 castid ，并返回一個包含了 castid 的新對象。嘗試添加一個已經存在的播客將引發一個錯誤。 -} addPodcast :: IConnection conn => conn -> Podcast -> IO Podcast addPodcast dbh podcast = handleSql errorHandler $ do -- Insert the castURL into the table. The database -- will automatically assign a cast ID. run dbh "INSERT INTO podcasts (castURL) VALUES (?)" [toSql (castURL podcast)] -- Find out the castID for the URL we just added. r <- quickQuery' dbh "SELECT castid FROM podcasts WHERE castURL = ?" [toSql (castURL podcast)] case r of [[x]] -> return $ podcast {castId = fromSql x} y -> fail $ "addPodcast: unexpected result: " ++ show y where errorHandler e = do fail $ "Error adding podcast; does this URL already exist?\n" ++ show e {- | 將一個新的分集添加到數據庫里面。因為這一操作是自動執行而非用戶請求執行的，我們將簡單地忽略創建重復分集的請求。這樣的話，在對播客源進行處理的時候，我們就可以把遇到的所有 URL 到傳給這個函數，而不必先檢查這個 URL 是否已經存在于數據庫當中。這個函數在創建新的分集時同樣不會考慮如何創建新的 ID ，因此它也沒有必要去考慮如何去獲取這個 ID 。 -} addEpisode :: IConnection conn => conn -> Episode -> IO () addEpisode dbh ep = run dbh "INSERT OR IGNORE INTO episodes (epCastId, epURL, epDone) \ \VALUES (?, ?, ?)" [toSql (castId . epCast $ ep), toSql (epURL ep), toSql (epDone ep)] >> return () {- | 對一個已經存在的播客進行修改。根據 ID 來查找指定的播客，并根據傳入的 Podcast 結構對數據庫記錄進行修改。 -} updatePodcast :: IConnection conn => conn -> Podcast -> IO () updatePodcast dbh podcast = run dbh "UPDATE podcasts SET castURL = ? WHERE castId = ?" [toSql (castURL podcast), toSql (castId podcast)] >> return () {- | 對一個已經存在的分集進行修改。根據 ID 來查找指定的分集，并根據傳入的 episode 結構對數據庫記錄進行修改。 -} updateEpisode :: IConnection conn => conn -> Episode -> IO () updateEpisode dbh episode = run dbh "UPDATE episodes SET epCastId = ?, epURL = ?, epDone = ? \ \WHERE epId = ?" [toSql (castId . epCast $ episode), toSql (epURL episode), toSql (epDone episode), toSql (epId episode)] >> return () {- | 移除一個播客。這個操作在執行之前會先移除這個播客已有的所有分集。 -} removePodcast :: IConnection conn => conn -> Podcast -> IO () removePodcast dbh podcast = do run dbh "DELETE FROM episodes WHERE epcastid = ?" [toSql (castId podcast)] run dbh "DELETE FROM podcasts WHERE castid = ?" [toSql (castId podcast)] return () {- | 獲取一個包含所有播客的列表。 -} getPodcasts :: IConnection conn => conn -> IO [Podcast] getPodcasts dbh = do res <- quickQuery' dbh "SELECT castid, casturl FROM podcasts ORDER BY castid" [] return (map convPodcastRow res) {- | 獲取特定的廣播。函數在成功執行時返回 Just Podcast ；在 ID 不匹配時返回 Nothing 。 -} getPodcast :: IConnection conn => conn -> Integer -> IO (Maybe Podcast) getPodcast dbh wantedId = do res <- quickQuery' dbh "SELECT castid, casturl FROM podcasts WHERE castid = ?" [toSql wantedId] case res of [x] -> return (Just (convPodcastRow x)) [] -> return Nothing x -> fail $ "Really bad error; more than one podcast with ID" {- | 將 SELECT 語句的執行結果轉換為 Podcast 記錄 -} convPodcastRow :: [SqlValue] -> Podcast convPodcastRow [svId, svURL] = Podcast {castId = fromSql svId, castURL = fromSql svURL} convPodcastRow x = error $ "Can't convert podcast row " ++ show x {- | 獲取特定播客的所有分集。 -} getPodcastEpisodes :: IConnection conn => conn -> Podcast -> IO [Episode] getPodcastEpisodes dbh pc = do r <- quickQuery' dbh "SELECT epId, epURL, epDone FROM episodes WHERE epCastId = ?" [toSql (castId pc)] return (map convEpisodeRow r) where convEpisodeRow [svId, svURL, svDone] = Episode {epId = fromSql svId, epURL = fromSql svURL, epDone = fromSql svDone, epCast = pc} ~~~ PodDB 模塊定義了連接數據庫的函數、創建所需數據庫表的函數、將數據添加到數據庫里面的函數、查詢數據庫的函數以及從數據庫里面移除數據的函數。以下代碼展示了一個與數據庫進行交互的 **ghci** 會話，這個會話將在當前目錄里面創建一個名為 poddbtest.db 的數據庫文件，并將廣播和分集添加到這個文件里面。 ~~~ ghci> :load PodDB.hs [1 of 2] Compiling PodTypes ( PodTypes.hs, interpreted ) [2 of 2] Compiling PodDB ( PodDB.hs, interpreted ) Ok, modules loaded: PodDB, PodTypes. ghci> dbh <- connect "poddbtest.db" ghci> :type dbh dbh :: Connection ghci> getTables dbh ["episodes","podcasts","sqlite_sequence"] ghci> let url = "http://feeds.thisamericanlife.org/talpodcast" ghci> pc <- addPodcast dbh (Podcast {castId=0, castURL=url}) Podcast {castId = 1, castURL = "http://feeds.thisamericanlife.org/talpodcast"} ghci> getPodcasts dbh [Podcast {castId = 1, castURL = "http://feeds.thisamericanlife.org/talpodcast"}] ghci> addEpisode dbh (Episode {epId = 0, epCast = pc, epURL = "http://www.example.com/foo.mp3", epDone = False}) ghci> getPodcastEpisodes dbh pc [Episode {epId = 1, epCast = Podcast {castId = 1, castURL = "http://feeds.thisamericanlife.org/talpodcast"}, epURL = "http://www.example.com/foo.mp3", epDone = False}] ghci> commit dbh ghci> disconnect dbh ~~~ ## 分析器在實現了抓取器的數據庫部分之后，我們接下來就需要實現抓取器中負責對廣播源進行語法分析的部分，這個部分要分析的是一些包含著多種信息的 XML 文件，例子如下： ~~~ <?xml version="1.0" encoding="UTF-8"?> <rss xmlns:itunes="http://www.itunes.com/DTDs/Podcast-1.0.dtd" version="2.0"> <channel> <title>Haskell Radio</title> <link>http://www.example.com/radio/</link> <description>Description of this podcast</description> <item> <title>Episode 2: Lambdas</title> <link>http://www.example.com/radio/lambdas</link> <enclosure url="http://www.example.com/radio/lambdas.mp3" type="audio/mpeg" length="10485760"/> </item> <item> <title>Episode 1: Parsec</title> <link>http://www.example.com/radio/parsec</link> <enclosure url="http://www.example.com/radio/parsec.mp3" type="audio/mpeg" length="10485150"/> </item> </channel> </rss> ~~~ 在這些文件里面，我們最關心的是兩樣東西：廣播的標題以及它們的附件（enclosure） URL 。我們將使用 [HaXml 工具包](http://www.cs.york.ac.uk/fp/HaXml/) [http://www.cs.york.ac.uk/fp/HaXml/]來對 XML 文件進行分析，以下代碼就是這個工具包的源碼： ~~~ -- file: ch22/PodParser.hs module PodParser where import PodTypes import Text.XML.HaXml import Text.XML.HaXml.Parse import Text.XML.HaXml.Html.Generate(showattr) import Data.Char import Data.List data PodItem = PodItem {itemtitle :: String, enclosureurl :: String } deriving (Eq, Show, Read) data Feed = Feed {channeltitle :: String, items :: [PodItem]} deriving (Eq, Show, Read) {- | 根據給定的廣播和 PodItem ，產生一個分集。 -} item2ep :: Podcast -> PodItem -> Episode item2ep pc item = Episode {epId = 0, epCast = pc, epURL = enclosureurl item, epDone = False} {- | 從給定的字符串里面分析出數據，給定的名字在有需要的時候會被用在錯誤消息里面。 -} parse :: String -> String -> Feed parse content name = Feed {channeltitle = getTitle doc, items = getEnclosures doc} where parseResult = xmlParse name (stripUnicodeBOM content) doc = getContent parseResult getContent :: Document -> Content getContent (Document _ _ e _) = CElem e {- | Some Unicode documents begin with a binary sequence; strip it off before processing. -} stripUnicodeBOM :: String -> String stripUnicodeBOM ('\xef':'\xbb':'\xbf':x) = x stripUnicodeBOM x = x {- | 從文檔里面提取出頻道部分（channel part）注意 HaXml 會將 CFilter 定義為： > type CFilter = Content -> [Content] -} channel :: CFilter channel = tag "rss" /> tag "channel" getTitle :: Content -> String getTitle doc = contentToStringDefault "Untitled Podcast" (channel /> tag "title" /> txt $ doc) getEnclosures :: Content -> [PodItem] getEnclosures doc = concatMap procPodItem $ getPodItems doc where procPodItem :: Content -> [PodItem] procPodItem item = concatMap (procEnclosure title) enclosure where title = contentToStringDefault "Untitled Episode" (keep /> tag "title" /> txt $ item) enclosure = (keep /> tag "enclosure") item getPodItems :: CFilter getPodItems = channel /> tag "item" procEnclosure :: String -> Content -> [PodItem] procEnclosure title enclosure = map makePodItem (showattr "url" enclosure) where makePodItem :: Content -> PodItem makePodItem x = PodItem {itemtitle = title, enclosureurl = contentToString [x]} {- | 將 [Content] 轉換為可打印的字符串，如果傳入的 [Content] 為 [] ，那么向用戶說明此次匹配未成功。 -} contentToStringDefault :: String -> [Content] -> String contentToStringDefault msg [] = msg contentToStringDefault _ x = contentToString x {- | 將 [Content] 轉換為可打印的字符串，并且小心地對它進行反解碼（unescape）。一個沒有反解碼實現的實現可以簡單地定義為： > contentToString = concatMap (show . content) 因為 HaXml 的反解碼操作只能對 Elements 使用，我們必須保證每個 Content 都被包裹為 Element ，然后使用 txt 函數去將 Element 內部的數據提取出來。 -} contentToString :: [Content] -> String contentToString = concatMap procContent where procContent x = verbatim $ keep /> txt $ CElem (unesc (fakeElem x)) fakeElem :: Content -> Element fakeElem x = Elem "fake" [] [x] unesc :: Element -> Element unesc = xmlUnEscape stdXmlEscaper ~~~ 讓我們好好看看這段代碼。它首先定義了兩種類型：PodItem 和 Feed 。程序會將 XML 文件轉換為 Feed ，而每個 Feed 可以包含多個 PodItem 。此外，程序還提供了一個函數，它可以將 PodItem 轉換為 PodTypes.hs 文件中定義的 Episode 。接下來，程序開始定義與語法分析有關的函數。parse 函數接受兩個參數，一個是 String 表示的 XML 文本，另一個則是用于展示錯誤信息的 String 表示的名字，這個函數也會返回一個 Feed 。 HaXml 被設計成一個將數據從一種類型轉換為另一種類型的“過濾器”，它是一個簡單直接的轉換操作，可以將 XML 轉換為 XML 、將 XML 轉換為 Haskell 數據、或者將 Haskell 數據轉換為 XML 。HaXml 擁有一種名為 CFilter 的數據類型，它的定義如下： ~~~ type CFilter = Content -> [Content] ~~~ 一個 CFilter 接受一個 XML 文檔片段（fragments），然后返回 0 個或多個片段。CFilter 可能會被要求找出指定標簽（tag）的所有子標簽、所有具有指定名字的標簽、XML 文檔某一部分包含的文本，又或者其他幾樣東西（a number of other things）。操作符 (/>) 可以將多個 CFilter 函數組合在一起。抓取器想要的是那些包圍在 <channel> 標簽里面的數據，所以我們首先要做的就是找出這些數據。以下是實現這一操作的一個簡單的 CFilter ： ~~~ channel = tag "rss" /> tag "channel" ~~~ 當我們將一個文檔傳遞給 channel 函數時，函數會從文檔的頂層（top level）查找名為 rss 的標簽。并在發現這些標簽之后，尋找 channel 標簽。余下的程序也會遵循這一基本方法進行。txt 函數會從標簽中提取出文本，然后通過使用 CFilter 函數，程序可以取得文檔的任意部分。 ## 下載構建抓取器的下一個步驟是完成用于下載數據的模塊。抓取器需要下載兩種不同類型的數據：它們分別是廣播的內容以及每個分集的音頻。對于前者，程序需要對數據進行語法分析并更新數據庫；而對于后者，程序則需要將數據寫入到文件里面并儲存到硬盤上。抓取器將通過 HTTP 服務器進行下載，所以我們需要使用一個 Haskell HTTP 庫。為了下載廣播源，抓取器需要下載文檔、對文檔進行語法分析并更新數據庫。對于分集音頻，程序會下載文件、將它寫入到硬盤并在數據庫里面將該分集標記為“已下載”。以下是執行這一工作的代碼： ~~~ -- file: ch22/PodDownload.hs module PodDownload where import PodTypes import PodDB import PodParser import Network.HTTP import System.IO import Database.HDBC import Data.Maybe import Network.URI {- | 下載 URL 。函數在發生錯誤時返回 (Left errorMessage) ；下載成功時返回 (Right doc) 。 -} downloadURL :: String -> IO (Either String String) downloadURL url = do resp <- simpleHTTP request case resp of Left x -> return $ Left ("Error connecting: " ++ show x) Right r -> case rspCode r of (2,_,_) -> return $ Right (rspBody r) (3,_,_) -> -- A HTTP redirect case findHeader HdrLocation r of Nothing -> return $ Left (show r) Just url -> downloadURL url _ -> return $ Left (show r) where request = Request {rqURI = uri, rqMethod = GET, rqHeaders = [], rqBody = ""} uri = fromJust $ parseURI url {- | 對數據庫中的廣播源進行更新。 -} updatePodcastFromFeed :: IConnection conn => conn -> Podcast -> IO () updatePodcastFromFeed dbh pc = do resp <- downloadURL (castURL pc) case resp of Left x -> putStrLn x Right doc -> updateDB doc where updateDB doc = do mapM_ (addEpisode dbh) episodes commit dbh where feed = parse doc (castURL pc) episodes = map (item2ep pc) (items feed) {- | 下載一個分集，并以 String 表示的形式，將儲存該分集的文件名返回給調用者。函數在發生錯誤時返回一個 Nothing 。 -} getEpisode :: IConnection conn => conn -> Episode -> IO (Maybe String) getEpisode dbh ep = do resp <- downloadURL (epURL ep) case resp of Left x -> do putStrLn x return Nothing Right doc -> do file <- openBinaryFile filename WriteMode hPutStr file doc hClose file updateEpisode dbh (ep {epDone = True}) commit dbh return (Just filename) -- This function ought to apply an extension based on the filetype where filename = "pod." ++ (show . castId . epCast $ ep) ++ "." ++ (show (epId ep)) ++ ".mp3" ~~~ 這個函數定義了三個函數： - downloadURL 函數對 URL 進行下載，并以 String 形式返回它； - updatePodcastFromFeed 函數對 XML 源文件進行下載，對文件進行分析，并更新數據庫； - getEpisode 下載一個給定的分集，并在數據庫里面將該分集標記為“已下載”。 Warning 這里使用的 HTTP 庫并不會以惰性的方式讀取 HTTP 結果，因此在下載諸如廣播這樣的大文件的時候，這個庫可能會消耗掉大量的內容。其他一些 HTTP 庫并沒有這一限制。我們之所以在這里使用這個有缺陷的庫，是因為它穩定、易于安裝并且也易于使用。對于正式的 HTTP 需要，我們推薦使用 mini-http 庫，這個庫可以從 Hackage 里面獲得。 ## 主程序最后，我們需要編寫一個程序來將上面展示的各個部分結合在一起。以下是這個主模塊（main module）： ~~~ -- file: ch22/PodMain.hs module Main where import PodDownload import PodDB import PodTypes import System.Environment import Database.HDBC import Network.Socket(withSocketsDo) main = withSocketsDo $ handleSqlError $ do args <- getArgs dbh <- connect "pod.db" case args of ["add", url] -> add dbh url ["update"] -> update dbh ["download"] -> download dbh ["fetch"] -> do update dbh download dbh _ -> syntaxError disconnect dbh add dbh url = do addPodcast dbh pc commit dbh where pc = Podcast {castId = 0, castURL = url} update dbh = do pclist <- getPodcasts dbh mapM_ procPodcast pclist where procPodcast pc = do putStrLn $ "Updating from " ++ (castURL pc) updatePodcastFromFeed dbh pc download dbh = do pclist <- getPodcasts dbh mapM_ procPodcast pclist where procPodcast pc = do putStrLn $ "Considering " ++ (castURL pc) episodelist <- getPodcastEpisodes dbh pc let dleps = filter (\ep -> epDone ep == False) episodelist mapM_ procEpisode dleps procEpisode ep = do putStrLn $ "Downloading " ++ (epURL ep) getEpisode dbh ep syntaxError = putStrLn "Usage: pod command [args]\n\ \\n\ \pod add url Adds a new podcast with the given URL\n\ \pod download Downloads all pending episodes\n\ \pod fetch Updates, then downloads\n\ \pod update Downloads podcast feeds, looks for new episodes\n" ~~~ 這個程序使用了一個非常簡單的命令行解釋器，并且這個解釋器還包含了一個用于展示命令行語法錯誤的函數，以及一些用于處理不同命令行參數的小函數。通過以下命令，可以對這個程序進行編譯： ~~~ ghc --make -O2 -o pod -package HTTP -package HaXml -package network \ -package HDBC -package HDBC-sqlite3 PodMain.hs ~~~ 你也可以通過《創建包》一節介紹的方法，使用 Cabal 文件來構建這個項目： ~~~ -- ch23/pod.cabal Name: pod Version: 1.0.0 Build-type: Simple Build-Depends: HTTP, HaXml, network, HDBC, HDBC-sqlite3, base Executable: pod Main-Is: PodMain.hs GHC-Options: -O2 ~~~ 除此之外，我們還需要一個簡單的 Setup.hs 文件： ~~~ import Distribution.Simple main = defaultMain ~~~ 如果你是使用 Cabal 進行構建的話，那么只要運行以下代碼即可： ~~~ runghc Setup.hs configure runghc Setup.hs build ~~~ 程序的輸出將被放到一個名為 dist 的文件及里面。要將程序安裝到系統里面的話，可以運行 runrunghcSetup.hsinstall 。