1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
diff -rupN ch23/PodDownload.hs new-ch23/PodDownload.hs
--- ch23/PodDownload.hs 2025-09-14 15:33:15.647379522 +0200
+++ new-ch23/PodDownload.hs 2025-09-14 15:41:54.129935197 +0200
@@ -3,32 +3,35 @@ module PodDownload where
import PodTypes
import PodDB
import PodParser
-import Network.HTTP
+import Network.HTTP.Conduit
+import Network.HTTP.Types.Method
+import Network.HTTP.Types.Status
import System.IO
import Database.HDBC
import Data.Maybe
import Network.URI
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LTE
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.ByteString.Lazy as LBS
+
{- | Download a URL. (Left errorMessage) if an error,
(Right doc) if success. -}
-downloadURL :: String -> IO (Either String String)
+downloadURL :: String -> IO (Either String LBS.ByteString)
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
+ do initReq <- parseRequest url
+ let request = initReq { method = methodGet }
+ manager <- newManager tlsManagerSettings
+ resp <- httpLbs request manager
+ let status = responseStatus resp
+ -- httpLbs follows redirections (up to the limit specified in the
+ -- request, default is 10). No need to handle redirections explicitly
+ -- here.
+ if statusIsSuccessful status
+ then return $ Right $ responseBody resp
+ else return $ Left $ T.unpack $ TE.decodeUtf8 $ statusMessage status
{- | Update the podcast in the database. -}
updatePodcastFromFeed :: IConnection conn => conn -> Podcast -> IO ()
@@ -36,7 +39,7 @@ updatePodcastFromFeed dbh pc =
do resp <- downloadURL (castURL pc)
case resp of
Left x -> putStrLn x
- Right doc -> updateDB doc
+ Right doc -> updateDB $ LT.unpack $ LTE.decodeUtf8 $ doc
where updateDB doc =
do mapM_ (addEpisode dbh) episodes
@@ -53,9 +56,7 @@ getEpisode dbh ep =
Left x -> do putStrLn x
return Nothing
Right doc ->
- do file <- openBinaryFile filename WriteMode
- hPutStr file doc
- hClose file
+ do LBS.writeFile filename doc
updateEpisode dbh (ep {epDone = True})
commit dbh
return (Just filename)
|
