pwncash/lib/Internal/Utils.hs

510 lines
16 KiB
Haskell

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Internal.Utils
( compareDate
, intervalMaybeBounds
, fmtRational
, matches
, fromGregorian'
, resolveBounds
, leftToMaybe
, dec2Rat
, concatEithers2
, concatEither3
, concatEither2
, concatEitherL
, concatEithersL
, parseRational
, showError
, unlessLeft_
, unlessLefts_
, unlessLeft
, unlessLefts
, inMaybeBounds
, acntPath2Text
, showT
, lookupErr
)
where
import Data.Time.Format.ISO8601
import GHC.Real
import Internal.Types
import RIO
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.Text as T
import RIO.Time
import Text.Regex.TDFA
--------------------------------------------------------------------------------
-- dates
gregTup :: Gregorian -> (Integer, Int, Int)
gregTup Gregorian {..} =
( fromIntegral gYear
, fromIntegral gMonth
, fromIntegral gDay
)
gregMTup :: GregorianM -> (Integer, Int)
gregMTup GregorianM {..} =
( fromIntegral gmYear
, fromIntegral gmMonth
)
data YMD_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
fromMatchYMD :: MatchYMD -> YMD_
fromMatchYMD m = case m of
Y y -> Y_ $ fromIntegral y
YM g -> uncurry YM_ $ gregMTup g
YMD g -> uncurry3 YMD_ $ gregTup g
compareDate :: MatchDate -> Day -> Ordering
compareDate (On md) x =
case fromMatchYMD md of
Y_ y' -> compare y y'
YM_ y' m' -> compare (y, m) (y', m')
YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
where
(y, m, d) = toGregorian x
compareDate (In md offset) x = do
case fromMatchYMD md of
Y_ y' -> compareRange y' y
YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
YMD_ y' m' d' ->
let s = toModifiedJulianDay $ fromGregorian y' m' d'
in compareRange s $ toModifiedJulianDay x
where
(y, m, _) = toGregorian x
compareRange start z
| z < start = LT
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
toMonth year month = (year * 12) + fromIntegral month
-- boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds
-- boundsFromGregorian (a, b) = (fromGregorian' a, fromGregorian' b)
fromGregorian' :: Gregorian -> Day
fromGregorian' = uncurry3 fromGregorian . gregTup
-- inBounds :: Bounds -> Day -> Bool
-- inBounds (d0, d1) x = d0 <= x && x <= d1
inMaybeBounds :: MaybeBounds -> Day -> Bool
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
intervalMaybeBounds :: Interval -> MaybeBounds
intervalMaybeBounds Interval {intStart = s, intEnd = e} =
(fmap fromGregorian' s, fmap fromGregorian' e)
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
resolveBounds (s, e) = do
s' <- maybe getDay return s
e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
return (s', e')
where
getDay = utctDay <$> getCurrentTime
--------------------------------------------------------------------------------
-- matching
matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
matches Match {..} r@TxRecord {..} = do
res <- concatEither3 val other desc $ \x y z -> x && y && z
if date && res
then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
else Right MatchFail
where
val = valMatches mVal trAmount
date = maybe True (`dateMatches` trDate) mDate
other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
desc = maybe (return True) (matchMaybe trDesc) mDesc
convert (ToTx cur a ss) = toTx cur a ss r
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
toTx sc sa toSplits r@TxRecord {..} =
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
let fromSplit =
Split
{ sAcnt = a_
, sCurrency = c_
, sValue = Just trAmount
, sComment = ""
}
in Tx
{ txTags = []
, txDate = trDate
, txDescr = trDesc
, txSplits = fromSplit : ss_
}
where
acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
valMatches :: MatchVal -> Rational -> EitherErr Bool
valMatches MatchVal {..} x
| Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
| otherwise =
Right $
checkMaybe (s ==) mvSign
&& checkMaybe (n ==) mvNum
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen
where
(n, d) = properFraction $ abs x
p = 10 ^ mvPrec
s = signum x >= 0
checkMaybe = maybe True
dateMatches :: MatchDate -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md
otherMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool
otherMatches dict m = case m of
Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n)
Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ MatchText n
where
lookup_ t n = lookupErr (MatchField t) n dict
resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
concatEithers2 acRes valRes $
\(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
where
acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
valRes = plural $ mapM (resolveValue r) v
resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
resolveValue r s = case s of
(LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
(ConstN c) -> Right $ dec2Rat c
AmountN -> Right $ trAmount r
resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveAcnt = resolveSplitField AcntField
resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
resolveCurrency = resolveSplitField CurField
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
resolveSplitField t TxRecord {trOther = o} s = case s of
ConstT p -> Right p
LookupT f -> plural $ lookup_ f o
MapT (Field f m) -> plural $ do
k <- lookup_ f o
lookup_ k m
Map2T (Field (f1, f2) m) -> do
(k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,)
plural $ lookup_ (k1, k2) m
where
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v
lookup_ = lookupErr (SplitIDField t)
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v
lookupErr what k m = case M.lookup k m of
Just x -> Right x
_ -> Left $ LookupError what $ showT k
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
parseRational pat s = case ms of
[sign, x, ""] -> uncurry (*) <$> readWhole sign x
[sign, x, y] -> do
d <- readT "decimal" y
let p = 10 ^ T.length y
(k, w) <- readWhole sign x
return $ k * (w + d % p)
_ -> msg "malformed decimal"
where
(_, _, _, ms) = (s =~ pat) :: (T.Text, T.Text, T.Text, [T.Text])
readT what t = case readMaybe $ T.unpack t of
Just d -> return $ fromInteger d
_ -> msg $ T.unwords ["could not parse", what, t]
msg m =
fail $
T.unpack $
T.concat
[ m
, "; pattern = "
, pat
, "; query = "
, s
]
readSign x
| x == "-" = return (-1)
| x == "+" || x == "" = return 1
| otherwise = msg $ T.append "invalid sign: " x
readWhole sign x = do
w <- readT "whole number" x
k <- readSign sign
return (k, w)
readRational :: T.Text -> EitherErr Rational
readRational s = case T.split (== '.') s of
[x] -> maybe err (return . fromInteger) $ readT x
[x, y] -> case (readT x, readT y) of
(Just x', Just y') ->
let p = 10 ^ T.length y
k = if x' >= 0 then 1 else -1
in return $ fromInteger x' + k * y' % p
_ -> err
_ -> err
where
readT = readMaybe . T.unpack
err = Left $ ConversionError s
-- TODO smells like a lens
-- mapTxSplits :: (a -> b) -> Tx a -> Tx b
-- mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
fmtRational :: Natural -> Rational -> T.Text
fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
where
s = if x >= 0 then "" else "-"
x'@(n :% d) = abs x
p = 10 ^ precision
n' = div n d
d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
txt = T.pack . show
pad i c z = T.append (T.replicate (i - T.length z) c) z
dec2Rat :: Decimal -> Rational
dec2Rat D {..} =
k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
where
k = if sign then 1 else -1
acntPath2Text :: AcntPath -> T.Text
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
--------------------------------------------------------------------------------
-- error display
showError :: InsertError -> [T.Text]
showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
showError other = (: []) $ case other of
(RegexError re) -> T.append "could not make regex from pattern: " re
(ConversionError x) -> T.append "Could not convert to rational number: " x
(InsertIOError msg) -> T.append "IO Error: " msg
(ParseError msg) -> T.append "Parse Error: " msg
(MatchValPrecisionError d p) ->
T.unwords ["Match denominator", showT d, "must be less than", showT p]
(LookupError t f) ->
T.unwords ["Could not find field", singleQuote f, "when resolving", what]
where
what = case t of
SplitIDField st -> T.unwords ["split", idName st, "ID"]
SplitValField -> "split value"
MatchField mt -> T.unwords [matchName mt, "match"]
DBKey st -> T.unwords ["database", idName st, "ID key"]
idName AcntField = "account"
idName CurField = "currency"
matchName MatchNumeric = "numeric"
matchName MatchText = "text"
(AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
where
msg = case t of
NoAllocations -> "No post-tax allocations present"
ExceededTotal -> "Allocations exceed total income"
MissingBlank -> "No blank allocation to balance"
TooManyBlanks -> "Cannot balance multiple blank allocations"
(BalanceError t cur rss) ->
T.unwords
[ msg
, "for currency"
, singleQuote cur
, "and for splits"
, splits
]
where
msg = case t of
TooFewSplits -> "Need at least two splits to balance"
NotOneBlank -> "Exactly one split must be blank"
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
showTx :: TxRecord -> T.Text
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
T.append "Unmatched transaction: " $
keyVals
[ ("path", T.pack f)
, ("date", T.pack $ iso8601Show d)
, ("value", showT (fromRational v :: Float))
, ("description", doubleQuote e)
]
showMatch :: Match -> T.Text
showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriority = p} =
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
where
kvs =
[ ("date", showMatchDate <$> d)
, ("val", showMatchVal v)
, ("desc", e)
, ("other", others)
, ("counter", Just $ maybe "Inf" showT n)
, ("priority", Just $ showT p)
]
others = case o of
[] -> Nothing
xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
-- | Convert match date to text
-- Single date matches will just show the single date, and ranged matches will
-- show an interval like [YY-MM-DD, YY-MM-DD)
showMatchDate :: MatchDate -> T.Text
showMatchDate md = case md of
(On x) -> showMatchYMD x
(In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"]
where
-- TODO not DRY (this shifting thing happens during the comparison
-- function (kinda)
end = case fromMatchYMD start of
Y_ y -> Y_ $ y + fromIntegral n
YM_ y m ->
let (y_, m_) = divMod (m + fromIntegral n - 1) 12
in YM_ (y + fromIntegral y_) (m + m_ + 1)
YMD_ y m d ->
uncurry3 YMD_ $
toGregorian $
addDays (fromIntegral n) $
fromGregorian y m d
-- | convert YMD match to text
showMatchYMD :: MatchYMD -> T.Text
showMatchYMD = showYMD_ . fromMatchYMD
showYMD_ :: YMD_ -> T.Text
showYMD_ md =
T.intercalate "-" $ L.take 3 (fmap showT digits ++ L.repeat "*")
where
digits = case md of
Y_ y -> [fromIntegral y]
YM_ y m -> [fromIntegral y, m]
YMD_ y m d -> [fromIntegral y, m, d]
showMatchVal :: MatchVal -> Maybe T.Text
showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
showMatchVal MatchVal {..} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
where
kvs =
[ ("sign", (\s -> if s then "+" else "-") <$> mvSign)
, ("numerator", showT <$> mvNum)
, ("denominator", showT <$> mvDen)
, ("precision", Just $ showT mvPrec)
]
showMatchOther :: MatchOther -> T.Text
showMatchOther (Desc (Field f re)) =
T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
showMatchOther (Val (Field f mv)) =
T.unwords
[ "val field"
, singleQuote f
, "with match value"
, singleQuote $ fromMaybe "*" $ showMatchVal mv
]
showSplit :: RawSplit -> T.Text
showSplit Split {sAcnt = a, sValue = v, sComment = c} =
keyVals
[ ("account", a)
, ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))
, ("comment", doubleQuote c)
]
singleQuote :: T.Text -> T.Text
singleQuote t = T.concat ["'", t, "'"]
doubleQuote :: T.Text -> T.Text
doubleQuote t = T.concat ["'", t, "'"]
keyVal :: T.Text -> T.Text -> T.Text
keyVal a b = T.concat [a, "=", b]
keyVals :: [(T.Text, T.Text)] -> T.Text
keyVals = T.intercalate "; " . fmap (uncurry keyVal)
showT :: Show a => a -> T.Text
showT = T.pack . show
--------------------------------------------------------------------------------
-- pure error processing
concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
concatEither2 a b fun = case (a, b) of
(Right a_, Right b_) -> Right $ fun a_ b_
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
concatEither3 a b c fun = case (a, b, c) of
(Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
concatEithers2 a b = merge . concatEither2 a b
-- concatEithers3
-- :: Either [x] a
-- -> Either [x] b
-- -> Either [x] c
-- -> (a -> b -> c -> d)
-- -> Either [x] d
-- concatEithers3 a b c = merge . concatEither3 a b c
concatEitherL :: [Either x a] -> Either [x] [a]
concatEitherL as = case partitionEithers as of
([], bs) -> Right bs
(es, _) -> Left es
concatEithersL :: [Either [x] a] -> Either [x] [a]
concatEithersL = merge . concatEitherL
leftToMaybe :: Either a b -> Maybe a
leftToMaybe (Left a) = Just a
leftToMaybe _ = Nothing
unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
unlessLeft (Left es) _ = return (return es)
unlessLeft (Right rs) f = f rs
unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a)
unlessLefts (Left es) _ = return es
unlessLefts (Right rs) f = f rs
unlessLeft_ :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a)
unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)
unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
plural :: Either a b -> Either [a] b
plural = first (: [])
merge :: Either [[a]] b -> Either [a] b
merge = first concat
--------------------------------------------------------------------------------
-- random functions
-- when bifunctor fails...
-- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
-- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
-- lpad :: a -> Int -> [a] -> [a]
-- lpad c n s = replicate (n - length s) c ++ s
-- rpad :: a -> Int -> [a] -> [a]
-- rpad c n s = s ++ replicate (n - length s) c
-- lpadT :: Char -> Int -> T.Text -> T.Text
-- lpadT c n s = T.append (T.replicate (n - T.length s) (T.singleton c)) s
matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re