generate static news page with haskell

news.hs

{-

this code is licensed under a "bsd" license, which is stated below

Copyright (c) 2007, Brad Clawsie. All rights reserved.
http://b7j0c.org/stuff/license.txt

-}

{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
module Main (main) where
import qualified Text.XHtml.Strict as X
import qualified Text.XML.HXT.Arrow as HXT
import qualified Network.HTTP.Simple as H (httpGet)
import qualified Network.URI as U (parseURI)
import qualified Data.String.Utils as S (replace,strip,startswith,join)
import qualified Data.Tree.NTree.TypeDefs as T (NTree(..))
import qualified Control.Monad as M (mapM)
import qualified System.Time (getClockTime,ClockTime(..))
import qualified Data.Map as DM (lookup,Map(..))
import qualified Finance.Quote.Yahoo as Q (getQuote,
                                           QuoteSymbol(..),
                                           QuoteValue(..),
                                           QuoteField(..))

-- These are the RSS feeds we want to use for our news section.
feeds = [("top stories","http://rss.news.yahoo.com/rss/topstories"),
         ("most emailed","http://rss.news.yahoo.com/rss/mostemailed"),
         ("business","http://rss.news.yahoo.com/rss/business"),
         ("tech","http://rss.news.yahoo.com/rss/tech"),
         ("linux","http://rss.news.yahoo.com/rss/linux")] :: [(String,String)]

-- For our stocks section, these are the tickers and fields. All
-- fields are from Yahoo Finance
symbols = ["^DJI","^IXIC","^GSPC","^TNX","^N225",
           "YHOO","GOOG","MSFT","EBAY","GLD"] :: [Q.QuoteSymbol]
fields = ["s","l1","c"] :: [Q.QuoteField]

-- For a given RSS feed (uri), return a list of (title,printurl) tuples.
rss2Tuple :: String -> IO [(String,String)]
rss2Tuple u =
  case U.parseURI u of
    Nothing -> error("malformed uri:" ++ u)
    Just uri ->
        do
          tryGet <- H.httpGet uri
          case tryGet of
            Nothing -> error("http get error for " ++ u)
            Just xmlText -> -- the RSS xml
                do
                  let xml = HXT.readString [(HXT.a_validate,HXT.v_0)] xmlText
                  -- each "item" is a tuple: (link title, link printurl)
                  items <- HXT.runX (xml HXT.>>> getItems)
                  return items
        where
          -- For each RSS item, extract the link and make a printurl
          getItems :: (HXT.ArrowXml a) => 
                      a (T.NTree HXT.XNode) (String,String)
          getItems = HXT.deep (HXT.isElem HXT.>>> HXT.hasName "item") HXT.>>>
                     proc x -> do
                       l <- HXT.getText HXT.<<< HXT.getChildren 
                            HXT.<<< HXT.deep (HXT.hasName "link") -< x
                       t <- HXT.getText HXT.<<< HXT.getChildren 
                            HXT.<<< HXT.deep (HXT.hasName "title") -< x
                       HXT.returnA -< (t, (printURI l))
              where
                -- Make the printurl for a Yahoo News link
                printURI :: String -> String
                printURI u = ((tail . dropWhile (/= '*')) u) ++ "?printer=1"

-- Create the <ul> for a news feed, where each <li> is a link constructed
-- from the (title,printurl) tuple
feedUL :: (String,[(String,String)]) -> X.Html
feedUL l = X.h3 X.<< (fst l) X.+++ X.ulist X.<<
           (map newsLI (snd l))
           where
             newsLI :: (String,String) -> X.Html
             newsLI i = X.li X.<< X.anchor X.! [X.href (snd i)] 
                        X.<< (X.primHtml $ fst i)

-- Make a list of <li>'s for stock quotes
quoteLIs :: [Q.QuoteSymbol] -> [Q.QuoteField] -> 
            DM.Map (Q.QuoteSymbol, Q.QuoteField) Q.QuoteValue -> [X.Html]
quoteLIs s f m = map (quoteLI f m) s
    where 
      quoteLI f m s' = let t = S.replace " - " "," $ S.join " " $ 
                                map (quoteMk s' m) f in X.li X.<< t
              where 
                quoteMk s' m f' = case (DM.lookup (s',f') m) of
                                      Just v -> v
                                      Nothing -> ""

-- Make a table and <ul> for the individual stock quote <li>'s.
quotesTable :: [X.Html] -> X.Html
quotesTable q = let n = (length q) `div` 2 in
                X.table X.<< X.tr X.<< 
                     [X.td X.<< X.ulist X.<< take n q,
                      X.td X.<< X.ulist X.<< drop n q]

main :: IO ()
main = do 

  -- Quotes
  quotes <- Q.getQuote symbols fields
  let quoteHTML = case quotes of 
                    Nothing -> error "no quote map"
                    Just m -> quotesTable (quoteLIs symbols fields m) 

  -- News
  tuples <- M.mapM (rss2Tuple . snd) feeds
  let newsHTML = X.concatHtml $ map feedUL (zip (map fst feeds) tuples)   

  now <- System.Time.getClockTime -- the time is our page title
  p <- return $ X.showHtml $ 
       X.header X.<< (X.thetitle X.<< (show now) X.+++
                     (X.meta X.! 
                           [X.httpequiv "Content-Type",
                            X.content "text/html;charset=utf-8"])) X.+++ 
       X.body X.<< (quoteHTML X.+++ newsHTML)
  putStr p
  return ()