diff options
| author | Jan Sucan <jan@jansucan.com> | 2025-09-12 09:10:37 +0200 |
|---|---|---|
| committer | Jan Sucan <jan@jansucan.com> | 2025-09-12 09:10:37 +0200 |
| commit | 305837683782841b0d93dabc61e7e6e19df220b4 (patch) | |
| tree | a93a7e17dad1f278d56405ebc6b067d22ee61187 /ch23/23_a_1/PodDownload.hs | |
| parent | a5aafff8df0a00482d60ce98d891a4e1dd360d79 (diff) | |
23_a_1: Copy code of ch23 from the examples
Diffstat (limited to 'ch23/23_a_1/PodDownload.hs')
| -rw-r--r-- | ch23/23_a_1/PodDownload.hs | 65 |
1 files changed, 65 insertions, 0 deletions
diff --git a/ch23/23_a_1/PodDownload.hs b/ch23/23_a_1/PodDownload.hs new file mode 100644 index 0000000..84e6ab7 --- /dev/null +++ b/ch23/23_a_1/PodDownload.hs @@ -0,0 +1,65 @@ +{-- snippet all --}
+module PodDownload where
+import PodTypes
+import PodDB
+import PodParser
+import Network.HTTP
+import System.IO
+import Database.HDBC
+import Data.Maybe
+import Network.URI
+
+{- | Download a URL. (Left errorMessage) if an error,
+(Right doc) if success. -}
+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
+
+{- | Update the podcast in the database. -}
+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)
+
+{- | Downloads an episode, returning a String representing
+the filename it was placed into, or Nothing on error. -}
+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"
+{-- /snippet all --}
|