slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

web: officially drop GHC 6.12 support, fix build warnings with 7.0, 7.2, 7.4

Browse Source
This commit is contained in:
Simon Michael 2012-03-29 23:24:48 +00:00
parent 7f3b990394
commit 2912a11929
8 changed files with 89 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hledger-web/Hledger/Web/Application.hs
View File

@ -24,7 +24,7 @@ import Network.Wai (Application)
import Hledger.Web.Foundation import Hledger.Web.Foundation
import Hledger.Web.Handlers import Hledger.Web.Handlers
import Hledger.Web.Options import Hledger.Web.Options
import Hledger.Web.Settings (parseExtra) import Hledger.Web.Settings (Extra(..), parseExtra)
import Hledger.Web.Settings.StaticFiles (staticSite) import Hledger.Web.Settings.StaticFiles (staticSite)
-- This line actually creates our YesodSite instance. It is the second half -- This line actually creates our YesodSite instance. It is the second half

9
hledger-web/Hledger/Web/Foundation.hs
View File

@ -8,7 +8,6 @@ module Hledger.Web.Foundation
, Handler , Handler
, Widget , Widget
, module Yesod.Core , module Yesod.Core
, module Hledger.Web.Settings
, liftIO , liftIO
) where ) where
@ -24,7 +23,7 @@ import Text.Hamlet
import Hledger.Web.Options import Hledger.Web.Options
import qualified Hledger.Web.Settings import qualified Hledger.Web.Settings
import Hledger.Web.Settings (Extra (..), widgetFile) import Hledger.Web.Settings (Extra (..))
import Hledger.Web.Settings.StaticFiles import Hledger.Web.Settings.StaticFiles
@ -75,8 +74,8 @@ instance Yesod App where
encryptKey _ = fmap Just $ getKey "client_session_key.aes" encryptKey _ = fmap Just $ getKey "client_session_key.aes"
defaultLayout widget = do defaultLayout widget = do
master <- getYesod -- master <- getYesod
mmsg <- getMessage -- mmsg <- getMessage
-- We break up the default layout into two components: -- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and -- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final -- default-layout-wrapper is the entire page. Since the final
@ -88,7 +87,7 @@ instance Yesod App where
-- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") -- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
pc <- widgetToPageContent $ do pc <- widgetToPageContent $ do
widget widget
hamletToRepHtml [$hamlet| hamletToRepHtml [hamlet|
!!! !!!
<html <html
<head <head

118
hledger-web/Hledger/Web/Handlers.hs
View File

@ -9,8 +9,6 @@ module Hledger.Web.Handlers where
import Prelude import Prelude
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
-- import Data.Aeson
import Data.ByteString (ByteString)
import Data.Either (lefts,rights) import Data.Either (lefts,rights)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
@ -19,7 +17,7 @@ import qualified Data.Text (null)
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Format import Data.Time.Format
import System.FilePath (takeFileName, (</>)) import System.FilePath (takeFileName)
import System.IO.Storage (putValue, getValue) import System.IO.Storage (putValue, getValue)
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
import Text.Blaze (preEscapedString, toHtml) import Text.Blaze (preEscapedString, toHtml)
@ -28,7 +26,7 @@ import Text.Printf
import Yesod.Core import Yesod.Core
-- import Yesod.Json -- import Yesod.Json
import Hledger hiding (today) import Hledger hiding (today,subs,is,d)
import Hledger.Cli hiding (version) import Hledger.Cli hiding (version)
import Hledger.Web.Foundation import Hledger.Web.Foundation
import Hledger.Web.Options import Hledger.Web.Options
@ -60,15 +58,15 @@ getJournalR = do
filtering = m /= Any filtering = m /= Any
-- showlastcolumn = if injournal && not filtering then False else True -- showlastcolumn = if injournal && not filtering then False else True
title = case inacct of title = case inacct of
Nothing -> "Journal"++filter Nothing -> "Journal"++s2
Just (a,subs) -> "Transactions in "++a++andsubs++filter Just (a,subs) -> "Transactions in "++a++s1++s2
where andsubs = if subs then " (and subaccounts)" else "" where s1 = if subs then " (and subaccounts)" else ""
where where
filter = if filtering then ", filtered" else "" s2 = if filtering then ", filtered" else ""
maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web journal" setTitle "hledger-web journal"
addHamlet [$hamlet| addHamlet [hamlet|
^{topbar vd} ^{topbar vd}
<div#content <div#content
<div#sidebar <div#sidebar
@ -101,7 +99,7 @@ getJournalEntriesR = do
maincontent = entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j maincontent = entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web journal" setTitle "hledger-web journal"
addHamlet [$hamlet| addHamlet [hamlet|
^{topbar vd} ^{topbar vd}
<div#content <div#content
<div#sidebar <div#sidebar
@ -133,15 +131,15 @@ getRegisterR = do
let sidecontent = sidebar vd let sidecontent = sidebar vd
-- injournal = isNothing inacct -- injournal = isNothing inacct
filtering = m /= Any filtering = m /= Any
title = "Transactions in "++a++andsubs++filter title = "Transactions in "++a++s1++s2
where where
(a,subs) = fromMaybe ("all accounts",False) $ inAccount qopts (a,subs) = fromMaybe ("all accounts",False) $ inAccount qopts
andsubs = if subs then " (and subaccounts)" else "" s1 = if subs then " (and subaccounts)" else ""
filter = if filtering then ", filtered" else "" s2 = if filtering then ", filtered" else ""
maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web register" setTitle "hledger-web register"
addHamlet [$hamlet| addHamlet [hamlet|
^{topbar vd} ^{topbar vd}
<div#content <div#content
<div#sidebar <div#sidebar
@ -199,7 +197,7 @@ sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport2 (reportopts_
-- | Render a "AccountsReport" as HTML. -- | Render a "AccountsReport" as HTML.
accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute
accountsReportAsHtml _ vd@VD{..} (items',total) = accountsReportAsHtml _ vd@VD{..} (items',total) =
[$hamlet| [hamlet|
<div#accountsheading <div#accountsheading
<a#accounts-toggle-link.togglelink href="#" title="Toggle sidebar">[+] <a#accounts-toggle-link.togglelink href="#" title="Toggle sidebar">[+]
<div#accounts <div#accounts
@ -241,7 +239,7 @@ accountsReportAsHtml _ vd@VD{..} (items',total) =
allaccts = isNothing inacctmatcher allaccts = isNothing inacctmatcher
items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher
itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute
itemAsHtml _ (acct, adisplay, aindent, abal) = [$hamlet| itemAsHtml _ (acct, adisplay, aindent, abal) = [hamlet|
<tr.item.#{inacctclass} <tr.item.#{inacctclass}
<td.account.#{depthclass} <td.account.#{depthclass}
#{indent} #{indent}
@ -262,7 +260,7 @@ accountsReportAsHtml _ vd@VD{..} (items',total) =
numpostings = length $ apostings $ ledgerAccount l acct numpostings = length $ apostings $ ledgerAccount l acct
depthclass = "depth"++show aindent depthclass = "depth"++show aindent
inacctclass = case inacctmatcher of inacctclass = case inacctmatcher of
Just m -> if m `matchesAccount` acct then "inacct" else "notinacct" Just m' -> if m' `matchesAccount` acct then "inacct" else "notinacct"
Nothing -> "" :: String Nothing -> "" :: String
indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) "&nbsp;" indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) "&nbsp;"
acctquery = (RegisterR, [("q", pack $ accountQuery acct)]) acctquery = (RegisterR, [("q", pack $ accountQuery acct)])
@ -274,19 +272,19 @@ accountQuery a = "inacct:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)
accountOnlyQuery :: AccountName -> String accountOnlyQuery :: AccountName -> String
accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a) accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)
-- accountUrl :: AppRoute -> AccountName -> (AppRoute,[(String,ByteString)]) accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
accountUrl r a = (r, [("q", pack $ accountQuery a)]) accountUrl r a = (r, [("q", pack $ accountQuery a)])
-- | Render a "EntriesReport" as HTML for the journal entries view. -- | Render a "EntriesReport" as HTML for the journal entries view.
entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute
entriesReportAsHtml _ vd items = [$hamlet| entriesReportAsHtml _ vd items = [hamlet|
<table.journalreport> <table.journalreport>
$forall i <- numbered items $forall i <- numbered items
^{itemAsHtml vd i} ^{itemAsHtml vd i}
|] |]
where where
itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute
itemAsHtml _ (n, t) = [$hamlet| itemAsHtml _ (n, t) = [hamlet|
<tr.item.#{evenodd}> <tr.item.#{evenodd}>
<td.transaction> <td.transaction>
<pre>#{txn} <pre>#{txn}
@ -297,7 +295,7 @@ entriesReportAsHtml _ vd items = [$hamlet|
-- | Render an "TransactionsReport" as HTML for the formatted journal view. -- | Render an "TransactionsReport" as HTML for the formatted journal view.
journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet| journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|
<table.journalreport <table.journalreport
<tr.headings <tr.headings
<th.date align=left>Date <th.date align=left>Date
@ -310,19 +308,19 @@ journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|
where where
-- .#{datetransition} -- .#{datetransition}
itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute
itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [$hamlet| itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [hamlet|
<tr.item.#{evenodd}.#{firstposting} <tr.item.#{evenodd}.#{firstposting}
<td.date>#{date} <td.date>#{date}
<td.description colspan=2 title="#{show t}">#{elideRight 60 desc} <td.description colspan=2 title="#{show t}">#{elideRight 60 desc}
<td.amount align=right> <td.amount align=right>
$if showamt $if showamt
#{mixedAmountAsHtml amt} #{mixedAmountAsHtml amt}
$forall p <- tpostings t $forall p' <- tpostings t
<tr.item.#{evenodd}.posting <tr.item.#{evenodd}.posting
<td.date <td.date
<td.description <td.description
<td.account>&nbsp;<a href="@?{accountUrl here $ paccount p}" title="Show transactions in #{paccount p}">#{elideRight 40 $ paccount p} <td.account>&nbsp;<a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}
<td.amount align=right>#{mixedAmountAsHtml $ pamount p} <td.amount align=right>#{mixedAmountAsHtml $ pamount p'}
|] |]
where where
evenodd = if even n then "even" else "odd" :: String evenodd = if even n then "even" else "odd" :: String
@ -335,14 +333,14 @@ $forall p <- tpostings t
-- Generate html for an account register, including a balance chart and transaction list. -- Generate html for an account register, including a balance chart and transaction list.
registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
registerReportHtml opts vd r@(_,items) = [$hamlet| registerReportHtml opts vd r@(_,items) = [hamlet|
^{registerChartHtml items} ^{registerChartHtml items}
^{registerItemsHtml opts vd r} ^{registerItemsHtml opts vd r}
|] |]
-- Generate html for a transaction list from an "TransactionsReport". -- Generate html for a transaction list from an "TransactionsReport".
registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
registerItemsHtml _ vd (balancelabel,items) = [$hamlet| registerItemsHtml _ vd (balancelabel,items) = [hamlet|
<table.registerreport <table.registerreport
<tr.headings <tr.headings
<th.date align=left>Date <th.date align=left>Date
@ -360,7 +358,7 @@ registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
-- inacct = inAccount qopts -- inacct = inAccount qopts
-- filtering = m /= Any -- filtering = m /= Any
itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute
itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [$hamlet| itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [hamlet|
<tr.item.#{evenodd}.#{firstposting}.#{datetransition} <tr.item.#{evenodd}.#{firstposting}.#{datetransition}
<td.date>#{date} <td.date>#{date}
<td.description title="#{show t}">#{elideRight 30 desc} <td.description title="#{show t}">#{elideRight 30 desc}
@ -374,12 +372,12 @@ registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
$if showamt $if showamt
#{mixedAmountAsHtml amt} #{mixedAmountAsHtml amt}
<td.balance align=right>#{mixedAmountAsHtml bal} <td.balance align=right>#{mixedAmountAsHtml bal}
$forall p <- tpostings t $forall p' <- tpostings t
<tr.item.#{evenodd}.posting style=#{postingsdisplaystyle} <tr.item.#{evenodd}.posting style=#{postingsdisplaystyle}
<td.date <td.date
<td.description <td.description
<td.account>&nbsp;<a href="@?{accountUrl here $ paccount p}" title="Show transactions in #{paccount p}">#{elideRight 40 $ paccount p} <td.account>&nbsp;<a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}
<td.amount align=right>#{mixedAmountAsHtml $ pamount p} <td.amount align=right>#{mixedAmountAsHtml $ pamount p'}
<td.balance align=right> <td.balance align=right>
|] |]
where where
@ -394,10 +392,15 @@ $forall p <- tpostings t
-- | Generate javascript/html for a register balance line chart based on -- | Generate javascript/html for a register balance line chart based on
-- the provided "TransactionsReportItem"s. -- the provided "TransactionsReportItem"s.
-- registerChartHtml :: forall t (t1 :: * -> *) t2 t3 t4 t5.
-- Data.Foldable.Foldable t1 =>
-- t1 (Transaction, t2, t3, t4, t5, MixedAmount)
-- -> t -> Text.Blaze.Internal.HtmlM ()
registerChartHtml :: [TransactionsReportItem] -> HtmlUrl AppRoute
registerChartHtml items = registerChartHtml items =
-- have to make sure plot is not called when our container (maincontent) -- have to make sure plot is not called when our container (maincontent)
-- is hidden, eg with add form toggled -- is hidden, eg with add form toggled
[$hamlet| [hamlet|
<script type=text/javascript> <script type=text/javascript>
if (document.getElementById('maincontent').style.display != 'none') if (document.getElementById('maincontent').style.display != 'none')
\$(document).ready(function() { \$(document).ready(function() {
@ -425,7 +428,7 @@ stringIfLongerThan n s = if length s > n then s else ""
numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)] numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]
numberTransactionsReportItems [] = [] numberTransactionsReportItems [] = []
numberTransactionsReportItems is = number 0 nulldate is numberTransactionsReportItems items = number 0 nulldate items
where where
number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)] number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]
number _ _ [] = [] number _ _ [] = []
@ -437,6 +440,7 @@ numberTransactionsReportItems is = number 0 nulldate is
(dy,dm,_) = toGregorian d (dy,dm,_) = toGregorian d
(prevdy,prevdm,_) = toGregorian prevd (prevdy,prevdm,_) = toGregorian prevd
mixedAmountAsHtml :: MixedAmount -> Html
mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ show b mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ show b
where addclass = printf "<span class=\"%s\">%s</span>" (c :: String) where addclass = printf "<span class=\"%s\">%s</span>" (c :: String)
c = case isNegativeMixedAmount b of Just True -> "negative amount" c = case isNegativeMixedAmount b of Just True -> "negative amount"
@ -511,12 +515,12 @@ handleAdd = do
}) })
-- display errors or add transaction -- display errors or add transaction
case tE of case tE of
Left errs -> do Left errs' -> do
-- save current form values in session -- save current form values in session
-- setMessage $ toHtml $ intercalate "; " errs -- setMessage $ toHtml $ intercalate "; " errs
setMessage [$shamlet| setMessage [shamlet|
Errors:<br> Errors:<br>
$forall e<-errs $forall e<-errs'
#{e}<br> #{e}<br>
|] |]
Right t -> do Right t -> do
@ -524,7 +528,7 @@ handleAdd = do
liftIO $ do ensureJournalFileExists journalpath liftIO $ do ensureJournalFileExists journalpath
appendToJournalFileOrStdout journalpath $ showTransaction t' appendToJournalFileOrStdout journalpath $ showTransaction t'
-- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String) -- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String)
setMessage [$shamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|] setMessage [shamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]
redirect (RegisterR, [("add","1")]) redirect (RegisterR, [("add","1")])
@ -600,7 +604,7 @@ handleImport = do
-- | Global toolbar/heading area. -- | Global toolbar/heading area.
topbar :: ViewData -> HtmlUrl AppRoute topbar :: ViewData -> HtmlUrl AppRoute
topbar VD{..} = [$hamlet| topbar VD{..} = [hamlet|
<div#topbar <div#topbar
<a.topleftlink href=#{hledgerorgurl} title="More about hledger" <a.topleftlink href=#{hledgerorgurl} title="More about hledger"
hledger-web hledger-web
@ -608,24 +612,24 @@ topbar VD{..} = [$hamlet|
#{version} #{version}
<a.toprightlink href=#{manualurl} target=hledgerhelp title="User manual">manual <a.toprightlink href=#{manualurl} target=hledgerhelp title="User manual">manual
<h1>#{title} <h1>#{title}
$maybe m <- msg $maybe m' <- msg
<div#message>#{m} <div#message>#{m'}
|] |]
where where
title = takeFileName $ journalFilePath j title = takeFileName $ journalFilePath j
-- | Navigation link, preserving parameters and possibly highlighted. -- | Navigation link, preserving parameters and possibly highlighted.
navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute
navlink VD{..} s dest title = [$hamlet| navlink VD{..} s dest title = [hamlet|
<a##{s}link.#{style} href=@?{u} title="#{title}">#{s} <a##{s}link.#{style} href=@?{u'} title="#{title}">#{s}
|] |]
where u = (dest, if null q then [] else [("q", pack q)]) where u' = (dest, if null q then [] else [("q", pack q)])
style | dest == here = "navlinkcurrent" style | dest == here = "navlinkcurrent"
| otherwise = "navlink" :: Text | otherwise = "navlink" :: Text
-- | Links to the various journal editing forms. -- | Links to the various journal editing forms.
editlinks :: HtmlUrl AppRoute editlinks :: HtmlUrl AppRoute
editlinks = [$hamlet| editlinks = [hamlet|
<a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit <a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit
\ | # \ | #
<a#addformlink href="#" onclick="return addformToggle(event)" title="Toggle transaction add form">add <a#addformlink href="#" onclick="return addformToggle(event)" title="Toggle transaction add form">add
@ -634,14 +638,14 @@ editlinks = [$hamlet|
-- | Link to a topic in the manual. -- | Link to a topic in the manual.
helplink :: String -> String -> HtmlUrl AppRoute helplink :: String -> String -> HtmlUrl AppRoute
helplink topic label = [$hamlet| helplink topic label = [hamlet|
<a href=#{u} target=hledgerhelp>#{label} <a href=#{u} target=hledgerhelp>#{label}
|] |]
where u = manualurl ++ if null topic then "" else '#':topic where u = manualurl ++ if null topic then "" else '#':topic
-- | Search form for entering custom queries to filter journal data. -- | Search form for entering custom queries to filter journal data.
searchform :: ViewData -> HtmlUrl AppRoute searchform :: ViewData -> HtmlUrl AppRoute
searchform VD{..} = [$hamlet| searchform VD{..} = [hamlet|
<div#searchformdiv <div#searchformdiv
<form#searchform.form method=GET <form#searchform.form method=GET
<table <table
@ -682,7 +686,7 @@ searchform VD{..} = [$hamlet|
-- | Add transaction form. -- | Add transaction form.
addform :: ViewData -> HtmlUrl AppRoute addform :: ViewData -> HtmlUrl AppRoute
addform vd@VD{..} = [$hamlet| addform vd@VD{..} = [hamlet|
<script type=text/javascript> <script type=text/javascript>
\$(document).ready(function() { \$(document).ready(function() {
/* dhtmlxcombo setup */ /* dhtmlxcombo setup */
@ -743,7 +747,8 @@ addform vd@VD{..} = [$hamlet|
date = "today" :: String date = "today" :: String
descriptions = sort $ nub $ map tdescription $ jtxns j descriptions = sort $ nub $ map tdescription $ jtxns j
manyfiles = (length $ files j) > 1 manyfiles = (length $ files j) > 1
postingfields VD{..} n = [$hamlet| postingfields :: ViewData -> Int -> HtmlUrl AppRoute
postingfields _ n = [hamlet|
<tr#postingrow <tr#postingrow
<td align=right>#{acctlabel}: <td align=right>#{acctlabel}:
<td <td
@ -762,14 +767,14 @@ addform vd@VD{..} = [$hamlet|
|] |]
where where
shouldselect a = n == 2 && maybe False ((a==).fst) (inAccount qopts) shouldselect a = n == 2 && maybe False ((a==).fst) (inAccount qopts)
numbered = (++ show n) withnumber = (++ show n)
acctvar = numbered "account" acctvar = withnumber "account"
amtvar = numbered "amount" amtvar = withnumber "amount"
acctnames = sort $ journalAccountNamesUsed j acctnames = sort $ journalAccountNamesUsed j
(acctlabel, accthelp, amtfield, amthelp) (acctlabel, accthelp, amtfield, amthelp)
| n == 1 = ("To account" | n == 1 = ("To account"
,"eg: expenses:food" ,"eg: expenses:food"
,[$hamlet| ,[hamlet|
<td style=padding-left:1em; <td style=padding-left:1em;
Amount: Amount:
<td <td
@ -785,7 +790,7 @@ addform vd@VD{..} = [$hamlet|
-- | Edit journal form. -- | Edit journal form.
editform :: ViewData -> HtmlUrl AppRoute editform :: ViewData -> HtmlUrl AppRoute
editform VD{..} = [$hamlet| editform VD{..} = [hamlet|
<form#editform method=POST style=display:none; <form#editform method=POST style=display:none;
<h2#contenttitle>#{title} <h2#contenttitle>#{title}
<table.form <table.form
@ -817,7 +822,7 @@ editform VD{..} = [$hamlet|
-- | Import journal form. -- | Import journal form.
importform :: HtmlUrl AppRoute importform :: HtmlUrl AppRoute
importform = [$hamlet| importform = [hamlet|
<form#importform method=POST style=display:none; <form#importform method=POST style=display:none;
<table.form <table.form
<tr <tr
@ -830,14 +835,14 @@ importform = [$hamlet|
|] |]
journalselect :: [(FilePath,String)] -> HtmlUrl AppRoute journalselect :: [(FilePath,String)] -> HtmlUrl AppRoute
journalselect journalfiles = [$hamlet| journalselect journalfiles = [hamlet|
<select id=journalselect name=journal onchange="editformJournalSelect(event)" <select id=journalselect name=journal onchange="editformJournalSelect(event)"
$forall f <- journalfiles $forall f <- journalfiles
<option value=#{fst f}>#{fst f} <option value=#{fst f}>#{fst f}
|] |]
nulltemplate :: HtmlUrl AppRoute nulltemplate :: HtmlUrl AppRoute
nulltemplate = [$hamlet||] nulltemplate = [hamlet||]
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- utilities -- utilities
@ -925,6 +930,7 @@ getMessageOr mnewmsg = do
oldmsg <- getMessage oldmsg <- getMessage
return $ maybe oldmsg (Just . toHtml) mnewmsg return $ maybe oldmsg (Just . toHtml) mnewmsg
numbered :: [a] -> [(Int,a)]
numbered = zip [1..] numbered = zip [1..]
dayToJsTimestamp :: Day -> Integer dayToJsTimestamp :: Day -> Integer

3
hledger-web/Hledger/Web/Import.hs
View File

@ -1,6 +1,5 @@
module Hledger.Web.Import module Hledger.Web.Import
( module Prelude ( module Prelude
, module Hledger.Web.Foundation
, (<>) , (<>)
, Text , Text
, module Data.Monoid , module Data.Monoid
@ -12,8 +11,6 @@ import Data.Monoid (Monoid (mappend, mempty, mconcat))
import Control.Applicative ((<$>), (<*>), pure) import Control.Applicative ((<$>), (<*>), pure)
import Data.Text (Text) import Data.Text (Text)
import Hledger.Web.Foundation
infixr 5 <> infixr 5 <>
(<>) :: Monoid m => m -> m -> m (<>) :: Monoid m => m -> m -> m
(<>) = mappend (<>) = mappend

5
hledger-web/Hledger/Web/Options.hs
View File

@ -22,15 +22,19 @@ version = ""
progname = $(packageVariable (pkgName . package)) progname = $(packageVariable (pkgName . package))
version = $(packageVariable (pkgVersion . package)) version = $(packageVariable (pkgVersion . package))
#endif #endif
prognameandversion :: String
prognameandversion = progname ++ " " ++ version :: String prognameandversion = progname ++ " " ++ version :: String
defbaseurlexample :: String
defbaseurlexample = (reverse $ drop 4 $ reverse $ defbaseurl defport) ++ "PORT" defbaseurlexample = (reverse $ drop 4 $ reverse $ defbaseurl defport) ++ "PORT"
webflags :: [Flag [([Char], [Char])]]
webflags = [ webflags = [
flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "URL" ("set the base url (default: "++defbaseurlexample++")") flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "URL" ("set the base url (default: "++defbaseurlexample++")")
,flagReq ["port"] (\s opts -> Right $ setopt "port" s opts) "PORT" ("listen on this tcp port (default: "++show defport++")") ,flagReq ["port"] (\s opts -> Right $ setopt "port" s opts) "PORT" ("listen on this tcp port (default: "++show defport++")")
] ]
webmode :: Mode [([Char], [Char])]
webmode = (mode "hledger-web" [("command","web")] webmode = (mode "hledger-web" [("command","web")]
"start serving the hledger web interface" "start serving the hledger web interface"
mainargsflag []){ mainargsflag []){
@ -51,6 +55,7 @@ data WebOpts = WebOpts {
,cliopts_ :: CliOpts ,cliopts_ :: CliOpts
} deriving (Show) } deriving (Show)
defwebopts :: WebOpts
defwebopts = WebOpts defwebopts = WebOpts
def def
def def

104
hledger-web/Hledger/Web/Settings.hs
View File

@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Settings are centralized, as much as possible, into this file. This -- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc. -- includes database connection settings, static file locations, etc.
-- In addition, you can configure a number of different aspects of Yesod -- In addition, you can configure a number of different aspects of Yesod
@ -12,41 +10,21 @@ module Hledger.Web.Settings
, staticDir , staticDir
, Extra (..) , Extra (..)
, parseExtra , parseExtra
-- , hamletFile
-- , cassiusFile
-- , juliusFile
-- , luciusFile
-- , AppEnvironment(..)
-- , AppConfig(..)
, defport , defport
, defbaseurl , defbaseurl
, hledgerorgurl , hledgerorgurl
, manualurl , manualurl
) where ) where
import Prelude import Control.Applicative
import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax
import Yesod.Default.Config
import qualified Yesod.Default.Util
import Data.Text (Text) import Data.Text (Text)
import Data.Yaml import Data.Yaml
import Control.Applicative import Language.Haskell.TH.Syntax
import Prelude
-- import qualified Text.Hamlet as S
-- import qualified Text.Cassius as S
-- import qualified Text.Julius as S
-- import qualified Text.Lucius as S
import Text.Printf import Text.Printf
import qualified Text.Shakespeare.Text as S
import Text.Shakespeare.Text (st) import Text.Shakespeare.Text (st)
import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile) import Yesod.Default.Config
import Data.Monoid (mempty) import qualified Yesod.Default.Util
import System.Directory (doesFileExist)
import Data.Text (pack)
import Control.Monad (join)
hledgerorgurl, manualurl :: String hledgerorgurl, manualurl :: String
@ -100,73 +78,3 @@ parseExtra :: DefaultEnv -> Object -> Parser Extra
parseExtra _ o = Extra parseExtra _ o = Extra
<$> o .: "copyright" <$> o .: "copyright"
<*> o .:? "analytics" <*> o .:? "analytics"
{-
-- The rest of this file contains settings which rarely need changing by a
-- user.
-- The following functions are used for calling HTML, CSS,
-- Javascript, and plain text templates from your Haskell code. During development,
-- the "Debug" versions of these functions are used so that changes to
-- the templates are immediately reflected in an already running
-- application. When making a production compile, the non-debug version
-- is used for increased performance.
--
-- You can see an example of how to call these functions in Handler/Root.hs
--
-- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer
-- used; to get the same auto-loading effect, it is recommended that you
-- use the devel server.
-- | expects a root folder for each type, e.g: hamlet/ lucius/ julius/
globFile :: String -> String -> FilePath
-- globFile kind x = kind ++ "/" ++ x ++ "." ++ kind
globFile kind x = "templates/" ++ x ++ "." ++ kind
hamletFile :: FilePath -> Q Exp
hamletFile = S.hamletFile . globFile "hamlet"
cassiusFile :: FilePath -> Q Exp
cassiusFile =
#ifdef PRODUCTION
S.cassiusFile . globFile "cassius"
#else
S.cassiusFileDebug . globFile "cassius"
#endif
luciusFile :: FilePath -> Q Exp
luciusFile =
#ifdef PRODUCTION
S.luciusFile . globFile "lucius"
#else
S.luciusFileDebug . globFile "lucius"
#endif
juliusFile :: FilePath -> Q Exp
juliusFile =
#ifdef PRODUCTION
S.juliusFile . globFile "julius"
#else
S.juliusFileDebug . globFile "julius"
#endif
textFile :: FilePath -> Q Exp
textFile =
#ifdef PRODUCTION
S.textFile . globFile "text"
#else
S.textFileDebug . globFile "text"
#endif
widgetFile :: FilePath -> Q Exp
widgetFile x = do
let h = whenExists (globFile "hamlet") (whamletFile . globFile "hamlet")
let c = whenExists (globFile "cassius") cassiusFile
let j = whenExists (globFile "julius") juliusFile
let l = whenExists (globFile "lucius") luciusFile
[|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|]
where
whenExists tofn f = do
e <- qRunIO $ doesFileExist $ tofn x
if e then f x else [|mempty|]
-}

1
hledger-web/Hledger/Web/Settings/StaticFiles.hs
View File

@ -11,7 +11,6 @@ This is a separate module to satisfy template haskell requirements.
-} -}
module Hledger.Web.Settings.StaticFiles where module Hledger.Web.Settings.StaticFiles where
import Prelude (IO)
import System.IO import System.IO
import Yesod.Static import Yesod.Static
import qualified Yesod.Static as Static import qualified Yesod.Static as Static

12
hledger-web/hledger-web.hs
View File

@ -12,8 +12,8 @@ where
import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort) import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort)
import Yesod.Default.Config import Yesod.Default.Config
import Yesod.Default.Main (defaultMain) -- import Yesod.Default.Main (defaultMain)
import Yesod.Logger (Logger, defaultDevelopmentLogger) --, logString) import Yesod.Logger ({- Logger,-} defaultDevelopmentLogger) --, logString)
import Prelude hiding (putStrLn) import Prelude hiding (putStrLn)
-- -- import Control.Concurrent (forkIO, threadDelay) -- -- import Control.Concurrent (forkIO, threadDelay)
@ -26,9 +26,8 @@ import Text.Printf
import Hledger import Hledger
import Hledger.Cli hiding (progname,prognameandversion) import Hledger.Cli hiding (progname,prognameandversion)
import Hledger.Web.Settings (parseExtra)
import Hledger.Utils.UTF8IOCompat (putStrLn) import Hledger.Utils.UTF8IOCompat (putStrLn)
import Hledger.Web import Hledger.Web hiding (opts,j)
main :: IO () main :: IO ()
@ -38,9 +37,7 @@ main = do
runWith opts runWith opts
runWith :: WebOpts -> IO () runWith :: WebOpts -> IO ()
runWith opts = run opts runWith opts
where
run opts
| "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp webmode) >> exitSuccess | "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp webmode) >> exitSuccess
| "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess | "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
| "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname) | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
@ -85,6 +82,7 @@ server baseurl port opts j = do
appEnv = Development appEnv = Development
, appPort = port_ opts , appPort = port_ opts
, appRoot = pack baseurl , appRoot = pack baseurl
, appExtra = Extra "" Nothing
} }
logger <- defaultDevelopmentLogger logger <- defaultDevelopmentLogger
app <- getApplication config logger app <- getApplication config logger