diff options
| -rw-r--r-- | Application.hs | 1 | ||||
| -rw-r--r-- | Foundation.hs | 9 | ||||
| -rw-r--r-- | Handler/Home.hs | 1 | ||||
| -rw-r--r-- | Handler/Journal.hs | 45 | ||||
| -rw-r--r-- | Hledger/JournalCSVs.hs | 113 | ||||
| -rw-r--r-- | config/routes | 1 | ||||
| -rw-r--r-- | sflc-ledger-reports.cabal | 7 | ||||
| -rw-r--r-- | templates/homepage.hamlet | 12 |
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) |