DB.hs

{- hpodder component
Copyright (C) 2006-2008 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-2008 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 5 _ = return ()

upgradeSchema dbh 4 tables =
    do dbdebug "Upgrading schema 4 -> 5"
       dbdebug "Recreating episodes table to add epguid column and UNIQUE constaint"
       -- Silly sqlite can't add a UNIQUE constaint to an existing table, so we
       -- have to recreate it.
       run dbh "CREATE TABLE episodes5 (\
               \castid INTEGER NOT NULL,\
               \episodeid INTEGER NOT NULL,\
               \title TEXT NOT NULL,\
               \epurl TEXT NOT NULL,\
               \enctype TEXT NOT NULL,\
               \status TEXT NOT NULL,\
               \eplength INTEGER NOT NULL DEFAULT 0,\
               \epfirstattempt INTEGER,\
               \eplastattempt INTEGER,\
               \epfailedattempts INTEGER NOT NULL DEFAULT 0,\
               \epguid TEXT,\
               \UNIQUE(castid, epurl),\
               \UNIQUE(castid, episodeid),\
               \UNIQUE(castid, epguid))" []
       dbdebug "Copying data from old episodes table"
       run dbh "INSERT INTO episodes5 SELECT *, NULL FROM episodes" []
       dbdebug "Dropping old episodes table"
       run dbh "DROP TABLE episodes" []
       dbdebug "Renaming new episodes table"
       run dbh "ALTER TABLE episodes5 RENAME TO episodes" []

       setSchemaVer dbh 5
       commit dbh
       upgradeSchema dbh 5 tables

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 4 tables

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, epguid 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, sepguid] =
              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,
                       epguid = fromSql sepguid}
          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, based solely on
looking at the GUID (if present), update the URL and title fields while 
preserving other fields as they are. Returns the number of inserted rows. -}
addEpisode :: Connection -> Episode -> IO Integer
addEpisode dbh ep = 
    do 
       -- We have to be careful of cases where a feed may have two
       -- different episodes with different GUIDs but identical URLs.
       -- So if we have a GUID match here, we must have a conflict on URL,
       -- so we ignore the request to change it.
       when (epguid ep /= Nothing) $
          do run dbh "UPDATE OR IGNORE episodes SET epurl = ?, epguid = ?, title = ? \
                  \WHERE castid = ? AND epguid = ?"
                 [toSql (epurl ep), toSql (epguid ep), toSql (eptitle ep),
                  toSql (castid (podcast ep)), toSql (epguid ep)]
             return ()
       -- if the UPDATE was successful, that means that something with the same
       -- URL or GUID already exists, so the INSERT below will be ignored.
       dbdebug "update done"
       nextepid <- getepid
       dbdebug $ "addEpisode: epid: " ++ show nextepid
       dbdebug "addEpisode: running insertEpisode"
       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, epguid) 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),
            toSql (epguid 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