第二十二章：擴(kuò)展示例 —— Web 客戶端編程
第二十二章：擴(kuò)展示例 —— Web 客戶端編程
到目前為止，我們已經(jīng)了解過(guò)如何與數(shù)據(jù)庫(kù)進(jìn)行交互、如何進(jìn)行語(yǔ)法分析（parse）以及如何處理錯(cuò)誤。接下來(lái)，讓我們更進(jìn)一步，通過(guò)引入一個(gè) web 客戶端庫(kù)來(lái)將這些知識(shí)結(jié)合在一起。
在這一章，我們將要構(gòu)建一個(gè)實(shí)際的程序：一個(gè)播客下載器（podcast downloader），或者叫“播客抓取器”（podcatcher）。這個(gè)博客抓取器的概念非常簡(jiǎn)單，它接受一系列 URL 作為輸入，通過(guò)下載這些 URL 來(lái)得到一些 RSS 格式的 XML 文件，然后在這些 XML 文件里面找到下載音頻文件所需的 URL 。
播客抓取器常常會(huì)讓用戶通過(guò)將 RSS URL 添加到配置文件里面的方法來(lái)訂閱播客，之后用戶就可以定期地進(jìn)行更新操作：播客抓取器會(huì)下載 RSS 文檔，對(duì)它們進(jìn)行檢查以尋找音頻文件的下載鏈接，并為用戶下載所有目前尚未存在的音頻文件。
Tip
用戶通常將 RSS 文件稱之為“廣播”（podcast）或是“廣播源”（podcast feed），而每個(gè)單獨(dú)的音頻文件則是播客的其中一集（episode）。
為了實(shí)現(xiàn)具有類似功能的播客抓取器，我們需要以下幾樣?xùn)|西：
- 一個(gè)用于下載文件的 HTTP 客戶端庫(kù)；
- 一個(gè) XML 分析器；
- 一種能夠記錄我們感興趣的廣播，并將這些記錄永久地儲(chǔ)存起來(lái)的方法；
- 一種能夠永久地記錄已下載廣播分集（episodes）的方法。
這個(gè)列表的后兩樣可以通過(guò)使用 HDBC 設(shè)置的數(shù)據(jù)庫(kù)來(lái)完成，而前兩樣則可以通過(guò)本章介紹的其他庫(kù)模塊來(lái)完成。
Tip
本章的代碼是專為本書(shū)而寫(xiě)的，但這些代碼實(shí)際上是基于 hpodder —— 一個(gè)使用 Haskell 編寫(xiě)的播客抓取器來(lái)編寫(xiě)的。hpodder 擁有的特性比本書(shū)展示的播客抓取器要多得多，因此本書(shū)不太可能詳細(xì)地對(duì)它進(jìn)行介紹。如果讀者對(duì) hpodder 感興趣的話，可以在 http://software.complete.org/hpodder 找到 hpodder 的源代碼。
本章的所有代碼都是以自成一體的方式來(lái)編寫(xiě)的，每段代碼都是一個(gè)獨(dú)立的 Haskell 模塊，讀者可以通過(guò) ghci 獨(dú)立地運(yùn)行這些模塊。本章的最后會(huì)寫(xiě)出一段代碼，將這些模塊全部結(jié)合起來(lái)，構(gòu)成一個(gè)完整的程序。我們首先要做的就是寫(xiě)出構(gòu)建博客抓取器需要用到的基本類型。
基本類型
為了構(gòu)建播客抓取器，我們首先需要思考抓取器需要引入（important）的基本信息有那些。一般來(lái)說(shuō)，抓取器關(guān)心的都是記錄用戶感興趣的博客的信息，以及那些記錄了用戶已經(jīng)看過(guò)和處理過(guò)的分集的信息。在有需要的時(shí)候改變這些信息并不困難，但是因?yàn)槲覀冊(cè)谡麄€(gè)抓取器里面都要用到這些信息，所以我們最好還是先定義它們：
-- file: ch22/PodTypes.hs
module PodTypes where
data Podcast =
Podcast {castId :: Integer, -- ^ 這個(gè)播客的數(shù)字 ID
castURL :: String -- ^ 這個(gè)播客的源 URL
}
deriving (Eq, Show, Read)
data Episode =
Episode {epId :: Integer, -- ^ 這個(gè)分集的數(shù)字 ID
epCast :: Podcast, -- ^ 這個(gè)分集所屬播客的 ID
epURL :: String, -- ^ 下載這一集所使用的 URL
epDone :: Bool -- ^ 記錄用戶是否已經(jīng)看過(guò)這一集
}
deriving (Eq, Show, Read)
這些信息將被儲(chǔ)存到數(shù)據(jù)庫(kù)里面。通過(guò)為每個(gè)播客和博客的每一集都創(chuàng)建一個(gè)獨(dú)一無(wú)二的 ID ，程序可以更容易找到分集所屬的播客，也可以更容易地從一個(gè)特定的播客或者分集里面載入信息，并且更好地應(yīng)對(duì)將來(lái)可能會(huì)出現(xiàn)的“博客 URL 改變”這類情況。
數(shù)據(jù)庫(kù)
接下來(lái)，我們需要編寫(xiě)代碼，以便將信息永久地儲(chǔ)存到數(shù)據(jù)庫(kù)里面。我們最感興趣的，就是通過(guò)數(shù)據(jù)庫(kù)，將 PodTypes.hs 文件定義的 Haskell 結(jié)構(gòu)中的數(shù)據(jù)儲(chǔ)存到硬盤(pán)里面。并在用戶首次運(yùn)行程序的時(shí)候，創(chuàng)建儲(chǔ)存數(shù)據(jù)所需的數(shù)據(jù)庫(kù)表。
我們將使用 21 章介紹過(guò)的 HDBC 與 Sqlite 數(shù)據(jù)庫(kù)進(jìn)行交互。Sqlite 非常輕量，并且是自包含的（self-contained），因此它對(duì)于這個(gè)小項(xiàng)目來(lái)說(shuō)簡(jiǎn)直是再合適不過(guò)了。HDBC 和 Sqlite 的安裝方法可以在 21 章的《安裝 HDBC 和驅(qū)動(dòng)》一節(jié)看到。
-- 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
{- | 對(duì)數(shù)據(jù)庫(kù)進(jìn)行設(shè)置，做好儲(chǔ)存數(shù)據(jù)的準(zhǔn)備。
這個(gè)程序會(huì)創(chuàng)建兩個(gè)表，并要求數(shù)據(jù)庫(kù)引擎為我們檢查某些數(shù)據(jù)的一致性：
* castid 和 epid 都是獨(dú)一無(wú)二的主鍵（unique primary keys），它們的值不能重復(fù)
* castURL 的值也應(yīng)該是獨(dú)一無(wú)二的
* 在記錄分集的表里面，對(duì)于一個(gè)給定的播客（epcast)，每個(gè)給定的 URL 或者分集 ID 只能出現(xiàn)一次
-}
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
{- | 將一個(gè)新的播客添加到數(shù)據(jù)庫(kù)里面。
在創(chuàng)建播客時(shí)忽略播客的 castid ，并返回一個(gè)包含了 castid 的新對(duì)象。
嘗試添加一個(gè)已經(jīng)存在的播客將引發(fā)一個(gè)錯(cuò)誤。 -}
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
{- | 將一個(gè)新的分集添加到數(shù)據(jù)庫(kù)里面。
因?yàn)檫@一操作是自動(dòng)執(zhí)行而非用戶請(qǐng)求執(zhí)行的，我們將簡(jiǎn)單地忽略創(chuàng)建重復(fù)分集的請(qǐng)求。
這樣的話，在對(duì)播客源進(jìn)行處理的時(shí)候，我們就可以把遇到的所有 URL 到傳給這個(gè)函數(shù)，
而不必先檢查這個(gè) URL 是否已經(jīng)存在于數(shù)據(jù)庫(kù)當(dāng)中。
這個(gè)函數(shù)在創(chuàng)建新的分集時(shí)同樣不會(huì)考慮如何創(chuàng)建新的 ID ，
因此它也沒(méi)有必要去考慮如何去獲取這個(gè) 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 ()
{- | 對(duì)一個(gè)已經(jīng)存在的播客進(jìn)行修改。
根據(jù) ID 來(lái)查找指定的播客，并根據(jù)傳入的 Podcast 結(jié)構(gòu)對(duì)數(shù)據(jù)庫(kù)記錄進(jìn)行修改。 -}
updatePodcast :: IConnection conn => conn -> Podcast -> IO ()
updatePodcast dbh podcast =
run dbh "UPDATE podcasts SET castURL = ? WHERE castId = ?"
[toSql (castURL podcast), toSql (castId podcast)]
>> return ()
{- | 對(duì)一個(gè)已經(jīng)存在的分集進(jìn)行修改。
根據(jù) ID 來(lái)查找指定的分集，并根據(jù)傳入的 episode 結(jié)構(gòu)對(duì)數(shù)據(jù)庫(kù)記錄進(jìn)行修改。 -}
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 ()
{- | 移除一個(gè)播客。 這個(gè)操作在執(zhí)行之前會(huì)先移除這個(gè)播客已有的所有分集。 -}
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 ()
{- | 獲取一個(gè)包含所有播客的列表。 -}
getPodcasts :: IConnection conn => conn -> IO [Podcast]
getPodcasts dbh =
do res <- quickQuery' dbh
"SELECT castid, casturl FROM podcasts ORDER BY castid" []
return (map convPodcastRow res)
{- | 獲取特定的廣播。
函數(shù)在成功執(zhí)行時(shí)返回 Just Podcast ；在 ID 不匹配時(shí)返回 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 語(yǔ)句的執(zhí)行結(jié)果轉(zhuǎn)換為 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 模塊定義了連接數(shù)據(jù)庫(kù)的函數(shù)、創(chuàng)建所需數(shù)據(jù)庫(kù)表的函數(shù)、將數(shù)據(jù)添加到數(shù)據(jù)庫(kù)里面的函數(shù)、查詢數(shù)據(jù)庫(kù)的函數(shù)以及從數(shù)據(jù)庫(kù)里面移除數(shù)據(jù)的函數(shù)。以下代碼展示了一個(gè)與數(shù)據(jù)庫(kù)進(jìn)行交互的 ghci 會(huì)話，這個(gè)會(huì)話將在當(dāng)前目錄里面創(chuàng)建一個(gè)名為 poddbtest.db 的數(shù)據(jù)庫(kù)文件，并將廣播和分集添加到這個(gè)文件里面。
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
分析器
在實(shí)現(xiàn)了抓取器的數(shù)據(jù)庫(kù)部分之后，我們接下來(lái)就需要實(shí)現(xiàn)抓取器中負(fù)責(zé)對(duì)廣播源進(jìn)行語(yǔ)法分析的部分，這個(gè)部分要分析的是一些包含著多種信息的 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>
在這些文件里面，我們最關(guān)心的是兩樣?xùn)|西：廣播的標(biāo)題以及它們的附件（enclosure） URL 。我們將使用 HaXml 工具包 [http://www.cs.york.ac.uk/fp/HaXml/]來(lái)對(duì) XML 文件進(jìn)行分析，以下代碼就是這個(gè)工具包的源碼：
-- 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)
{- | 根據(jù)給定的廣播和 PodItem ，產(chǎn)生一個(gè)分集。 -}
item2ep :: Podcast -> PodItem -> Episode
item2ep pc item =
Episode {epId = 0,
epCast = pc,
epURL = enclosureurl item,
epDone = False}
{- | 從給定的字符串里面分析出數(shù)據(jù)，給定的名字在有需要的時(shí)候會(huì)被用在錯(cuò)誤消息里面。 -}
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 會(huì)將 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] 轉(zhuǎn)換為可打印的字符串，
如果傳入的 [Content] 為 [] ，那么向用戶說(shuō)明此次匹配未成功。 -}
contentToStringDefault :: String -> [Content] -> String
contentToStringDefault msg [] = msg
contentToStringDefault _ x = contentToString x
{- | 將 [Content] 轉(zhuǎn)換為可打印的字符串，并且小心地對(duì)它進(jìn)行反解碼（unescape）。
一個(gè)沒(méi)有反解碼實(shí)現(xiàn)的實(shí)現(xiàn)可以簡(jiǎn)單地定義為：
> contentToString = concatMap (show . content)
因?yàn)?HaXml 的反解碼操作只能對(duì) Elements 使用，
我們必須保證每個(gè) Content 都被包裹為 Element ，
然后使用 txt 函數(shù)去將 Element 內(nèi)部的數(shù)據(jù)提取出來(lái)。 -}
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 。程序會(huì)將 XML 文件轉(zhuǎn)換為 Feed ，而每個(gè) Feed 可以包含多個(gè) PodItem 。此外，程序還提供了一個(gè)函數(shù)，它可以將 PodItem 轉(zhuǎn)換為 PodTypes.hs 文件中定義的 Episode 。
接下來(lái)，程序開(kāi)始定義與語(yǔ)法分析有關(guān)的函數(shù)。parse 函數(shù)接受兩個(gè)參數(shù)，一個(gè)是 String 表示的 XML 文本，另一個(gè)則是用于展示錯(cuò)誤信息的 String 表示的名字，這個(gè)函數(shù)也會(huì)返回一個(gè) Feed 。
HaXml 被設(shè)計(jì)成一個(gè)將數(shù)據(jù)從一種類型轉(zhuǎn)換為另一種類型的“過(guò)濾器”，它是一個(gè)簡(jiǎn)單直接的轉(zhuǎn)換操作，可以將 XML 轉(zhuǎn)換為 XML 、將 XML 轉(zhuǎn)換為 Haskell 數(shù)據(jù)、或者將 Haskell 數(shù)據(jù)轉(zhuǎn)換為 XML 。HaXml 擁有一種名為 CFilter 的數(shù)據(jù)類型，它的定義如下：
type CFilter = Content -> [Content]
一個(gè) CFilter 接受一個(gè) XML 文檔片段（fragments），然后返回 0 個(gè)或多個(gè)片段。CFilter 可能會(huì)被要求找出指定標(biāo)簽（tag）的所有子標(biāo)簽、所有具有指定名字的標(biāo)簽、XML 文檔某一部分包含的文本，又或者其他幾樣?xùn)|西（a number of other things）。操作符 (/>) 可以將多個(gè) CFilter 函數(shù)組合在一起。抓取器想要的是那些包圍在 標(biāo)簽里面的數(shù)據(jù)，所以我們首先要做的就是找出這些數(shù)據(jù)。以下是實(shí)現(xiàn)這一操作的一個(gè)簡(jiǎn)單的 CFilter ：
channel = tag "rss" /> tag "channel"
當(dāng)我們將一個(gè)文檔傳遞給 channel 函數(shù)時(shí)，函數(shù)會(huì)從文檔的頂層（top level）查找名為 rss 的標(biāo)簽。并在發(fā)現(xiàn)這些標(biāo)簽之后，尋找 channel 標(biāo)簽。
余下的程序也會(huì)遵循這一基本方法進(jìn)行。txt 函數(shù)會(huì)從標(biāo)簽中提取出文本，然后通過(guò)使用 CFilter 函數(shù)，程序可以取得文檔的任意部分。
下載
構(gòu)建抓取器的下一個(gè)步驟是完成用于下載數(shù)據(jù)的模塊。抓取器需要下載兩種不同類型的數(shù)據(jù)：它們分別是廣播的內(nèi)容以及每個(gè)分集的音頻。對(duì)于前者，程序需要對(duì)數(shù)據(jù)進(jìn)行語(yǔ)法分析并更新數(shù)據(jù)庫(kù)；而對(duì)于后者，程序則需要將數(shù)據(jù)寫(xiě)入到文件里面并儲(chǔ)存到硬盤(pán)上。
抓取器將通過(guò) HTTP 服務(wù)器進(jìn)行下載，所以我們需要使用一個(gè) Haskell HTTP 庫(kù)。為了下載廣播源，抓取器需要下載文檔、對(duì)文檔進(jìn)行語(yǔ)法分析并更新數(shù)據(jù)庫(kù)。對(duì)于分集音頻，程序會(huì)下載文件、將它寫(xiě)入到硬盤(pán)并在數(shù)據(jù)庫(kù)里面將該分集標(biāo)記為“已下載”。以下是執(zhí)行這一工作的代碼：
-- 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 。
函數(shù)在發(fā)生錯(cuò)誤時(shí)返回 (Left errorMessage) ；
下載成功時(shí)返回 (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
{- | 對(duì)數(shù)據(jù)庫(kù)中的廣播源進(jìn)行更新。 -}
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)
{- | 下載一個(gè)分集，并以 String 表示的形式，將儲(chǔ)存該分集的文件名返回給調(diào)用者。
函數(shù)在發(fā)生錯(cuò)誤時(shí)返回一個(gè) 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"
這個(gè)函數(shù)定義了三個(gè)函數(shù)：
- downloadURL 函數(shù)對(duì) URL 進(jìn)行下載，并以 String 形式返回它；
- updatePodcastFromFeed 函數(shù)對(duì) XML 源文件進(jìn)行下載，對(duì)文件進(jìn)行分析，并更新數(shù)據(jù)庫(kù)；
- getEpisode 下載一個(gè)給定的分集，并在數(shù)據(jù)庫(kù)里面將該分集標(biāo)記為“已下載”。
Warning
這里使用的 HTTP 庫(kù)并不會(huì)以惰性的方式讀取 HTTP 結(jié)果，因此在下載諸如廣播這樣的大文件的時(shí)候，這個(gè)庫(kù)可能會(huì)消耗掉大量的內(nèi)容。其他一些 HTTP 庫(kù)并沒(méi)有這一限制。我們之所以在這里使用這個(gè)有缺陷的庫(kù)，是因?yàn)樗€(wěn)定、易于安裝并且也易于使用。對(duì)于正式的 HTTP 需要，我們推薦使用 mini-http 庫(kù)，這個(gè)庫(kù)可以從 Hackage 里面獲得。
主程序
最后，我們需要編寫(xiě)一個(gè)程序來(lái)將上面展示的各個(gè)部分結(jié)合在一起。以下是這個(gè)主模塊（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"
這個(gè)程序使用了一個(gè)非常簡(jiǎn)單的命令行解釋器，并且這個(gè)解釋器還包含了一個(gè)用于展示命令行語(yǔ)法錯(cuò)誤的函數(shù)，以及一些用于處理不同命令行參數(shù)的小函數(shù)。
通過(guò)以下命令，可以對(duì)這個(gè)程序進(jìn)行編譯：
ghc --make -O2 -o pod -package HTTP -package HaXml -package network \
-package HDBC -package HDBC-sqlite3 PodMain.hs
你也可以通過(guò)《創(chuàng)建包》一節(jié)介紹的方法，使用 Cabal 文件來(lái)構(gòu)建這個(gè)項(xiàng)目：
-- 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
除此之外，我們還需要一個(gè)簡(jiǎn)單的 Setup.hs 文件：
import Distribution.Simple
main = defaultMain
如果你是使用 Cabal 進(jìn)行構(gòu)建的話，那么只要運(yùn)行以下代碼即可：
runghc Setup.hs configure
runghc Setup.hs build
程序的輸出將被放到一個(gè)名為 dist 的文件及里面。要將程序安裝到系統(tǒng)里面的話，可以運(yùn)行 runrunghcSetup.hsinstall 。
更多建議：