journal-query-based monthly reports (p&l, assets, liabilities)

8 files changed, 188 insertions, 1 deletions

diff --git a/Application.hs b/Application.hs
index 5c9bf83..a74c493 100644
--- a/Application.hs
+++ b/Application.hs
@@ -20,6 +20,7 @@ import Control.Monad (mzero)
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
 import Handler.Home
+import Handler.Journal
 import Handler.Register
 
 -- This line actually creates our YesodSite instance. It is the second half
diff --git a/Foundation.hs b/Foundation.hs
index 49acd52..4ce89c8 100644
--- a/Foundation.hs
+++ b/Foundation.hs
@@ -29,9 +29,18 @@ import Web.ClientSession (getKey)
 import Text.Hamlet (hamletFile)
 import qualified Data.Text
 import Data.Map (Map)
+import Hledger.JournalCSVs (JReportType(..))
 
 type Ledger = Data.Text.Text
 
+instance PathPiece JReportType where
+    fromPathPiece "pandl" = Just PandL
+    fromPathPiece "assets" = Just Assets
+    fromPathPiece "liabilities" = Just Liabilities
+    fromPathPiece "everything" = Just Everything
+    fromPathPiece _ = Nothing
+    toPathPiece = Data.Text.toLower . Data.Text.pack . show
+
 -- | The site argument for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have
diff --git a/Handler/Home.hs b/Handler/Home.hs
index 94b206e..7e8d79d 100644
--- a/Handler/Home.hs
+++ b/Handler/Home.hs
@@ -19,6 +19,7 @@ module Handler.Home where
 
 import Import
 import Data.Map (keys)
+import Hledger.JournalCSVs (JReportType(..))
 
 getHomeR :: Handler RepHtml
 getHomeR = do
