Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
182 lines (154 sloc) 6.33 KB
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
module Csv
( CanCsv
, CsvError(..)
, AsCsvError(_CsvError,_CsvIoError, _CsvHeaderParseError, _CsvDecodeErrors)
, readTransactions
) where
import BasePrelude hiding (first, try, words)
import Control.Error (headMay, note)
import Control.Lens (makeClassyPrisms, (^.),(#))
import Control.Monad.Error.Hoist ((<?>),(<%?>))
import Control.Monad.Except (MonadError, runExceptT)
import Control.Monad.TM ((.>>=.))
import Control.Monad.Trans (MonadIO)
import Data.Bifunctor (bimap, first)
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LC8
import Data.Csv (FromField (..), FromRecord (..),
HasHeader (NoHeader), decode, (.!))
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time (Day, parseTimeM,defaultTimeLocale)
import Data.Validation (AccValidation, _AccValidation)
import qualified Data.Vector as V
import Text.Parsec (alphaNum, anyChar, char, choice,
digit, lookAhead, many1, manyTill,
parse, sepEndBy1, space, spaces,
string, try)
import Text.Parsec.Text (Parser)
import Types hiding (transactionDesc)
import Utils
data CsvError
= CsvIoError IOException
| CsvHeaderParseError String
| CsvDecodeErrors [String]
deriving (Eq,Show)
makeClassyPrisms ''CsvError
type CanCsv e m = ( CanCsvError e m , MonadIO m )
type CanCsvError e m = ( MonadError e m , AsCsvError e )
readTransactions :: CanCsv e m => FilePath -> m Transactions
readTransactions fn = do
lbs <- wrapException (_CsvIoError #) $ (LBS.readFile fn)
let (headers,csvs) = splitAt 2 . LC8.lines $ lbs
(name,t,num) <- parseHeader headers
xactsV <- throwAccValidation (_CsvDecodeErrors #) $ csvs .>>=. decodeCsvLine -- t .>>=. f is fmap fold . traverse f t
pure $ Transactions name t num xactsV
decodeCsvLine
:: FromRecord a
=> LBS.ByteString
-> AccValidation [String] [a]
decodeCsvLine bs =
(bimap (:[]) toList . decode NoHeader $ bs) ^._AccValidation
parseHeader
:: (CanCsvError e m, Applicative m)
=> [LBS.ByteString]
-> m (T.Text,T.Text,Int)
parseHeader hs = do
h <- headMay hs <?> (_CsvHeaderParseError # "Header Missing")
let r = parse header (LC8.unpack h) (decodeUtf8 . LBS.toStrict $ h)
r <%?> ((_CsvHeaderParseError #) . show)
where
header = do
void $ string "\"Account History for Account:\",\""
name <- manyTill anyChar (try $ string " - ")
t <- manyTill anyChar (try $ string " - ")
num <- int
pure (T.pack name,T.pack t,num)
words :: Parser T.Text
words = T.unwords . fmap T.pack <$> sepEndBy1 (many1 alphaNum) space
int :: Parser Int
int = read <$> many1 digit
anyText :: Parser T.Text
anyText = T.pack <$> many anyChar
enumParser :: a -> String -> Parser a
enumParser c s = const c <$> string s
desc :: String -> Parser a -> Parser a
desc s p = string s *> spaces *> p
transactionDesc :: Parser TransactionDesc
transactionDesc = choice
[ desc "VISA PURCHASE" $ fmap VisaPurchase visaPurchaseDesc
, desc "EFTPOS WDL" $ fmap (EftposPurchase . Place) anyText
, desc "FOREIGN CURRENCY CONVERSION FEE" $ pure ForeignCurrencyConversionFee
, desc "DIRECT CREDIT" $ fmap DirectCredit directCreditDesc
, string "ATM " *> choice
[ desc "OPERATOR FEE" $ fmap AtmOperatorFee atmOperatorFeeDesc
, desc "WITHDRAWAL" $ fmap AtmWithdrawal place
]
, string "INTERNET TRANSFER " *> choice
[ desc "CREDIT FROM" $ fmap InternetTransferCredit (internetTransferDesc "REF NO")
, desc "DEBIT TO" $ fmap InternetTransferDebit (internetTransferDesc "REFERENCE NO")
]
]
visaPurchaseDesc :: Parser VisaPurchaseDesc
visaPurchaseDesc = VisaPurchaseDesc
-- This one is different because we can't rely on the double space to end things
-- So lets parse anyChar until we hit space then the DD/MM bit
<$> (Place . T.pack <$> manyTill anyChar (try . lookAhead $ space >> ddMm))
<*> (spaces *> ddMm)
<*> (spaces *> countryCode)
<*> (spaces *> currencyCode)
directCreditDesc :: Parser DirectCreditDesc
directCreditDesc = DirectCreditDesc
<$> place
<*> (spaces *> int)
place :: Parser Place
place = Place <$> words
atmOperatorFeeDesc :: Parser AtmOperatorFeeDesc
atmOperatorFeeDesc = AtmOperatorFeeDesc
<$> choice [enumParser Withdrawal "WITHDRAWAL"]
<*> (spaces *> place)
internetTransferDesc :: String -> Parser InternetTransferDesc
internetTransferDesc s = InternetTransferDesc
<$> int
<*> (spaces *> string s *> spaces *> anyText)
countryCode :: Parser CountryCode
countryCode = choice
[ enumParser AU "AU"
, enumParser US "US"
]
currencyCode :: Parser CurrencyCode
currencyCode = choice
[ enumParser AUD "AUD"
, enumParser USD "USD"
]
ddMm :: Parser DdMm
ddMm = DdMm <$> (int <* char '/') <*> int
instance FromField Currency where
parseField bs =
let s = C8.unpack bs
sign = bool id (0-) $ isPrefixOf "-" s
in maybe (fail $ "Invalid currency: " <> s) (pure . Currency . sign)
. readMaybe
. filter (/= ',')
. dropWhile (== '$')
. dropWhile (== '-')
$ s
instance FromField TransactionDesc where
parseField s = either (fail . show) pure $
parse transactionDesc (C8.unpack s) (decodeUtf8 s)
instance FromField Day where
parseField s = maybe (fail "Invalid DD/MM/YYYY date") pure $
parseTimeM True defaultTimeLocale "%d/%m/%Y" (C8.unpack s)
instance FromRecord Transaction where
parseRecord v
| V.length v == 4 = Transaction <$> v .! 0 <*> v .! 1 <*> v .! 2 <*> v .! 3
| otherwise = fail $ "Invalid number of fields: " <> show (V.length v)