feed-cli-2009.7.5: FeedCLI.hs

{-

TODO / ideas:
- try using it for something :)
- --watch mode that runs feed-cli at a given interval
- attachments
- when adding an item to a non-existant feed, create a new feed file?
- use -c"command --arg" instead of --pipe-mode so we can get more information about a command being run?
- delete oldest feeds instead of front feeds
- implement very simple version? ./feed-cli title "this is description" or so?
- clean up parameter checks, -D others
- --format=atom, rss 
- test it against feed verifyer - http://feedvalidator.org/

DONE:
- --pipe-mode = stdin becomes description, subject is command run, time, return value? echo items to screen?  or maybe use -c"command" for more control?
- clean up num parser for better error
- input & output from files
- description input from file
- --update file instead of -i and -o - if -i and -o are the same, or if they use -u then create a temp file and update.
--limit=10 delete the oldest feeds so that only 10 remain - could stand alone as a command?
-}
module Main where

import Text.RSS.Syntax (RSS (..), RSSChannel (..), RSSItem (..), nullItem, nullRSS)
import Text.RSS.Export (xmlRSS)
import Text.RSS.Import (elementToRSS)

import Text.XML.Light.Output (showTopElement)
import Text.XML.Light.Input (parseXMLDoc)

import System.Environment(getArgs)
import System.Locale (defaultTimeLocale)
import System.IO (openTempFile, openFile, hGetContents
                 , hClose, hPutStr, IOMode(..), stdin)
import System.Directory (renameFile)
import System.Directory(doesFileExist)

import Data.Maybe(fromJust, fromMaybe)
import Control.Monad(when)
import Data.Time.Clock (getCurrentTime, UTCTime)
import Data.Time.Format (formatTime)

import Options (Options(..), LimitType (..), DescType (..), parseOpts)

------------------------------------------------------------
-- * Helpers
------------------------------------------------------------

inetFormat             :: UTCTime -> String
inetFormat t            = formatTime defaultTimeLocale "%a, %d %b %Y %T GMT" t

notImplemented :: String -> a
notImplemented a = error $ a ++ " not implemented."

-- * Transformers
addFeedItem :: RSS -> RSSItem -> RSS
addFeedItem feed item
    = let oldChannel = rssChannel feed
          oldItems = rssItems oldChannel in
       feed{rssChannel=oldChannel{rssItems=item:oldItems}}

------------------------------------------------------------
-- * IO
------------------------------------------------------------

writeRSS :: Maybe FilePath -- If they haven't provided an argument, stdout.
         -> RSS
         -> Bool -- ^create a temporary file?
         -> FilePath -- ^directory for temporary files
         -> IO ()
writeRSS (Just outFile) rss createTemp tmpDir = do
  (fileToWrite, h) <- if createTemp
                       then openTempFile tmpDir ("rssGenTemp.xml") -- fix: portable?
                       else do h' <- openFile outFile WriteMode
                               return (outFile, h')
  hPutStr h (showTopElement $ xmlRSS rss)
  hClose h
  when createTemp (renameFile fileToWrite outFile)

writeRSS Nothing rss _ _ = putStrLn $  showTopElement $ xmlRSS rss

-- Throw some sane exceptions open file fail, etc.  Creates basic empty feed if it doesn't exist
readRSS :: FilePath -> IO RSS
readRSS inFile = do
  exists <- doesFileExist inFile
  when (not exists) (
     (error ("input file doesn't exist: " ++ inFile
          ++ "\n(hint, use ./feed-cli new-feed)" ))
   )
  xmlStr <- readFile inFile
  let mXmlDoc = parseXMLDoc xmlStr
  return $ fromJust $ elementToRSS (fromJust mXmlDoc)


------------------------------------------------------------
-- * Handling Commands & Main
------------------------------------------------------------

handleCommands :: Options
               -> [String]
               -> IO ()
handleCommands opts command = do
    case command of
      ["new-feed"] -> doNewFeed opts
      ["new-item"] -> doNewItem opts
      c -> error ("unknown command: " ++ (show c))

------------------------------------------------------------

-- |Take the given number of elements from the front. Don't compare time yet.
limitItems :: RSS -- ^ the feed to filter
           -> Integer -- ^Max items
           -> RSS -- ^the feed with max items
limitItems rss limit
    = let oldChannel = rssChannel rss
          oldItems   = rssItems oldChannel
          newItems   = take (fromIntegral limit) oldItems
       in rss{rssChannel=oldChannel{rssItems=newItems}}

doNewItem :: Options -> IO ()
doNewItem opts = do
  let mOutFile = optOutput opts
  let feedTitle = optTitle opts

  let mLink = optLink opts
  -- fix: These will become more flexible when we have more commands we can do:
  let inFile = fromMaybe (error "infile required") (optInput opts)
  let createTemp = Just inFile == mOutFile
  let mLimit = optLimit opts
  let tmpDir = optTmpDir opts

  feedDescription <- getDescription (optDescription opts) (optPreDesc opts)

  readFeed <- readRSS inFile
  time <- getCurrentTime
  let emptyItem = nullItem feedTitle
  let newItem=emptyItem{rssItemPubDate=Just (inetFormat time)
                       ,rssItemDescription = Just feedDescription
                       ,rssItemLink = mLink
                       }
  let feedWithItem = addFeedItem readFeed newItem
  let newFeed
       = case mLimit of
           NoLimit  -> addFeedItem readFeed newItem
           KeepLimit -> limitItems feedWithItem
                          (fromIntegral $ length $ rssItems $ rssChannel readFeed)
           NumLimit lim -> limitItems feedWithItem lim
  writeRSS mOutFile newFeed createTemp tmpDir


getDescription :: DescType
               -> Bool -- add <pre>description</pre> tags?
               -> IO String
getDescription oDescription pre = do
  desc <- case oDescription of
            DescCLI s -> return s
            DescFile d  -> readFile d
            DescSTDIN -> hGetContents stdin
  return $ if pre then ("<pre>" ++ desc ++ "</pre>") else desc



doNewFeed :: Options -> IO ()
doNewFeed opts = do
  let mOutFile = optOutput opts
  let title = optTitle opts
  desc <- getDescription (optDescription opts) (optPreDesc opts)
  let mLink = optLink opts
  let link = fromMaybe (error "--link required") mLink
  let tmpDir = optTmpDir opts

  let newRSS = nullRSS title link
  let newChannel = (rssChannel newRSS){rssDescription = desc}

  writeRSS mOutFile newRSS{rssChannel=newChannel} False tmpDir

------------------------------------------------------------

main :: IO ()
main = do args <- getArgs
          (opts, command) <- parseOpts args
          handleCommands opts command