227 lines
8.0 KiB
Haskell
227 lines
8.0 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PolyKinds #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Main where
|
|
|
|
import Lens.Micro ((&), (.~))
|
|
import Control.Monad
|
|
import Data.Aeson
|
|
import qualified Data.ByteString.Lazy.Char8 as BL8
|
|
import Data.Decimal
|
|
import qualified Data.Map as M
|
|
import Data.Proxy
|
|
import Data.String (fromString)
|
|
import Data.Swagger
|
|
import Data.Text hiding (map,reverse)
|
|
import Network.Wai as Wai
|
|
import Network.Wai.Handler.Warp as Warp
|
|
import Network.Wai.Middleware.RequestLogger
|
|
import Safe
|
|
import Servant
|
|
import Servant.Swagger
|
|
import System.Console.Docopt
|
|
import System.Environment (getArgs)
|
|
import System.Exit
|
|
import Text.Printf
|
|
|
|
import Hledger.Query
|
|
import Hledger.Cli hiding (Reader, version)
|
|
|
|
hledgerApiVersion="1.1.98"
|
|
|
|
-- https://github.com/docopt/docopt.hs#readme
|
|
doc :: Docopt
|
|
doc = [docopt|
|
|
hledger-api 1.1.98
|
|
|
|
Serves hledger data and reports as a JSON web API.
|
|
|
|
Usage:
|
|
hledger-api [options]
|
|
start API server
|
|
hledger-api --swagger
|
|
print API docs in Swagger 2.0 format
|
|
hledger-api --version
|
|
hledger-api -h|--help|--info
|
|
|
|
Options:
|
|
-f --file FILE use a different input file
|
|
(default: $LEDGER_FILE or ~/.hledger.journal)
|
|
-d --static-dir DIR serve files from a different directory
|
|
(default: .)
|
|
--host IPADDR listen on this IP address (default: 127.0.0.1)
|
|
-p --port PORT listen on this TCP port (default: 8001)
|
|
--version show version
|
|
-h show usage
|
|
--help show manual
|
|
--man show manual with man
|
|
--info show manual with info
|
|
|]
|
|
|
|
swaggerSpec :: Swagger
|
|
swaggerSpec = toSwagger (Proxy :: Proxy HledgerApi)
|
|
& info.title .~ "hledger API"
|
|
& info.version .~ pack hledgerApiVersion
|
|
& info.description .~ Just "This is the API provided by hledger-api for reading hledger data"
|
|
& info.license .~ Just (License "GPLv3+" (Nothing))
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs >>= parseArgsOrExit doc
|
|
when (isPresent args (shortOption 'h')) $ exitWithUsage doc
|
|
when (isPresent args (longOption "help")) $ printHelpForTopic "api" >> exitSuccess
|
|
when (isPresent args (longOption "man")) $ runManForTopic "api" >> exitSuccess
|
|
when (isPresent args (longOption "info")) $ runInfoForTopic "api" >> exitSuccess
|
|
when (isPresent args (longOption "version")) $ putStrLn hledgerApiVersion >> exitSuccess
|
|
when (isPresent args (longOption "swagger")) $ BL8.putStrLn (encode swaggerSpec) >> exitSuccess
|
|
let
|
|
defh = "127.0.0.1"
|
|
h = getArgWithDefault args defh (longOption "host")
|
|
defp = "8001"
|
|
p <- case readMay $ getArgWithDefault args defp (longOption "port") of
|
|
Nothing -> exitWithUsage doc
|
|
Just n -> return n
|
|
deff <- defaultJournalPath
|
|
let f = getArgWithDefault args deff (longOption "file")
|
|
requireJournalFileExists f
|
|
let
|
|
defd = "."
|
|
d = getArgWithDefault args defd (longOption "static-dir")
|
|
readJournalFile Nothing Nothing True f >>= either error' (serveApi h p d f)
|
|
|
|
serveApi :: String -> Int -> FilePath -> FilePath -> Journal -> IO ()
|
|
serveApi h p d f j = do
|
|
printf "Starting web api http://%s:%d/api/v1 for %s\n" h p f
|
|
printf "and file server http://%s:%d for %s/\n" h p d
|
|
printf "Press ctrl-c to quit\n"
|
|
let warpsettings = defaultSettings
|
|
& setHost (fromString h)
|
|
& setPort p
|
|
Warp.runSettings warpsettings $
|
|
logStdout $
|
|
hledgerApiApp d j
|
|
|
|
type HledgerApi =
|
|
"api" :> "v1" :>
|
|
(
|
|
"accountnames" :> Get '[JSON] [AccountName]
|
|
:<|> "transactions" :> Get '[JSON] [Transaction]
|
|
:<|> "prices" :> Get '[JSON] [MarketPrice]
|
|
:<|> "commodities" :> Get '[JSON] [CommoditySymbol]
|
|
:<|> "accounts" :> Get '[JSON] [Account]
|
|
:<|> "accounts" :> Capture "acct" AccountName :> Get '[JSON] AccountTransactionsReport
|
|
)
|
|
|
|
type HledgerSwaggerApi =
|
|
"swagger.json" :> Get '[JSON] Swagger
|
|
:<|> HledgerApi
|
|
|
|
type HledgerSwaggerFilesApi =
|
|
HledgerSwaggerApi
|
|
:<|> Raw
|
|
|
|
hledgerApiApp :: FilePath -> Journal -> Wai.Application
|
|
hledgerApiApp staticdir j = Servant.serve api server
|
|
where
|
|
api :: Proxy HledgerSwaggerFilesApi
|
|
api = Proxy
|
|
|
|
server :: Server HledgerSwaggerFilesApi
|
|
server =
|
|
(
|
|
return swaggerSpec
|
|
--
|
|
:<|> accountnamesH
|
|
:<|> transactionsH
|
|
:<|> pricesH
|
|
:<|> commoditiesH
|
|
:<|> accountsH
|
|
:<|> accounttransactionsH
|
|
)
|
|
--
|
|
:<|> serveDirectory staticdir
|
|
where
|
|
accountnamesH = return $ journalAccountNames j
|
|
transactionsH = return $ jtxns j
|
|
pricesH = return $ jmarketprices j
|
|
commoditiesH = return $ (M.keys . jinferredcommodities) j
|
|
accountsH = return $ ledgerTopAccounts $ ledgerFromJournal Hledger.Query.Any j
|
|
accounttransactionsH (a::AccountName) = do
|
|
-- d <- liftIO getCurrentDay
|
|
let
|
|
ropts = defreportopts
|
|
-- ropts' = ropts {depth_=Nothing
|
|
-- ,balancetype_=HistoricalBalance
|
|
-- }
|
|
q = Hledger.Query.Any --filterQuery (not . queryIsDepth) $ queryFromOpts d ropts'
|
|
thisacctq = Acct $ accountNameToAccountRegex a -- includes subs
|
|
return $ accountTransactionsReport ropts j q thisacctq
|
|
|
|
instance ToJSON ClearedStatus where toJSON = genericToJSON defaultOptions -- avoiding https://github.com/bos/aeson/issues/290
|
|
instance ToJSON GenericSourcePos where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON Decimal where
|
|
toJSON = toJSON . show
|
|
instance ToJSON Amount where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON AmountStyle where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON Side where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON DigitGroupStyle where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON MixedAmount where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON Price where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON MarketPrice where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON PostingType where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON Posting where
|
|
toJSON Posting{..} =
|
|
object
|
|
["pdate" .= toJSON pdate
|
|
,"pdate2" .= toJSON pdate2
|
|
,"pstatus" .= toJSON pstatus
|
|
,"paccount" .= toJSON paccount
|
|
,"pamount" .= toJSON pamount
|
|
,"pcomment" .= toJSON pcomment
|
|
,"ptype" .= toJSON ptype
|
|
,"ptags" .= toJSON ptags
|
|
,"pbalanceassertion" .= toJSON pbalanceassertion
|
|
,"ptransactionidx" .= toJSON (maybe "" (show.tindex) ptransaction)
|
|
]
|
|
instance ToJSON Transaction where toJSON = genericToJSON defaultOptions
|
|
instance ToJSON Account where
|
|
toJSON a =
|
|
object
|
|
["aname" .= toJSON (aname a)
|
|
,"aebalance" .= toJSON (aebalance a)
|
|
,"aibalance" .= toJSON (aibalance a)
|
|
,"anumpostings" .= toJSON (anumpostings a)
|
|
,"aboring" .= toJSON (aboring a)
|
|
,"aparentname" .= toJSON (maybe "" aname $ aparent a)
|
|
,"asubs" .= toJSON (map toJSON $ asubs a)
|
|
]
|
|
instance ToSchema ClearedStatus
|
|
instance ToSchema GenericSourcePos
|
|
instance ToSchema Decimal
|
|
where
|
|
declareNamedSchema _proxy = pure $ NamedSchema (Just "Decimal") schema
|
|
where
|
|
schema = mempty
|
|
& type_ .~ SwaggerNumber
|
|
& example .~ Just (toJSON (100 :: Decimal))
|
|
instance ToSchema Amount
|
|
instance ToSchema AmountStyle
|
|
instance ToSchema Side
|
|
instance ToSchema DigitGroupStyle
|
|
instance ToSchema MixedAmount
|
|
instance ToSchema Price
|
|
instance ToSchema MarketPrice
|
|
instance ToSchema PostingType
|
|
instance ToSchema Posting
|
|
instance ToSchema Transaction
|
|
instance ToSchema Account
|
|
-- instance ToSchema AccountTransactionsReport
|