[Basic HTML rendering except items
Manuel M T Chakravarty **20060427225105] {
addfile ./Config.hs
hunk ./Config.hs 1
+-- |A simple feed generator: Configuration management and command line parsing
+--
+-- Copyright (c) 2006 Manuel M T Chakravarty
+--
+-- License:
+--
+--- Description ---------------------------------------------------------------
+--
+-- Language: Haskell 98
+--
+
+module Config (
+
+ -- * File suffixes
+ chanSuffix, itemSuffix, htmlSuffix, rssSuffix,
+
+ -- * Configuration record
+ Config(..),
+
+ -- * Command line argument parsing
+ processArgs
+
+) where
+
+-- hierachical libraries
+--
+
+import Control.Monad (
+ when, foldM)
+
+import System.Console.GetOpt (
+ ArgOrder(..), OptDescr(..), ArgDescr(..), getOpt, usageInfo)
+import System.Environment (
+ getArgs, getProgName)
+
+-- lambdaFeed
+import Error (
+ abortWithIO, exitSuccess)
+
+
+-- Version information
+-- -------------------
+
+name = "lambdaFeed"
+versnum = "0.1.0"
+versnick = "\"Lambdas for all!\""
+date = "26 Apr 2006"
+version = name ++ ", version " ++ versnum ++ " " ++ versnick ++ ", " ++ date
+copyright = "Copyright (c) 2006 Manuel M T Chakravarty"
+disclaimer = "This software is distributed under the \
+ \terms of the GNU Public Licence.\n\
+ \NO WARRANTY WHATSOEVER IS PROVIDED. \
+ \See ."
+
+
+-- Constants
+-- ---------
+
+-- Suffixes
+--
+chanSuffix = "lfc"
+itemSuffix = "lfi"
+htmlSuffix = "html"
+rssSuffix = "xml"
+
+
+-- Dynamic configuration
+-- ---------------------
+
+-- Configuration
+--
+data Config = Config {
+ debugCfg :: Int,
+ feedDirCfg :: FilePath,
+ htmlDirCfg :: FilePath,
+ rssDirCfg :: FilePath,
+ verboseCfg :: Bool,
+ quietCfg :: Bool
+ }
+
+-- Default configuration
+--
+dftConfig = Config {
+ debugCfg = 0,
+ feedDirCfg = "feed",
+ htmlDirCfg = "",
+ rssDirCfg = "",
+ verboseCfg = False,
+ quietCfg = False
+ }
+
+-- Available options
+--
+data Option = Debug
+ | FeedDirOpt FilePath
+ | Help
+ | HTMLDirOpt FilePath
+ | RSSDirOpt FilePath
+ | OutputOpt FilePath
+ | Verbose
+ | Version
+ | Quiet
+ deriving Eq
+
+-- Option description
+--
+options :: [OptDescr Option]
+options = [ Option ['d'] ["debug"] (NoArg Debug)
+ "produces extra diagnostic output; repeat for more"
+ , Option ['f'] ["feed"] (ReqArg FeedDirOpt "DIR")
+ "feed directory with channel descriptions (default: feed/)"
+ , Option ['h', '?'] ["help"] (NoArg Help)
+ "this help message"
+ , Option [] ["htmldir"] (ReqArg HTMLDirOpt "DIR")
+ "target directory for generated HTML files"
+ , Option [] ["rssdir"] (ReqArg RSSDirOpt "DIR")
+ "target directory for generated RSS 2.0 files"
+ , Option ['o'] ["output"] (ReqArg OutputOpt "DIR")
+ "sets target directory for both HTML and RSS 2.0 files"
+ , Option ['v'] ["verbose"] (NoArg Verbose)
+ "print summary information (default: off)"
+ , Option ['V'] ["version"] (NoArg Version)
+ "version information"
+ , Option ['q'] ["quiet"] (NoArg Quiet)
+ "suppress all output, including parser warnings"
+ ]
+
+-- Option processing
+--
+processArgs :: IO Config
+processArgs =
+ do
+ args <- getArgs
+ case getOpt RequireOrder options args of
+ (opts, [] , [] ) -> processVersion opts >>=
+ processHelp >>=
+ processConfig dftConfig
+ (opts, args, [] ) -> abort [unrecErr ++ unwords args]
+ (_ , _ , errs) -> abort errs
+ where
+ unrecErr = "Unrecognised arguments: "
+
+-- Print version information if `Help' or `Version' requested and remove any
+-- `Version' options.
+--
+processVersion :: [Option] -> IO [Option]
+processVersion opts =
+ do
+ when (Version `elem` opts || Help `elem` opts) $ do
+ putStrLn version
+ putStrLn copyright
+ putStrLn disclaimer
+ return $ filter (/= Version) opts
+
+-- Print help information if `Help' requested and terminate successfully.
+--
+processHelp :: [Option] -> IO [Option]
+processHelp opts =
+ do
+ name <- getProgName
+ let header = "\nUsage: " ++ name ++ " [ option... ]\n"
+ when (Help `elem` opts) $ do
+ putStrLn $ usageInfo header options
+ exitSuccess
+ return opts
+
+-- Process configuration options.
+--
+processConfig :: Config -> [Option] -> IO Config
+processConfig = foldM processOneOption
+ where
+ processOneOption config Debug =
+ return $ config {debugCfg = debugCfg config + 1}
+ processOneOption config (FeedDirOpt dir) =
+ return $ config {feedDirCfg = dir}
+ processOneOption config (HTMLDirOpt dir) =
+ return $ config {htmlDirCfg = dir}
+ processOneOption config (RSSDirOpt dir) =
+ return $ config {rssDirCfg = dir}
+ processOneOption config (OutputOpt dir) =
+ return $ config {htmlDirCfg = dir, rssDirCfg = dir}
+ processOneOption config Verbose =
+ return $ config {verboseCfg = True}
+ processOneOption config Quiet =
+ return $ config {quietCfg = True}
+
+-- Error during parsing command line options
+--
+abort :: [String] -> IO a
+abort =
+ abortWithIO . (++ ["Try the option `--help' on its own for more \
+ \information."])
+
hunk ./Date.hs 13
- Date(..), parseDate,
+ Date(..), addMinutes, parseDate,
hunk ./Date.hs 28
- Month(..), ClockTime, CalendarTime(..), toUTCTime, toClockTime,
- formatCalendarTime)
+ Month(..), ClockTime, TimeDiff(..), CalendarTime(..), noTimeDiff,
+ addToClockTime, toUTCTime, toClockTime, formatCalendarTime)
hunk ./Date.hs 48
+-- Advance a date specification by the specified number of minutes.
+--
+addMinutes :: Date -> Int -> Date
+addMinutes (Date ct) min =
+ Date $ addToClockTime (noTimeDiff {tdMin = min}) ct
+
hunk ./Error.hs 13
- elementErrStr, abortWith
+
+ -- * Error formatting
+ elementErrStr,
+
+ -- * Program termination
+ abortWith, abortWithIO, exitSuccess
+
hunk ./Error.hs 22
+-- hierachical libraries
+import System.Environment (
+ getProgName)
+import System.Exit (
+ ExitCode(..), exitWith, exitFailure)
+
+
hunk ./Error.hs 41
+-- Terminate with a set of errors (in IO code).
+--
+abortWithIO :: [String] -> IO a
+abortWithIO errs =
+ do
+ name <- getProgName
+ putStrLn $ name ++ ": FATAL ERROR"
+ putStr (unlines errs)
+ exitFailure
hunk ./Error.hs 51
+-- Terminate sucessfully.
+--
+exitSuccess :: IO a
+exitSuccess = exitWith ExitSuccess
hunk ./Feed.hs 16
- Enclosure(..), GUID(..), Source(..),
+ Enclosure(..), GUID(..), Source(..), Info(..),
hunk ./Feed.hs 67
- itemsChan :: items
+ itemsChan :: items,
+ infoChan :: Info -- internal info about a channel
hunk ./Feed.hs 135
+-- lambdaFeed specific information about a channel
+--
+data Info = Info {
+ fnameInfo :: FilePath -- basename of .lfc
+ }
+ deriving Show
+
hunk ./Feed.hs 166
- itemsChan = error "channel missing items (after copy)"
+ itemsChan = error "channel missing items (after copy)",
+ infoChan = infoChan chan
hunk ./Feed.hs 193
- itemsChan = error "channel missing items"
+ itemsChan = error "channel missing items",
+ infoChan = error "channel missing info"
hunk ./LambdaFeed.hs 65
+-- * Synthetic channels: Channels that don't have an item directory, but
+-- instead instructions on how to synthesise them from other channels by
+-- eg, merging and filtering.
+--
+-- * Don't regenerate a channel if neither its description nor items changed.
+--
hunk ./LambdaFeed.hs 72
--- URLs, same for email addresses.
+-- URLs, same for email addresses, but only warnings in case of errors.
hunk ./LambdaFeed.hs 77
+-- * Use plugins to do the reading and writing of various formats and for
+-- formatting the feed. Also for configuration as in Yi.
+--
hunk ./LambdaFeed.hs 90
- when, foldM, liftM)
+ liftM)
hunk ./LambdaFeed.hs 97
-import System.Console.GetOpt (
- ArgOrder(..), OptDescr(..), ArgDescr(..), getOpt, usageInfo)
+import Numeric (
+ showFFloat)
+
+import System.CPUTime (
+ getCPUTime)
hunk ./LambdaFeed.hs 104
-import System.Environment (
- getArgs, getProgName)
-import System.Exit (
- ExitCode(..), exitWith, exitFailure)
hunk ./LambdaFeed.hs 110
+import Config (
+ version,
+ chanSuffix, itemSuffix, htmlSuffix, rssSuffix,
+ Config(..), processArgs)
hunk ./LambdaFeed.hs 117
- elementErrStr, abortWith)
+ elementErrStr, abortWith, abortWithIO, exitSuccess)
hunk ./LambdaFeed.hs 120
- Enclosure(..), GUID(..), Source(..),
+ Enclosure(..), GUID(..), Source(..), Info(..),
hunk ./LambdaFeed.hs 123
+import HTML (
+ channelToHTML)
+import RSS (
+ channelToRSS)
hunk ./LambdaFeed.hs 132
--- Version information
--- -------------------
-
-name = "lambdaFeed"
-versnum = "0.1.0"
-versnick = "\"Lambdas for all!\""
-date = "26 Apr 2006"
-version = name ++ ", version " ++ versnum ++ " " ++ versnick ++ ", " ++ date
-copyright = "Copyright (c) 2006 Manuel M T Chakravarty"
-disclaimer = "This software is distributed under the \
- \terms of the GNU Public Licence.\n\
- \NO WARRANTY WHATSOEVER IS PROVIDED. \
- \See ."
-
-
--- Configuration
--- -------------
-
--- Constants
---
-chanSuffix = "lfc"
-itemSuffix = "lfi"
-
--- Configuration
---
-data Config = Config {
- debugCfg :: Int,
- feedDirCfg :: FilePath,
- verboseCfg :: Bool,
- quietCfg :: Bool
- }
-
--- Default configuration
---
-dftConfig = Config {
- debugCfg = 0,
- feedDirCfg = "feed",
- verboseCfg = False,
- quietCfg = False
- }
-
--- Available options
---
-data Option = Debug
- | FeedDirOpt FilePath
- | Help
- | Verbose
- | Version
- | Quiet
- deriving Eq
-
--- Option description
---
-options :: [OptDescr Option]
-options = [ Option ['d'] ["debug"] (NoArg Debug)
- "produces extra diagnostic output; repeat for more"
- , Option ['f'] ["feed"] (ReqArg FeedDirOpt "DIR")
- "feed directory with channel descriptions (default: feed/)"
- , Option ['h', '?'] ["help"] (NoArg Help)
- "this help message"
- , Option ['v'] ["verbose"] (NoArg Verbose)
- "print summary information (default: off)"
- , Option ['V'] ["version"] (NoArg Version)
- "version information"
- , Option ['q'] ["quiet"] (NoArg Quiet)
- "suppress all output, including parser warnings"
- ]
-
--- Option processing
---
-processOptions :: [String] -> IO Config
-processOptions args =
- case getOpt RequireOrder options args of
- (opts, [] , [] ) -> processVersion opts >>=
- processHelp >>=
- processConfig dftConfig
- (opts, args, [] ) -> abortWithOptionsErrors [unrecErr ++ unwords args]
- (_ , _ , errs) -> abortWithOptionsErrors errs
- where
- unrecErr = "Unrecognised arguments: "
-
--- Print version information if `Help' or `Version' requested and remove any
--- `Version' options.
---
-processVersion :: [Option] -> IO [Option]
-processVersion opts =
- do
- when (Version `elem` opts || Help `elem` opts) $ do
- putStrLn version
- putStrLn copyright
- putStrLn disclaimer
- return $ filter (/= Version) opts
-
--- Print help information if `Help' requested and terminate successfully.
---
-processHelp :: [Option] -> IO [Option]
-processHelp opts =
- do
- name <- getProgName
- let header = "\nUsage: " ++ name ++ " [ option... ]\n"
- when (Help `elem` opts) $ do
- putStrLn $ usageInfo header options
- exitWith ExitSuccess
- return opts
-
--- Process configuration options.
---
-processConfig :: Config -> [Option] -> IO Config
-processConfig = foldM processOneOption
- where
- processOneOption config Debug =
- return $ config {debugCfg = debugCfg config + 1}
- processOneOption config (FeedDirOpt dir) =
- return $ config {feedDirCfg = dir}
- processOneOption config Verbose =
- return $ config {verboseCfg = True}
- processOneOption config Quiet =
- return $ config {quietCfg = True}
-
--- Error during parsing command line options
---
-abortWithOptionsErrors :: [String] -> IO a
-abortWithOptionsErrors errs =
- do
- putStrLn (unlines errs)
- putStrLn "Try the option `--help' on its own for more information."
- exitFailure
-
-
hunk ./LambdaFeed.hs 137
-data Summary = Summary
+data Summary = Summary {
+ -- number of items for each cannel
+ channelItemsSummary :: [Int]
+ }
hunk ./LambdaFeed.hs 176
+ generatorChan = version,
hunk ./LambdaFeed.hs 178
- itemsChan = dirname fname itemsChan chan
+ itemsChan = dirname fname itemsChan chan,
hunk ./LambdaFeed.hs 180
+ infoChan = Info {
+ fnameInfo = (stripSuffix . basename) fname
+ }
hunk ./LambdaFeed.hs 217
--- Write feed data to RSS files.
+-- Generate the requested feed representation.
+--
+formatFeed :: Config -> Feed [Item] -> IO (Feed [Item])
+formatFeed config feed =
+ return feed
+
+-- Write feed data to HTML and RSS files.
hunk ./LambdaFeed.hs 226
-writeFeed config feed =
+writeFeed config (Feed chans) =
hunk ./LambdaFeed.hs 228
- return $ undefined
+ mapM generateHTML chans
+ mapM generateRSS chans
+ return $ Summary {channelItemsSummary = map (length . itemsChan) chans}
+ where
+ generateHTML chan =
+ do
+ let fname = htmlDirCfg config (fnameInfo . infoChan) chan <.>
+ htmlSuffix
+ writeFile fname (channelToHTML config chan)
+ generateRSS chan =
+ do
+ let fname = rssDirCfg config (fnameInfo . infoChan) chan <.>
+ rssSuffix
+ writeFile fname (channelToRSS config chan)
+
hunk ./LambdaFeed.hs 249
- return ()
+ pico <- getCPUTime
+ let noChannels = length (channelItemsSummary summary)
+ noItems = sum (channelItemsSummary summary)
+ secs = fromInteger (pico `div` 1000000000) / 1000 :: Float
+ sayV config $ "Processed " ++ show noItems ++ " item(s) in " ++
+ show noChannels ++ " channel(s) in " ++
+ showFFloat (Just 3) secs "s."
hunk ./LambdaFeed.hs 599
+-- Remove the suffix from a filename.
+--
+stripSuffix :: FilePath -> String
+stripSuffix fname | null fname' = fname
+ | otherwise = reverse (tail fname')
+ where
+ fname' = dropWhile (/= '.') . reverse $ fname
+
+-- Drop the directory of a path.
+--
+basename :: FilePath -> String
+basename fname | null fname' = fname
+ | otherwise = fname'
+ where
+ fname' = reverse . takeWhile (/= '/') . reverse $ fname
+
hunk ./LambdaFeed.hs 630
+-- Join a suffix to a file name.
+--
+(<.>) :: FilePath -> String -> FilePath
+fname <.> "" = fname
+fname <.> suffix = fname ++ "." ++ suffix
+
hunk ./LambdaFeed.hs 665
- args <- getArgs
- config <- processOptions args
- (readFeed config >>= writeFeed config >>= printSummary config)
- `catch` \e -> abort (show e)
- exitWith ExitSuccess
- where
- abort err =
- do
- name <- getProgName
- putStrLn $ name ++ ": " ++ err
+ config <- processArgs
+ ( readFeed config
+ >>= formatFeed config
+ >>= writeFeed config
+ >>= printSummary config)
+ `catch` \e -> abortWithIO [show e]
+ exitSuccess
}