packages feed

hpodder 1.0.0 → 1.0.2

raw patch · 20 files changed

+2361/−1 lines, 20 files

Files

+ Commands.hs view
@@ -0,0 +1,102 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+   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"
+ Commands/Add.hs view
@@ -0,0 +1,48 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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"
+ Commands/Catchup.hs view
@@ -0,0 +1,70 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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"
+ Commands/Download.hs view
@@ -0,0 +1,289 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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"
+ Commands/EnableDisable.hs view
@@ -0,0 +1,72 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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"
+ Commands/ImportIpodder.hs view
@@ -0,0 +1,113 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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+
+ Commands/Ls.hs view
@@ -0,0 +1,96 @@+{- hpodder component+Copyright (C) 2006 John Goerzen <jgoerzen@complete.org>++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"
+ Commands/Rm.hs view
@@ -0,0 +1,65 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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"
+ Commands/SetStatus.hs view
@@ -0,0 +1,82 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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"
+ Commands/SetTitle.hs view
@@ -0,0 +1,68 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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"
+ Commands/Setup.hs view
@@ -0,0 +1,110 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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"]+
+ Commands/Update.hs view
@@ -0,0 +1,160 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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."
+ Config.hs view
@@ -0,0 +1,104 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+   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"
+ DB.hs view
@@ -0,0 +1,267 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+   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
+ Download.hs view
@@ -0,0 +1,139 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+   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+
+ DownloadQueue.hs view
@@ -0,0 +1,207 @@+{- hpodder component+Copyright (C) 2006 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+   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
+ FeedParser.hs view
@@ -0,0 +1,163 @@+{- hpodder component+Copyright (C) 2006 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+   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)+
+ Types.hs view
@@ -0,0 +1,75 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+   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 ()}+
+ Utils.hs view
@@ -0,0 +1,125 @@+{- hpodder component+Copyright (C) 2006-2007 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+   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+
hpodder.cabal view
@@ -1,5 +1,5 @@ Name: hpodder-Version: 1.0.0+Version: 1.0.2 License: GPL Maintainer: John Goerzen <jgoerzen@complete.org> 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