hledger/hledger-api/hledger-api.hs

{-# 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.Swagger
import           Data.Text hiding (map,reverse)
import           Network.Wai as Wai
import           Network.Wai.Handler.Warp as Warp
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="0.27.98"

-- https://github.com/docopt/docopt.hs#readme
doc :: Docopt
doc = [docopt|
hledger-api 0.27.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: .)
  -p --port PORT  use a different 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 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 p d f)

serveApi :: Int -> FilePath -> FilePath -> Journal -> IO ()
serveApi p d f j = do
  printf "Starting web api http://localhost:%d/api/v1 for %s\n" p f
  printf "and file server  http://localhost:%d        for %s/\n" p d
  printf "Press ctrl-c to quit\n"
  Warp.run p $ 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