diff --git a/Handler/Journal.hs b/Handler/Journal.hs
new file mode 100644
index 0000000..dc68fa5
--- /dev/null
+++ b/Handler/Journal.hs
@@ -0,0 +1,45 @@
+-- sflc-ledger-reports: web interface to hledger-based reports
+--  Copyright (C) 2013  Clint Adams
+--
+--  This program is free software: you can redistribute it and/or modify
+--  it under the terms of the GNU Affero General Public License as
+--  published by the Free Software Foundation, either version 3 of the
+--  License, or (at your option) any later version.
+--
+--  This program is distributed in the hope that it will be useful,
+--  but WITHOUT ANY WARRANTY; without even the implied warranty of
+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+--  GNU Affero General Public License for more details.
+--
+--  You should have received a copy of the GNU Affero General Public License
+--  along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.Journal where
+
+import Import
+import qualified Data.Text as T
+import Hledger.JournalCSVs
+import qualified Data.Map as Map
+
+typeCsv :: ContentType
+typeCsv = "text/csv; charset=utf-8"
+
+newtype RepCsv = RepCsv Content
+instance HasReps RepCsv where
+    chooseRep (RepCsv c) _ = return (typeCsv, c)
+
+getJournalR :: JReportType -> Text -> Handler RepCsv
+getJournalR jrt ledger = do
+    ledgers <- fmap hledgerConfig getYesod
+    case Map.lookup ledger ledgers of
+        Nothing -> notFound
+	Just fn -> do
+            csv <- liftIO $ (jReport jrt) fn
+            setHeader "Content-Disposition" (T.concat ["attachment; filename=", ledger, "-", (T.pack . show) jrt, ".csv"])
+            return $ RepCsv $ toContent csv
+    where
+        jReport PandL = pAndL
+        jReport Assets = assets
+        jReport Liabilities = liabilities
+        jReport Everything = everything
diff --git a/Hledger/JournalCSVs.hs b/Hledger/JournalCSVs.hs
new file mode 100644
index 0000000..b7d5420
--- /dev/null
+++ b/Hledger/JournalCSVs.hs
@@ -0,0 +1,113 @@
+-- sflc-ledger-reports: web interface to hledger-based reports
+--  Copyright (C) 2013  Clint Adams
+--
+--  This program is free software: you can redistribute it and/or modify
+--  it under the terms of the GNU Affero General Public License as
+--  published by the Free Software Foundation, either version 3 of the
+--  License, or (at your option) any later version.
+--
+--  This program is distributed in the hope that it will be useful,
+--  but WITHOUT ANY WARRANTY; without even the implied warranty of
+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+--  GNU Affero General Public License for more details.
+--
+--  You should have received a copy of the GNU Affero General Public License
+--  along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE FlexibleContexts #-}
+
+module Hledger.JournalCSVs (pAndL, assets, liabilities, everything, JReportType(..)) where
+
+import Prelude (Enum(..), String, Integer, Int, Eq, Show, (.), ($), (*), (+), (++), (==), (&&), (>>=), (=<<), const, div, length, lookup, map, mod, subtract, filter, flip, fromIntegral, fst, return, snd, head, last, error, uncurry, Maybe(..), Bool(..), Either(..), IO, FilePath, Read)
+import Control.Applicative (liftA2)
+import Control.Monad (ap, when)
+import Data.Conduit (($$), ($=))
+import qualified Data.Conduit.List as CL
+import Data.CSV.Conduit (fromCSV, defCSVSettings, runResourceT)
+import Data.List (nub, sort, sortBy, isPrefixOf, intercalate)
+import Data.List.Split (splitOn)
+import Data.Maybe (fromMaybe)
+import Data.Ord (comparing)
+import qualified Data.Text as T
+import Data.Time.Calendar (fromGregorian, toGregorian, Day(..))
+import Data.Time.Format (formatTime)
+import Data.Tree (Tree(..))
+import System.Locale (defaultTimeLocale)
+
+import Hledger.Data.Amount (showMixedAmount)
+import Hledger.Data.Journal (journalProfitAndLossAccountQuery, journalAssetAccountQuery, journalLiabilityAccountQuery)
+import Hledger.Data.Types (DateSpan(..), Journal(..), Transaction(..))
+import Hledger.Query (Query(..))
+import Hledger.Read (readJournalFile)
+import Hledger.Reports (accountsReport, defreportopts, ReportOpts(..))
+
+data JReportType = PandL | Assets | Liabilities | Everything
+    deriving (Eq, Read, Show)
+
+pAndL :: FilePath -> IO T.Text
+pAndL fn = fn2CSV (journalProfitAndLossAccountQuery) fn
+
+assets :: FilePath -> IO T.Text
+assets fn = fn2CSV (journalAssetAccountQuery) fn
+
+liabilities :: FilePath -> IO T.Text
+liabilities fn = fn2CSV (journalLiabilityAccountQuery) fn
+
+everything :: FilePath -> IO T.Text
+everything fn = fn2CSV (const Any) fn
+
+fn2CSV :: (Journal -> Query) -> FilePath -> IO T.Text
+fn2CSV q fn = readJournalFile Nothing Nothing fn >>= \(Right j) -> jToCSV True j (q j)
+
+-- sign-change Income lines
+
+newtype YearMonth = YearMonth { unYM :: (Integer,Int) }
+    deriving (Eq, Show)
+instance Enum YearMonth where
+    toEnum = YearMonth . liftA2 (,) (fromIntegral . (`div` 12)) ((1 +) . (`mod` 12))
+    fromEnum = ap ((+) . (12 *) . fromIntegral . fst) (subtract 1 . snd) . unYM
+
+dayToYearMonth :: Day -> YearMonth
+dayToYearMonth = YearMonth . (\(x,y,_) -> (x,y)) . toGregorian
+
+yearMonthToDay :: YearMonth -> Day
+yearMonthToDay = uncurry (flip flip 1 . fromGregorian) . unYM
+
+jToCSV :: Bool -> Journal -> Query -> IO (T.Text)
+jToCSV delta jnl q = do
+    let sortedtrans = sortBy (comparing tdate) (jtxns jnl)
+        firstTxn = tdate (head sortedtrans)
+        lastTxn = tdate (last sortedtrans)
+        firstMonth = dayToYearMonth firstTxn
+        lastMonth = dayToYearMonth lastTxn
+        q' mon = And [q, Date (dS delta mon)]
+    when (firstMonth == lastMonth) $ error "Need multiple months"
+    let reports = map (\m -> accountsReport defreportopts { no_elide_ = True } (q' m) jnl) [firstMonth..lastMonth]
+        reportT = accountsReport defreportopts { no_elide_ = True } Any jnl
+        reports' = map (map (\(n, _, _, a) -> (n, showMixedAmount a)) . fst) reports
+        reportT' = (map (\(n, _, _, a) -> (n, showMixedAmount a)) . fst) reportT
+        allaccounts = sort . nub . (map fst =<<) $ reports'
+        accounttree = accts2Tree (map (splitOn ":") allaccounts)
+        concordant = map (\x -> x : fetchSeries reports' x ++ fetchSeries [reportT'] x) allaccounts
+        withheader = ("Account":map (formatTime defaultTimeLocale "%b of %Y" . yearMonthToDay) [firstMonth..lastMonth] ++ ["Period Total"]):concordant
+    c <- runResourceT $ CL.sourceList withheader $= CL.map (map T.pack) $= fromCSV defCSVSettings $$ CL.consume
+    return $ T.concat c
+
+dS :: Bool -> YearMonth -> DateSpan
+dS delta (YearMonth (y,m)) = DateSpan (if delta then Just startD else Nothing) (Just endD)
+    where
+        startD = fromGregorian y m 01
+        endD = fromGregorian y m 31
+
+fetchSeries :: [[(String, String)]] -> String -> [String]
+fetchSeries rs a = map (fromMaybe "$0.00" . lookup a) rs
+
+chirren :: [String] -> [[String]] -> [[String]]
+chirren p = filter (\x -> length x == (length p + 1) && isPrefixOf p x)
+
+accts2Tree :: [[String]] -> Tree String
+accts2Tree as = Node "" (subtrees [])
+    where
+        subtrees xs = map (\x -> Node (colonize x) (subtrees x)) (chirren xs as)
+        colonize = intercalate ":"
+
diff --git a/config/routes b/config/routes
index 5ec7492..f9ca949 100644
--- a/config/routes
+++ b/config/routes
@@ -6,3 +6,4 @@
 
 / HomeR GET
 /register/#Ledger RegisterR GET
+/monthly/#JReportType/#Ledger JournalR GET
diff --git a/sflc-ledger-reports.cabal b/sflc-ledger-reports.cabal
index 196f314..723adc8 100644
--- a/sflc-ledger-reports.cabal
+++ b/sflc-ledger-reports.cabal
@@ -1,7 +1,7 @@
 name:              sflc-ledger-reports
 version:           0.0.0
 license:           AGPL-3
-license-file:      LICENSE
+license-file:      COPYING
 author:            Clint Adams
 maintainer:        Clint Adams
 synopsis:          hledger reports for SFLC
@@ -28,7 +28,9 @@ library
                      Settings.StaticFiles
                      Settings.Development
                      Hledger.RegisterCSV
+                     Hledger.JournalCSVs
                      Handler.Home
+                     Handler.Journal
                      Handler.Register
 
     if flag(dev) || flag(library-only)
@@ -83,6 +85,9 @@ library
                  , resourcet >= 0.3.2.1
                  , transformers >= 0.3.0.0
                  , containers
+                 , old-locale
+                 , time
+                 , split
 
 executable         sflc-ledger-reports
     if flag(library-only)
diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet
index 4078139..f6acc22 100644
--- a/templates/homepage.hamlet
+++ b/templates/homepage.hamlet
@@ -8,3 +8,15 @@
         <td .reports>
           <a href=@{RegisterR l}>
             Register (CSV)
+        <td .reports>
+          <a href=@{JournalR PandL l}>
+            P&L (CSV)
+        <td .reports>
+          <a href=@{JournalR Assets l}>
+            Assets (CSV)
+        <td .reports>
+          <a href=@{JournalR Liabilities l}>
+            Liabilities (CSV)
+        <td .reports>
+          <a href=@{JournalR Everything l}>
+            Everything (CSV)