module Data.OFX
(
Err
, HeaderTag
, HeaderValue
, OFXHeader(..)
, TagName
, TagData
, Tag(..)
, OFXFile(..)
, find
, findPath
, tagData
, pathData
, findData
, fiName
, creditCardNumber
, bankAccountNumber
, accountNumber
, Transaction(..)
, transaction
, transactions
, TrnType(..)
, trnType
, Payee(..)
, payee
, CorrectAction(..)
, BankAcctTo(..)
, bankAcctTo
, CCAcctTo(..)
, ccAcctTo
, AcctType(..)
, acctType
, CurrencyData(..)
, currencyData
, Currency(..)
, currency
, OrigCurrency(..)
, origCurrency
, ofxFile
, newline
, escChar
, header
, openingTag
, closingTag
, tag
, date
, time
, tzOffset
, pPayee
, pTransaction
, pTag
, pHeader
, pFile
, pEither
, pMaybe
, pList
, label
, pExceptional
) where
import Control.Applicative (many, optional, (<|>))
import Control.Monad (replicateM)
import qualified Data.Time as T
import Text.Parsec.String (Parser)
import Text.Parsec
( lookAhead, char, manyTill, anyChar, (<?>), eof,
try, digit, many1, spaces, string, choice )
import qualified Text.Parsec as P
import Data.Maybe (listToMaybe)
import Data.Monoid ((<>))
import qualified Data.Monoid as M
import Text.PrettyPrint
( Doc, hang, text, sep, vcat, nest, (<+>), ($$),
parens, brackets )
type Err = Either String
type HeaderTag = String
type HeaderValue = String
data OFXHeader = OFXHeader HeaderTag HeaderValue
deriving (Eq, Show)
type TagName = String
type TagData = String
data Tag = Tag TagName (Either TagData [Tag])
deriving (Eq, Show)
data OFXFile = OFXFile
{ fHeader :: [OFXHeader]
, fTag :: Tag
} deriving (Eq, Show)
newline :: Parser ()
newline = () <$ char '\n' <|> () <$ (char '\r' *> char '\n')
<?> "newline"
escChar :: Parser Char
escChar =
do
c <- anyChar
case c of
'&' -> do
let mkParser (ch, str) = try (ch <$ string str)
ent <- choice (map mkParser
[('<', "lt"), ('>', "gt"), ('&', "amp")])
<?> ( "entity (\"lt\", \"gt\", or \"amp\")\n"
++ "some banks create broken OFX files. Try\n"
++ "removing the ampersands from the file and\n"
++ "trying again.")
_ <- char ';'
return ent
_ -> return c
<?> "character"
header :: Parser OFXHeader
header
= OFXHeader
<$> manyTill anyChar (char ':')
<* optional (many (char ' '))
<*> manyTill anyChar newline
<?> "OFX header"
openingTag :: Parser TagName
openingTag =
do
_ <- char '<'
cs <- manyTill escChar (char '>')
case cs of
[] -> fail "opening tag with empty name"
x:_ ->
if x == '/'
then fail "this is a closing tag"
else return cs
<?> "opening tag"
closingTag :: TagName -> Parser ()
closingTag n =
do
_ <- char '<'
_ <- char '/'
cs <- manyTill escChar (char '>')
if cs == n
then return ()
else fail $ "expecting closing tag named " ++ n
++ "; saw closing tag named " ++ cs
<?> "closing tag named " ++ n
tag :: Parser Tag
tag =
do
n <- try (openingTag <* spaces)
children <- many tag
if null children
then Tag n . Left
<$> manyTill escChar
(eof <|> lookAhead (() <$ char '<') <|> newline)
<* spaces
<* optional (try (closingTag n))
<* spaces
else Tag n (Right children) <$ spaces <* closingTag n
<* spaces
<?> "OFX tag"
ofxFile :: Parser OFXFile
ofxFile
= OFXFile
<$> manyTill header newline
<*> tag
<* spaces
<* eof
<?> "OFX file"
parseDate :: String -> Err T.ZonedTime
parseDate s = case P.parse date "" s of
Left e -> Left $ "could not parse date: " ++ s ++ ": "
++ show e
Right g -> return g
date :: Parser T.ZonedTime
date =
do
ys <- fmap read $ replicateM 4 digit
ms <- fmap read $ replicateM 2 digit
ds <- fmap read $ replicateM 2 digit
day <- case T.fromGregorianValid ys ms ds of
Nothing -> fail $ "invalid date: " ++ show ys
++ "-" ++ show ms ++ "-" ++ show ds
Just d -> return d
mayTime <- optional time
case mayTime of
Nothing ->
let localTime = T.LocalTime day T.midnight
in return $ T.ZonedTime localTime T.utc
Just (t, z) -> return $ T.ZonedTime (T.LocalTime day t) z
<?> "date"
time :: Parser (T.TimeOfDay, T.TimeZone)
time =
do
h <- fmap read $ replicateM 2 digit
m <- fmap read $ replicateM 2 digit
s <- fmap read $ replicateM 2 digit
(milli, tz) <- do
mayDot <- optional (char '.')
case mayDot of
Nothing -> return (0, T.utc)
Just _ -> do
mil <- fmap ((/ 1000) . read) $ replicateM 3 digit
mayTz <- optional tzOffset
case mayTz of
Nothing -> return (mil, T.utc)
Just t -> return (mil, t)
let sec = s + milli
return (T.TimeOfDay h m sec, tz)
<?> "time"
tzOffset :: Parser T.TimeZone
tzOffset =
do
_ <- char '['
sn <- parseSign
whole <- many1 digit
mayDot <- optional (char '.')
frac <- case mayDot of
Nothing -> return "0"
Just _ -> many1 digit
mayColon <- optional (char ':')
name <- case mayColon of
Nothing -> return ""
Just _ -> many1 P.letter
_ <- char ']'
let off = sn $ round ((read (whole ++ "." ++ frac))
* (60 :: Double))
return $ T.TimeZone off False name
<?> "time zone offset"
where
parseSign = do
mayMinus <- optional (char '-')
case mayMinus of
Nothing -> do
mayPlus <- optional (char '+')
return $ case mayPlus of
Nothing -> id
Just _ -> negate
Just _ -> return negate
find :: TagName -> Tag -> [Tag]
find n t@(Tag x p)
| n == x = [t]
| otherwise = case p of
Left _ -> []
Right ts -> concatMap (find n) ts
findPath :: [TagName] -> Tag -> Maybe Tag
findPath [] t = Just t
findPath (n:ns) t = case listToMaybe (find n t) of
Nothing -> Nothing
Just r -> findPath ns r
tagData :: Tag -> Maybe TagData
tagData (Tag _ ei) = either return (const Nothing) ei
pathData :: [TagName] -> OFXFile -> Maybe TagData
pathData p (OFXFile _ t) = findPath p t >>= tagData
fiName :: OFXFile -> Maybe TagData
fiName = pathData ["SIGNONMSGSRSV1", "SONRS", "FI", "ORG"]
creditCardNumber :: OFXFile -> Maybe TagData
creditCardNumber =
pathData [ "CREDITCARDMSGSRSV1", "CCSTMTTRNRS", "CCSTMTRS",
"CCACCTFROM", "ACCTID" ]
bankAccountNumber :: OFXFile -> Maybe TagData
bankAccountNumber =
pathData [ "BANKMSGSRSV1", "STMTTRNRS", "STMTRS",
"BANKACCTFROM", "ACCTID" ]
accountNumber :: OFXFile -> Maybe TagData
accountNumber f = creditCardNumber f <|> bankAccountNumber f
findData :: TagName -> Tag -> Maybe TagData
findData n (Tag tn e) = case e of
Left d -> if tn == n then Just d else Nothing
Right ts -> M.getFirst . M.mconcat . map M.First
. map (findData n) $ ts
required :: TagName -> Tag -> Err TagData
required n t = case findData n t of
Nothing -> Left $ "required tag missing: " ++ n
Just r -> return r
data TrnType
= TCREDIT
| TDEBIT
| TINT
| TDIV
| TFEE
| TSRVCHG
| TDEP
| TATM
| TPOS
| TXFER
| TCHECK
| TPAYMENT
| TCASH
| TDIRECTDEP
| TDIRECTDEBIT
| TREPEATPMT
| TOTHER
deriving (Eq, Ord, Show)
data Transaction = Transaction
{ txTRNTYPE :: TrnType
, txDTPOSTED :: T.ZonedTime
, txDTUSER :: Maybe T.ZonedTime
, txDTAVAIL :: Maybe T.ZonedTime
, txTRNAMT :: String
, txFITID :: String
, txCORRECTFITID :: Maybe String
, txCORRECTACTION :: Maybe CorrectAction
, txSRVRTID :: Maybe String
, txCHECKNUM :: Maybe String
, txREFNUM :: Maybe String
, txSIC :: Maybe String
, txPAYEEID :: Maybe String
, txPayeeInfo :: Maybe (Either String Payee)
, txAccountTo :: Maybe (Either BankAcctTo CCAcctTo)
, txMEMO :: Maybe String
, txCurrency :: Maybe (Either Currency OrigCurrency)
} deriving (Show)
data Payee = Payee
{ peNAME :: String
, peADDR1 :: String
, peADDR2 :: Maybe String
, peADDR3 :: Maybe String
, peCITY :: String
, peSTATE :: String
, pePOSTALCODE :: String
, peCOUNTRY :: Maybe String
, pePHONE :: String
} deriving (Eq, Show)
data CorrectAction
= REPLACE
| DELETE
deriving (Eq, Show, Read)
data BankAcctTo = BankAcctTo
{ btBANKID :: String
, btBRANCHID :: Maybe String
, btACCTID :: String
, btACCTTYPE :: AcctType
, btACCTKEY :: Maybe String
} deriving Show
data CCAcctTo = CCAcctTo
{ ctACCTID :: String
, ctACCTKEY :: Maybe String
} deriving (Eq, Show)
data AcctType
= ACHECKING
| ASAVINGS
| AMONEYMRKT
| ACREDITLINE
deriving (Eq, Show, Ord)
acctType :: String -> Err AcctType
acctType s
| s == "CHECKING" = return ACHECKING
| s == "SAVINGS" = return ASAVINGS
| s == "MONEYMRKT" = return AMONEYMRKT
| s == "CREDITLINE" = return ACREDITLINE
| otherwise = Left $ "unrecognized account type: " ++ s
data CurrencyData = CurrencyData
{ cdCURRATE :: String
, cdCURSYM :: String
} deriving (Eq, Show)
data Currency = Currency CurrencyData
deriving (Eq, Show)
data OrigCurrency = OrigCurrency CurrencyData
deriving (Eq, Show)
trnType :: TagData -> Maybe TrnType
trnType d = case d of
"CREDIT" -> Just TCREDIT
"DEBIT" -> Just TDEBIT
"INT" -> Just TINT
"DIV" -> Just TDIV
"FEE" -> Just TFEE
"SRVCHG" -> Just TSRVCHG
"DEP" -> Just TDEP
"ATM" -> Just TATM
"POS" -> Just TPOS
"XFER" -> Just TXFER
"CHECK" -> Just TCHECK
"PAYMENT" -> Just TPAYMENT
"CASH" -> Just TCASH
"DIRECTDEP" -> Just TDIRECTDEP
"DIRECTDEBIT" -> Just TDIRECTDEBIT
"REPEATPMT" -> Just TREPEATPMT
"OTHER" -> Just TOTHER
_ -> Nothing
transaction :: Tag -> Err Transaction
transaction t = do
let fromMaybe e = maybe (Left e) Right
trntyStr <- required "TRNTYPE" t
trnTy <- fromMaybe ("could not parse transaction type: " ++ trntyStr)
$ trnType trntyStr
dtpStr <- required "DTPOSTED" t
dtp <- parseDate dtpStr
let mayDtuStr = findData "DTUSER" t
dtu <- maybe (return Nothing) (fmap Just . parseDate) mayDtuStr
let mayDtAvail = findData "DTAVAIL" t
dta <- maybe (return Nothing) (fmap Just . parseDate) mayDtAvail
amt <- required "TRNAMT" t
fitid <- required "FITID" t
let correctFitId = findData "CORRECTFITID" t
correctAct <-
case findData "CORRECTACTION" t of
Nothing -> return Nothing
Just d ->
maybe (return Nothing)
(fromMaybe ("could not parse correct action: " ++ d))
. safeRead
$ d
let srvrtid = findData "SRVRTID" t
checknum = findData "CHECKNUM" t
refnum = findData "REFNUM" t
sic = findData "SIC" t
payeeId = findData "PAYEEID" t
let mayPyeInfo = fmap (return . Left) (findData "NAME" t)
<|> fmap (fmap Right) (payee t)
pyeInfo <- maybe (return Nothing) (fmap Just) mayPyeInfo
let mayAcctTo = (fmap (fmap Left) $ bankAcctTo t)
<|> (fmap (fmap Right) $ ccAcctTo t)
mayCcy = (fmap (fmap Left) $ currency t)
<|> (fmap (fmap Right) $ origCurrency t)
acctTo <- maybe (return Nothing) (fmap Just) mayAcctTo
ccy <- maybe (return Nothing) (fmap Just) mayCcy
let memo = findData "MEMO" t
return Transaction
{ txTRNTYPE = trnTy
, txDTPOSTED = dtp
, txDTUSER = dtu
, txDTAVAIL = dta
, txTRNAMT = amt
, txFITID = fitid
, txCORRECTFITID = correctFitId
, txCORRECTACTION = correctAct
, txSRVRTID = srvrtid
, txCHECKNUM = checknum
, txREFNUM = refnum
, txSIC = sic
, txPAYEEID = payeeId
, txPayeeInfo = pyeInfo
, txAccountTo = acctTo
, txMEMO = memo
, txCurrency = ccy
}
payee
:: Tag
-> Maybe (Err Payee)
payee = fmap getPayee . listToMaybe . find "PAYEE"
where
getPayee t = Payee
<$> required "NAME" t
<*> required "ADDR1" t
<*> pure (findData "ADDR2" t)
<*> pure (findData "ADDR3" t)
<*> required "CITY" t
<*> required "STATE" t
<*> required "POSTALCODE" t
<*> pure (findData "COUNTRY" t)
<*> required "PHONE" t
currency :: Tag -> Maybe (Err Currency)
currency
= fmap (fmap Currency)
. fmap currencyData
. listToMaybe
. find "CURRENCY"
origCurrency :: Tag -> Maybe (Err OrigCurrency)
origCurrency
= fmap (fmap OrigCurrency)
. fmap currencyData
. listToMaybe
. find "ORIGCURRENCY"
currencyData
:: Tag
-> Err CurrencyData
currencyData t = CurrencyData
<$> required "CURRATE" t
<*> required "CURSYM" t
bankAcctTo :: Tag -> Maybe (Err BankAcctTo)
bankAcctTo = fmap getTo . listToMaybe . find "BANKACCTTO"
where
getTo t = BankAcctTo
<$> required "BANKID" t
<*> pure (findData "BRANCHID" t)
<*> required "ACCTID" t
<*> (required "ACCTTYPE" t >>= acctType)
<*> pure (findData "ACCTKEY" t)
ccAcctTo :: Tag -> Maybe (Err CCAcctTo)
ccAcctTo = fmap getTo . listToMaybe . find "CCACCTTO"
where
getTo t = CCAcctTo
<$> required "ACCTID" t
<*> pure (findData "ACCTKEY" t)
safeRead :: Read a => String -> Maybe a
safeRead s = case reads s of
(x, ""):[] -> Just x
_ -> Nothing
transactions :: OFXFile -> Err [Transaction]
transactions = mapM transaction . find "STMTTRN" . fTag
pPayee :: Payee -> Doc
pPayee p = hang "Payee:" 2 ls
where
ls = sep [ label "Name" (text . peNAME $ p)
, label "Addr1" (text . peADDR1 $ p)
, label "Addr2" (pMaybe text . peADDR2 $ p)
, label "Addr3" (pMaybe text . peADDR3 $ p)
, label "City" (text . peCITY $ p)
, label "State" (text . peSTATE $ p)
, label "Postal" (text . pePOSTALCODE $ p)
, label "Country" (pMaybe text . peCOUNTRY $ p)
, label "Phone" (text . pePHONE $ p)
]
pTransaction :: Transaction -> Doc
pTransaction a = hang "Transaction:" 2 ls
where
ls = sep [ label "TRNTYPE" (text . show . txTRNTYPE $ a)
, label "DTPOSTED" (text . show . txDTPOSTED $ a)
, label "DTUSER" (text . show . txDTUSER $ a)
, label "DTAVAIL" (text . show . txDTAVAIL $ a)
, label "TRNAMT" (text . txTRNAMT $ a)
, label "FITID" (text . txFITID $ a)
, label "CORRECTFITID"
(pMaybe text . txCORRECTFITID $ a)
, label "CORRECTACTION"
(text . show . txCORRECTACTION $ a)
, label "SRVRTID" (pMaybe text . txSRVRTID $ a)
, label "CHECKNUM" (pMaybe text . txCHECKNUM $ a)
, label "REFNUM" (pMaybe text . txREFNUM $ a)
, label "SIC" (pMaybe text . txSIC $ a)
, label "PAYEEID" (pMaybe text . txPAYEEID $ a)
, label "PAYEEINFO"
(pMaybe (pEither text (text . show)) . txPayeeInfo $ a)
, label "ACCOUNTTO"
(pMaybe id . fmap (text . show)
. txAccountTo $ a)
, label "MEMO" (pMaybe text . txMEMO $ a)
, label "CURRENCY"
(pMaybe (text . show) . txCurrency $ a)
]
pTag :: Tag -> Doc
pTag (Tag n ei) = case ei of
Left d -> "<" <> text n <> ">" <> text d
Right ts -> vcat $ "<" <> text n <> ">"
: map (nest 2 . pTag) ts
++ ["</" <> text n <> ">"]
pHeader :: OFXHeader -> Doc
pHeader (OFXHeader t v) = text t <> ": " <> text v
pFile :: OFXFile -> Doc
pFile (OFXFile hs t)
= "OFX file:"
$$ nest 2 (vcat [ pList . map pHeader $ hs
, mempty
, pTag t ])
pEither :: (a -> Doc) -> (b -> Doc) -> Either a b -> Doc
pEither fa fb = either (\l -> "Left" <+> parens (fa l))
(\r -> "Right" <+> parens (fb r))
pMaybe :: (a -> Doc) -> Maybe a -> Doc
pMaybe f = maybe "Nothing" (\x -> "Just" <+> parens (f x))
pList :: [Doc] -> Doc
pList ds = case ds of
[] -> "[]"
x:[] -> brackets x
x:xs -> sep $ hang "[" 2 x
: map (\d -> hang "," 2 d) xs
++ [ "]" ]
label :: String -> Doc -> Doc
label s = hang (text (s ++ ":")) (length s + 2)
pExceptional
:: (e -> Doc)
-> (a -> Doc)
-> Either e a
-> Doc
pExceptional fe fa =
either (\e -> hang "Exception:" 2 $ parens (fe e))
(\g -> hang "Success:" 2 $ parens (fa g))