module Control.Shell.Download
( URI
, fetch, fetchBytes
, fetchFile
, fetchTags, fetchXML, fetchFeed
) where
import Data.ByteString as BS (ByteString, writeFile)
import Data.String
import Network.HTTP
import qualified Network.URI as U
import Text.Feed.Import (parseFeedString)
import Text.Feed.Types (Feed)
import Text.HTML.TagSoup (Tag, parseTags)
import Text.XML.Light (Content, parseXML)
import Control.Shell
type URI = String
liftE :: Show e => IO (Either e a) -> Shell a
liftE m = do
res <- liftIO m
case res of
Left e -> fail (show e)
Right x -> return x
httpFail :: (Int, Int, Int) -> String -> Shell a
httpFail (a,b,c) reason =
fail $ "HTTP error " ++ concat [show a, show b, show c] ++ ": " ++ reason
fetchSomething :: (IsString a, HStream a) => URI -> Shell a
fetchSomething uri = do
u <- assert ("could not parse URI `" ++ uri ++ "'") (U.parseURI uri)
rsp <- liftE $ simpleHTTP (req u)
case rspCode rsp of
(2,_,_) -> return (rspBody rsp)
code -> httpFail code (rspReason rsp)
where
req u = Request {
rqURI = u,
rqMethod = GET,
rqHeaders = [],
rqBody = ""
}
fetchBytes :: URI -> Shell ByteString
fetchBytes = fetchSomething
fetch :: URI -> Shell String
fetch = fetchSomething
fetchFile :: FilePath -> URI -> Shell ()
fetchFile file = fetchBytes >=> liftIO . BS.writeFile file
fetchTags :: URI -> Shell [Tag String]
fetchTags = fmap parseTags . fetch
fetchXML :: URI -> Shell [Content]
fetchXML = fmap parseXML . fetch
fetchFeed :: URI -> Shell Feed
fetchFeed uri = do
str <- fetch uri
assert ("could not parse feed from `" ++ uri ++ "'") (parseFeedString str)