hledger-web 0.17.1 → 0.18
raw patch · 11 files changed
+627/−659 lines, 11 filesdep +network-conduitdep +yamldep +yesod-defaultdep −aesondep −bytestringdep −data-objectdep ~blaze-htmldep ~hledgerdep ~hledger-lib
Dependencies added: network-conduit, yaml, yesod-default
Dependencies removed: aeson, bytestring, data-object, data-object-yaml, failure, file-embed, http-enumerator, shakespeare-css, shakespeare-js, tls-extra, yesod-form, yesod-json
Dependency ranges changed: blaze-html, hledger, hledger-lib, template-haskell, text, transformers, wai, wai-extra, warp, yesod, yesod-static
Files
- Hledger/Web.hs +2/−0
- Hledger/Web/Application.hs +35/−40
- Hledger/Web/Foundation.hs +65/−74
- Hledger/Web/Handlers.hs +302/−260
- Hledger/Web/Import.hs +16/−0
- Hledger/Web/Options.hs +12/−1
- Hledger/Web/Settings.hs +33/−136
- Hledger/Web/Settings/StaticFiles.hs +21/−2
- hledger-web.cabal +103/−67
- hledger-web.hs +36/−77
- routes +2/−2
Hledger/Web.hs view
@@ -6,6 +6,7 @@ module Hledger.Web.Foundation, module Hledger.Web.Application, module Hledger.Web.Handlers,+ module Hledger.Web.Import, module Hledger.Web.Options, module Hledger.Web.Settings, module Hledger.Web.Settings.StaticFiles,@@ -17,6 +18,7 @@ import Hledger.Web.Foundation import Hledger.Web.Application import Hledger.Web.Handlers+import Hledger.Web.Import import Hledger.Web.Options import Hledger.Web.Settings import Hledger.Web.Settings.StaticFiles
Hledger/Web/Application.hs view
@@ -3,61 +3,56 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Hledger.Web.Application (- withApp- ,withDevelAppPort- )+module Hledger.Web.Application+ ( getApplication+ , getApplicationDev+ ) where -import Data.Dynamic (Dynamic, toDyn)+import Prelude+import Yesod.Default.Config+import Yesod.Default.Main (defaultDevelApp)+import Yesod.Default.Handlers (getRobotsR)+#if DEVELOPMENT+import Yesod.Logger (Logger, logBS)+import Network.Wai.Middleware.RequestLogger (logCallbackDev)+#else+import Yesod.Logger (Logger, logBS, toProduction)+import Network.Wai.Middleware.RequestLogger (logCallback)+#endif import Network.Wai (Application)-import Network.Wai.Middleware.Debug (debugHandle)-import Yesod.Core hiding (AppConfig,loadConfig,appPort)-import Yesod.Logger (makeLogger, flushLogger, Logger, logLazyText, logString)-import Yesod.Static import Hledger.Web.Foundation import Hledger.Web.Handlers import Hledger.Web.Options-import Hledger.Web.Settings+import Hledger.Web.Settings (Extra(..), parseExtra)+import Hledger.Web.Settings.StaticFiles (staticSite) -- This line actually creates our YesodSite instance. It is the second half -- of the call to mkYesodData which occurs in App.hs. Please see -- the comments there for more details. mkYesodDispatch "App" resourcesApp --- This function allocates resources (such as a database connection pool),--- performs initialization and creates a WAI application. This is also the--- place to put your migrate statements to have automatic database--- migrations handled by Yesod.-withApp :: AppConfig -> Logger -> WebOpts -> (Application -> IO a) -> IO a-withApp conf logger opts f = do-#ifdef PRODUCTION- putStrLn $ "Production mode, using embedded web files"- let s = $(embed staticDir)+getApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application+getApplication conf logger = do+ s <- staticSite+ let foundation = App conf setLogger s defwebopts -- XXX+ app <- toWaiAppPlain foundation+ return $ logWare app+ where+#ifdef DEVELOPMENT+ logWare = logCallbackDev (logBS setLogger)+ setLogger = logger #else- putStrLn $ "Not in production mode, using web files from " ++ staticDir ++ "/"- s <- staticDevel staticDir+ setLogger = toProduction logger -- by default the logger is set for development+ logWare = logCallback (logBS setLogger) #endif- let a = App {settings=conf- ,getLogger=logger- ,getStatic=s- ,appOpts=opts- }- toWaiApp a >>= f -- for yesod devel-withDevelAppPort :: Dynamic-withDevelAppPort =- toDyn go+getApplicationDev :: IO (Int, Application)+getApplicationDev =+ defaultDevelApp loader getApplication where- go :: ((Int, Application) -> IO ()) -> IO ()- go f = do- conf <- loadConfig Development- let port = appPort conf- logger <- makeLogger- logString logger $ "Devel application launched with default options, listening on port " ++ show port- withApp conf logger defwebopts $ \app -> f (port, debugHandle (logHandle logger) app)- flushLogger logger- where- logHandle logger msg = logLazyText logger msg >> flushLogger logger+ loader = loadConfig (configSettings Development)+ { csParseExtra = parseExtra+ }
Hledger/Web/Foundation.hs view
@@ -1,97 +1,90 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, CPP #-}+{-++Define the web application's foundation, in the usual Yesod style.+See a default Yesod app's comments for more details of each part.++-}+ module Hledger.Web.Foundation ( App (..)- , AppRoute (..)+ , Route (..)+ , AppRoute+ -- , AppMessage (..) , resourcesApp , Handler , Widget- , StaticRoute (..)- , lift+ , module Yesod.Core , liftIO ) where -import Control.Monad (unless)+import Prelude+import Yesod.Core hiding (Route)+import Yesod.Default.Config+#ifndef DEVELOPMENT+import Yesod.Default.Util (addStaticContentExternal)+#endif+import Yesod.Static+import Yesod.Logger (Logger, logMsg, formatLogText) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Class (lift)-import System.Directory-import Text.Hamlet hiding (hamletFile)-import Web.ClientSession (getKey)-import Yesod.Core-import Yesod.Logger (Logger, logLazyText)-import Yesod.Static (Static, base64md5, StaticRoute(..))-import qualified Data.ByteString.Lazy as L-import qualified Data.Text as T import Hledger.Web.Options import Hledger.Web.Settings import Hledger.Web.Settings.StaticFiles ---- | 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--- access to the data present here.+-- | The web application's configuration and data, available to all request handlers. data App = App- { settings :: Hledger.Web.Settings.AppConfig+ { settings :: AppConfig DefaultEnv Extra , getLogger :: Logger , getStatic :: Static -- ^ Settings for static file serving.-- ,appOpts :: WebOpts- -- ,appJournal :: Journal+ , appOpts :: WebOpts+ -- , appJournal :: Journal } --- This is where we define all of the routes in our application. For a full--- explanation of the syntax, please see:--- http://docs.yesodweb.com/book/web-routes-quasi/------ This function does three things:------ * Creates the route datatype AppRoute. Every valid URL in your--- application can be represented as a value of this type.--- * Creates the associated type:--- type instance Route App = AppRoute--- * Creates the value resourcesApp which contains information on the--- resources declared below. This is used in Handler.hs by the call to--- mkYesodDispatch------ What this function does *not* do is create a YesodSite instance for--- App. Creating that instance requires all of the handler functions--- for our application to be in scope. However, the handler functions--- usually require access to the AppRoute datatype. Therefore, we--- split these actions into two functions and place them in separate files.+-- Set up i18n messages.+-- mkMessage "App" "messages" "en"++-- The web application's routes (urls). mkYesodData "App" $(parseRoutesFile "routes") --- Please see the documentation for the Yesod typeclass. There are a number--- of settings which can be configured by overriding methods here.-instance Yesod App where- approot = Hledger.Web.Settings.appRoot . settings+-- | A convenience alias.+type AppRoute = Route App - -- Place the session key file in the config folder- encryptKey _ = fmap Just $ getKey "client_session_key.aes"+-- More configuration, including the default page layout.+instance Yesod App where+ -- approot = Hledger.Web.Settings.appRoot . settings+ approot = ApprootMaster $ appRoot . settings defaultLayout widget = do+ -- master <- getYesod -- mmsg <- getMessage+ -- We break up the default layout into two components:+ -- default-layout is the contents of the body tag, and+ -- default-layout-wrapper is the entire page. Since the final+ -- value passed to hamletToRepHtml cannot be a widget, this allows+ -- you to use normal widget features in default-layout.+ -- pc <- widgetToPageContent $ do+ -- $(widgetFile "normalize")+ -- $(widgetFile "default-layout")+ -- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") pc <- widgetToPageContent $ do- widget- -- addCassius $(cassiusFile "default-layout")- -- hamletToRepHtml $(hamletFile "default-layout")- hamletToRepHtml [$hamlet|-!!!-<html- <head+ widget+ hamletToRepHtml [hamlet|+$doctype 5+<html>+ <head> <title>#{pageTitle pc} ^{pageHead pc}- <meta http-equiv=Content-Type content="text/html; charset=utf-8"- <script type=text/javascript src=@{StaticR jquery_js}- <script type=text/javascript src=@{StaticR jquery_url_js}- <script type=text/javascript src=@{StaticR jquery_flot_js}+ <meta http-equiv=Content-Type content="text/html; charset=utf-8">+ <script type=text/javascript src=@{StaticR jquery_js}>+ <script type=text/javascript src=@{StaticR jquery_url_js}>+ <script type=text/javascript src=@{StaticR jquery_flot_js}> <!--[if lte IE 8]><script language="javascript" type="text/javascript" src="excanvas.min.js"></script><![endif]-->- <script type=text/javascript src=@{StaticR dhtmlxcommon_js}- <script type=text/javascript src=@{StaticR dhtmlxcombo_js}- <script type=text/javascript src=@{StaticR hledger_js}- <link rel=stylesheet type=text/css media=all href=@{StaticR style_css}- <body+ <script type=text/javascript src=@{StaticR dhtmlxcommon_js}>+ <script type=text/javascript src=@{StaticR dhtmlxcombo_js}>+ <script type=text/javascript src=@{StaticR hledger_js}>+ <link rel=stylesheet type=text/css media=all href=@{StaticR style_css}>+ <body> ^{pageBody pc} |] @@ -102,17 +95,15 @@ -- urlRenderOverride _ _ = Nothing messageLogger y loc level msg =- formatLogMessage loc level msg >>= logLazyText (getLogger y)+ formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y) +#ifndef DEVELOPMENT -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of -- users receiving stale content.- addStaticContent ext' _ content = do- let fn = base64md5 content ++ '.' : T.unpack ext'- let statictmp = Hledger.Web.Settings.staticDir ++ "/tmp/"- liftIO $ createDirectoryIfMissing True statictmp- let fn' = statictmp ++ fn- exists <- liftIO $ doesFileExist fn'- unless exists $ liftIO $ L.writeFile fn' content- return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])+ addStaticContent = addStaticContentExternal (const $ Left ()) base64md5 Hledger.Web.Settings.staticDir (StaticR . flip StaticRoute [])+#endif++ -- Place Javascript at bottom of the body tag so the rest of the page loads first+ jsLoader _ = BottomOfBody
Hledger/Web/Handlers.hs view
@@ -1,15 +1,46 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, RecordWildCards #-} {- hledger-web's request handlers, and helpers. -} -module Hledger.Web.Handlers where+module Hledger.Web.Handlers+(+ -- * GET handlers+ getRootR,+ getJournalR,+ getJournalEntriesR,+ getJournalEditR,+ getRegisterR,+ -- ** helpers+ -- sidebar,+ -- accountsReportAsHtml,+ -- accountQuery,+ -- accountOnlyQuery,+ -- accountUrl,+ -- entriesReportAsHtml,+ -- journalTransactionsReportAsHtml,+ -- registerReportHtml,+ -- registerItemsHtml,+ -- registerChartHtml,+ -- stringIfLongerThan,+ -- numberTransactionsReportItems,+ -- mixedAmountAsHtml,+ -- * POST handlers+ postJournalR,+ postJournalEntriesR,+ postJournalEditR,+ postRegisterR,+ -- * Common page components+ -- * Utilities+ ViewData(..),+ nullviewdata,+)+where +import Prelude import Control.Applicative ((<$>))-import Data.Aeson-import Data.ByteString (ByteString) import Data.Either (lefts,rights) import Data.List import Data.Maybe@@ -18,33 +49,38 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format-import System.FilePath (takeFileName, (</>))+import System.FilePath (takeFileName) import System.IO.Storage (putValue, getValue) import System.Locale (defaultTimeLocale) import Text.Blaze (preEscapedString, toHtml)-import Text.Hamlet hiding (hamletFile)+import Text.Hamlet hiding (hamlet) import Text.Printf import Yesod.Core-import Yesod.Json+-- import Yesod.Json -import Hledger hiding (today)+import Hledger hiding (is) import Hledger.Cli hiding (version) import Hledger.Web.Foundation import Hledger.Web.Options import Hledger.Web.Settings --getFaviconR :: Handler ()-getFaviconR = sendFile "image/x-icon" $ Hledger.Web.Settings.staticDir </> "favicon.ico"+-- routes:+-- /static StaticR Static getStatic+-- -- /favicon.ico FaviconR GET+-- /robots.txt RobotsR GET+-- / RootR GET+-- /journal JournalR GET POST+-- /journal/entries JournalEntriesR GET POST+-- /journal/edit JournalEditR GET POST+-- /register RegisterR GET POST+-- -- /accounts AccountsR GET+-- -- /api/accounts AccountsJsonR GET -getRobotsR :: Handler RepPlain-getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)+----------------------------------------------------------------------+-- GET handlers getRootR :: Handler RepHtml-getRootR = redirect RedirectTemporary defaultroute where defaultroute = RegisterR--------------------------------------------------------------------------- main views:+getRootR = redirect defaultroute where defaultroute = RegisterR -- | The formatted journal view, with sidebar. getJournalR :: Handler RepHtml@@ -54,24 +90,24 @@ -- XXX like registerReportAsHtml inacct = inAccount qopts -- injournal = isNothing inacct- filtering = m /= MatchAny+ filtering = m /= Any -- showlastcolumn = if injournal && not filtering then False else True title = case inacct of- Nothing -> "Journal"++filter- Just (a,subs) -> "Transactions in "++a++andsubs++filter- where andsubs = if subs then " (and subaccounts)" else ""+ Nothing -> "Journal"++s2+ Just (a,inclsubs) -> "Transactions in "++a++s1++s2+ where s1 = if inclsubs then " (and subaccounts)" else "" where- filter = if filtering then ", filtered" else ""+ s2 = if filtering then ", filtered" else "" maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m defaultLayout $ do setTitle "hledger-web journal"- addHamlet [$hamlet|+ addWidget $ toWidget [hamlet| ^{topbar vd}-<div#content- <div#sidebar+<div#content>+ <div#sidebar> ^{sidecontent}- <div#main.register- <div#maincontent+ <div#main.register>+ <div#maincontent> <h2#contenttitle>#{title} ^{searchform vd} ^{maincontent}@@ -80,31 +116,23 @@ ^{importform} |] --- | The journal editform, no sidebar.-getJournalEditR :: Handler RepHtml-getJournalEditR = do- vd <- getViewData- defaultLayout $ do- setTitle "hledger-web journal edit form"- addHamlet $ editform vd- -- | The journal entries view, with sidebar. getJournalEntriesR :: Handler RepHtml getJournalEntriesR = do vd@VD{..} <- getViewData let sidecontent = sidebar vd- title = "Journal entries" ++ if m /= MatchAny then ", filtered" else "" :: String- maincontent = entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j+ title = "Journal entries" ++ if m /= Any then ", filtered" else "" :: String+ maincontent = entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) Any $ filterJournalTransactions m j defaultLayout $ do setTitle "hledger-web journal"- addHamlet [$hamlet|+ addWidget $ toWidget [hamlet| ^{topbar vd}-<div#content- <div#sidebar+<div#content>+ <div#sidebar> ^{sidecontent}- <div#main.journal- <div#maincontent+ <div#main.journal>+ <div#maincontent> <h2#contenttitle>#{title} ^{searchform vd} ^{maincontent}@@ -113,15 +141,21 @@ ^{importform} |] --- | The journal entries view, no sidebar.-getJournalOnlyR :: Handler RepHtml-getJournalOnlyR = do- vd@VD{..} <- getViewData+-- | The journal editform, no sidebar.+getJournalEditR :: Handler RepHtml+getJournalEditR = do+ vd <- getViewData defaultLayout $ do- setTitle "hledger-web journal only"- addHamlet $ entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j+ setTitle "hledger-web journal edit form"+ addWidget $ toWidget $ editform vd -----------------------------------------------------------------------+-- -- | The journal entries view, no sidebar.+-- getJournalOnlyR :: Handler RepHtml+-- getJournalOnlyR = do+-- vd@VD{..} <- getViewData+-- defaultLayout $ do+-- setTitle "hledger-web journal only"+-- addWidget $ toWidget $ entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j -- | The main journal/account register view, with accounts sidebar. getRegisterR :: Handler RepHtml@@ -129,22 +163,22 @@ vd@VD{..} <- getViewData let sidecontent = sidebar vd -- injournal = isNothing inacct- filtering = m /= MatchAny- title = "Transactions in "++a++andsubs++filter+ filtering = m /= Any+ title = "Transactions in "++a++s1++s2 where- (a,subs) = fromMaybe ("all accounts",False) $ inAccount qopts- andsubs = if subs then " (and subaccounts)" else ""- filter = if filtering then ", filtered" else ""- maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe MatchAny $ inAccountMatcher qopts+ (a,inclsubs) = fromMaybe ("all accounts",False) $ inAccount qopts+ s1 = if inclsubs then " (and subaccounts)" else ""+ s2 = if filtering then ", filtered" else ""+ maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts defaultLayout $ do setTitle "hledger-web register"- addHamlet [$hamlet|+ addWidget $ toWidget [hamlet| ^{topbar vd}-<div#content- <div#sidebar+<div#content>+ <div#sidebar> ^{sidecontent}- <div#main.register- <div#maincontent+ <div#main.register>+ <div#maincontent> <h2#contenttitle>#{title} ^{searchform vd} ^{maincontent}@@ -153,18 +187,17 @@ ^{importform} |] --- | The register view, no sidebar.-getRegisterOnlyR :: Handler RepHtml-getRegisterOnlyR = do- vd@VD{..} <- getViewData- defaultLayout $ do- setTitle "hledger-web register only"- addHamlet $- case inAccountMatcher qopts of Just m' -> registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m m'- Nothing -> registerReportHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m------------------------------------------------------------------------+-- -- | The register view, no sidebar.+-- getRegisterOnlyR :: Handler RepHtml+-- getRegisterOnlyR = do+-- vd@VD{..} <- getViewData+-- defaultLayout $ do+-- setTitle "hledger-web register only"+-- addWidget $ toWidget $+-- case inAccountQuery qopts of Just m' -> registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m m'+-- Nothing -> registerReportHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m +{- -- | A simple accounts view. This one is json-capable, returning the chart -- of accounts as json if the Accept header specifies json. getAccountsR :: Handler RepHtmlJson@@ -173,7 +206,7 @@ let j' = filterJournalPostings2 m j html = do setTitle "hledger-web accounts"- addHamlet $ accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j'+ addWidget $ toWidget $ accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j' json = jsonMap [("accounts", toJSON $ journalAccountNames j')] defaultLayoutJson html json @@ -183,40 +216,40 @@ VD{..} <- getViewData let j' = filterJournalPostings2 m j jsonToRepJson $ jsonMap [("accounts", toJSON $ journalAccountNames j')]+-} -------------------------------------------------------------------------- view helpers+-- helpers -- | Render the sidebar used on most views. sidebar :: ViewData -> HtmlUrl AppRoute-sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j+sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport (reportopts_ $ cliopts_ opts) am j --- | Render a "AccountsReport" as HTML.+-- | Render an "AccountsReport" as html. accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute accountsReportAsHtml _ vd@VD{..} (items',total) =- [$hamlet|-<div#accountsheading+ [hamlet|+<div#accountsheading> <a#accounts-toggle-link.togglelink href="#" title="Toggle sidebar">[+]-<div#accounts+<div#accounts> <table.balancereport>- <tr- <td.add colspan=3+ <tr>+ <td.add colspan=3> <br> <a#addformlink href="#" onclick="return addformToggle(event)" title="Add a new transaction to the journal">Add a transaction.. - <tr.item :allaccts:.inacct- <td.journal colspan=3+ <tr.item :allaccts:.inacct>+ <td.journal colspan=3> <br> <a href=@{JournalR} title="Show all transactions in journal format">Journal- <span.hoverlinks+ <span.hoverlinks> <a href=@{JournalEntriesR} title="Show journal entries">entries <a#editformlink href="#" onclick="return editformToggle(event)" title="Edit the journal"> edit - <tr- <td colspan=3+ <tr>+ <td colspan=3> <br> Accounts @@ -231,17 +264,17 @@ <td> |] where- l = journalToLedger nullfilterspec j- inacctmatcher = inAccountMatcher qopts+ l = journalToLedger Any j+ inacctmatcher = inAccountQuery qopts allaccts = isNothing inacctmatcher items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute- itemAsHtml _ (acct, adisplay, aindent, abal) = [$hamlet|-<tr.item.#{inacctclass}- <td.account.#{depthclass}+ itemAsHtml _ (acct, adisplay, aindent, abal) = [hamlet|+<tr.item.#{inacctclass}>+ <td.account.#{depthclass}> #{indent} <a href="@?{acctquery}" title="Show transactions in this account, including subaccounts">#{adisplay}- <span.hoverlinks+ <span.hoverlinks> $if hassubs <a href="@?{acctonlyquery}" title="Show transactions in this account only">only@@ -257,7 +290,7 @@ numpostings = length $ apostings $ ledgerAccount l acct depthclass = "depth"++show aindent 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 indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) " " acctquery = (RegisterR, [("q", pack $ accountQuery acct)])@@ -269,19 +302,19 @@ accountOnlyQuery :: AccountName -> String accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a) --- accountUrl :: AppRoute -> AccountName -> (AppRoute,[(String,ByteString)])-accountUrl r a = (r, [("q",pack $ accountQuery a)])+accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])+accountUrl r a = (r, [("q", pack $ accountQuery a)]) --- | Render a "EntriesReport" as HTML for the journal entries view.+-- | Render an "EntriesReport" as html for the journal entries view. entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute-entriesReportAsHtml _ vd items = [$hamlet|+entriesReportAsHtml _ vd items = [hamlet| <table.journalreport> $forall i <- numbered items ^{itemAsHtml vd i} |] where itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute- itemAsHtml _ (n, t) = [$hamlet|+ itemAsHtml _ (n, t) = [hamlet| <tr.item.#{evenodd}> <td.transaction> <pre>#{txn}@@ -290,11 +323,11 @@ evenodd = if even n then "even" else "odd" :: String txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse --- | Render an "TransactionsReport" as HTML for the formatted journal view.+-- | Render a "TransactionsReport" as html for the formatted journal view. journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute-journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|-<table.journalreport- <tr.headings+journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|+<table.journalreport>+ <tr.headings> <th.date align=left>Date <th.description align=left>Description <th.account align=left>Accounts@@ -305,19 +338,19 @@ where -- .#{datetransition} itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute- itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [$hamlet|-<tr.item.#{evenodd}.#{firstposting}+ itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [hamlet|+<tr.item.#{evenodd}.#{firstposting}> <td.date>#{date} <td.description colspan=2 title="#{show t}">#{elideRight 60 desc} <td.amount align=right> $if showamt #{mixedAmountAsHtml amt}-$forall p <- tpostings t- <tr.item.#{evenodd}.posting- <td.date- <td.description- <td.account> <a href="@?{accountUrl here $ paccount p}" title="Show transactions in #{paccount p}">#{elideRight 40 $ paccount p}- <td.amount align=right>#{mixedAmountAsHtml $ pamount p}+$forall p' <- tpostings t+ <tr.item.#{evenodd}.posting>+ <td.date>+ <td.description>+ <td.account> <a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}+ <td.amount align=right>#{mixedAmountAsHtml $ pamount p'} |] where evenodd = if even n then "even" else "odd" :: String@@ -330,16 +363,16 @@ -- Generate html for an account register, including a balance chart and transaction list. registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute-registerReportHtml opts vd r@(_,items) = [$hamlet|+registerReportHtml opts vd r@(_,items) = [hamlet| ^{registerChartHtml items} ^{registerItemsHtml opts vd r} |] -- Generate html for a transaction list from an "TransactionsReport". registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute-registerItemsHtml _ vd (balancelabel,items) = [$hamlet|-<table.registerreport- <tr.headings+registerItemsHtml _ vd (balancelabel,items) = [hamlet|+<table.registerreport>+ <tr.headings> <th.date align=left>Date <th.description align=left>Description <th.account align=left>To/From Account@@ -353,28 +386,28 @@ |] where -- inacct = inAccount qopts- -- filtering = m /= MatchAny+ -- filtering = m /= Any itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute- itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [$hamlet|-<tr.item.#{evenodd}.#{firstposting}.#{datetransition}+ itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [hamlet|+<tr.item.#{evenodd}.#{firstposting}.#{datetransition}> <td.date>#{date} <td.description title="#{show t}">#{elideRight 30 desc}- <td.account title="#{show t}"- <a+ <td.account title="#{show t}">+ <a> #{elideRight 40 acct} - <a.postings-toggle-link.togglelink href="#" title="Toggle all postings"+ <a.postings-toggle-link.togglelink href="#" title="Toggle all postings"> [+] <td.amount align=right> $if showamt #{mixedAmountAsHtml amt} <td.balance align=right>#{mixedAmountAsHtml bal}-$forall p <- tpostings t- <tr.item.#{evenodd}.posting style=#{postingsdisplaystyle}- <td.date- <td.description- <td.account> <a href="@?{accountUrl here $ paccount p}" title="Show transactions in #{paccount p}">#{elideRight 40 $ paccount p}- <td.amount align=right>#{mixedAmountAsHtml $ pamount p}+$forall p' <- tpostings t+ <tr.item.#{evenodd}.posting style=#{postingsdisplaystyle}>+ <td.date>+ <td.description>+ <td.account> <a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}+ <td.amount align=right>#{mixedAmountAsHtml $ pamount p'} <td.balance align=right> |] where@@ -389,15 +422,22 @@ -- | Generate javascript/html for a register balance line chart based on -- 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 = -- have to make sure plot is not called when our container (maincontent) -- is hidden, eg with add form toggled- [$hamlet|+ [hamlet|+<div#register-chart style="width:600px;height:100px; margin-bottom:1em;"> <script type=text/javascript>- if (document.getElementById('maincontent').style.display != 'none')- \$(document).ready(function() {- /* render chart */- \$.plot($('#register-chart'),+ \$(document).ready(function() {+ /* render chart with flot, if visible */+ var chartdiv = $('#register-chart');+ if (chartdiv.is(':visible'))+ \$.plot(chartdiv, [ [ $forall i <- items@@ -412,15 +452,14 @@ } ); });-<div#register-chart style="width:600px;height:100px; margin-bottom:1em;" |] -stringIfLongerThan :: Int -> String -> String-stringIfLongerThan n s = if length s > n then s else ""+-- stringIfLongerThan :: Int -> String -> String+-- stringIfLongerThan n s = if length s > n then s else "" numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)] numberTransactionsReportItems [] = []-numberTransactionsReportItems is = number 0 nulldate is+numberTransactionsReportItems items = number 0 nulldate items where number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)] number _ _ [] = []@@ -432,13 +471,14 @@ (dy,dm,_) = toGregorian d (prevdy,prevdm,_) = toGregorian prevd -mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ show b+mixedAmountAsHtml :: MixedAmount -> Html+mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ showMixedAmount b where addclass = printf "<span class=\"%s\">%s</span>" (c :: String) c = case isNegativeMixedAmount b of Just True -> "negative amount" _ -> "positive amount" ---------------------------------------------------------------------------------- post handlers+-- POST handlers postJournalR :: Handler RepHtml postJournalR = handlePost@@ -479,8 +519,8 @@ maybeNonNull = maybe Nothing (\t -> if Data.Text.null t then Nothing else Just t) acct1E = maybe (Left "to account required") (Right . unpack) $ maybeNonNull acct1M acct2E = maybe (Left "from account required") (Right . unpack) $ maybeNonNull acct2M- amt1E = maybe (Left "amount required") (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx someamount . unpack) amt1M- amt2E = maybe (Right missingamt) (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx someamount . unpack) amt2M+ amt1E = maybe (Left "amount required") (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx amount . unpack) amt1M+ amt2E = maybe (Right missingmixedamt) (either (const $ Left "could not parse amount") Right . parseWithCtx nullctx amount . unpack) amt2M journalE = maybe (Right $ journalFilePath j) (\f -> let f' = unpack f in if f' `elem` journalFilePaths j@@ -506,22 +546,22 @@ }) -- display errors or add transaction case tE of- Left errs -> do+ Left errs' -> do -- save current form values in session -- setMessage $ toHtml $ intercalate "; " errs- setMessage [$shamlet|+ setMessage [shamlet| Errors:<br>- $forall e<-errs+ $forall e<-errs' #{e}<br> |] Right t -> do let t' = txnTieKnot t -- XXX move into balanceTransaction- liftIO $ do ensureJournalFile journalpath+ liftIO $ do ensureJournalFileExists journalpath appendToJournalFileOrStdout journalpath $ showTransaction t' -- 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>|] - redirectParams RedirectTemporary RegisterR [("add","1")]+ redirect (RegisterR, [("add","1")]) chomp :: String -> String chomp = reverse . dropWhile (`elem` "\r\n") . reverse@@ -548,7 +588,7 @@ if not $ null errs then do setMessage $ toHtml (intercalate "; " errs :: String)- redirect RedirectTemporary JournalR+ redirect JournalR else do -- try to avoid unnecessary backups or saving invalid data@@ -559,24 +599,24 @@ if not changed then do setMessage "No change"- redirect RedirectTemporary JournalR+ redirect JournalR else do- jE <- liftIO $ journalFromPathAndString Nothing journalpath tnew+ jE <- liftIO $ readJournal Nothing Nothing (Just journalpath) tnew either (\e -> do setMessage $ toHtml e- redirect RedirectTemporary JournalR)+ redirect JournalR) (const $ do liftIO $ writeFileWithBackup journalpath tnew setMessage $ toHtml (printf "Saved journal %s\n" (show journalpath) :: String)- redirect RedirectTemporary JournalR)+ redirect JournalR) jE -- | Handle a post from the journal import form. handleImport :: Handler RepHtml handleImport = do setMessage "can't handle file upload yet"- redirect RedirectTemporary JournalR+ redirect JournalR -- -- get form input values, or basic validation errors. E means an Either value. -- fileM <- runFormPost $ maybeFileInput "file" -- let fileE = maybe (Left "No file provided") Right fileM@@ -584,79 +624,79 @@ -- case fileE of -- Left errs -> do -- setMessage errs- -- redirect RedirectTemporary JournalR+ -- redirect JournalR -- Right s -> do -- setMessage s- -- redirect RedirectTemporary JournalR+ -- redirect JournalR ------------------------------------------------------------------------- | Other view components.+-- Common page components. -- | Global toolbar/heading area. topbar :: ViewData -> HtmlUrl AppRoute-topbar VD{..} = [$hamlet|-<div#topbar- <a.topleftlink href=#{hledgerorgurl} title="More about hledger"+topbar VD{..} = [hamlet|+<div#topbar>+ <a.topleftlink href=#{hledgerorgurl} title="More about hledger"> hledger-web <br /> #{version} <a.toprightlink href=#{manualurl} target=hledgerhelp title="User manual">manual <h1>#{title}-$maybe m <- msg- <div#message>#{m}+$maybe m' <- msg+ <div#message>#{m'} |] where title = takeFileName $ journalFilePath j --- | Navigation link, preserving parameters and possibly highlighted.-navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute-navlink VD{..} s dest title = [$hamlet|-<a##{s}link.#{style} href=@?{u} title="#{title}">#{s}-|]- where u = (dest, if null q then [] else [("q", pack q)])- style | dest == here = "navlinkcurrent"- | otherwise = "navlink" :: Text+-- -- | Navigation link, preserving parameters and possibly highlighted.+-- navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute+-- navlink VD{..} s dest title = [hamlet|+-- <a##{s}link.#{style} href=@?{u'} title="#{title}">#{s}+-- |]+-- where u' = (dest, if null q then [] else [("q", pack q)])+-- style | dest == here = "navlinkcurrent"+-- | otherwise = "navlink" :: Text --- | Links to the various journal editing forms.-editlinks :: HtmlUrl AppRoute-editlinks = [$hamlet|-<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#importformlink href="#" onclick="return importformToggle(event)" style="display:none;">import transactions-|]+-- -- | Links to the various journal editing forms.+-- editlinks :: HtmlUrl AppRoute+-- editlinks = [hamlet|+-- <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#importformlink href="#" onclick="return importformToggle(event)" style="display:none;">import transactions+-- |] -- | Link to a topic in the manual. helplink :: String -> String -> HtmlUrl AppRoute-helplink topic label = [$hamlet|+helplink topic label = [hamlet| <a href=#{u} target=hledgerhelp>#{label} |] where u = manualurl ++ if null topic then "" else '#':topic -- | Search form for entering custom queries to filter journal data. searchform :: ViewData -> HtmlUrl AppRoute-searchform VD{..} = [$hamlet|-<div#searchformdiv- <form#searchform.form method=GET- <table- <tr- <td+searchform VD{..} = [hamlet|+<div#searchformdiv>+ <form#searchform.form method=GET>+ <table>+ <tr>+ <td> Search: \ #- <td- <input name=q size=70 value=#{q}- <input type=submit value="Search"+ <td>+ <input name=q size=70 value=#{q}>+ <input type=submit value="Search"> $if filtering \ #- <span.showall+ <span.showall> <a href=@{here}>clear search \ # <a#search-help-link href="#" title="Toggle search help">help- <tr- <td- <td- <div#search-help.help style="display:none;"+ <tr>+ <td>+ <td>+ <div#search-help.help style="display:none;"> Leave blank to see journal (all transactions), or click account links to see transactions under that account. <br> Transactions/postings may additionally be filtered by:@@ -677,7 +717,7 @@ -- | Add transaction form. addform :: ViewData -> HtmlUrl AppRoute-addform vd@VD{..} = [$hamlet|+addform vd@VD{..} = [hamlet| <script type=text/javascript> \$(document).ready(function() { /* dhtmlxcombo setup */@@ -695,37 +735,37 @@ /* desccombo.setOptionHeight(200); */ }); -<form#addform method=POST style=display:none;+<form#addform method=POST style=display:none;> <h2#contenttitle>#{title}- <table.form- <tr- <td colspan=4- <table- <tr#descriptionrow- <td+ <table.form>+ <tr>+ <td colspan=4>+ <table>+ <tr#descriptionrow>+ <td> Date:- <td- <input.textinput size=15 name=date value=#{date}- <td style=padding-left:1em;+ <td>+ <input.textinput size=15 name=date value=#{date}>+ <td style=padding-left:1em;> Description:- <td- <select id=description name=description- <option+ <td>+ <select id=description name=description>+ <option> $forall d <- descriptions <option value=#{d}>#{d}- <tr.helprow- <td- <td+ <tr.helprow>+ <td>+ <td> <span.help>#{datehelp} #- <td- <td+ <td>+ <td> <span.help>#{deschelp} ^{postingfields vd 1} ^{postingfields vd 2}- <tr#addbuttonrow- <td colspan=4- <input type=hidden name=action value=add- <input type=submit name=submit value="add transaction"+ <tr#addbuttonrow>+ <td colspan=4>+ <input type=hidden name=action value=add>+ <input type=submit name=submit value="add transaction"> $if manyfiles \ to: ^{journalselect $ files j} \ or #@@ -738,37 +778,38 @@ date = "today" :: String descriptions = sort $ nub $ map tdescription $ jtxns j manyfiles = (length $ files j) > 1- postingfields VD{..} n = [$hamlet|-<tr#postingrow+ postingfields :: ViewData -> Int -> HtmlUrl AppRoute+ postingfields _ n = [hamlet|+<tr#postingrow> <td align=right>#{acctlabel}:- <td- <select id=#{acctvar} name=#{acctvar}- <option+ <td>+ <select id=#{acctvar} name=#{acctvar}>+ <option> $forall a <- acctnames <option value=#{a} :shouldselect a:selected>#{a} ^{amtfield}-<tr.helprow- <td- <td+<tr.helprow>+ <td>+ <td> <span.help>#{accthelp}- <td- <td+ <td>+ <td> <span.help>#{amthelp} |] where shouldselect a = n == 2 && maybe False ((a==).fst) (inAccount qopts)- numbered = (++ show n)- acctvar = numbered "account"- amtvar = numbered "amount"+ withnumber = (++ show n)+ acctvar = withnumber "account"+ amtvar = withnumber "amount" acctnames = sort $ journalAccountNamesUsed j (acctlabel, accthelp, amtfield, amthelp) | n == 1 = ("To account" ,"eg: expenses:food"- ,[$hamlet|-<td style=padding-left:1em;+ ,[hamlet|+<td style=padding-left:1em;> Amount:-<td- <input.textinput size=15 name=#{amtvar} value=""+<td>+ <input.textinput size=15 name=#{amtvar} value=""> |] ,"eg: $6" )@@ -780,28 +821,28 @@ -- | Edit journal form. editform :: ViewData -> HtmlUrl AppRoute-editform VD{..} = [$hamlet|-<form#editform method=POST style=display:none;- <h2#contenttitle>#{title}- <table.form+editform VD{..} = [hamlet|+<form#editform method=POST style=display:none;>+ <h2#contenttitle>#{title}>+ <table.form> $if manyfiles- <tr- <td colspan=2+ <tr>+ <td colspan=2> Editing ^{journalselect $ files j}- <tr- <td colspan=2+ <tr>+ <td colspan=2> <!-- XXX textarea ids are unquoted journal file paths here, not valid html --> $forall f <- files j- <textarea id=#{fst f}_textarea name=text rows=25 cols=80 style=display:none; disabled=disabled+ <textarea id=#{fst f}_textarea name=text rows=25 cols=80 style=display:none; disabled=disabled> #{snd f}- <tr#addbuttonrow- <td+ <tr#addbuttonrow>+ <td> <span.help>^{formathelp}- <td align=right- <span.help+ <td align=right>+ <span.help> Are you sure ? This will overwrite the journal. #- <input type=hidden name=action value=edit- <input type=submit name=submit value="save journal"+ <input type=hidden name=action value=edit>+ <input type=submit name=submit value="save journal"> \ or # <a href="#" onclick="return editformToggle(event)">cancel |]@@ -812,30 +853,30 @@ -- | Import journal form. importform :: HtmlUrl AppRoute-importform = [$hamlet|-<form#importform method=POST style=display:none;- <table.form- <tr- <td- <input type=file name=file- <input type=hidden name=action value=import- <input type=submit name=submit value="import from file"+importform = [hamlet|+<form#importform method=POST style=display:none;>+ <table.form>+ <tr>+ <td>+ <input type=file name=file>+ <input type=hidden name=action value=import>+ <input type=submit name=submit value="import from file"> \ or #- <a href="#" onclick="return importformToggle(event)" cancel+ <a href="#" onclick="return importformToggle(event)">cancel |] journalselect :: [(FilePath,String)] -> HtmlUrl AppRoute-journalselect journalfiles = [$hamlet|-<select id=journalselect name=journal onchange="editformJournalSelect(event)"+journalselect journalfiles = [hamlet|+<select id=journalselect name=journal onchange="editformJournalSelect(event)"> $forall f <- journalfiles <option value=#{fst f}>#{fst f} |] nulltemplate :: HtmlUrl AppRoute-nulltemplate = [$hamlet||]+nulltemplate = [hamlet||] ------------------------------------------------------------------------- utilities+-- Utilities -- | A bundle of data useful for hledger-web request handlers and templates. data ViewData = VD {@@ -845,9 +886,9 @@ ,today :: Day -- ^ today's date (for queries containing relative dates) ,j :: Journal -- ^ the up-to-date parsed unfiltered journal ,q :: String -- ^ the current q parameter, the main query expression- ,m :: Matcher -- ^ a matcher parsed from the q parameter+ ,m :: Query -- ^ a query parsed from the q parameter ,qopts :: [QueryOpt] -- ^ query options parsed from the q parameter- ,am :: Matcher -- ^ a matcher parsed from the accounts sidebar query expr ("a" parameter)+ ,am :: Query -- ^ a query parsed from the accounts sidebar query expr ("a" parameter) ,aopts :: [QueryOpt] -- ^ query options parsed from the accounts sidebar query expr ,showpostings :: Bool -- ^ current p parameter, 1 or 0 shows/hides all postings where applicable }@@ -920,6 +961,7 @@ oldmsg <- getMessage return $ maybe oldmsg (Just . toHtml) mnewmsg +numbered :: [a] -> [(Int,a)] numbered = zip [1..] dayToJsTimestamp :: Day -> Integer
+ Hledger/Web/Import.hs view
@@ -0,0 +1,16 @@+module Hledger.Web.Import+ ( module Prelude+ , (<>)+ , Text+ , module Data.Monoid+ , module Control.Applicative+ ) where++import Prelude hiding (writeFile, readFile, putStrLn)+import Data.Monoid (Monoid (mappend, mempty, mconcat))+import Control.Applicative ((<$>), (<*>), pure)+import Data.Text (Text)++infixr 5 <>+(<>) :: Monoid m => m -> m -> m+(<>) = mappend
Hledger/Web/Options.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, CPP #-} {-| -} module Hledger.Web.Options where+import Prelude import Data.Maybe import Distribution.PackageDescription.TH (packageVariable, package, pkgName, pkgVersion) import System.Console.CmdArgs@@ -14,17 +15,26 @@ import Hledger.Web.Settings progname, version :: String+#if HADDOCK+progname = ""+version = ""+#else progname = $(packageVariable (pkgName . package)) version = $(packageVariable (pkgVersion . package))+#endif+prognameandversion :: String prognameandversion = progname ++ " " ++ version :: String +defbaseurlexample :: String defbaseurlexample = (reverse $ drop 4 $ reverse $ defbaseurl defport) ++ "PORT" +webflags :: [Flag [([Char], [Char])]] webflags = [ 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++")") ] +webmode :: Mode [([Char], [Char])] webmode = (mode "hledger-web" [("command","web")] "start serving the hledger web interface" mainargsflag []){@@ -45,6 +55,7 @@ ,cliopts_ :: CliOpts } deriving (Show) +defwebopts :: WebOpts defwebopts = WebOpts def def
Hledger/Web/Settings.hs view
@@ -1,45 +1,35 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, TemplateHaskell, QuasiQuotes, OverloadedStrings #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod -- by overriding methods in the Yesod typeclass. That instance is -- declared in the hledger-web.hs file. module Hledger.Web.Settings- ( hamletFile- , cassiusFile- , juliusFile- , luciusFile- , widgetFile+ ( widgetFile , staticRoot , staticDir- , loadConfig- , AppEnvironment(..)- , AppConfig(..)-+ , Extra (..)+ , parseExtra+ , hamlet , defport , defbaseurl , hledgerorgurl , manualurl- ) where -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 Control.Applicative+import Data.Text (Text)+import Data.Yaml+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote+import Prelude import Text.Printf-import qualified Text.Shakespeare.Text as S import Text.Shakespeare.Text (st)-import Language.Haskell.TH.Syntax-import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile)-import Data.Monoid (mempty)-import System.Directory (doesFileExist)-import Data.Text (Text, pack)-import Data.Object-import qualified Data.Object.Yaml as YAML-import Control.Monad (join)+import Yesod.Default.Config+import qualified Yesod.Default.Util+import qualified Text.Hamlet (hamlet)+-- when available:+-- import Text.Hamlet (HamletSettings(..), hamletWithSettings, defaultHamletSettings, hamletRules) hledgerorgurl, manualurl :: String@@ -54,54 +44,8 @@ defbaseurl port = printf "http://localhost:%d" port -data AppEnvironment = Test- | Development- | Staging- | Production- deriving (Eq, Show, Read, Enum, Bounded)- -- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml. -- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).------ By convention these settings should be overwritten by any command line arguments.--- See config/App.hs for command line arguments--- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku).----data AppConfig = AppConfig {- appEnv :: AppEnvironment-- , appPort :: Int-- -- The base URL for your application. This will usually be different for- -- development and production. Yesod automatically constructs URLs for you,- -- so this value must be accurate to create valid links.- -- Please note that there is no trailing slash.- --- -- You probably want to change this! If your domain name was "yesod.com",- -- you would probably want it to be:- -- > "http://yesod.com"- , appRoot :: Text-} deriving (Show)--loadConfig :: AppEnvironment -> IO AppConfig-loadConfig env = do- allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping- settings <- lookupMapping (show env) allSettings- hostS <- lookupScalar "host" settings- port <- fmap read $ lookupScalar "port" settings- return $ AppConfig {- appEnv = env- , appPort = port- , appRoot = pack $ hostS ++ addPort port- }- where- addPort :: Int -> String-#ifdef PRODUCTION- addPort _ = ""-#else- addPort p = ":" ++ (show p)-#endif- -- | The location of static files on your system. This is a file system -- path. The default value works properly with your scaffolded site. staticDir :: FilePath@@ -120,73 +64,26 @@ -- have to make a corresponding change here. -- -- To see how this value is used, see urlRenderOverride in hledger-web.hs-staticRoot :: AppConfig -> Text-staticRoot conf = [$st|#{appRoot conf}/static|]---- 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+staticRoot :: AppConfig DefaultEnv a -> Text+staticRoot conf = [st|#{appRoot conf}/static|] -luciusFile :: FilePath -> Q Exp-luciusFile =-#ifdef PRODUCTION- S.luciusFile . globFile "lucius"+widgetFile :: String -> Q Exp+#if DEVELOPMENT+widgetFile = Yesod.Default.Util.widgetFileReload #else- S.luciusFileDebug . globFile "lucius"+widgetFile = Yesod.Default.Util.widgetFileNoReload #endif -juliusFile :: FilePath -> Q Exp-juliusFile =-#ifdef PRODUCTION- S.juliusFile . globFile "julius"-#else- S.juliusFileDebug . globFile "julius"-#endif+data Extra = Extra+ { extraCopyright :: Text+ , extraAnalytics :: Maybe Text -- ^ Google Analytics+ } -textFile :: FilePath -> Q Exp-textFile =-#ifdef PRODUCTION- S.textFile . globFile "text"-#else- S.textFileDebug . globFile "text"-#endif+parseExtra :: DefaultEnv -> Object -> Parser Extra+parseExtra _ o = Extra+ <$> o .: "copyright"+ <*> o .:? "analytics" -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|]+hamlet :: QuasiQuoter+hamlet = Text.Hamlet.hamlet+-- hamlet = hamletWithSettings hamletRules defaultHamletSettings{hamletNewlines=True}
Hledger/Web/Settings/StaticFiles.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, CPP, OverloadedStrings #-} {-| This module exports routes for all the files in the static directory at@@ -11,8 +11,27 @@ -} module Hledger.Web.Settings.StaticFiles where +import System.IO import Yesod.Static+import qualified Yesod.Static as Static +import Prelude import Hledger.Web.Settings (staticDir) -$(staticFiles staticDir)+-- | use this to create your static file serving site+staticSite :: IO Static.Static+staticSite = do+#ifdef DEVELOPMENT+ putStrLn ("using web files from: " ++ staticDir ++ "/") >> hFlush stdout+ Static.staticDevel staticDir+#else+ putStrLn "using embedded web files" >> hFlush stdout+ return $(Static.embed staticDir)+#endif+++-- | This generates easy references to files in the static directory at compile time,+-- giving you compile-time verification that referenced files exist.+-- Warning: any files added to your static directory during run-time can't be+-- accessed this way. You'll have to use their FilePath or URL to access them.+$(publicFiles staticDir)
hledger-web.cabal view
@@ -1,5 +1,5 @@ name: hledger-web-version: 0.17.1+version: 0.18 category: Finance synopsis: A web interface for the hledger accounting tool. description: @@ -17,7 +17,7 @@ homepage: http://hledger.org bug-reports: http://code.google.com/p/hledger/issues stability: beta-tested-with: GHC==7.0, GHC==7.2+tested-with: GHC==7.0, GHC==7.2, GHC==7.4.1 cabal-version: >= 1.6 build-type: Simple extra-tmp-files:@@ -39,90 +39,126 @@ type: darcs location: http://joyful.com/repos/hledger -Flag production- Description: Build fully optimised and with web files embedded (not loaded from ./static/)- Default: True+-- Flag production+-- Description: Build fully optimised and with web files embedded (not loaded from ./static/)+-- Default: True flag threaded- Description: Build with support for multithreaded execution+ Description: Build with support for multithreaded execution. Default: True -Flag devel- Description: Build for auto-recompiling by "yesod devel"+flag dev+ Description: Turn on development settings, like auto-reload templates. Default: False -executable hledger-web- main-is: hledger-web.hs- if flag(devel)- Buildable: False- if flag(production)- cpp-options: -DPRODUCTION- ghc-options: -O2- else- ghc-options: -Wall- if flag(threaded)- ghc-options: -threaded- other-modules:+flag library-only+ Description: Build for use with "yesod devel"+ Default: False++library+ if flag(library-only)+ Buildable: True+ else+ Buildable: False++ if flag(threaded)+ ghc-options: -threaded++ exposed-modules: + Hledger.Web.Application+ other-modules: Hledger.Web Hledger.Web.Foundation- Hledger.Web.Application+ Hledger.Web.Import Hledger.Web.Options Hledger.Web.Settings Hledger.Web.Settings.StaticFiles Hledger.Web.Handlers- build-depends:- hledger == 0.17- ,hledger-lib == 0.17- ,HUnit- ,base >= 4 && < 5- ,bytestring- ,cabal-file-th- ,cmdargs >= 0.9.1 && < 0.10- ,directory- ,filepath- ,old-locale- ,parsec- ,regexpr >= 0.5.1- ,safe >= 0.2- ,text- ,time- ,io-storage >= 0.3 && < 0.4- ,failure >= 0.1 && < 0.2- ,file-embed == 0.0.*- ,template-haskell >= 2.4 && < 2.8 - ,yesod == 0.9.4.1- ,yesod-core- ,yesod-form- ,yesod-json- ,yesod-static >= 0.3 && < 0.10- ,aeson >= 0.3.2.13- ,blaze-html- ,clientsession- ,data-object- ,data-object-yaml- ,hamlet- ,shakespeare-css- ,shakespeare-js- ,shakespeare-text- ,transformers- ,wai < 1.0- ,wai-extra < 1.0- ,warp < 1.0- ,http-enumerator < 0.7.3- ,tls-extra < 0.4.3+ ghc-options: -Wall -O0 -fno-warn-unused-do-bind+ cpp-options: -DDEVELOPMENT -library- if flag(devel)- Buildable: True- else+ extensions: TemplateHaskell+ QuasiQuotes+ OverloadedStrings+ NoImplicitPrelude+ CPP+ OverloadedStrings+ MultiParamTypeClasses+ TypeFamilies++executable hledger-web+ if flag(library-only) Buildable: False- exposed-modules: - Hledger.Web.Application++ if flag(dev)+ cpp-options: -DDEVELOPMENT+ ghc-options: -Wall -O0 -fno-warn-unused-do-bind+ else+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind++ if flag(threaded)+ ghc-options: -threaded++ extensions: TemplateHaskell+ QuasiQuotes+ OverloadedStrings+ NoImplicitPrelude+ CPP+ OverloadedStrings+ MultiParamTypeClasses+ TypeFamilies++ main-is: hledger-web.hs+ other-modules: Hledger.Web Hledger.Web.Foundation+ Hledger.Web.Application+ Hledger.Web.Import Hledger.Web.Options Hledger.Web.Settings Hledger.Web.Settings.StaticFiles Hledger.Web.Handlers++ build-depends:+ hledger == 0.18+ , hledger-lib == 0.18+ , base >= 4 && < 5+ , cabal-file-th+ , cmdargs >= 0.9.1 && < 0.10+ , directory+ , filepath+ , HUnit+ , io-storage >= 0.3 && < 0.4+ , old-locale+ , parsec+ , regexpr >= 0.5.1+ , safe >= 0.2+ , time++ , yesod == 1.0.*+ , yesod-core+ , yesod-default+ , yesod-static+ , blaze-html < 0.5+ , clientsession+ , hamlet+ , network-conduit+ , shakespeare-text+ , template-haskell+ , text >= 0.11 && < 0.12+ , transformers >= 0.2 && < 0.4+ , wai+ , wai-extra+ , warp+ , yaml+++ -- if flag(production)+ -- cpp-options: -DPRODUCTION+ -- ghc-options: -O2+ -- else+ -- ghc-options: -Wall+ -- if flag(threaded)+ -- ghc-options: -threaded
hledger-web.hs view
@@ -1,33 +1,34 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {-|+ hledger-web - a hledger add-on providing a web interface.-Copyright (c) 2007-2011 Simon Michael <simon@joyful.com>+Copyright (c) 2007-2012 Simon Michael <simon@joyful.com> Released under GPL version 3 or later.+ -} module Main where --- import Control.Concurrent (forkIO, threadDelay)+import Data.Conduit.Network (HostPreference(..))+import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort)+import Yesod.Default.Config+-- import Yesod.Default.Main (defaultMain)+import Yesod.Logger ({- Logger,-} defaultDevelopmentLogger) --, logString)++import Prelude hiding (putStrLn)+-- -- import Control.Concurrent (forkIO, threadDelay) import Control.Monad-import Data.Maybe+-- import Data.Maybe import Data.Text(pack)-import Network.Wai.Handler.Warp (run) import System.Exit import System.IO.Storage (withStore, putValue) import Text.Printf-#ifndef PRODUCTION-import Network.Wai.Middleware.Debug (debugHandle)-import Yesod.Logger (logString, logLazyText, flushLogger, makeLogger)-#else-import Yesod.Logger (makeLogger)-#endif import Hledger import Hledger.Cli hiding (progname,prognameandversion)-import Prelude hiding (putStrLn)-import Hledger.Utils.UTF8 (putStrLn)-import Hledger.Web+import Hledger.Utils.UTF8IOCompat (putStrLn)+import Hledger.Web hiding (opts,j) main :: IO ()@@ -37,17 +38,15 @@ runWith opts runWith :: WebOpts -> IO ()-runWith opts = run opts- where- run opts- | "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp webmode) >> exitSuccess- | "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess- | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)- | otherwise = journalFilePathFromOpts (cliopts_ opts) >>= ensureJournalFile >> withJournalDo' opts web+runWith opts+ | "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp webmode) >> exitSuccess+ | "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess+ | "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)+ | otherwise = journalFilePathFromOpts (cliopts_ opts) >>= ensureJournalFileExists >> withJournalDo' opts web withJournalDo' :: WebOpts -> (WebOpts -> Journal -> IO ()) -> IO () withJournalDo' opts cmd = do- journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing >>=+ journalFilePathFromOpts (cliopts_ opts) >>= readJournalFile Nothing Nothing >>= either error' (cmd opts . journalApplyAliases (aliasesFromOpts $ cliopts_ opts)) -- | The web command.@@ -74,61 +73,21 @@ withStore "hledger" $ do putValue "hledger" "journal" j - -- yesod main- logger <- makeLogger- -- args <- cmdArgs argConfig- -- env <- getAppEnv args- let env = Development- -- c <- loadConfig env- -- let c' = if port_ opts /= 0- -- then c{ appPort = port args }- -- else c- let c = AppConfig {- appEnv = env+-- defaultMain :: (Show env, Read env)+-- => IO (AppConfig env extra)+-- -> (AppConfig env extra -> Logger -> IO Application)+-- -> IO ()+-- defaultMain load getApp = do+ -- config <- fromArgs parseExtra+ let config = AppConfig {+ appEnv = Development , appPort = port_ opts , appRoot = pack baseurl+ , appHost = HostIPv4+ , appExtra = Extra "" Nothing }-#if PRODUCTION- withApp c logger opts $ run (appPort c)-#else- logString logger $ (show env) ++ " application launched, listening on port " ++ show (appPort c)- withApp c logger opts $ run (appPort c) . debugHandle (logHandle logger)- flushLogger logger-- where- logHandle logger msg = logLazyText logger msg >> flushLogger logger-#endif---- data ArgConfig = ArgConfig--- { environment :: String--- , port :: Int--- } deriving (Show, Data, Typeable)---- argConfig :: ArgConfig--- argConfig = ArgConfig--- { environment = def --- &= help ("application environment, one of: " ++ (foldl1 (\a b -> a ++ ", " ++ b) environments))--- &= typ "ENVIRONMENT"--- , port = def--- &= typ "PORT"--- }---- environments :: [String]--- environments = map ((map toLower) . show) ([minBound..maxBound] :: [AppEnvironment])---- | retrieve the -e environment option--- getAppEnv :: ArgConfig -> IO AppEnvironment--- getAppEnv cfg = do--- let e = if environment cfg /= ""--- then environment cfg--- else--- #if PRODUCTION--- "production"--- #else--- "development"--- #endif--- return $ read $ capitalize e---- where--- capitalize [] = []--- capitalize (x:xs) = toUpper x : map toLower xs+ logger <- defaultDevelopmentLogger+ app <- getApplication config logger+ runSettings defaultSettings+ { settingsPort = appPort config+ } app
routes view
@@ -6,5 +6,5 @@ /journal/entries JournalEntriesR GET POST /journal/edit JournalEditR GET POST /register RegisterR GET POST-/accounts AccountsR GET-/api/accounts AccountsJsonR GET+-- /accounts AccountsR GET+-- /api/accounts AccountsJsonR GET