#define DERIVING Generic, Default, Show, FromJSON
module Buchhaltung.Types
(module Control.Monad.Except
,module Buchhaltung.Types
)where
import Buchhaltung.Utils
import Control.Applicative
import Control.Arrow
import Control.DeepSeq
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.RWS.Strict
import Control.Monad.Reader
import qualified Data.Aeson as A
import qualified Data.Aeson.Text as A
import qualified Data.Aeson.Types as A
import Data.Char
import Data.Default
import Data.Foldable
import Data.Function
import Data.Functor
import qualified Data.HashMap.Strict as HM
import Data.Hashable
import qualified Data.ListLike as L
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as V
import Data.Yaml
import Formatting
import Formatting.Internal (Format)
import qualified Formatting.ShortFormatters as F
import GHC.Generics
import Hledger.Data
import Prelude hiding (lookup)
import System.FilePath
import Text.Printf
import qualified Text.Regex.TDFA as R
import Text.Regex.TDFA.Text ()
type CommonM env = RWST (FullOptions env) () () (ErrorT IO)
type Version = T.Text
data SFormat a = SFormat { fName :: T.Text
, fVersion :: a
}
deriving (Generic, Show, Eq, Ord, Read, Hashable, Functor)
data Source = Source { sFormat :: SFormat Version
, sStore :: M.Map T.Text T.Text }
deriving (Generic, Show, Eq, Ord, Read)
fromMapToSource :: SFormat Version -> HM.HashMap T.Text T.Text -> Source
fromMapToSource format = Source format . M.fromList .
filter (not . L.null . snd) . HM.toList
sourceToMap :: Source -> M.Map T.Text T.Text
sourceToMap s = M.unionWith (\x y -> x <> ", " <> y)
(sStore s)
$ M.fromList $ formatToAssoc $ sFormat s
formatToAssoc f = [("formatName", fName f)
,("formatVersion", fVersion f)]
json :: Source -> TL.Text
json = A.encodeToLazyText
instance FromJSON Source where
parseJSON (Object v) = do
Source <$>
(SFormat <$> v .: "name" <*> v .: "version")
<*> v.: "store"
instance ToJSON Source where
toJSON s = Object $ HM.insert "store" (toJSON $ sStore s) $ toJSON
<$> HM.fromList (formatToAssoc $ sFormat s)
stripPrefixOptions n = A.defaultOptions{A.fieldLabelModifier = g}
where g = drop n . fmap toLower
newtype ImportTag = ImportTag { fromImportTag :: T.Text }
deriving ( Generic, Show)
instance Default ImportTag where
def = "SOURCE"
instance IsString ImportTag where
fromString = ImportTag . fromString
type Msg = T.Text
type Error = Either Msg
type ErrorT = ExceptT Msg
throwFormat
:: MonadError Msg m => Format T.Text t -> (t -> Msg) -> m b
throwFormat msg a = throwError $ a $ sformat msg
maybeThrow
:: MonadError Msg m => Format T.Text t
-> (t -> Msg) -> (a1 -> m b) -> Maybe a1 -> m b
maybeThrow msg a = maybe (throwFormat msg a)
lookupErrD
:: Show t => [Char]
-> (t -> t1 -> Maybe a)
-> t
-> t1
-> a
lookupErrD d l k m =
either (error . T.unpack) id $ runExcept $ lookupErrM d l k m
lookupErrM
:: (MonadError Msg m, Show a) =>
String -> (a -> t -> Maybe b) -> a -> t -> m b
lookupErrM description lookup k container =
maybeThrow ("lookupErr: " %F.sh% " not found: " %F.s)
(\f -> f k description) return
$ lookup k container
fromListUnique :: (MonadError Msg m, Show k, Ord k)
=> [(k, a)] -> m (M.Map k a)
fromListUnique = sequence . M.fromListWithKey
(\k a b -> throwFormat ("Duplicate key '"%shown%"' in M.fromList") ($ k))
. fmap (second pure)
data Options user config env = Options
{ oUser :: user
, oProfile :: FilePath
, oAction :: Action
, oConfig :: config
, oEnv :: env
}
deriving (Show, Generic, NFData)
type FullOptions = Options User Config
type RawOptions = Options (Maybe Username) ()
toFull :: MonadError Msg m
=> RawOptions env
-> Config
-> m (FullOptions env)
toFull opts1@Options{oUser=user} config =
(\u -> opts2{oUser = u}) <$>
runReaderT (maybe (defaultUser 0) lookupUser user) opts2
where opts2 = opts1 { oConfig = config }
readConfig :: MonadReader (Options user config env) m => (config -> a) -> m a
readConfig f = reader $ f. oConfig
readUser :: MonadReader (Options user config env) m => (user -> a) -> m a
readUser f = reader $ f . oUser
user :: MonadReader (Options user config env) m => m user
user = readUser id
readLedger
:: MonadReader (Options User config env) m =>
(Ledgers -> FilePath) -> m FilePath
readLedger = (<$> readUser ledgers)
absolute
:: MonadReader (Options user config env) m =>
FilePath -> m FilePath
absolute f = do prof <- reader oProfile
return $ prof </> f
data Config = Config
{
cUsers :: Users
, cUserList :: V.Vector Username
, cImportTag :: ImportTag
, cTodoAccount :: AccountName
, cDbaclExecutable :: FilePath
, cLedgerExecutable :: FilePath
, cHledgerExecutable :: FilePath
}
deriving ( Generic, Show )
askTag :: MonadReader (Options user Config env) m => m ImportTag
askTag = readConfig $ cImportTag
askTodoFilter :: MonadReader (Options user Config env) m
=> m (AccountName -> Bool)
askTodoFilter = return . L.isPrefixOf =<< readConfig cTodoAccount
instance FromJSON Config where
parseJSON (Object v) = do
users <- parseJSON =<< v .: "users" :: A.Parser (V.Vector User)
dbEx <- v .:? "dbaclExecutable" .!= "dbacl" :: Parser FilePath
[lEx, hlEx] <- forM ["", "h"] $ \pfx ->
v .:? (T.pack pfx <> "ledgerExecutable") .!= (pfx <> "ledger")
:: Parser FilePath
return Config
{ cUsers = HM.fromList $ (\u -> (name u, u)) <$> V.toList users
, cUserList = name <$> users
, cImportTag = def
, cTodoAccount = "TODO"
, cDbaclExecutable = dbEx
, cLedgerExecutable = lEx
, cHledgerExecutable = hlEx
}
parseJSON invalid = A.typeMismatch "Config" invalid
readConfigFromFile :: FilePath -> IO Config
readConfigFromFile path = either (error . prettyPrintParseException) id <$>
decodeFileEither (path </> "config" <.> "yml") :: IO Config
data User = User
{ name :: Username
, ledgers :: Ledgers
, accountPrefixOthers :: Maybe AccountName
, aqBanking :: Maybe AQBankingConf
, bankAccounts :: Maybe BankAccounts
, ignoredAccountsOnAdd :: Maybe [Regex]
, numSuggestedAccounts :: Maybe Int
}
deriving ( Generic, Show, FromJSON )
type Users = HM.HashMap Username User
newtype Username = Username T.Text
deriving ( Generic, FromJSON, NFData, Eq, Hashable, A.FromJSONKey)
fromUsername :: Username -> T.Text
fromUsername (Username n) = n
instance Show Username where
show = T.unpack . fromUsername
instance Eq User where
(==) = (==) `on` name
lookupUser :: ( MonadError Msg m
, MonadReader (Options user Config e) m)
=> Username
-> m User
lookupUser user = do
maybeThrow msg ($ user) return . HM.lookup user . cUsers =<< reader oConfig
where msg = "User '"%F.sh%"' not found"
defaultUser :: ( MonadError Msg m
, MonadReader (Options user Config e) m)
=> Int
-> m User
defaultUser ix = do
config <- reader oConfig
maybeThrow msg ($ succ ix) lookupUser $ cUserList config V.!? ix
where msg = "There are less than "%F.d%
" users configured. Please add a user to the config file."
data Ledgers = Ledgers
{ imported :: FilePath
, addedByThisUser :: FilePath
, addedByOthers :: Maybe FilePath
, mainLedger :: FilePath
, mainHledger :: Maybe FilePath
}
deriving (Generic, Default, Show, FromJSON)
receivablePayable
:: (MonadError Msg m, MonadReader (FullOptions env) m)
=> Bool
-> User
-> m T.Text
receivablePayable forThis other = do
this <- readUser id
let (ledgerU, accountU) =
if forThis then (this, other) else (other, this)
let full pref = return $ intercalateL ":" $ pref :
(fromUsername . name <$> [accountU, this])
maybeThrow msg ($ name ledgerU) full
$ accountPrefixOthers ledgerU
where msg = "User '"%F.sh%"' has no accountPrefixOthers configured"
askAccountMap :: MonadReader (Options User config env) m => m AccountMap
askAccountMap = readUser $ maybe mempty fromBankAccounts . bankAccounts
newtype BankAccounts = BankAccounts AccountMap
deriving (Generic, Default, Show)
fromBankAccounts :: BankAccounts -> AccountMap
fromBankAccounts (BankAccounts b) = b
isIgnored :: User -> AccountName -> Bool
isIgnored user acc = or $ maybe [] (fmap g) $
ignoredAccountsOnAdd user
where g ign = R.match (rRegex ign) acc
data Regex = Regex
{rShow :: T.Text
, rRegex :: R.Regex
}
instance FromJSON Regex where
parseJSON (String v) = Regex v <$> R.makeRegexM v
parseJSON invalid = A.typeMismatch "regex string" invalid
instance Show Regex where
show = T.unpack . rShow
data AccountId = AccountId { aBank :: T.Text
, aAccount :: T.Text }
deriving (Generic, Eq, Ord, Hashable, Show)
type AccountMap = HM.HashMap AccountId AccountName
instance (Hashable a, Eq a) => Default (HM.HashMap a b) where
def = mempty
instance FromJSON BankAccounts where
parseJSON (Object v) = BankAccounts . HM.fromList . concat
<$> traverse parseAccountMap (HM.toList v)
parseJSON invalid = A.typeMismatch "BankAccounts" invalid
parseAccountMap :: FromJSON b => (T.Text, Value) -> Parser [(AccountId, b)]
parseAccountMap (bank, (Object m)) = traverse f $ HM.toList m
where f (acc,v) = (,) (AccountId bank acc) <$> parseJSON v
parseAccountMap (_, invalid) = A.typeMismatch "parseAccountMap" invalid
data AQBankingConf = AQBankingConf
{ connections :: [AQConnection]
, configDir :: FilePath
, aqBankingExecutable :: Maybe FilePath
, aqhbciToolExecutable :: Maybe FilePath
}
deriving ( DERIVING )
data AQConnection = AQConnection
{ aqUser :: String
, aqBlz :: String
, aqUrl :: String
, aqHbciv :: HBCIv
, aqName :: String
, aqType :: AQType
}
deriving ( Generic, Show)
instance FromJSON AQConnection where
parseJSON = A.genericParseJSON $ stripPrefixOptions 2
instance ToJSON AQConnection where
toEncoding = A.genericToEncoding $ stripPrefixOptions 2
data AQType = PinTan
| Other
deriving ( Generic, Show, FromJSON, ToJSON, Eq )
data HBCIv = HBCI201
| HBCI210
| HBCI220
| HBCI300
deriving ( Generic, Show, FromJSON, ToJSON )
toArg HBCI201 = "201"
toArg HBCI210 = "210"
toArg HBCI220 = "220"
toArg HBCI300 = "300"
type PaypalUsername = T.Text
data Action = Add { aPartners :: [Username] }
| Match
| Import { iVersion :: Maybe Version
, iPath :: FilePath
, iAction :: ImportAction }
| Update { aqVersion :: Maybe Version
, aqMatch :: Bool
, aqRequest :: Bool
}
| Commit { cArgs :: [String] }
| ListBalances
| Setup
| Ledger { lArgs :: [String] }
| HLedger { hlArgs :: [String] }
| AQBanking { aqArgs :: [String] }
deriving (Show, Generic, NFData)
data ImportAction = Paypal PaypalUsername
| AQBankingImport
| ComdirectVisa { comdirectVisaBlz :: T.Text }
deriving (Show, Generic, NFData)
type Comment = T.Text