Browse files

Starting Download.hs in prep for build

  • Loading branch information...
1 parent 5bf36ff commit 2deb3c948f15764b408d621e3c0cdc21dbeb7c4e @jgoerzen committed Sep 10, 2008
Showing with 17 additions and 119 deletions.
  1. +15 −89 Download.hs
  2. +1 −1 Makefile
  3. +1 −29 TODO
View
104 Download.hs
@@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
{- |
Module : Download
- Copyright : Copyright (C) 2006-2007 John Goerzen
+ Copyright : Copyright (C) 2006-2008 John Goerzen
License : GNU GPL, version 2 or above
Maintainer : John Goerzen <jgoerzen@complete.org>
@@ -36,30 +36,14 @@ import System.Posix.Process
import Config
import System.Log.Logger
import Text.Printf
-import System.Exit
-import System.Directory
-import System.Posix.Files
-import System.Posix.Process
-import System.Posix.Types
-import System.Posix.IO
-import Data.Hash.MD5
-import Control.Exception(evaluate)
-
-data Result = Success | Failure
- deriving (Eq, Show, Read)
-
-data DownloadTok =
- DownloadTok {tokpid :: ProcessID,
- tokurl :: String,
- tokpath :: FilePath,
- tokstartsize :: Maybe FileOffset}
- deriving (Eq, Show, Ord)
+import Data.ConfigParser
+import HSH
d = debugM "download"
i = infoM "download"
curl = "curl"
-curlopts = ["-A", "hpodder v1.0.0; Haskell; GHC", -- Set User-Agent
+curlopts = ["-A", "twidge v1.0.0; Haskell; GHC", -- Set User-Agent
"-s", -- Silent mode
"-S", -- Still show error messages
"-L", -- Follow redirects
@@ -68,72 +52,14 @@ curlopts = ["-A", "hpodder v1.0.0; Haskell; GHC", -- Set User-Agent
"-f" -- Fail on server errors
]
-getCurlConfig :: IO String
-getCurlConfig =
- do ad <- getAppDir
- return $ ad ++ "/curlrc"
-
-getsize fp = catch (getFileStatus fp >>= (return . Just . fileSize))
- (\_ -> return Nothing)
-
-{- | Begin the download process on the given URL.
-
-Once it has finished, pass the returned token to finishGetURL. -}
-startGetURL :: String -- ^ URL to download
- -> FilePath -- ^ Directory into which to put downloaded file
- -> Bool -- ^ Whether to allow resuming
- -> IO DownloadTok -- ^ Result including path to which the file is being downloaded
-startGetURL url dirbase allowresume =
- do curlrc <- getCurlConfig
- havecurlrc <- doesFileExist curlrc
- let curlrcopts = (if havecurlrc then ["-K", curlrc] else [])
- ++ (if allowresume then ["-C", "-"] else [])
- let fp = dirbase ++ "/" ++ getdlfname url
- startsize <- getsize fp
- case startsize of
- Just x -> d $ printf "Resuming download of %s at %s" fp (show x)
- Nothing -> d $ printf "Beginning download of %s" fp
-
- msgfd <- openFd (fp ++ ".msg") WriteOnly (Just 0o600)
- (defaultFileFlags {trunc = True})
- msgfd2 <- dup msgfd
- pid <- pOpen3Raw Nothing (Just msgfd) (Just msgfd2)
- curl (curlopts ++ curlrcopts ++ [url, "-o", fp])
- (return ())
- closeFd msgfd
- closeFd msgfd2
- return $ DownloadTok pid url fp startsize
-
-getdlfname url = md5s (Str url)
-{- | Checks to see how much has been downloaded on the given file. Also works
-after download is complete to get the final size. Returns Nothing if the
-file doesn't exist. -}
-checkDownloadSize :: DownloadTok -> IO (Maybe FileOffset)
-checkDownloadSize dltok = getsize (tokpath dltok)
-
-finishGetURL :: DownloadTok -> ProcessStatus -> IO Result
-finishGetURL dltok ec =
- do newsize <- getsize (tokpath dltok)
- let r = case ec of
- Exited ExitSuccess -> Success
- Exited (ExitFailure i) -> Failure
- Terminated _ -> Failure
- Stopped _ -> Failure
- if r == Success
- then do d $ "curl returned successfully; new size is " ++
- (show newsize)
- if (tokstartsize dltok /= Nothing) &&
- (newsize == tokstartsize dltok)
- -- compensate for resumes that failed
- then do i $ "Attempt to resume download failed; will re-try download on next run"
- removeFile (tokpath dltok)
- --getURL url fp
- return Failure
- else if newsize == Nothing
- -- Sometimes Curl returns success but doesn't
- -- actually download anything
- then return Failure
- else return r
- else do d $ "curl returned error; new size is " ++ (show newsize)
- return r
-
+sendAuthRequest :: ConfigParser -> String -> IO String
+sendAuthRequst cp url =
+ do authopts <- getAuthOpts
+ run $ (curl, curlopts ++ authopts ++ url)
+
+getAuthOpts :: ConfigParser -> [String]
+getAuthOpts =
+ case (get cp "DEFAULT" "username", get cp "DEFAULT" "password") of
+ (Right user, Right pass) ->
+ ["--user", user ++ ":" ++ pass]
+ _ -> error "Missing username or password section in config file"
View
2 Makefile
@@ -12,7 +12,7 @@ hugsbuild: setup
./setup configure --hugs
./setup build
-setup: Setup.lhs hpodder.cabal
+setup: Setup.lhs twidge.cabal
ghc -package Cabal Setup.lhs -o setup
clean: clean-code clean-doc
View
30 TODO
@@ -1,29 +1 @@
-posthook stuff
-
-New stuff:
- -- Don't say B/s for feeds
-
- -- Two line Get display in download, something like:
-
- Get: 99.177 Episode Title
- From Podcast Title
-
-
- or
-
- Get 99: Podcast Title
- Episode 177: Episode Title
-
- -- Option to force two numbers to be rendered on the same
- scale, and to drop the suffix from the first
-
-catchup -- what if some are already pending?
-
-document sqlite3 stuff
-
-OPML import
-
-nicer display
- -- libcurl?
-
-set id3 before rename
+support for more secure curl stuff (netrc)

0 comments on commit 2deb3c9

Please sign in to comment.