Finance-Treasury (empty) → 0.1
raw patch · 7 files changed
+450/−0 lines, 7 filesdep +HTTPdep +HTTP-Simpledep +basesetup-changed
Dependencies added: HTTP, HTTP-Simple, base, containers, hxt, network, old-locale, time
Files
- Finance-Treasury.cabal +22/−0
- Finance/Treasury.hs +326/−0
- LICENSE +24/−0
- Setup.lhs +3/−0
- tests/clean.sh +14/−0
- tests/test.sh +30/−0
- tests/treas.hs +31/−0
+ Finance-Treasury.cabal view
@@ -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
+ Finance/Treasury.hs view
@@ -0,0 +1,326 @@+{- | +Module : Finance.Treasury+Copyright : Copyright (c) 2008, Steve lihn <stevelihn@gmail.com>+License : BSD3+Maintainer : Steve lihn <stevelihn@gmail.com>+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 =~ <?xml..., error if not+ -- debug: putStrLn $ take 3000 $ skiphead ss+ return $ parseFunc $ skiphead ss++parseRawXML1 xmlstr = parseRawXML getGNewDateNodes getBcNodes xmlstr+parseRawXML2 xmlstr = parseRawXML getGCurveDateNodes getBc30Nodes xmlstr++parseRawXML getnodes getbc xmlstr = + if (not $ M.null m) then m else error "parseRawXML: error empty result" + where m = M.fromList $ dtlist $ getnodes xmlstr + dtlist :: [XP.XmlTree] -> [(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 <?xml> and <!-- tags, HXT does not take them well+skiphead :: String -> String+skiphead [] = [] +skiphead [a,b] = [a,b] +skiphead s@(c1:c2:sx) = + if c1 == '<' && not ( c2 == '?' || c2 == '!' ) then s+ else skiphead (c2:sx)++splitc :: Char -> String -> [String]+splitc delim s = + if null rest then [token]+ else token : splitc delim (tail rest)+ where (token,rest) = span (/=delim) s++join :: String -> [String] -> String+join sep = concat . intersperse sep++validint y [] = True +validint y x@(s:sx) = + if validc s then validint y sx+ else error $ "invalid date list: "++(show y)+ where validc [] = True+ validc (s:sx) = isDigit s && validc sx++validnum y x = + if validc x then True+ else error $ "invalid number: "++(show y)+ where validc [] = True+ validc (s:sx) = (isDigit s || s == '.') && validc sx++-- prepend 0 in numbers such as .9, otherwise read will fail+fixnum [] = [] +fixnum s@(c:cx) = if c=='.' then ('0':s) else s++-- remove leading spaces+rmspace :: String -> String+rmspace [] = []+rmspace s@(c:sx) = if c == ' ' then rmspace sx else s
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2008, Stephen Lihn+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of b7j0c.org nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY BRAD CLAWSIE ``AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL BRAD CLAWSIE BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ tests/clean.sh view
@@ -0,0 +1,14 @@+#!/bin/bash++ pwd=`pwd`+ if [ `basename $pwd` != 'tests' ] ; then+ exit 1+ fi++ cd ../+ rm -f */*.hi */*.o+ echo "*.hi *.o cleaned up"+ rm -rf dist/+ rm -f tests/treas+ echo "dists/ treas cleaned up"+
+ tests/test.sh view
@@ -0,0 +1,30 @@+#!/bin/bash++# to clean up, +# rm treas+# rm -Rf *.hi *.o++ pwd=`pwd`+ if [ `basename $pwd` != 'tests' ] ; then+ exit 1+ fi++mk_treas ()+{+ cp treas.hs ../+ cd ../+ ghc treas.hs --make+ mv treas* tests/+ cd tests/+ ./treas+}++ [ -f "./treas" ] && rm ./treas+ cd ../+ Setup.lhs configure --user && \+ Setup.lhs build && \+ cd tests && \+ mk_treas+++
+ tests/treas.hs view
@@ -0,0 +1,31 @@+++ 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 ()+