diff --git a/Finance-Treasury.cabal b/Finance-Treasury.cabal new file mode 100644 --- /dev/null +++ b/Finance-Treasury.cabal @@ -0,0 +1,22 @@ +Name: Finance-Treasury +Version: 0.1 +Description: Obtain Treasury yield curve data from Department of Treasury website +Synopsis: Obtain Treasury yield curve data +Category: Web +Stability: experimental +Homepage: http://www.ecoin.net/haskell/Finance-Treasury.html +License: BSD3 +License-file: LICENSE +Author: Stephen Lihn +Maintainer: stevelihn@gmail.com +cabal-version: >=1.2 +build-type: Simple +Flag splitBase + Description: Choose the new smaller, split-up base package. +Library + if flag(splitBase) + Build-Depends: base >= 3,containers, network, HTTP, HTTP-Simple, time>=1.1.1, old-locale, hxt>=7.3 + else + Build-Depends: base < 3, network, HTTP, HTTP-Simple, time>=1.1.1, hxt>=7.3 + GHC-Options: -O + Exposed-modules: Finance.Treasury diff --git a/Finance/Treasury.hs b/Finance/Treasury.hs new file mode 100644 --- /dev/null +++ b/Finance/Treasury.hs @@ -0,0 +1,326 @@ +{- | +Module : Finance.Treasury +Copyright : Copyright (c) 2008, Steve lihn +License : BSD3 +Maintainer : Steve lihn +Stability : experimental +Tested with: GHC 6.6.1 + +Finance.Treasury is a module to obtain yield curve data from Department +of Treasury website. + +Error reporting is somewhat of a mixed model in this module. More +improvement is desired in future releases. + +Here is a small complete program illustrating the use of this module: + +@ + + module Main where + import Finance.Treasury + import qualified Data.Map as M + import Data.List (sort) + import Text.Printf + main = do + putStrLn "**************************************" + m <- getYieldCurveThisMonth + putStrLn "*** pretty print 10y rates for all dates" + prettyYieldCurve m (Just "10y") + -- + d <- getLatestYieldCurve + putStrLn "*** pretty print the latest daily yield curve" + prettyYieldCurve (M.fromList [d]) Nothing + -- + putStrLn "*** show some yield curves of past year" + h <- getYieldCurveHist + prettyYieldCurve (minmax h) (Just "10y") + mapM_ prt yrs + putStrLn "**************************************" + return () + where minmax h = M.fromList [ M.findMin h, M.findMax h ] + yrs = reverse [ 1992..2007 ] + prt :: Int -> IO () + prt yr = do putStrLn $ "*** show some yield curves of "++(show yr) + yc <- getYieldCurveYyyy yr + prettyYieldCurve (minmax yc) (Just "10y") + return () + + +@ + +-} +{- + License info: + The license is a simple BSD3-style license. +-} + +module Finance.Treasury ( + DailyYieldCurve, + DailyYieldCurveList, + yieldCurveHash, + getLatestYieldCurve, + getYieldCurveThisMonth, + getYieldCurveHist, + getYieldCurveYyyy, + prettyYieldCurve + ) where + +import Network.URI (parseURI, escapeURIString, isUnescapedInURI) +-- import Network.HTTP +import Network.HTTP.Simple (httpGet) +import Data.List (intersperse, sortBy, sort, null) +import Data.Maybe (listToMaybe, fromJust) +import Data.Char (isDigit) + +import qualified Data.Time.Calendar as C +import qualified Data.Map as M +import qualified Data.Tree.Class as DT +import qualified Text.XML.HXT.Parser as XP +import qualified Control.Exception as E +import Text.Printf + +baseURL = "http://www.treas.gov/offices/domestic-finance/debt-management/interest-rate/" + +-- yield.xml (current month if traded) +-- yield_historical.xml for this year or last year (if January) +-- yield_historical_YYYY.xml for YYYY is last year or earlier +-- up to 1990 + +yieldURL = baseURL++"yield.xml" +yieldHistURL = baseURL++"yield_historical.xml" +yieldYyyyURL :: Int -> String +yieldYyyyURL yr = baseURL++"yield_historical_"++s2++".xml" + where s1 = show yr + s2 = if length s1 == 4 then s1 + else error "yieldYyyyURL: "++s1++" is not YYYYY" + + +{- yieldCurveHash translates maturity from XML names to abbreviations. + E.g. "BC_1MONTH" becomes "1m". + List of all maturities: 1m 3m 6m 1y 2y 3y 5y 7y 10y 20y 30y +-} +yieldCurveHash :: M.Map String String +yieldCurveHash = M.fromList + [ ( "BC_1MONTH", "1m" ), + ( "BC_3MONTH", "3m" ), + ( "BC_6MONTH", "6m" ), + ( "BC_1YEAR", "1y" ), + ( "BC_2YEAR", "2y" ), + ( "BC_3YEAR", "3y" ), + ( "BC_5YEAR", "5y" ), + ( "BC_7YEAR", "7y" ), + ( "BC_10YEAR", "10y" ), + ( "BC_20YEAR", "20y" ), + ( "BC_30YEAR", "30y" ) ] + + +type DailyYieldCurve = M.Map String Float +type DailyYieldCurveList = [ (String, Float) ] +type YieldCurveMap = M.Map C.Day DailyYieldCurve + +getLatestYieldCurve :: IO (C.Day, DailyYieldCurve) +getLatestYieldCurve = + do ycs <- getYieldCurveThisMonth + return $ M.findMax ycs + +-- There is no reason to fail, so it is an error if there is no XML returned +getYieldCurveThisMonth :: IO YieldCurveMap +getYieldCurveThisMonth = + do jstr <- fetchXML yieldURL + parseRawWrapper parseRawXML1 jstr + +-- There is no reason to fail, so it is an error if there is no XML returned +getYieldCurveHist :: IO YieldCurveMap +getYieldCurveHist = + do jstr <- fetchXML yieldHistURL + parseRawWrapper parseRawXML2 jstr + +-- If YYYY is not in range, this call may fail +-- Otherwise, there is no reason to fail +getYieldCurveYyyy :: Int -> IO YieldCurveMap +getYieldCurveYyyy yr = + do s <- fetchXML $ yieldYyyyURL yr + parseRawWrapper parseRawXML2 s + +-------------------------------------------------------------------- +-- helper function +parseRawWrapper parseFunc s = + case s of + Nothing -> return M.empty + Just ss -> do -- FIXME: May need to check if ss =~ [(C.Day,DailyYieldCurve)] + dtlist [] = [] + dtlist (s:xs) = + let d = showdt . getdt $ s + yc = parseYieldCurve $ DT.getChildren $ justhead s $ getbc $ s in + if ( length d == 10 ) then (mktuple d yc):(dtlist xs) + else dtlist xs + mktuple d yc = ( makeDay d , M.fromList yc ) + getdt node = let dt1 = nodematch $ map getNewDateNode $ DT.getChildren node + bc = justhead node $ getbc $ node + dt2 = nodematch $ map getNewDateNode $ DT.getChildren $ bc + justdt sx = justhead node sx in + if not (null dt1) then justdt dt1 + else if not (null dt2) then justdt dt2 + else error $ "getNewDateNode error at \n"++(XP.formatXmlTree node) + showdt dt = showText $ justhead dt $ DT.getChildren dt +-------------------------------------------------------------------- + +justhead node (s:sx) = s +justhead node [] = error $ "parse error at \n"++(XP.formatXmlTree node) + +-- a quick test function +prettyYieldCurve :: YieldCurveMap -> Maybe String -> IO () +prettyYieldCurve ycm mmat = + do let ds = sort $ M.keys ycm + prt1 mat d = do curv <- M.lookup d ycm + rate <- M.lookup mat curv + printf fmt (show d) mat rate + prt2 d = do curv <- M.lookup d ycm + mapM_ (prt4 d) $ sorted curv + prt0 d = case mmat of + Nothing -> prt2 d + Just mat -> prt1 mat d + mapM_ prt0 ds + where prt4 d (a,b) = printf fmt (show d) a b + sorted yc = sortByMaturity $ M.toList yc + fmt = "%s, %3s, %5.2f\n" +-- ----------------------------------------------------------------- +-- ----------------------------------------------------------------- +-- Private helper functions + +-- expect MM-DD-YYYY +makeDay :: String -> C.Day +makeDay s = + let a = splitc '-' s in + case (length s == 10 && length a == 3 && validint a a) of + False -> error("date field " ++ s ++ " malformed") + True -> let y = read (a!!2) :: Integer + m = read (a!!0) :: Int + d = read (a!!1) :: Int in + C.fromGregorian y m d + +fetchXML :: String -> IO (Maybe String) +fetchXML url = + case parseURI url of + Nothing -> error("uri malformed:" ++ url) + Just uri -> httpGet uri + +-- helper function to sort keys (maturity) in yield curve +sortByMaturity :: DailyYieldCurveList -> DailyYieldCurveList +sortByMaturity yc = sortBy yc_sort yc + +-- helper function, sort by maturity in correct order (month then year) +yc_sort (a1,a2) (b1,b2) = compare (convkey a1) (convkey b1) + +-- helper function for yc_sort +convkey :: String -> Int +convkey k = + if not $ validint [k1] [k1] then 0 + else k2 * (if d == 'y' then 1000 else 100) + where k1 = reverse $ tail $ reverse k + k2 = read k1 :: Int + d = head $ reverse k + + +parseYieldCurve :: [ XP.XmlTree ] -> [(String,Float)] +parseYieldCurve [] = [] +parseYieldCurve (s:sx) = + case (M.lookup lp mx) of + Nothing -> parseYieldCurve sx + Just p -> if (ts == [] || ls == "N/A" || (not $ validnum ls ls)) then parseYieldCurve sx + else if yd > 0 then (p,yd):(parseYieldCurve sx) + else parseYieldCurve sx + where mx = yieldCurveHash + lp = XP.localPartOf s + ts = DT.getChildren s + ls = rmspace $ showText $ justhead s $ ts + yd = read (fixnum ls) :: Float + +-- HXT XML Parser combinators + +getGNewDateNodes :: String -> [ XP.XmlTree ] +getGNewDateNodes s = gettags $ head $ if sx == [] then error err else sx + where gettags = XP.deep ( XP.isTag "G_NEW_DATE") + sx = XP.xread s + err = "getGNewDateNodes: error empty result" + +getGCurveDateNodes :: String -> [ XP.XmlTree ] +getGCurveDateNodes s = gettags $ head $ if sx == [] then error err else sx + where gettags = XP.deep ( XP.isTag "G_BID_CURVE_DATE") + sx = XP.xread s + err = "getGCurveDateNodes: error empty result" + +getNewDateNode = XP.isTag "NEW_DATE" + +-- FIXME: I am just lazy, this is quick, but may have performance cost +getBcNodes = XP.deep ( XP.isTag "G_BC_CAT" ) + +getBc30Nodes = XP.deep ( XP.isTag "G_BC_30YEAR" ) + +-- FIXME: This is a hack to XHT, I just can't find the right function to show text +showText :: XP.XmlTree -> String +showText t = showt n + where n = DT.getNode t + showt (XP.XText a) = a + showt _ = "" + +-- FIXME: There is probably a better way to do this! +nodematch :: [[a]] -> [a] +nodematch [] = [] +nodematch xs@(n:nx) = case n of + [] -> nodematch $ nx + [a] -> a:(nodematch $ nx) + _ -> error "nodematch error, there is a problem with XML syntax" + + +------------------------------------------------------------ +-- auxillary functions -- + +-- skip and