diff --git a/Commands.hs b/Commands.hs new file mode 100644 --- /dev/null +++ b/Commands.hs @@ -0,0 +1,102 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Commands + Copyright : Copyright (C) 2006 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} +module Commands where + +import Data.List +import Text.Printf +import Utils +import Types +import Config +import Data.ConfigFile +import Data.Either.Utils + +import qualified Commands.Add +import qualified Commands.Ls +import qualified Commands.Update +import qualified Commands.Download +import qualified Commands.Setup +import qualified Commands.Catchup +import qualified Commands.ImportIpodder +import qualified Commands.Rm +import qualified Commands.SetStatus +import qualified Commands.SetTitle +import qualified Commands.EnableDisable + +--allCommands :: [(String, Command)] +allCommands = + [Commands.Add.cmd, + Commands.Catchup.cmd, + Commands.EnableDisable.cmd_disable, + Commands.Download.cmd, + Commands.EnableDisable.cmd_enable, + fetch, + Commands.ImportIpodder.cmd, + Commands.Ls.lscasts, + lscommands, + Commands.Ls.lsepisodes, + Commands.Ls.lseps, + Commands.Rm.cmd, + Commands.SetStatus.cmd, + Commands.SetTitle.cmd, + Commands.Update.cmd] + +lscommands = + simpleCmd "lscommands" "Display a list of all available commands" "" + [] lscommands_worker + +lscommands_worker _ _ = + do putStrLn "All available commands:" + printf "%-20s %s\n" "Name" "Description" + putStrLn "-------------------- -------------------------------------------------------" + mapM_ (\(_, x) -> printf "%-20s %s\n" (cmdname x) (cmddescrip x)) + allCommands + + +fetch = + simpleCmd "fetch" "Scan feeds, then download new episodes" fetch_help + [] fetch_worker + +fetch_worker gi ([], casts) = + do cp <- loadCP + let showintro = forceEither $ get cp "general" "showintro" + if showintro + then Commands.Setup.cmd_worker gi ([], []) + else do Commands.Update.cmd_worker gi ([], casts) + Commands.Download.cmd_worker gi ([], casts) + +fetch_worker _ _ = + fail $ "Invalid arguments to fetch; please see hpodder fetch --help" + +fetch_help = "Usage: hpodder fetch [castid [castid...]]\n\n" ++ + genericIdHelp ++ + "\nThe fetch command will cause hpodder to scan all feeds (as with\n\ + \\"hpodder update\") and then download all new episodes (as with\n\ + \\"hpodder download\").\n" diff --git a/Commands/Add.hs b/Commands/Add.hs new file mode 100644 --- /dev/null +++ b/Commands/Add.hs @@ -0,0 +1,48 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.Add(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Types +import Database.HDBC +import Text.Printf + +i = infoM "add" + +cmd = simpleCmd "add" + "Add a new podcast" helptext + [] cmd_worker + +cmd_worker gi (_, [url]) = + do pc <- addPodcast (gdbh gi) (Podcast {castid = 0, + castname = "", + feedurl = url, + lastupdate = Nothing, + pcenabled = PCEnabled, + lastattempt = Nothing, + failedattempts = 0}) + commit (gdbh gi) + printf "Podcast added:\n URL: %s\n ID: %d\n" url (castid pc) + +cmd_worker _ _ = + do fail "Feed URL required; see hpodder add --help for info" + +helptext = + "Usage: hpodder add feedurl" diff --git a/Commands/Catchup.hs b/Commands/Catchup.hs new file mode 100644 --- /dev/null +++ b/Commands/Catchup.hs @@ -0,0 +1,70 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.Catchup(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Monad +import Utils +import System.Console.GetOpt +import System.Console.GetOpt.Utils + +i = infoM "catchup" +w = warningM "catchup" + +cmd = simpleCmd "catchup" + "Tell hpodder to ignore old undownloaded episodes" helptext + [Option "n" ["number-eps"] (ReqArg (stdRequired "n") "NUM") + "Number of episodes to allow to download (default 1)"] + cmd_worker + +cmd_worker gi (args, casts) = lock $ + do podcastlist <- getSelectedPodcasts (gdbh gi) casts + let n = case lookup "n" args of + Nothing -> 1 + Just y -> read y + i $ printf "%d podcast(s) to consider\n" (length podcastlist) + mapM_ (catchupThePodcast gi n) podcastlist + +catchupThePodcast gi n pc = + do i $ printf " * Podcast %d: %s" (castid pc) (feedurl pc) + eps <- getEpisodes (gdbh gi) pc + let epstoproc = take (length eps - n) eps + mapM procEp epstoproc + commit (gdbh gi) + where procEp ep = + updateEpisode (gdbh gi) (ep {epstatus = newstatus}) + where newstatus = + case epstatus ep of + Pending -> Skipped + Error -> Skipped + x -> x + + +helptext = "Usage: hpodder catchup [-n x] [castid ...]\n\n" ++ + genericIdHelp ++ + "\nRunning catchup will cause hpodder to mark all but the n most recent\n\ + \episodes as Skipped. This will prevent hpodder from automatically\n\ + \downloading such episodes. You can specify the value for n with -n.\n" diff --git a/Commands/Download.hs b/Commands/Download.hs new file mode 100644 --- /dev/null +++ b/Commands/Download.hs @@ -0,0 +1,289 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.Download(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import DownloadQueue +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Monad hiding(forM_) +import Utils +import Data.Hash.MD5 +import System.FilePath +import System.IO +import System.Directory +import System.Cmd.Utils +import System.Posix.Process +import Data.ConfigFile +import Data.String +import Data.Either.Utils +import Data.List +import System.Exit +import Control.Exception +import Data.Progress.Tracker +import Data.Progress.Meter +import Control.Concurrent.MVar +import Control.Concurrent +import Data.Foldable(forM_) +import Network.URI(unEscapeString) +import System.Posix.IO( + OpenMode(..), + closeFd, + defaultFileFlags, + dupTo, + openFd, + stdOutput + ) + +d = debugM "download" +i = infoM "download" +w = warningM "download" + +cmd = simpleCmd "download" + "Downloads all pending podcast episodes (run update first)" helptext + [] cmd_worker + +cmd_worker gi ([], casts) = lock $ + do podcastlist_raw <- getSelectedPodcasts (gdbh gi) casts + let podcastlist = filter_disabled podcastlist_raw + episodelist <- mapM (getEpisodes (gdbh gi)) podcastlist + let episodes = filter (\x -> epstatus x == Pending) . concat $ episodelist + + -- Now force the DB to be read so that we don't maintain a lock + evaluate (length episodes) + i $ printf "%d episode(s) to consider from %d podcast(s)" + (length episodes) (length podcastlist) + downloadEpisodes gi episodes + cleanupDirectory gi episodes + +cmd_worker _ _ = + fail $ "Invalid arguments to download; please see hpodder download --help" + +cleanupDirectory gi episodes = + do base <- getEnclTmp + files <- getDirectoryContents base + mapM_ (removeold base) files + where epmd5s = map (getdlfname . epurl) episodes + epmsgs = map (\e -> e ++ ".msg") epmd5s + eps = epmd5s ++ epmsgs + removeold base file = + when ((not (file `elem` eps)) && + (not (file `elem` [".", ".."]))) $ + removeFile (base ++ "/" ++ file) + +downloadEpisodes gi episodes = + do progressinterval <- getProgressInterval + + watchFiles <- newMVar [] + wfthread <- forkIO (watchTheFiles progressinterval watchFiles) + + easyDownloads "download" getEnclTmp True + (\pt -> mapM (ep2dlentry pt) episodes) + (procStart watchFiles) + (callback watchFiles) + + where nameofep e = printf "%d.%d" (castid . podcast $ e) (epid e) + ep2dlentry pt episode = + do cpt <- newProgress (nameofep episode) + (eplength episode) + addParent cpt pt + return $ DownloadEntry {dlurl = epurl episode, + usertok = episode, + dlname = nameofep episode, + dlprogress = cpt} + procStart watchFilesMV pt meter dlentry dltok = + do writeMeterString stdout meter $ + "Get: " ++ nameofep (usertok dlentry) ++ " " + ++ (take 60 . eptitle . usertok $ dlentry) ++ "\n" + modifyMVar_ watchFilesMV $ \wf -> + return $ (dltok, dlprogress dlentry) : wf + + callback watchFilesMV pt meter dlentry dltok status result = + modifyMVar_ watchFilesMV $ \wf -> + do size <- checkDownloadSize dltok + setP (dlprogress dlentry) (case size of + Nothing -> 0 + Just x -> toInteger x) + procEpisode gi meter dltok + (usertok dlentry) (dlname dlentry) + (result, status) + return $ filter (\(x, _) -> x /= dltok) wf + +-- FIXME: this never terminates, but at present, that may not hurt anything + +watchTheFiles progressinterval watchFilesMV = + do withMVar watchFilesMV $ \wf -> mapM_ examineFile wf + threadDelay (progressinterval * 1000000) + watchTheFiles progressinterval watchFilesMV + + where examineFile (dltok, cpt) = + do size <- checkDownloadSize dltok + setP cpt (case size of + Nothing -> 0 + Just x -> toInteger x) + +procEpisode gi meter dltok ep name r = + case r of + (Success, _) -> procSuccess gi ep (tokpath dltok) + (Failure, Terminated sigINT) -> + do i "Ctrl-C hit; aborting!" + -- Do not consider Ctrl-C a trackable error + exitFailure + _ -> do curtime <- now + let newep = considerDisable gi $ + updateAttempt curtime $ + (ep {eplastattempt = Just curtime, + epfailedattempts = epfailedattempts ep + 1}) + updateEpisode (gdbh gi) newep + commit (gdbh gi) + writeMeterString stderr meter $ " *** " ++ name ++ + ": Error downloading\n" + when (epstatus newep == Error) $ + writeMeterString stderr meter $ " *** " ++ name ++ + ": Disabled due to errors.\n" +considerDisable gi ep = forceEither $ + do faildays <- get (gcp gi) cast "epfaildays" + failattempts <- get (gcp gi) cast "epfailattempts" + let lupdate = case epfirstattempt ep of + Nothing -> 0 + Just x -> x + let timepermitsdel = case eplastattempt ep of + Nothing -> True + Just x -> x - lupdate > faildays * 60 * 60 * 24 + case epstatus ep of + Pending -> return $ ep {epstatus = + if (epfailedattempts ep > failattempts) && timepermitsdel + then Error + else Pending} + _ -> return ep + + where cast = show . castid . podcast $ ep + +updateAttempt curtime ep = + ep {epfirstattempt = + case epfirstattempt ep of + Nothing -> Just curtime + Just x -> Just x + } + + +procSuccess gi ep tmpfp = + do cp <- getCP ep idstr fnpart + let cfg = get cp idstr + let newfn = (strip $ forceEither $ cfg "downloaddir") ++ "/" ++ + (strip $ forceEither $ cfg "namingpatt") + createDirectoryIfMissing True (fst . splitFileName $ newfn) + finalfn <- if ((eptype ep) `elem` ["audio/mpeg", "audio/mp3", + "x-audio/mp3"]) && + not (isSuffixOf ".mp3" newfn) + then movefile tmpfp (newfn ++ ".mp3") + else movefile tmpfp newfn + when (isSuffixOf ".mp3" finalfn) $ + do d " Setting ID3 tags..." + --posixRawSystem "id3v2" ["-C", finalfn] >>= id3result + --posixRawSystem "id3v2" ["-s", finalfn] >>= id3result + posixRawSystem "id3v2" ["-A", castname . podcast $ ep, + "-t", eptitle ep, + "--WOAF", epurl ep, + "--WOAS", feedurl . podcast $ ep, + -- "--WXXX", feedurl . podcast $ ep, + finalfn] >>= id3result + cp <- getCP ep idstr fnpart + let cfg = get cp (show . castid . podcast $ ep) + forM_ (either (const Nothing) Just $ cfg "posthook") + (runHook finalfn) + curtime <- now + updateEpisode (gdbh gi) $ + updateAttempt curtime $ (ep {epstatus = Downloaded}) + commit (gdbh gi) + + where idstr = show . castid . podcast $ ep + fnpart = snd . splitFileName $ epurl ep + id3result res = + case res of + Exited (ExitSuccess) -> d $ " id3v2 was successful." + Exited (ExitFailure y) -> w $ "\n id3v2 returned: " ++ show y + Terminated y -> w $ "\n id3v2 terminated by signal " ++ show y + _ -> fail "Stopped unexpected" + +-- | Runs a hook script. +runHook :: String -- ^ The name of the file to pass as an argument to the script. + -> String -- ^ The name of the script to invoke. + -> IO () +runHook fn script = + do child <- forkProcess runScript + status <- getProcessStatus True False child + case status of + Nothing -> fail "No status unexpected." + Just (Stopped _) -> fail "Stopped process unexpected." + Just (Terminated sig) -> fail (printf "Post-hook \"%s\" terminated by signal %s" script (show sig)) + Just (Exited (ExitFailure code)) -> fail (printf "Post-hook \"%s\" failed with exit code %s" script (show code)) + Just (Exited ExitSuccess) -> return () + where runScript = + -- Open /dev/null, duplicate it to stdout, and close it. + do bracket (openFd "/dev/null" ReadOnly + Nothing defaultFileFlags) + closeFd + (\devNull -> + do dupTo devNull stdOutput) + executeFile script False [fn] Nothing + +getCP :: Episode -> String -> String -> IO ConfigParser +getCP ep idstr fnpart = + do cp <- loadCP + return $ forceEither $ + do cp <- if has_section cp idstr + then return cp + else add_section cp idstr + cp <- set cp idstr "safecasttitle" + (sanitize_fn . castname . podcast $ ep) + cp <- set cp idstr "epid" (show . epid $ ep) + cp <- set cp idstr "castid" idstr + cp <- set cp idstr "safefilename" + (sanitize_fn (unEscapeString fnpart)) + cp <- set cp idstr "safeeptitle" (sanitize_fn . eptitle $ ep) + return cp + +movefile old new = + do realnew <- findNonExisting new + copyFile old (realnew ++ ".partial") + renameFile (realnew ++ ".partial") realnew + removeFile old + return realnew + +findNonExisting template = + do dfe <- doesFileExist template + if (not dfe) + then return template + else do let (dirname, fn) = splitFileName template + (fp, h) <- openTempFile dirname fn + hClose h + return fp + +helptext = "Usage: hpodder download [castid [castid...]]\n\n" ++ + genericIdHelp ++ + "\nThe download command will cause hpodder to download any podcasts\n\ + \episodes that are marked Pending. Such episodes are usually generated\n\ + \by a prior call to \"hpodder update\". If you want to combine an update\n\ + \with a download, as is normally the case, you may want \"hpodder fetch\".\n" diff --git a/Commands/EnableDisable.hs b/Commands/EnableDisable.hs new file mode 100644 --- /dev/null +++ b/Commands/EnableDisable.hs @@ -0,0 +1,72 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.EnableDisable(cmd_enable, cmd_disable, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Exception(evaluate) +import Control.Monad +import Utils +import Data.String +import System.IO + +i = infoM "enable/disable" +w = warningM "enable/disable" +d = debugM "enable/disable" + +cmd_enable = simpleCmd "enable" + "Enable a podcast that was previously disabled" helptext + [] (cmd_worker "enable" PCEnabled) + +cmd_disable = simpleCmd "disable" + "Stop updating and downloading given podcasts" helptext_disable + [] (cmd_worker "disable" PCUserDisabled) + +cmd_worker cmd _ gi ([], []) = + fail $ cmd ++ " requires a podcast ID to remove; please see hpodder " + ++ cmd ++ " --help" + +cmd_worker cmd newstat gi ([], casts) = lock $ + do podcastlist <- getSelectedPodcasts (gdbh gi) casts + evaluate (length podcastlist) + d $ "Setting " ++ (show . length $ podcastlist) ++ " podcasts to " ++ + show (newstat) + mapM_ (\x -> updatePodcast (gdbh gi) + (x {pcenabled = newstat, + failedattempts = if newstat == PCEnabled then 0 + else failedattempts x})) + podcastlist + commit (gdbh gi) + + +cmd_worker cmd _ _ _ = + fail $ "Invalid arguments to enable; please see hpodder " ++ cmd ++ " --help" + +helptext = "Usage: hpodder enable castid [castid...]\n\n" ++ + "\nEnables selected podcasts for downloading and updating\n" + +helptext_disable = "Usage: hpodder disable castid [castid...]\n\n" ++ + "\nDisables selected podcasts -- they will no longer be downloaded or\n\ + \updated until re-enabled.\n" diff --git a/Commands/ImportIpodder.hs b/Commands/ImportIpodder.hs new file mode 100644 --- /dev/null +++ b/Commands/ImportIpodder.hs @@ -0,0 +1,113 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.ImportIpodder(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Monad +import Utils +import System.Console.GetOpt +import System.Console.GetOpt.Utils +import qualified Commands.Update +import System.FilePath +import Data.List +import Data.String +import System.Directory +import Control.Exception + +d = debugM "import-ipodder" +i = infoM "import-ipodder" +w = warningM "import-ipodder" + +cmd = simpleCmd "import-ipodder" + "Import feeds and history from ipodder or castpodder" + "" + [Option "" ["from"] (ReqArg (stdRequired "from") "PATH") + "Location of ipodder data directory (default ~/.ipodder)"] + cmd_worker + +cmd_worker gi (args, []) = lock $ + do ipodderpath <- case lookup "from" args of + Nothing -> do getAppUserDataDirectory "ipodder" + Just x -> return x + i "Scanning ipodder podcast list and adding new podcasts to hpodder..." + pc <- newpodcasts ipodderpath gi + i $ printf "Added %d podcasts" (length pc) + + i "Loading new feeds..." + Commands.Update.cmd_worker gi ([], map (show . castid) pc) + commit (gdbh gi) + + i "Now importing iPodder history..." + history <- loadhistory ipodderpath + prochistory gi pc history + commit (gdbh gi) + i "Done." + +cmd_worker _ _ = + fail "Unknown arg to import-ipodder; see hpodder import-ipodder --help" + +prochistory _ [] _ = return () +prochistory gi (pc:xs) history = + do episodes <- getEpisodes (gdbh gi) pc + -- Force episodes to be consumed before proceeding + evaluate (length episodes) + d $ printf "Considering %d episode(s) for podcast %d" (length episodes) + (castid pc) + mapM_ procep episodes + prochistory gi xs history + where procep ep = + if (snd . splitFileName . epurl $ ep) `elem` history + && (epstatus ep) `elem` [Pending, Error] + then do d $ printf "Adjusting episode %d" (epid ep) + updateEpisode (gdbh gi) (ep {epstatus = Skipped}) + return () + else return () + +newpodcasts id gi = + do favorites <- readFile (id ++ "/favorites.txt") + let newurls = filter (not . isPrefixOf "#") . map strip . lines + $ favorites + existinglist <- getPodcasts (gdbh gi) + let existingurls = map feedurl existinglist + let urlstoadd = filter (\newurl -> not (newurl `elem` existingurls)) + newurls + let podcaststoadd = map (\url -> Podcast {castid = 0, + castname = "", + feedurl = url, + pcenabled = PCEnabled, + lastupdate = Nothing, + lastattempt = Nothing, + failedattempts = 0}) urlstoadd + + newpcs <- mapM (addPodcast (gdbh gi)) podcaststoadd + commit (gdbh gi) + return newpcs + +loadhistory :: String -> IO [String] +loadhistory id = + do historyfile <- readFile (id ++ "/history.txt") + return $ filter (/= "") . map strip . lines $ historyfile + diff --git a/Commands/Ls.hs b/Commands/Ls.hs new file mode 100644 --- /dev/null +++ b/Commands/Ls.hs @@ -0,0 +1,96 @@ +{- hpodder component +Copyright (C) 2006 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.Ls(lscasts, lscasts_worker, lsepisodes, lseps) where +import Utils +import System.Log.Logger +import DB +import Types +import Database.HDBC +import Text.Printf +import Control.Monad +import System.Console.GetOpt +import Data.List + +i = infoM "ls" + +-------------------------------------------------- +-- lscasts +-------------------------------------------------- + +lscasts = simpleCmd "lscasts" "List all configured podcasts on the system" + lscasts_help + [Option "l" [] (NoArg ("l", "")) "Long format display -- include URLs in output"] lscasts_worker + +lscasts_worker gi (opts, casts) = + do pc <- getSelectedPodcasts (gdbh gi) casts + printf "%-4s %-7s %s\n" "ID" "Pnd/Tot" "Title" + when (islong) (printf " URL\n") + mapM_ printpc (sort pc) + where islong = lookup "l" opts == Just "" + printpc pc = do pend <- quickQuery (gdbh gi) "SELECT COUNT(*) FROM \ + \episodes WHERE castid = ? AND \ + \status = 'Pending'" [toSql (castid pc)] + tot <- quickQuery (gdbh gi) "SELECT COUNT(*) FROM \ + \episodes WHERE castid = ?" + [toSql (castid pc)] + let (npend, ntot) = case (pend, tot) of + ([[x]], [[y]]) -> + (fromSql x, fromSql y) + _ -> error "Bad count result" + printf "%-4d %3d/%3d %s\n" (castid pc) + (npend::Int) (ntot::Int) title + when (islong) (printf " %s\n" (feedurl pc)) + where title = case pcenabled pc of + PCEnabled -> castname pc + PCUserDisabled -> "[disabled] " ++ castname pc + PCErrorDisabled -> "[disabled by errors] " ++ + castname pc + +lscasts_help = + "Usage: hpodder lscasts [-l] [castid [castid...]]\n\n" ++ genericIdHelp ++ + "\nIf no ID is given, then \"all\" will be used.\n" + +-------------------------------------------------- +-- lsepisodes +-------------------------------------------------- + +lsepisodes = simpleCmd "lsepisodes" "List episodes in hspodder database" + lsepisodes_help + [Option "l" [] (NoArg ("l", "")) "Long format display -- include URLs in output"] lsepisodes_worker + +lseps = simpleCmd "lseps" "Alias for lsepisodes" lsepisodes_help + [Option "l" [] (NoArg ("l", "")) "Long format display -- include URLs in output"] lsepisodes_worker + +lsepisodes_worker gi (opts, casts) = + do pc <- getSelectedPodcasts (gdbh gi) casts + printf "%-5s %-5s %-4s %-60.60s\n" "CstId" "EpId" "Stts" "Episode Title" + when (islong) (printf " Episode URL\n") + eps <- mapM (getEpisodes (gdbh gi)) pc + mapM_ printep (concat eps) + where printep ep = + do printf "%-5d %-5d %-4s %-60.60s\n" + (castid (podcast ep)) (epid ep) + (take 4 . show $ epstatus ep) (eptitle ep) + when (islong) (printf " %s\n" (epurl ep)) + islong = lookup "l" opts == Just "" + +lsepisodes_help = + "Usage: hpodder lsepisodes [-l] [castid [castid...]]\n\n" ++ genericIdHelp ++ + "\nIf no podcast ID is given, then \"all\" will be used. You can find your\n\ + \podcast IDs with \"hpodder lscasts\".\n" diff --git a/Commands/Rm.hs b/Commands/Rm.hs new file mode 100644 --- /dev/null +++ b/Commands/Rm.hs @@ -0,0 +1,65 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.Rm(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Monad +import Utils +import Data.String +import qualified Commands.Ls +import System.IO + +i = infoM "rm" +w = warningM "rm" + +cmd = simpleCmd "rm" + "Remove podcast(s) from hpodder" helptext + [] cmd_worker + +cmd_worker gi ([], []) = + fail $ "rm requires a podcast ID to remove; please see hpodder rm --help" + +cmd_worker gi ([], casts) = lock $ + do podcastlist <- getSelectedPodcasts (gdbh gi) casts + i "Will remove the following podcasts:\n" + Commands.Ls.lscasts_worker gi ([("l", "")], casts) + i $ printf "\nAre you SURE you want to remove these %d podcast(s)?\n" + (length podcastlist) + i "Type YES exactly as shown, in all caps, to delete them." + i "Remove podcasts? " + hFlush stdout + resp <- getLine + if resp == "YES" + then do mapM_ (removePodcast (gdbh gi)) podcastlist + commit (gdbh gi) + i $ "Remove completed." + else do i "Remove aborted by user." + +cmd_worker _ _ = + fail $ "Invalid arguments to rm; please see hpodder rm --help" + +helptext = "Usage: hpodder rm castid [castid...]\n\n" ++ + "\nRemoves the specified podcast(s) entirely from hpodder\n" diff --git a/Commands/SetStatus.hs b/Commands/SetStatus.hs new file mode 100644 --- /dev/null +++ b/Commands/SetStatus.hs @@ -0,0 +1,82 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.SetStatus(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Monad hiding (join) +import Utils +import Data.String +import System.IO +import System.Console.GetOpt +import System.Console.GetOpt.Utils +import qualified Control.Exception as E + +i = infoM "setstatus" +w = warningM "setstatus" +d = debugM "setstatus" + +possibleStatuses = join ", " . map show $ enumFrom Pending + +cmd = simpleCmd "setstatus" + "Alter status of individual episodes" helptext + [Option "c" ["castid"] (ReqArg (stdRequired "castid") "ID") + "Podcast ID in which the episodes occur", + Option "s" ["status"] (ReqArg (stdRequired "status") "STATUS") + ("Specify the new status. Possible statuses are:\n" ++ possibleStatuses)] + cmd_worker + +cmd_worker _ (_, []) = + fail $ "setstatus: episode IDs missing; see hpodder setstatus --help" + +cmd_worker gi (args, episodes) = lock $ + do podcastid <- case lookup "castid" args of + Just x -> return (read x) + Nothing -> fail "setstatus: --castid required; see hpodder setstatus --help" + newstatus <- case lookup "status" args of + Just x -> E.catch (E.evaluate (read x)) + (\_ -> fail $ "Invalid status supplied; use one of: " ++ possibleStatuses) + Nothing -> fail "setstatus: --status required; see hpodder setstatus --help" + podcastlist <- getPodcast (gdbh gi) podcastid + pc <- case podcastlist of + [x] -> return x + _ -> fail "setstatus: --castid did not give a valid podcast id" + + return $ seq pc pc + eplist_orig <- getSelectedEpisodes (gdbh gi) pc episodes + + -- Force evaluation of eplist_orig + E.evaluate (length eplist_orig) + d $ printf "Modifying %d episodes" (length eplist_orig) + return $ seq eplist_orig eplist_orig + let eplist_new = map (\e -> e {epstatus = newstatus, + epfailedattempts = 0 }) eplist_orig + mapM_ (updateEpisode (gdbh gi)) eplist_new + commit (gdbh gi) + +helptext = "Usage: hpodder setstatus -c CASTID -s STATUS episodeid [episodeid ...]\n\n\ + \You must specify one podcast ID with -c, one new status with -s.\n\ + \You must also specify one or more episode ID. To select all episodes,\n\ + \specify \"all\".\n" diff --git a/Commands/SetTitle.hs b/Commands/SetTitle.hs new file mode 100644 --- /dev/null +++ b/Commands/SetTitle.hs @@ -0,0 +1,68 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.SetTitle(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Monad +import Utils +import Data.String +import System.IO +import System.Console.GetOpt +import System.Console.GetOpt.Utils +import Control.Exception + +i = infoM "settitle" +w = warningM "settitle" +d = debugM "settitle" + +cmd = simpleCmd "settitle" + "Alter title of a podcast" helptext + [Option "c" ["castid"] (ReqArg (stdRequired "castid") "ID") + "Podcast ID to modify", + Option "t" ["title"] (ReqArg (stdRequired "title") "TITLE") + "New title for this podcast"] + cmd_worker + +cmd_worker gi (args, []) = lock $ + do podcastid <- case lookup "castid" args of + Just x -> return (read x) + Nothing -> fail "settitle: --castid required; see hpodder settitle --help" + newtitle <- case lookup "title" args of + Just x -> return x + Nothing -> fail "settitle: --title required; see hpodder settitle --help" + pc <- getPodcast (gdbh gi) podcastid + case pc of + [x] -> updatePodcast (gdbh gi) (x {castname = newtitle}) + _ -> fail $ "Invalid podcast ID given" + commit (gdbh gi) + +cmd_worker gi (_, _) = + fail $ "settitle: unrecognized arguments; see hpodder settitle --help" + + +helptext = "Usage: hpodder settitle -c CASTID -t 'TITLE'\n\n\ + \You must specify one podcast ID with -c and the new title with -t.\n\ + \If the title contains spaces, you must enclose it in quotes.\n" diff --git a/Commands/Setup.hs b/Commands/Setup.hs new file mode 100644 --- /dev/null +++ b/Commands/Setup.hs @@ -0,0 +1,110 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.Setup(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Monad +import Utils +import qualified Commands.Update +import qualified Commands.Download +import qualified Commands.Catchup +import qualified Commands.Add +import Data.ConfigFile +import System.IO +import Data.Either.Utils +import Data.String + +i = infoM "setup" +w = warningM "setup" + +--- This command is not available to the user by default -- it is +--- run on first execution of fetch + +cmd = simpleCmd "setup" + "Perform initial configuration of hpodder -- NOT USER-VISIBLE" "" + [] cmd_worker + +cmd_worker gi ([], []) = lock $ + do cp <- loadCP + putStr "Hello! Welcome to hpodder!\n\n\ + \It looks like this is your first time running hpodder, so we're going\n\ + \to take care of a few very quick matters.\n\n\ + \First, where would you like to store your downloaded podcast episodes?\n\ + \You can just press Enter to accept the default location in the brackets,\n\ + \or enter your own location (full path, please!)\n\n\ + \ Download Location [" + let defaultloc = forceEither $ get cp "DEFAULT" "downloaddir" + putStr defaultloc + putStr "]: " + hFlush stdout + dlloc_inp <- getLine + putStr "\n\nOK! Last question: Would you like hpodder to\n\ +\automatically subscribe you to a few sample podcasts? This could be a nice\n\ +\way to see what's out there. You can always remove these or add your own\n\ +\later.\n\n\ +\ Subscribe to sample podcasts? [Y/n] " + hFlush stdout + subscribe_inp <- getLine + cpname <- getCPName + writeFile cpname $ + (if (strip dlloc_inp) /= "" + then "[DEFAULT]\n\ndownloaddir = " ++ dlloc_inp ++ "\n" + else "\n") ++ + "[general]\n\n; The following line tells hpodder that\n\ + \; you have already gone through the intro.\n\ + \showintro = no\n" + case subscribe_inp of + [] -> subscribeSamples gi + 'y':_ -> subscribeSamples gi + 'Y':_ -> subscribeSamples gi + _ -> putStr "OK, as you wish, I won't add the sample subscriptions.\n\ + \You can find the list of samples later in the hpodder\n\ + \manual.\n" + putStr "\n\nOK, hpodder is ready to run! Each time you want to\n\ + \download new episodes, just run hpodder. If you let me subscribe you\n\ + \to episodes, type hpodder and hit Enter to start the podcasts downloading!\n\ + \\nDon't forget to check the hpodder manual for more tips on hpodder!\n\n" + +cmd_worker _ _ = + fail $ "Invalid arguments to setup" + +subscribeSamples gi = + do putStr "OK, just a moment while I initialize those feeds for you...\n" + mapM_ (\x -> Commands.Add.cmd_worker gi ([], [x])) sampleurls + Commands.Update.cmd_worker gi ([], []) + Commands.Catchup.cmd_worker gi ([("n", "1")], []) + --Commands.Download.cmd_worker gi ([], []) + +sampleurls = + ["http://soundofhistory.complete.org/files_soh/podcast.xml", + "http://www.thelinuxlink.net/tllts/tllts.rss", + "http://www.itconversations.com/rss/recentWithEnclosures.php", + "http://www.sciam.com/podcast/sciam_podcast_r.xml", + "http://www.npr.org/rss/podcast.php?id=510019", + "http://amateurtraveler.com/podcast/rss.xml", + "http://broadband.wgbh.org/amex/rss/podcast_np.xml", + "http://www.npr.org/rss/podcast.php?id=700000"] + diff --git a/Commands/Update.hs b/Commands/Update.hs new file mode 100644 --- /dev/null +++ b/Commands/Update.hs @@ -0,0 +1,160 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.Update(cmd, cmd_worker) where +import Utils +import System.Log.Logger +import DB +import Download +import DownloadQueue +import Data.Progress.Meter +import Data.Progress.Tracker +import FeedParser +import Types +import Text.Printf +import Config +import Database.HDBC +import Control.Monad +import Utils +import Data.String +import System.Exit +import System.Posix.Process +import System.Directory +import System.IO +import Data.List +import Data.Either.Utils +import Data.ConfigFile(get) + +i = infoM "update" +w = warningM "update" + +cmd = simpleCmd "update" + "Re-scan all feeds and update list of needed downloads" helptext + [] cmd_worker + +cmd_worker gi ([], casts) = lock $ + do podcastlist' <- getSelectedPodcasts (gdbh gi) casts + let podcastlist = filter_disabled podcastlist' + i $ printf "%d podcast(s) to consider\n" (length podcastlist) + updatePodcasts gi podcastlist + return () + +cmd_worker _ _ = + fail $ "Invalid arguments to update; please see hpodder update --help" + +updatePodcasts gi podcastlist = + do ft <- getFeedTmp + emptyDir ft + easyDownloads "update" getFeedTmp False + (\pt -> mapM (podcast2dlentry pt) podcastlist) + procStart + (updateThePodcast gi) + emptyDir ft + where podcast2dlentry pt podcast = + do cpt <- newProgress (show . castid $ podcast) 1 + addParent cpt pt + return $ DownloadEntry {dlurl = feedurl podcast, + usertok = podcast, + dlname = (show . castid $ podcast), + dlprogress = cpt} + + --removeFile ((\(_, _, fp, _) -> fp) dltok) + procStart pt meter dlentry dltok = + writeMeterString stdout meter $ + "Get: " ++ show (castid . usertok $ dlentry) ++ " " + ++ (take 65 . castname . usertok $ dlentry) ++ "\n" + + +updateThePodcast gi pt meter dlentry dltok status result = + do incrP (dlprogress dlentry) 1 + let pc = usertok dlentry + feed <- getFeed meter pc (result, status) dltok + case feed of + Nothing -> -- some problem with the feed + case status of + Terminated sigINT -> return () -- Ctrl-C is not a tackable error + _ -> do curtime <- now + let newpc = considerDisable gi + (pc {lastattempt = Just curtime, + failedattempts = 1 + failedattempts pc}) + updatePodcast (gdbh gi) newpc + commit (gdbh gi) + when (pcenabled newpc == PCErrorDisabled) $ + i (" Podcast " ++ castname newpc ++ " disabled due to errors.") + Just f -> do newpc <- updateFeed gi pc f + curtime <- now + updatePodcast (gdbh gi) + (newpc {lastupdate = Just curtime, + lastattempt = Just curtime, + failedattempts = 0}) + --i $ " Podcast Title: " ++ (castname newpc) + commit (gdbh gi) + +considerDisable gi pc = forceEither $ + do faildays <- get (gcp gi) (show (castid pc)) "podcastfaildays" + failattempts <- get (gcp gi) (show (castid pc)) "podcastfailattempts" + let lupdate = case lastupdate pc of + Nothing -> 0 + Just x -> x + let timepermitsdel = case lastattempt pc of + Nothing -> True + Just x -> x - lupdate > faildays * 60 * 60 * 24 + case pcenabled pc of + PCUserDisabled -> return pc + PCErrorDisabled -> return pc + PCEnabled -> return $ + pc {pcenabled = + if (failedattempts pc > failattempts) && timepermitsdel + then PCErrorDisabled + else PCEnabled + } + +updateFeed gi pcorig f = + do count <- foldM (updateEnc gi pc) 0 (items f) + --i $ printf " %d new episodes" count + return pc + where pc = pcorig {castname = newname} + newname = if (castname pcorig) == "" + then strip . sanitize_basic $ channeltitle f + else (castname pcorig) + +updateEnc gi pc count item = + do newc <- addEpisode (gdbh gi) (item2ep pc item) + return $ count + newc + +getFeed meter pc (result, status) dltok = + case (result, status) of + (Success, _) -> + do feed <- parse (tokpath dltok) (feedurl pc) + case feed of + Right f -> return $ Just (f {items = reverse (items f)}) + Left x -> do writeMeterString stderr meter $ + " *** " ++ (show . castid $ pc) ++ + ": Failure parsing feed: " ++ x ++ "\n" + return Nothing + (Failure, Terminated sigINT) -> do w "\n Ctrl-C hit; aborting!" + exitFailure + _ -> do writeMeterString stderr meter $ + " *** " ++ (show . castid $ pc) ++ ": Failure downloading feed\n" + return Nothing + +helptext = "Usage: hpodder update [castid [castid...]]\n\n" ++ genericIdHelp ++ + "\nRunning update will cause hpodder to look at each requested podcast. It\n\ + \will download the feed for each one and update its database of available\n\ + \episodes. It will not actually download any episodes; see the download\n\ + \command for that." diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -0,0 +1,104 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Config + Copyright : Copyright (C) 2006-2007 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} +module Config where + +import System.Directory +import Data.ConfigFile +import Control.Monad +import Data.Either.Utils +import System.Path + +getFeedTmp = + do appdir <- getAppDir + return $ appdir ++ "/feedxfer" + +bracketFeedCWD func = + do feeddir <- getFeedTmp + brackettmpdirCWD (feeddir ++ "/tmp-XXXXXX") func + +getEnclTmp = + do appdir <- getAppDir + return $ appdir ++ "/enclosurexfer" + +getAppDir = do appdir <- getAppUserDataDirectory "hpodder" + return appdir + +getDBName = + do appdir <- getAppDir + return $ appdir ++ "/hpodder.db" + +getDefaultCP = + do docsdir <- getUserDocumentsDirectory + let downloaddir = docsdir ++ "/podcasts" + return $ forceEither $ + do cp <- add_section startingcp "general" + cp <- set cp "general" "showintro" "yes" + cp <- set cp "DEFAULT" "downloaddir" downloaddir + cp <- set cp "DEFAULT" "namingpatt" + "%(safecasttitle)s/%(safefilename)s" + cp <- set cp "DEFAULT" "maxthreads" "2" + cp <- set cp "DEFAULT" "progressinterval" "1" + cp <- set cp "DEFAULT" "podcastfaildays" "21" + cp <- set cp "DEFAULT" "podcastfailattempts" "15" + cp <- set cp "DEFAULT" "epfaildays" "21" + cp <- set cp "DEFAULT" "epfailattempts" "15" + return cp + +startingcp = emptyCP {accessfunc = interpolatingAccess 10} + +getCPName = + do appdir <- getAppDir + return $ appdir ++ "/hpodder.conf" + +loadCP = + do cpname <- getCPName + defaultcp <- getDefaultCP + dfe <- doesFileExist cpname + if dfe + then do cp <- readfile defaultcp cpname + return $ forceEither cp + else return defaultcp + +writeCP cp = + do cpname <- getCPName + writeFile cpname (to_string cp) + +-- FIXME: these may be inefficient [PERFORMANCE] + +getMaxThreads :: IO Int +getMaxThreads = + do cp <- loadCP + return $ read . forceEither $ get cp "general" "maxthreads" + +getProgressInterval :: IO Int +getProgressInterval = + do cp <- loadCP + return $ read . forceEither $ get cp "general" "progressinterval" diff --git a/DB.hs b/DB.hs new file mode 100644 --- /dev/null +++ b/DB.hs @@ -0,0 +1,267 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : DB + Copyright : Copyright (C) 2006-2007 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} +module DB where +import Config +import Types + +import Database.HDBC +import Database.HDBC.Sqlite3 +import System.Log.Logger +import Control.Monad +import Control.Exception +import Utils +import Data.List.Utils +dbdebug = debugM "DB" + +connect :: IO Connection +connect = handleSqlError $ + do fp <- getDBName + dbh <- connectSqlite3 fp + setBusyTimeout dbh 5000 + prepDB dbh + dbdebug $ "DB preparation complete" + return dbh + +prepDB dbh = + do tables <- getTables dbh + evaluate (length tables) + schemaver <- prepSchema dbh tables + upgradeSchema dbh schemaver tables + +prepSchema :: Connection -> [String] -> IO Int +prepSchema dbh tables = + if "schemaver" `elem` tables + then do r <- quickQuery dbh "SELECT version FROM schemaver" [] + case r of + [[x]] -> return (fromSql x) + x -> fail $ "Unexpected result in prepSchema: " ++ show x + else do dbdebug "Initializing schemaver to 0" + run dbh "CREATE TABLE schemaver (version INTEGER)" [] + run dbh "INSERT INTO schemaver VALUES (0)" [] + commit dbh + return 0 + +upgradeSchema dbh 4 _ = return () + +upgradeSchema dbh 3 tables = + do dbdebug "Upgrading schema 3 -> 4" + dbdebug "Adding lastattempt column" + run dbh "ALTER TABLE podcasts ADD lastattempt INTEGER" [] + dbdebug "Adding failedattempts column" + run dbh "ALTER TABLE podcasts ADD failedattempts INTEGER NOT NULL DEFAULT 0" [] + + dbdebug "Adding epfirstattempt column" + run dbh "ALTER TABLE episodes ADD epfirstattempt INTEGER" [] + dbdebug "Adding eplastattempt column" + run dbh "ALTER TABLE episodes ADD eplastattempt INTEGER" [] + dbdebug "Adding epfailedattempts column" + run dbh "ALTER TABLE episodes ADD epfailedattempts INTEGER NOT NULL DEFAULT 0" [] + + setSchemaVer dbh 4 + commit dbh + +upgradeSchema dbh 2 tables = + do dbdebug "Upgrading schema 2 -> 3" + dbdebug "Adding eplength column" + run dbh "ALTER TABLE episodes ADD eplength INTEGER NOT NULL DEFAULT 0" [] + setSchemaVer dbh 3 + commit dbh + + -- Empty the enclosure storage since our naming changed when this + -- version arrived + edir <- getEnclTmp + emptyDir edir + upgradeSchema dbh 3 tables + +upgradeSchema dbh 1 tables = + do dbdebug "Upgrading schema 1 -> 2" + dbdebug "Adding pcenabled column" + run dbh "ALTER TABLE podcasts ADD pcenabled INTEGER NOT NULL DEFAULT 1" [] + dbdebug "Adding lastupdate column" + run dbh "ALTER TABLE podcasts ADD lastupdate INTEGER" [] + setSchemaVer dbh 2 + commit dbh + -- dbdebug "Vacuuming" + -- run dbh "VACUUM" [] + upgradeSchema dbh 2 tables + +upgradeSchema dbh 0 tables = + do dbdebug "Upgrading schema 0 -> 1" + unless ("podcasts" `elem` tables) + (run dbh "CREATE TABLE podcasts(\ + \castid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\ + \castname TEXT NOT NULL,\ + \feedurl TEXT NOT NULL UNIQUE)" [] >> return ()) + unless ("episodes" `elem` tables) + (run dbh "CREATE TABLE episodes (\ + \castid INTEGER NOT NULL, \ + \episodeid INTEGER NOT NULL, \ + \title TEXT NOT NULL, \ + \epurl TEXT NOT NULL, \ + \enctype TEXT NOT NULL,\ + \status TEXT NOT NULL,\ + \UNIQUE(castid, epurl),\ + \UNIQUE(castid, episodeid))" [] >> return ()) + setSchemaVer dbh 1 + commit dbh + upgradeSchema dbh 1 tables + +upgradeSchema dbh sv _ = + fail $ "Unrecognized DB schema version " ++ (show sv) ++ + "; you probably need a newer hpodder to read this database." + +setSchemaVer :: Connection -> Integer -> IO () +setSchemaVer dbh sv = + do dbdebug $ "Setting schema version to " ++ show sv + run dbh "DELETE FROM schemaver" [] + run dbh "INSERT INTO schemaver VALUES(?)" [toSql sv] + return () + +{- | Adds a new podcast to the database. Ignores the castid on the incoming +podcast, and returns a new object with the castid populated. + +A duplicate add is an error. -} +addPodcast :: Connection -> Podcast -> IO Podcast +addPodcast dbh podcast = + do handleSql + (\e -> fail $ "Error adding podcast; perhaps this URL already exists\n" + ++ show e) $ + run dbh "INSERT INTO podcasts (castname, feedurl, pcenabled, lastupdate, lastattempt, failedattempts) VALUES (?, ?, ?, ?, ?, ?, ?)" + [toSql (castname podcast), toSql (feedurl podcast), + toSql (fromEnum (pcenabled podcast)), + toSql (lastupdate podcast), + toSql (lastattempt podcast), + toSql (failedattempts podcast)] + r <- quickQuery dbh "SELECT castid FROM podcasts WHERE feedurl = ?" + [toSql (feedurl podcast)] + case r of + [[x]] -> return $ podcast {castid = fromSql x} + y -> fail $ "Unexpected result: " ++ show y + +updatePodcast :: Connection -> Podcast -> IO () +updatePodcast dbh podcast = + run dbh "UPDATE podcasts SET castname = ?, feedurl = ?, pcenabled = ?, \ + \lastupdate = ?, lastattempt = ?, failedattempts = ? \ + \WHERE castid = ?" + [toSql (castname podcast), toSql (feedurl podcast), + toSql (fromEnum (pcenabled podcast)), + toSql (lastupdate podcast), + toSql (lastattempt podcast), + toSql (failedattempts podcast), toSql (castid podcast)] >> return () + +{- | Remove a podcast. -} +removePodcast :: Connection -> Podcast -> IO () +removePodcast dbh podcast = + do run dbh "DELETE FROM episodes WHERE castid = ?" [toSql (castid podcast)] + run dbh "DELETE FROM podcasts WHERE castid = ?" [toSql (castid podcast)] + return () + +getPodcasts :: Connection -> IO [Podcast] +getPodcasts dbh = + do res <- quickQuery dbh "SELECT castid, castname, feedurl, pcenabled,\ + \lastupdate, lastattempt, failedattempts \ + \FROM podcasts ORDER BY castid" [] + return $ map podcast_convrow res + +getPodcast :: Connection -> Integer -> IO [Podcast] +getPodcast dbh wantedid = + do res <- quickQuery dbh "SELECT castid, castname, feedurl, pcenabled,\ + \lastupdate, lastattempt, failedattempts \ + \FROM podcasts WHERE castid = ? ORDER BY castid" [toSql wantedid] + return $ map podcast_convrow res + +getEpisodes :: Connection -> Podcast -> IO [Episode] +getEpisodes dbh pc = + do r <- quickQuery dbh "SELECT episodeid, title, epurl, enctype,\ + \status, eplength, epfirstattempt, eplastattempt, \ + \epfailedattempts FROM episodes \ + \WHERE castid = ? ORDER BY \ + \episodeid" [toSql (castid pc)] + return $ map toItem r + where toItem [sepid, stitle, sepurl, senctype, sstatus, slength, + slu, sla, sfa] = + Episode {podcast = pc, epid = fromSql sepid, + eptitle = fromSql stitle, + epurl = fromSql sepurl, eptype = fromSql senctype, + epstatus = read (fromSql sstatus), + eplength = fromSql slength, + epfirstattempt = fromSql slu, + eplastattempt = fromSql sla, + epfailedattempts = fromSql sfa} + toItem x = error $ "Unexpected result in getEpisodes: " ++ show x + +podcast_convrow [svid, svname, svurl, isenabled, lupdate, lattempt, + fattempts] = + Podcast {castid = fromSql svid, castname = fromSql svname, + feedurl = fromSql svurl, pcenabled = toEnum . fromSql $ isenabled, + lastupdate = fromSql lupdate, lastattempt = fromSql lattempt, + failedattempts = fromSql fattempts} + +{- | Add a new episode. If the episode already exists, ignore the add request +and preserve the existing record. -} +addEpisode :: Connection -> Episode -> IO Integer +addEpisode dbh ep = + do nextepid <- getepid + insertEpisode "INSERT OR IGNORE" dbh ep nextepid + where getepid = + do r <- quickQuery dbh "SELECT MAX(episodeid) FROM episodes WHERE castid = ?" [toSql (castid (podcast ep))] + case r of + [[SqlNull]] -> return 1 + [[x]] -> return ((fromSql x) + (1::Int)) + _ -> fail "Unexpected response in getepid" + +{- | Update an episode. If it doesn't already exist, create it. -} +updateEpisode :: Connection -> Episode -> IO Integer +updateEpisode dbh ep = insertEpisode "INSERT OR REPLACE" dbh ep (epid ep) + +insertEpisode insertsql dbh episode newepid = + run dbh (insertsql ++ " INTO episodes (castid, episodeid, title,\ + \epurl, enctype, status, eplength, epfirstattempt, eplastattempt,\ + \epfailedattempts) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)") + [toSql (castid (podcast episode)), toSql newepid, + toSql (eptitle episode), toSql (epurl episode), + toSql (eptype episode), toSql (show (epstatus episode)), + toSql (eplength episode), toSql (epfirstattempt episode), + toSql (eplastattempt episode), toSql (epfailedattempts episode)] + +getSelectedPodcasts dbh [] = getSelectedPodcasts dbh ["all"] +getSelectedPodcasts dbh ["all"] = getPodcasts dbh +getSelectedPodcasts dbh podcastlist = + do r <- mapM (getPodcast dbh) (map read podcastlist) + return $ uniq $ concat r + +getSelectedEpisodes :: Connection -> Podcast -> [String] -> IO [Episode] +getSelectedEpisodes _ _ [] = return [] +getSelectedEpisodes dbh pc ["all"] = getEpisodes dbh pc +getSelectedEpisodes dbh pc episodelist = + do eps <- getEpisodes dbh pc + return $ uniq . filter (\e -> (epid e `elem` eplist)) $ eps + where eplist = map read episodelist diff --git a/Download.hs b/Download.hs new file mode 100644 --- /dev/null +++ b/Download.hs @@ -0,0 +1,139 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Download + Copyright : Copyright (C) 2006-2007 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} + +module Download(startGetURL, finishGetURL, checkDownloadSize, Result(..), + DownloadTok(..), getdlfname) where +import System.Cmd.Utils +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) + +d = debugM "download" +i = infoM "download" + +curl = "curl" +curlopts = ["-A", "hpodder v1.0.0; Haskell; GHC", -- Set User-Agent + "-s", -- Silent mode + "-S", -- Still show error messages + "-L", -- Follow redirects + "-y", "60", "-Y", "1", -- Timeouts + "--retry", "2", -- Retry twice + "-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 + diff --git a/DownloadQueue.hs b/DownloadQueue.hs new file mode 100644 --- /dev/null +++ b/DownloadQueue.hs @@ -0,0 +1,207 @@ +{- hpodder component +Copyright (C) 2006 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : DownloadQueue + Copyright : Copyright (C) 2006 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} + +module DownloadQueue(DownloadEntry(..), + DownloadQueue(..), + DLAction(..), + easyDownloads, + runDownloads + ) where +import Download +import System.Cmd.Utils +import Data.Maybe.Utils +import System.Posix.Process +import Config +import System.Log.Logger +import Text.Printf +import System.Exit +import System.IO +import System.Directory +import System.Posix.Files +import System.Posix.Signals +import Data.Hash.MD5 +import Data.Progress.Tracker +import Data.Progress.Meter +import Data.Quantity +import Network.URI +import Data.List +import Control.Concurrent.MVar +import Control.Concurrent +import Data.Char +import Control.Monad(when) + +d = debugM "downloadqueue" +i = infoM "downloadqueue" + +data DownloadEntry a = + DownloadEntry {dlurl :: String, + dlname :: String, + usertok :: a, + dlprogress :: Progress} + +data DownloadQueue a = + DownloadQueue {pendingHosts :: [(String, [DownloadEntry a])], + -- activeDownloads :: (DownloadEntry, DownloadTok), + basePath :: FilePath, + allowResume :: Bool, + callbackFunc :: (DownloadEntry a -> DLAction -> IO ()), + completedDownloads :: [(DownloadEntry a, DownloadTok, Result)]} + +data DLAction = DLStarted DownloadTok | DLEnded (DownloadTok, ProcessStatus, Result, String) + deriving (Eq, Show) + +groupByHost :: [DownloadEntry a] -> [(String, [DownloadEntry a])] +groupByHost dllist = + combineGroups . + groupBy (\(host1, _) (host2, _) -> host1 == host2) . sortBy sortfunc . + map (\(x, y) -> (map toLower x, y)) . -- lowercase the hostnames + map conv $ dllist + where sortfunc (a, _) (b, _) = compare a b + conv de = case parseURI (dlurl de) of + Nothing -> ("", de) + Just x -> case uriAuthority x of + Nothing -> ("", de) + Just ua -> (uriRegName ua, de) + combineGroups :: [[(String, DownloadEntry a)]] -> [(String, [DownloadEntry a])] + combineGroups [] = [] + combineGroups (x:xs) = + (fst . head $ x, map snd x) : combineGroups xs + +easyDownloads :: String -- ^ Name for tracker + -> IO FilePath -- ^ Function to get base dir + -> Bool -- ^ Allow resuming + -> (Progress -> IO [DownloadEntry a]) -- ^ Function to get DLentries + -> (Progress -> ProgressMeter -> DownloadEntry a -> DownloadTok -> IO ()) -- ^ Callback when downloads starts + -> (Progress -> ProgressMeter -> DownloadEntry a -> DownloadTok -> ProcessStatus -> Result -> IO ()) -- ^ Callback that gets called after the download is complete + -> IO () + +easyDownloads ptname bdfunc allowresume getentryfunc procStart procFinish = + do maxthreads <- getMaxThreads + progressinterval <- getProgressInterval + basedir <- bdfunc + + pt <- newProgress ptname 0 + meter <- newMeter pt "B" 80 (renderNums binaryOpts 0) + meterthread <- autoDisplayMeter meter progressinterval + (displayMeter stdout) + + dlentries <- getentryfunc pt + + runDownloads (callback pt meter) basedir allowresume dlentries + maxthreads + + killAutoDisplayMeter meter meterthread + finishP pt + displayMeter stdout meter + putStrLn "" + + where callback pt meter dlentry (DLStarted dltok) = + do addComponent meter (dlprogress dlentry) + procStart pt meter dlentry dltok + callback pt meter dlentry (DLEnded (dltok, status, result, msg)) = + do removeComponent meter (dlname dlentry) + when (msg /= "") + (writeMeterString stderr meter $ + " *** " ++ dlname dlentry ++ ": Message on " ++ + tokurl dltok ++ ":\n" ++ msg ++ "\n") + procFinish pt meter dlentry dltok status result + finishP (dlprogress dlentry) + +runDownloads :: (DownloadEntry a -> DLAction -> IO ()) -> -- Callback when a download starts or stops + FilePath -> -- Base path + Bool -> -- Whether or not to allow resume + [DownloadEntry a] -> -- Items to download + Int -> -- Max number of download threads + IO [(DownloadEntry a, DownloadTok, Result)] -- The completed DLs +runDownloads callbackfunc basefp resumeOK delist maxthreads = + do oldsigs <- blocksignals + --print (map (\(h, el) -> (h, map dlurl el)) $ groupByHost delist) + dqmvar <- newMVar $ DownloadQueue {pendingHosts = groupByHost delist, + completedDownloads = [], + basePath = basefp, + allowResume = resumeOK, + callbackFunc = callbackfunc} + semaphore <- newQSem 0 -- Used by threads to signal they're done + mapM_ (\_ -> forkIO (childthread dqmvar semaphore)) [1..maxthreads] + mapM_ (\_ -> waitQSem semaphore) [1..maxthreads] + restoresignals oldsigs + withMVar dqmvar (\dq -> return (completedDownloads dq)) + +childthread :: MVar (DownloadQueue a) -> QSem -> IO () +childthread dqmvar semaphore = + do workdata <- getworkdata + if length(workdata) == 0 + then signalQSem semaphore -- We're done! + else do processChildWorkData workdata + childthread dqmvar semaphore -- And look for more hosts + where getworkdata = modifyMVar dqmvar $ \dq -> + do case pendingHosts dq of + [] -> return (dq, []) + (x:xs) -> return (dq {pendingHosts = xs}, snd x) + + getProcessStatusWithDelay pid = + do status <- getProcessStatus False False pid + case status of + Nothing -> do threadDelay 1000000 + getProcessStatusWithDelay pid + Just x -> return x + processChildWorkData [] = return [] + processChildWorkData (x:xs) = + do (basefp, resumeOK, callback) <- withMVar dqmvar + (\dq -> return (basePath dq, allowResume dq, + callbackFunc dq)) + dltok <- startGetURL (dlurl x) basefp resumeOK + callback x (DLStarted dltok) + status <- getProcessStatusWithDelay (tokpid dltok) + result <- finishGetURL dltok status + messages <- readFile (tokpath dltok ++ ".msg") + + -- Add to the completed DLs list. Also do callback here + -- so it's within the lock. Handy to prevent simultaneous + -- DB updates. + modifyMVar_ dqmvar $ \dq -> + do callback x (DLEnded (dltok, status, result, messages)) + -- Delete the messages file now that we don't + -- care about it anymore + catch (removeFile (tokpath dltok ++ ".msg")) + (\_ -> return ()) + return (dq {completedDownloads = + (x, dltok, result) : + completedDownloads dq}) + processChildWorkData xs -- Do the next one + +blocksignals = + do let sigset = addSignal sigCHLD emptySignalSet + oldset <- getSignalMask + blockSignals sigset + return oldset + +restoresignals = setSignalMask diff --git a/FeedParser.hs b/FeedParser.hs new file mode 100644 --- /dev/null +++ b/FeedParser.hs @@ -0,0 +1,163 @@ +{- hpodder component +Copyright (C) 2006 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : FeedParser + Copyright : Copyright (C) 2006 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} +module FeedParser where + +import Types +import Text.XML.HaXml +import Text.XML.HaXml.Parse +import Utils +import Data.Maybe.Utils +import Data.Char +import Data.Either.Utils +import Data.List + +data Item = Item {itemtitle :: String, + enclosureurl :: String, + enclosuretype :: String, + enclosurelength :: String + } + deriving (Eq, Show, Read) + +data Feed = Feed {channeltitle :: String, + items :: [Item]} + deriving (Eq, Show, Read) + +item2ep pc item = + Episode {podcast = pc, epid = 0, + eptitle = sanitize_basic (itemtitle item), + epurl = sanitize_basic (enclosureurl item), + eptype = sanitize_basic (enclosuretype item), epstatus = Pending, + eplength = case reads . sanitize_basic . enclosurelength $ item of + [] -> 0 + [(x, [])] -> x + _ -> 0, + epfirstattempt = Nothing, + eplastattempt = Nothing, + epfailedattempts = 0} + +parse :: FilePath -> String -> IO (Either String Feed) +parse fp name = + do c <- readFile fp + case xmlParse' name (unifrob c) of + Left x -> return (Left x) + Right y -> + do let doc = getContent y + let title = getTitle doc + let feeditems = getEnclosures doc + return $ Right $ + (Feed {channeltitle = title, items = feeditems}) + where getContent (Document _ _ e _) = CElem e + +unifrob ('\xef':'\xbb':'\xbf':x) = x -- Strip off unicode BOM +unifrob x = x + +unesc = xmlUnEscape stdXmlEscaper + +getTitle doc = forceEither $ strofm "title" (channel doc) + +getEnclosures doc = + concat . map procitem $ item doc + where procitem i = map (procenclosure title) enclosure + where title = case strofm "title" [i] of + Left x -> "Untitled" + Right x -> x + enclosure = tag "enclosure" `o` children $ i + procenclosure title e = + Item {itemtitle = title, + enclosureurl = head0 $ forceMaybe $ stratt "url" e, + enclosuretype = head0 $ case stratt "type" e of + Nothing -> ["application/octet-stream"] + Just x -> x, + enclosurelength = head $ case stratt "length" e of + Nothing -> ["0"] + Just [] -> ["0"] + Just x -> x + } + head0 [] = "" + head0 (x:xs) = x + + +item = tag "item" `o` children `o` channel + +channel = + tag "channel" `o` children `o` tag "rss" + + +-------------------------------------------------- +-- Utilities +-------------------------------------------------- + +attrofelem :: String -> Content -> Maybe AttValue +attrofelem attrname (CElem inelem) = + case unesc inelem of + Elem name al _ -> lookup attrname al +attrofelem _ _ = + error "attrofelem: called on something other than a CElem" +stratt :: String -> Content -> Maybe [String] +stratt attrname content = + case attrofelem attrname content of + Just (AttValue x) -> Just (concat . map mapfunc $ x) + Nothing -> Nothing + where mapfunc (Left x) = [x] + mapfunc (Right _) = [] + +-- Finds the literal children of the named tag, and returns it/them +tagof :: String -> CFilter +tagof x = keep /> tag x -- /> txt + +-- Retruns the literal string that tagof would find +strof :: String -> Content -> String +strof x y = forceEither $ strof_either x y + +strof_either :: String -> Content -> Either String String +strof_either x y = + case tagof x $ y of + [CElem elem] -> Right $ verbatim $ tag x /> txt $ CElem (unesc elem) + z -> Left $ "strof: expecting CElem in " ++ x ++ ", got " + ++ verbatim z ++ " at " ++ verbatim y + +strofm x y = + if length errors /= 0 + then Left errors + else Right (concat plainlist) + where mapped = map (strof_either x) $ y + (errors, plainlist) = conveithers mapped + isright (Left _) = False + isright (Right _) = True + +conveithers :: [Either a b] -> ([a], [b]) +conveithers inp = worker inp ([], []) + where worker [] y = y + worker (Left x:xs) (lefts, rights) = + worker xs (x:lefts, rights) + worker (Right x:xs) (lefts, rights) = + worker xs (lefts, x:rights) + diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -0,0 +1,75 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Types + Copyright : Copyright (C) 2006-2007 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} +module Types where +import Data.ConfigFile +import Database.HDBC + +data IConnection a => GlobalInfo a = GlobalInfo {gcp :: ConfigParser, + gdbh :: a} + +data EpisodeStatus = Pending -- ^ Ready to download + | Downloaded -- ^ Already downloaded + | Error -- ^ Error downloading + | Skipped -- ^ Skipped by some process or other + deriving (Eq, Show, Read, Ord, Enum) + +data PCEnabled = PCUserDisabled | PCEnabled | PCErrorDisabled + deriving (Eq, Show, Read, Ord, Enum) + +data Podcast = Podcast {castid :: Integer, + castname :: String, + feedurl :: String, + pcenabled :: PCEnabled, + lastupdate :: Maybe Integer, -- Last successful update + lastattempt :: Maybe Integer, -- Last attempt + failedattempts :: Integer} -- failed attempts since last success + deriving (Eq, Show, Read) + +instance Ord Podcast where + compare pc1 pc2 = compare (castname pc1) (castname pc2) + +data Episode = Episode {podcast :: Podcast, + epid :: Integer, + eptitle :: String, + epurl :: String, + eptype :: String, + epstatus :: EpisodeStatus, + eplength :: Integer, + epfirstattempt :: Maybe Integer, -- Last successful updat + eplastattempt :: Maybe Integer, -- Last attempt + epfailedattempts :: Integer} + deriving (Eq, Show, Read) + +data IConnection a => Command a = + Command {cmdname :: String, + cmddescrip :: String, + execcmd :: [String] -> GlobalInfo a -> IO ()} + diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,125 @@ +{- hpodder component +Copyright (C) 2006-2007 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Utils + Copyright : Copyright (C) 2006-2007 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} + +module Utils where +import System.Console.GetOpt.Utils +import System.Console.GetOpt +import Types +import System.Exit +import Config +import System.Directory +import Database.HDBC +import Data.List.Utils +import System.Time +import System.Time.Utils +import System.IO +import System.Posix.IO +import Control.Exception(finally) + +simpleCmd :: IConnection conn => + String -> String -> String -> [OptDescr (String, String)] + -> (GlobalInfo conn -> ([(String, String)], [String]) -> IO ()) + -> (String, Command conn) +simpleCmd name descrip helptext optionsinp func = + (name, Command {cmdname = name, cmddescrip = descrip, + execcmd = worker}) + where options = + optionsinp ++ [Option "" ["help"] (NoArg ("help", "")) "Display this help"] + worker argv gi = + case getOpt RequireOrder options argv of + (o, n, []) -> + if (lookup "help" o == Just "") + then usageerror [] + else func gi (o, n) + (_, _, errors) -> usageerror (concat errors) + usageerror errormsg = + do putStrLn $ "Error processing arguments for command " ++ + name ++ ":" + putStrLn errormsg + putStrLn (usageInfo header options) + putStrLn helptext + exitFailure + header = "Available command-options for " ++ name ++ " are:\n" + + +initDirs = + do appdir <- getAppDir + mapM_ mkdir [appdir, appdir ++ "/feedxfer", appdir ++ "/enclosurexfer"] + where mkdir = createDirectoryIfMissing True + +lock func = + do appdir <- getAppDir + lockh <- openFile (appdir ++ "/.lock") WriteMode + lockfd <- handleToFd lockh + catch (placelock lockfd) errorhandler + r <- finally func (releaselock lockfd) + return r + + where placelock lockfd = setLock lockfd (WriteLock, AbsoluteSeek, 0, 0) + releaselock lockfd = do + setLock lockfd (Unlock, AbsoluteSeek, 0, 0) + closeFd lockfd + errorhandler _ = + do putStrLn "Aborting because another hpodder is already running" + exitFailure + + +sanitize_basic inp = + case filter (\c -> not (c `elem` "\n\r\t\0")) inp of + ('-':x) -> ('_':x) -- Strip leading hyphen + x -> x + +sanitize_fn inp = + case map worker . sanitize_basic $ inp of + [] -> "UNKNOWN" + x -> x + where worker x = if x `elem` ";/|!`~ *?%^&(){}[]\\'\"<>:" + then '_' + else x + +genericIdHelp = + "You can optionally specify one or more podcast IDs. If given,\n\ + \only those IDs will be selected for processing.\n\n\ + \The special id \"all\" will select all podcast IDs.\n" + +now :: IO Integer +now = do ct <- getClockTime + return (clockTimeToEpoch ct) + +filter_disabled = filter (\x -> pcenabled x == PCEnabled) + +-- | Delete files in a given directory, but not the directory itself +emptyDir :: FilePath -> IO () +emptyDir fp = + do dircontents <- getDirectoryContents fp + mapM_ (\f -> catch (removeFile $ fp ++ "/" ++ f) (\_ -> return ())) + dircontents + diff --git a/hpodder.cabal b/hpodder.cabal --- a/hpodder.cabal +++ b/hpodder.cabal @@ -1,5 +1,5 @@ Name: hpodder -Version: 1.0.0 +Version: 1.0.2 License: GPL Maintainer: John Goerzen Author: John Goerzen @@ -68,6 +68,11 @@ Executable: hpodder Main-Is: hpodder.hs +Other-Modules: Commands, Config, DB, Download, DownloadQueue, FeedParser, + Types, Utils, Commands.Add, Commands.Catchup, Commands.Download, + Commands.EnableDisable, Commands.ImportIpodder, Commands.Ls, + Commands.Rm, Commands.SetStatus, Commands.SetTitle, + Commands.Setup, Commands.Update GHC-Options: -O2 Extensions: ExistentialQuantification, OverlappingInstances, UndecidableInstances