summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Application.hs88
-rw-r--r--CHANGES15
-rw-r--r--Foundation.hs397
-rw-r--r--Handler/AddForm.hs124
-rw-r--r--Handler/Common.hs251
-rw-r--r--Handler/JournalR.hs88
-rw-r--r--Handler/RegisterR.hs181
-rw-r--r--Handler/RootR.hs8
-rw-r--r--Handler/SidebarR.hs15
-rw-r--r--Handler/Utils.hs20
-rw-r--r--Hledger/Web.hs12
-rw-r--r--Hledger/Web/Application.hs53
-rw-r--r--Hledger/Web/Foundation.hs232
-rw-r--r--Hledger/Web/Handler/AddR.hs40
-rw-r--r--Hledger/Web/Handler/Common.hs38
-rw-r--r--Hledger/Web/Handler/EditR.hs47
-rw-r--r--Hledger/Web/Handler/JournalR.hs31
-rw-r--r--Hledger/Web/Handler/RegisterR.hs60
-rw-r--r--Hledger/Web/Handler/UploadR.hs63
-rw-r--r--Hledger/Web/Import.hs31
-rw-r--r--Hledger/Web/Main.hs87
-rw-r--r--Hledger/Web/Settings.hs (renamed from Settings.hs)34
-rw-r--r--Hledger/Web/Settings/StaticFiles.hs (renamed from Settings/StaticFiles.hs)16
-rw-r--r--Hledger/Web/WebOptions.hs207
-rw-r--r--Hledger/Web/Widget/AddForm.hs144
-rw-r--r--Hledger/Web/Widget/Common.hs89
-rw-r--r--Import.hs22
-rw-r--r--Settings/Development.hs15
-rw-r--r--config/routes13
-rw-r--r--hledger-web.12
-rw-r--r--hledger-web.cabal169
-rw-r--r--hledger-web.info8
-rw-r--r--hledger-web.txt2
-rw-r--r--messages/en.msg1
-rw-r--r--static/hledger.css99
-rw-r--r--static/hledger.js151
-rw-r--r--templates/add-form.hamlet71
-rw-r--r--templates/balance-report.hamlet25
-rw-r--r--templates/chart.hamlet59
-rw-r--r--templates/default-layout-wrapper.hamlet60
-rw-r--r--templates/default-layout.hamlet85
-rw-r--r--templates/edit-form.hamlet17
-rw-r--r--templates/journal.hamlet39
-rw-r--r--templates/manage.hamlet22
-rw-r--r--templates/register.hamlet37
-rw-r--r--templates/upload-form.hamlet14
-rw-r--r--tests/HomeTest.hs25
-rw-r--r--tests/TestImport.hs12
-rw-r--r--tests/main.hs24
49 files changed, 1533 insertions, 1810 deletions
diff --git a/Application.hs b/Application.hs
deleted file mode 100644
index a8185e4..0000000
--- a/Application.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-}
-module Application
- ( makeApplication
- , getApplicationDev
- , makeFoundation
- ) where
-
-import Data.Default
-import Data.IORef
-import Import
-import Yesod.Default.Config
-import Yesod.Default.Main
-import Yesod.Default.Handlers
-import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout)
-import Network.HTTP.Conduit (newManager)
-import Prelude (head)
-
--- adapt to http-conduit 1.x or 2.x when cabal macros are available, otherwise assume 2.x
-#ifdef MIN_VERSION_http_conduit
-#if MIN_VERSION_http_conduit(2,0,0)
-#define http_conduit_2
-#endif
-#else
-#define http_conduit_2
-#endif
-#ifdef http_conduit_2
-import Network.HTTP.Client (defaultManagerSettings)
-#else
-import Network.HTTP.Conduit (def)
-#endif
-
--- Import all relevant handler modules here.
--- Don't forget to add new modules to your cabal file!
-import Handler.RootR
-import Handler.JournalR
-import Handler.RegisterR
-import Handler.SidebarR
-
-import Hledger.Web.WebOptions (WebOpts(..), defwebopts)
-import Hledger.Data (Journal, nulljournal)
-import Hledger.Read (readJournalFile)
-import Hledger.Utils (error')
-import Hledger.Cli.CliOptions (defcliopts, journalFilePathFromOpts)
-
--- This line actually creates our YesodDispatch instance. It is the second half
--- of the call to mkYesodData which occurs in Foundation.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.
-makeApplication :: WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application
-makeApplication opts j conf = do
- foundation <- makeFoundation conf opts
- writeIORef (appJournal foundation) j
- app <- toWaiAppPlain foundation
- return $ logWare app
- where
- logWare | development = logStdoutDev
- | serve_ opts = logStdout
- | otherwise = id
-
-makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App
-makeFoundation conf opts = do
- manager <- newManager
-#ifdef http_conduit_2
- defaultManagerSettings
-#else
- def
-#endif
- s <- staticSite
- jref <- newIORef nulljournal
- return $ App conf s manager opts jref
-
--- for yesod devel
--- uses the journal specified by the LEDGER_FILE env var, or ~/.hledger.journal
-getApplicationDev :: IO (Int, Application)
-getApplicationDev = do
- f <- head `fmap` journalFilePathFromOpts defcliopts -- XXX head should be safe for now
- j <- either error' id `fmap` readJournalFile def f
- defaultDevelApp loader (makeApplication defwebopts j)
- where
- loader = Yesod.Default.Config.loadConfig (configSettings Development)
- { csParseExtra = parseExtra
- }
diff --git a/CHANGES b/CHANGES
index 12e2642..e8e40c0 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,6 +1,21 @@
User-visible changes in hledger-web. See also hledger, hledger-lib.
+# 1.10 (2018/6/30)
+
+* multiple -f options, and --auto, work again
+
+* view, add, edit permissions can be set at CLI or by Sandstorm HTTP header
+
+* the edit form has been revived, for whole-journal editing
+
+* the journal can now be uploaded and downloaded
+
+* the e key toggles empty accounts in the sidebar
+
+* use hledger-lib 1.10
+
+
# 1.9.2 (2018/4/30)
* use hledger-lib 1.9.1
diff --git a/Foundation.hs b/Foundation.hs
deleted file mode 100644
index f59a322..0000000
--- a/Foundation.hs
+++ /dev/null
@@ -1,397 +0,0 @@
-{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
-{-
-
-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 Foundation where
-
-import Prelude
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
-#endif
-import Data.IORef
-import Yesod
-import Yesod.Static
-import Yesod.Default.Config
-#ifndef DEVELOPMENT
-import Yesod.Default.Util (addStaticContentExternal)
-#endif
-import Network.HTTP.Conduit (Manager)
--- import qualified Settings
-import Settings.StaticFiles
-import Settings (staticRoot, widgetFile, Extra (..))
-#ifndef DEVELOPMENT
-import Settings (staticDir)
-import Text.Jasmine (minifym)
-#endif
-import Text.Blaze.Html.Renderer.String (renderHtml)
-import Text.Hamlet (hamletFile)
-
-import Hledger.Web.WebOptions
-import Hledger.Data.Types
--- import Hledger.Web.Settings
--- import Hledger.Web.Settings.StaticFiles
-
--- for addform
-import Data.List
-import Data.Maybe
-import Data.Text as Text (Text,pack,unpack)
-import Data.Time.Calendar
-#if BLAZE_HTML_0_4
-import Text.Blaze (preEscapedString, Markup)
-#else
-import Text.Blaze (Markup)
-import Text.Blaze.Internal (preEscapedString)
-#endif
-import Text.JSON
-import Hledger.Data.Journal
-import Hledger.Query
-import Hledger hiding (is)
-import Hledger.Cli hiding (version)
-
-
--- | 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.
-data App = App
- { settings :: AppConfig DefaultEnv Extra
- , getStatic :: Static -- ^ Settings for static file serving.
- , httpManager :: Manager
- --
- , appOpts :: WebOpts
- , appJournal :: IORef Journal
- }
-
--- Set up i18n messages. See the message folder.
-mkMessage "App" "messages" "en"
-
--- This is where we define all of the routes in our application. For a full
--- explanation of the syntax, please see:
--- http://www.yesodweb.com/book/handler
---
--- 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.
-mkYesodData "App" $(parseRoutesFile "config/routes")
-
--- | A convenience alias.
-type AppRoute = Route App
-
-#if MIN_VERSION_yesod(1,6,0)
-type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
-#else
-type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
-#endif
-
--- 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 = ApprootMaster $ appRoot . settings
-
--- -- Store session data on the client in encrypted cookies,
--- -- default session idle timeout is 120 minutes
--- makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
--- (120 * 60)
--- ".hledger-web_client_session_key.aes"
- -- don't use session data
- makeSessionBackend _ = return Nothing
-
- defaultLayout widget = do
- master <- getYesod
- lastmsg <- getMessage
- vd@VD{..} <- getViewData
-
- -- 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")
- -- addStylesheet $ StaticR css_bootstrap_css
- -- $(widgetFile "default-layout")
- -- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
-
- pc <- widgetToPageContent $ do
- addStylesheet $ StaticR css_bootstrap_min_css
- addStylesheet $ StaticR css_bootstrap_datepicker_standalone_min_css
- -- load these things early, in HEAD:
- toWidgetHead [hamlet|
- <script type="text/javascript" src="@{StaticR js_jquery_min_js}">
- <script type="text/javascript" src="@{StaticR js_typeahead_bundle_min_js}">
- |]
- addScript $ StaticR js_bootstrap_min_js
- -- addScript $ StaticR js_typeahead_bundle_min_js
- addScript $ StaticR js_bootstrap_datepicker_min_js
- addScript $ StaticR js_jquery_url_js
- addScript $ StaticR js_jquery_cookie_js
- addScript $ StaticR js_jquery_hotkeys_js
- addScript $ StaticR js_jquery_flot_min_js
- addScript $ StaticR js_jquery_flot_time_min_js
- addScript $ StaticR js_jquery_flot_tooltip_min_js
- toWidget [hamlet| \<!--[if lte IE 8]> <script type="text/javascript" src="@{StaticR js_excanvas_min_js}"></script> <![endif]--> |]
- addStylesheet $ StaticR hledger_css
- addScript $ StaticR hledger_js
- $(widgetFile "default-layout")
-
- staticRootUrl <- (staticRoot . settings) <$> getYesod
- withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-
- -- TODO outdated, still needed ?
- -- This is done to provide an optimization for serving static files from
- -- a separate domain. Please see the staticRoot setting in Settings.hs
- -- urlRenderOverride y (StaticR s) =
- -- Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
- urlParamRenderOverride _ _ _ = Nothing
-
-#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 = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
-#endif
-
- -- Place Javascript at bottom of the body tag so the rest of the page loads first
- jsLoader _ = BottomOfBody
-
--- This instance is required to use forms. You can modify renderMessage to
--- achieve customized and internationalized form validation messages.
-instance RenderMessage App FormMessage where
- renderMessage _ _ = defaultFormMessage
-
--- | Get the 'Extra' value, used to hold data from the settings.yml file.
-getExtra :: Handler Extra
-getExtra = fmap (appExtra . settings) getYesod
-
--- Note: previous versions of the scaffolding included a deliver function to
--- send emails. Unfortunately, there are too many different options for us to
--- give a reasonable default. Instead, the information is available on the
--- wiki:
---
--- https://github.com/yesodweb/yesod/wiki/Sending-email
-
-
-----------------------------------------------------------------------
--- template and handler utilities
-
--- view data, used by the add form and handlers
-
--- | A bundle of data useful for hledger-web request handlers and templates.
-data ViewData = VD {
- opts :: WebOpts -- ^ the command-line options at startup
- ,here :: AppRoute -- ^ the current route
- ,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request
- ,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 :: Query -- ^ a query parsed from the q parameter
- ,qopts :: [QueryOpt] -- ^ query options parsed from the q 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
- ,showsidebar :: Bool -- ^ current showsidebar cookie value
- } deriving (Show)
-
-instance Show Text.Blaze.Markup where show _ = "<blaze markup>"
-
--- | Make a default ViewData, using day 0 as today's date.
-nullviewdata :: ViewData
-nullviewdata = viewdataWithDateAndParams nulldate "" "" ""
-
--- | Make a ViewData using the given date and request parameters, and defaults elsewhere.
-viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData
-viewdataWithDateAndParams d q a p =
- let (querymatcher,queryopts) = parseQuery d (pack q)
- (acctsmatcher,acctsopts) = parseQuery d (pack a)
- in VD {
- opts = defwebopts
- ,j = nulljournal
- ,here = RootR
- ,msg = Nothing
- ,today = d
- ,q = q
- ,m = querymatcher
- ,qopts = queryopts
- ,am = acctsmatcher
- ,aopts = acctsopts
- ,showpostings = p == "1"
- ,showsidebar = True
- }
-
--- | Gather data used by handlers and templates in the current request.
-getViewData :: Handler ViewData
-getViewData = do
- mhere <- getCurrentRoute
- case mhere of
- Nothing -> return nullviewdata
- Just here -> do
- app <- getYesod
- let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app
- today <- liftIO getCurrentDay
- (j, merr) <- getCurrentJournal app copts{reportopts_=ropts{no_elide_=True}} today
- lastmsg <- getLastMessage
- let msg = maybe lastmsg (Just . toHtml) merr
- q <- getParameterOrNull "q"
- a <- getParameterOrNull "a"
- p <- getParameterOrNull "p"
- -- sidebar visibility: show it, unless there is a showsidebar cookie
- -- set to "0", or a ?sidebar=0 query parameter.
- msidebarparam <- lookupGetParam "sidebar"
- msidebarcookie <- reqCookies <$> getRequest >>= return . lookup "showsidebar"
- let showsidebar = maybe (msidebarcookie /= Just "0") (/="0") msidebarparam
-
- return (viewdataWithDateAndParams today q a p){
- opts=opts
- ,msg=msg
- ,here=here
- ,today=today
- ,j=j
- ,showsidebar=showsidebar
- }
- where
- -- | Update our copy of the journal if the file changed. If there is an
- -- error while reloading, keep the old one and return the error, and set a
- -- ui message.
- getCurrentJournal :: App -> CliOpts -> Day -> Handler (Journal, Maybe String)
- getCurrentJournal app opts d = do
- -- XXX put this inside atomicModifyIORef' for thread safety
- j <- liftIO $ readIORef $ appJournal app
- (ej, changed) <- liftIO $ journalReloadIfChanged opts d j
- -- re-apply any initial filter specified at startup
- let initq = queryFromOpts d $ reportopts_ opts
- ej' = filterJournalTransactions initq <$> ej
- if not changed
- then return (j,Nothing)
- else case ej' of
- Right j' -> do liftIO $ writeIORef (appJournal app) j'
- return (j',Nothing)
- Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-}
- return (j, Just e)
-
- -- | Get the named request parameter, or the empty string if not present.
- getParameterOrNull :: String -> Handler String
- getParameterOrNull p = unpack `fmap` fromMaybe "" <$> lookupGetParam (pack p)
-
--- | Get the message that was set by the last request, in a
--- referentially transparent manner (allowing multiple reads).
-getLastMessage :: Handler (Maybe Html)
-getLastMessage = cached getMessage
-
--- add form dialog, part of the default template
-
--- | Add transaction form.
-addform :: Text -> ViewData -> HtmlUrl AppRoute
-addform _ vd@VD{..} = [hamlet|
-
-<script>
- jQuery(document).ready(function() {
-
- /* set up typeahead fields */
-
- descriptionsSuggester = new Bloodhound({
- local:#{listToJsonValueObjArrayStr descriptions},
- limit:100,
- datumTokenizer: function(d) { return [d.value]; },
- queryTokenizer: function(q) { return [q]; }
- });
- descriptionsSuggester.initialize();
-
- accountsSuggester = new Bloodhound({
- local:#{listToJsonValueObjArrayStr accts},
- limit:100,
- datumTokenizer: function(d) { return [d.value]; },
- queryTokenizer: function(q) { return [q]; }
- /*
- datumTokenizer: Bloodhound.tokenizers.obj.whitespace('value'),
- datumTokenizer: Bloodhound.tokenizers.whitespace(d.value)
- queryTokenizer: Bloodhound.tokenizers.whitespace
- */
- });
- accountsSuggester.initialize();
-
- enableTypeahead(jQuery('input#description'), descriptionsSuggester);
- enableTypeahead(jQuery('input#account1, input#account2, input#account3, input#account4'), accountsSuggester);
-
- });
-
-<form#addform method=POST .form>
- <div .form-group>
- <div .row>
- <div .col-md-3 .col-xs-6 .col-sm-6>
- <div #dateWrap .input-group .date>
- <input #date required lang=en name=date .form-control .input-lg placeholder="Date" >
- <div .input-group-addon>
- <span .glyphicon .glyphicon-th>
- <div .col-md-9 .col-xs-6 .col-sm-6>
- <input #description required .typeahead .form-control .input-lg type=text size=40 name=description placeholder="Description">
- <div .account-postings>
- $forall n <- postingnums
- ^{postingfields vd n}
- <div .col-md-8 .col-xs-8 .col-sm-8>
- <div .col-md-4 .col-xs-4 .col-sm-4>
- <button type=submit .btn .btn-default .btn-lg name=submit>add
- $if length filepaths > 1
- <br>
- <span class="input-lg">to:
- ^{journalselect filepaths}
- <span style="padding-left:2em;">
- <span .small>
- Enter a value in the last field for
- <a href="#" onclick="addformAddPosting(); return false;">more
- (or ctrl +, ctrl -)
-|]
- where
- descriptions = sort $ nub $ map tdescription $ jtxns j
- accts = journalAccountNamesDeclaredOrImplied j
- escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>" -- #236
- listToJsonValueObjArrayStr as = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as
- numpostings = 4
- postingnums = [1..numpostings]
- filepaths = map fst $ jfiles j
- postingfields :: ViewData -> Int -> HtmlUrl AppRoute
- postingfields _ n = [hamlet|
-<div .form-group .row .account-group ##{grpvar}>
- <div .col-md-8 .col-xs-8 .col-sm-8>
- <input ##{acctvar} .account-input .typeahead .form-control .input-lg type=text name=#{acctvar} placeholder="#{acctph}">
- <div .col-md-4 .col-xs-4 .col-sm-4>
- <input ##{amtvar} .amount-input .form-control .input-lg type=text name=#{amtvar} placeholder="#{amtph}">
-|]
- where
- acctvar = "account" ++ show n
- acctph = "Account " ++ show n
- amtvar = "amount" ++ show n
- amtph = "Amount " ++ show n
- grpvar = "grp" ++ show n
-
-journalselect :: [FilePath] -> HtmlUrl AppRoute
-journalselect journalfilepaths = [hamlet|
-<select id=journalselect name=journal onchange="/*journalSelect(event)*/" class="form-control input-lg" style="width:auto; display:inline-block;">
- $forall p <- journalfilepaths
- <option value=#{p}>#{p}
-|]
-
-journalradio :: [FilePath] -> HtmlUrl AppRoute
-journalradio journalfilepaths = [hamlet|
- $forall p <- journalfilepaths
- <div style="white-space:nowrap;">
- <span class="input-lg" style="position:relative; top:-8px; left:8px;">#{p}
- <input name=journal type=radio value=#{p} class="form-control" style="width:auto; display:inline;">
-|]
-
diff --git a/Handler/AddForm.hs b/Handler/AddForm.hs
deleted file mode 100644
index 4944f52..0000000
--- a/Handler/AddForm.hs
+++ /dev/null
@@ -1,124 +0,0 @@
-{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, TypeFamilies #-}
--- | Add form data & handler. (The layout and js are defined in
--- Foundation so that the add form can be in the default layout for
--- all views.)
-
-module Handler.AddForm where
-
-import Import
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Monad.State.Strict (evalStateT)
-import Data.Either (lefts,rights)
-import Data.List (sort)
-import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
-import Data.Text (append, pack, unpack)
-import qualified Data.Text as T
-import Data.Time.Calendar
-import Text.Megaparsec.Compat (digitChar, eof, some, string, runParser, ParseError, MPErr)
-
-import Hledger.Utils
-import Hledger.Data
-import Hledger.Read
-import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout)
-
-
--- Part of the data required from the add form.
--- Don't know how to handle the variable posting fields with yesod-form yet.
-data AddForm = AddForm
- { addFormDate :: Day
- , addFormDescription :: Maybe Text -- String
- -- , addFormPostings :: [(AccountName, String)]
- , addFormJournalFile :: Maybe Text -- FilePath
- }
- deriving Show
-
-postAddForm :: Handler Html
-postAddForm = do
- let showErrors errs = do
- -- error $ show errs -- XXX uncomment to prevent redirect for debugging
- setMessage [shamlet|
- Errors:<br>
- $forall e<-errs
- \#{e}<br>
- |]
- -- 1. process the fixed fields with yesod-form
-
- VD{..} <- getViewData
- let
- validateJournalFile :: Text -> Either FormMessage Text
- validateJournalFile f
- | unpack f `elem` journalFilePaths j = Right f
- | otherwise = Left $ MsgInvalidEntry $ pack "the selected journal file \"" `append` f `append` "\"is unknown"
-
- validateDate :: Text -> Handler (Either FormMessage Day)
- validateDate s = return $
- case fixSmartDateStrEither' today $ T.pack $ strip $ unpack s of
- Right d -> Right d
- Left _ -> Left $ MsgInvalidEntry $ pack "could not parse date \"" `append` s `append` pack "\":" -- ++ show e)
-
- formresult <- runInputPostResult $ AddForm
- <$> ireq (checkMMap validateDate (pack . show) textField) "date"
- <*> iopt textField "description"
- <*> iopt (check validateJournalFile textField) "journal"
-
- ok <- case formresult of
- FormMissing -> showErrors ["there is no form data"::String] >> return False
- FormFailure errs -> showErrors errs >> return False
- FormSuccess dat -> do
- let AddForm{
- addFormDate =date
- ,addFormDescription=mdesc
- ,addFormJournalFile=mjournalfile
- } = dat
- desc = maybe "" unpack mdesc
- journalfile = maybe (journalFilePath j) unpack mjournalfile
-
- -- 2. the fixed fields look good; now process the posting fields adhocly,
- -- getting either errors or a balanced transaction
-
- (params,_) <- runRequestBody
- let numberedParams s =
- reverse $ dropWhile (T.null . snd) $ reverse $ sort
- [ (n,v) | (k,v) <- params
- , let en = parsewith (paramnamep s) k :: Either (ParseError Char MPErr) Int
- , isRight en
- , let Right n = en
- ]
- where paramnamep s = do {string s; n <- some digitChar; eof; return (read n :: Int)}
- acctparams = numberedParams "account"
- amtparams = numberedParams "amount"
- num = length acctparams
- paramErrs | num == 0 = ["at least one posting must be entered"]
- | map fst acctparams == [1..num] &&
- map fst amtparams `elem` [[1..num], [1..num-1]] = []
- | otherwise = ["the posting parameters are malformed"]
- eaccts = map (runParser (accountnamep <* eof) "" . textstrip . snd) acctparams
- eamts = map (runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd) amtparams
- (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
- (amts', amtErrs) = (rights eamts, map show $ lefts eamts)
- amts | length amts' == num = amts'
- | otherwise = amts' ++ [missingamt]
- errs = if not (null paramErrs) then paramErrs else (acctErrs ++ amtErrs)
- etxn | not $ null errs = Left errs
- | otherwise = either (\e -> Left [L.head $ lines e]) Right
- (balanceTransaction Nothing $ nulltransaction {
- tdate=date
- ,tdescription=T.pack desc
- ,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts]
- })
- case etxn of
- Left errs -> showErrors errs >> return False
- Right t -> do
- -- 3. all fields look good and form a balanced transaction; append it to the file
- liftIO $ do ensureJournalFileExists journalfile
- appendToJournalFileOrStdout journalfile $
- showTransaction $
- txnTieKnot -- XXX move into balanceTransaction
- t
- setMessage [shamlet|<span>Transaction added.|]
- return True
-
- if ok then redirect JournalR else redirect (JournalR, [("add","1")])
diff --git a/Handler/Common.hs b/Handler/Common.hs
deleted file mode 100644
index 3ebd626..0000000
--- a/Handler/Common.hs
+++ /dev/null
@@ -1,251 +0,0 @@
-{-# LANGUAGE CPP, OverloadedStrings, QuasiQuotes, RecordWildCards #-}
--- | Common page components and rendering helpers.
--- For global page layout, see Application.hs.
-
-module Handler.Common where
-
-import Import
-
--- import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Calendar
-import System.FilePath (takeFileName)
-#if BLAZE_HTML_0_4
-import Text.Blaze (preEscapedString)
-#else
-import Text.Blaze.Internal (preEscapedString)
-#endif
-import Text.Printf
-
-import Hledger.Utils
-import Hledger.Data
-import Hledger.Query
-import Hledger.Reports
-import Hledger.Cli.CliOptions
-import Hledger.Web.WebOptions
-
--------------------------------------------------------------------------------
--- Common page layout
-
--- | Standard hledger-web page layout.
-#if MIN_VERSION_yesod(1,6,0)
-hledgerLayout :: ViewData -> String -> HtmlUrl AppRoute -> HandlerFor App Html
-#else
-hledgerLayout :: ViewData -> String -> HtmlUrl AppRoute -> HandlerT App IO Html
-#endif
-hledgerLayout vd title content = do
- defaultLayout $ do
- setTitle $ toHtml $ title ++ " - hledger-web"
- toWidget [hamlet|
- ^{topbar vd}
- ^{sidebar vd}
- <div #main-content .col-xs-12 .#{showmd} .#{showsm}>
- ^{searchform vd}
- ^{content}
- |]
- where
- showmd = if showsidebar vd then "col-md-8" else "col-md-12" :: String
- showsm = if showsidebar vd then "col-sm-8" else "col-sm-12" :: String
-
--- | Global toolbar/heading area.
-topbar :: ViewData -> HtmlUrl AppRoute
-topbar VD{..} = [hamlet|
-<div#spacer .#{showsm} .#{showmd} .col-xs-2>
- <h1>
- <button .visible-xs .btn .btn-default type="button" data-toggle="offcanvas">
- <span .glyphicon .glyphicon-align-left .tgl-icon>
-<div#topbar .col-md-8 .col-sm-8 .col-xs-10>
- <h1>#{title}
-
-|]
- where
- title = takeFileName $ journalFilePath j
- showmd = if showsidebar then "col-md-4" else "col-any-0" :: String
- showsm = if showsidebar then "col-sm-4" else "" :: String
-
--- | The sidebar used on most views.
-sidebar :: ViewData -> HtmlUrl AppRoute
-sidebar vd@VD{..} =
- [hamlet|
- <div #sidebar-menu .#{showmd} .#{showsm} .sidebar-offcanvas>
- <table .main-menu .table>
- <tr .#{journalcurrent}>
- <td .top .acct>
- <a href=@{JournalR} .#{journalcurrent} title="Show general journal entries, most recent first">Journal
- <td .top>
- ^{accounts}
-|]
- where
- journalcurrent = if here == JournalR then "inacct" else "" :: String
- ropts = reportopts_ $ cliopts_ opts
- -- flip the default for items with zero amounts, show them by default
- ropts' = ropts{empty_=not $ empty_ ropts}
- accounts = balanceReportAsHtml opts vd $ balanceReport ropts' am j
- showmd = if showsidebar then "col-md-4" else "col-any-0" :: String
- showsm = if showsidebar then "col-sm-4" else "" :: String
-
--- -- | 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
--- |]
-
--- | Search form for entering custom queries to filter journal data.
-searchform :: ViewData -> HtmlUrl AppRoute
-searchform VD{..} = [hamlet|
-<div#searchformdiv .row>
- <form#searchform .form-inline method=GET>
- <div .form-group .col-md-12 .col-sm-12 .col-xs-12>
- <div #searchbar .input-group>
- <input .form-control name=q value=#{q} title="Enter hledger search patterns to filter the data below" placeholder="Search">
- <div .input-group-btn>
- $if filtering
- <a href=@{here} .btn .btn-default title="Clear search terms">
- <span .glyphicon .glyphicon-remove-circle>
- <button .btn .btn-default type=submit title="Apply search terms">
- <span .glyphicon .glyphicon-search>
- <button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal" title="Show search and general help">?
-|]
- where
- filtering = not $ null q
-
--- -- | Edit journal form.
--- editform :: ViewData -> HtmlUrl AppRoute
--- editform VD{..} = [hamlet|
--- <form#editform method=POST style=display:none;>
--- <h2#contenttitle>#{title}>
--- <table.form>
--- $if manyfiles
--- <tr>
--- <td colspan=2>
--- Editing ^{journalselect $ files j}
--- <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>
--- \#{snd f}
--- <tr#addbuttonrow>
--- <td>
--- <span.help>^{formathelp}
--- <td>
--- <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">
--- \ or #
--- <a href="#" onclick="return editformToggle(event)">cancel
--- |]
--- where
--- title = "Edit journal" :: String
--- manyfiles = length (files j) > 1
--- formathelp = helplink "file-format" "file format help"
-
--- -- | 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">
--- \ or #
--- <a href="#" onclick="return importformToggle(event)">cancel
--- |]
-
--- | Link to a topic in the manual.
-helplink :: String -> String -> HtmlUrl AppRoute
-helplink topic label = [hamlet|
-<a href=#{u} target=hledgerhelp>#{label}
-|]
- where u = manualurl ++ if null topic then "" else '#':topic
-
-nulltemplate :: HtmlUrl AppRoute
-nulltemplate = [hamlet||]
-
-
-----------------------------------------------------------------------
--- hledger report renderers
-
--- | Render a "BalanceReport" as html.
-balanceReportAsHtml :: WebOpts -> ViewData -> BalanceReport -> HtmlUrl AppRoute
-balanceReportAsHtml _ vd@VD{..} (items',total) =
- [hamlet|
- $forall i <- items
- ^{itemAsHtml vd i}
- <tr .total>
- <td>
- <td>
- #{mixedAmountAsHtml total}
-|]
- where
- l = ledgerFromJournal Any j
- inacctmatcher = inAccountQuery qopts
- items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher
- itemAsHtml :: ViewData -> BalanceReportItem -> HtmlUrl AppRoute
- itemAsHtml _ (acct, adisplay, aindent, abal) = [hamlet|
-<tr .#{inacctclass}>
- <td .acct>
- <div .ff-wrapper>
- \#{indent}
- <a href="@?{acctquery}" .#{inacctclass} title="Show transactions affecting this account and subaccounts">#{adisplay}
- $if hassubs
- <a href="@?{acctonlyquery}" .only .hidden-sm .hidden-xs title="Show transactions affecting this account but not subaccounts">only
- <td>
- #{mixedAmountAsHtml abal}
-|]
- where
- hassubs = not $ maybe False (null.asubs) $ ledgerAccount l acct
- inacctclass = case inacctmatcher of
- Just m' -> if m' `matchesAccount` acct then "inacct" else ""
- Nothing -> "" :: String
- indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) "&nbsp;"
- acctquery = (RegisterR, [("q", T.pack $ accountQuery acct)])
- acctonlyquery = (RegisterR, [("q", T.pack $ accountOnlyQuery acct)])
-
-accountQuery :: AccountName -> String
-accountQuery a = "inacct:" ++ T.unpack (quoteIfSpaced a) -- (accountNameToAccountRegex a)
-
-accountOnlyQuery :: AccountName -> String
-accountOnlyQuery a = "inacctonly:" ++ T.unpack (quoteIfSpaced a ) -- (accountNameToAccountRegex a)
-
-accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
-accountUrl r a = (r, [("q", T.pack $ accountQuery a)])
-
--- stringIfLongerThan :: Int -> String -> String
--- stringIfLongerThan n s = if length s > n then s else ""
-
-numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]
-numberTransactionsReportItems [] = []
-numberTransactionsReportItems items = number 0 nulldate items
- where
- number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]
- number _ _ [] = []
- number n prevd (i@(Transaction{tdate=d},_,_,_,_,_):rest) = (n+1,newday,newmonth,newyear,i): number (n+1) d rest
- where
- newday = d/=prevd
- newmonth = dm/=prevdm || dy/=prevdy
- newyear = dy/=prevdy
- (dy,dm,_) = toGregorian d
- (prevdy,prevdm,_) = toGregorian prevd
-
-mixedAmountAsHtml :: MixedAmount -> Html
-mixedAmountAsHtml b = preEscapedString $ unlines $ map addclass $ lines $ showMixedAmountWithoutPrice b
- where addclass = printf "<span class=\"%s\">%s</span><br/>" (c :: String)
- c = case isNegativeMixedAmount b of Just True -> "negative amount"
- _ -> "positive amount"
-
diff --git a/Handler/JournalR.hs b/Handler/JournalR.hs
deleted file mode 100644
index 572af85..0000000
--- a/Handler/JournalR.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes, RecordWildCards #-}
--- | /journal handlers.
-
-module Handler.JournalR where
-
--- import Data.Text (Text)
-import qualified Data.Text as T
-import Import
-
-import Handler.AddForm
-import Handler.Common
-
-import Hledger.Data
-import Hledger.Query
-import Hledger.Reports
-import Hledger.Utils
-import Hledger.Cli.CliOptions
-import Hledger.Web.WebOptions
-
--- | The formatted journal view, with sidebar.
-getJournalR :: Handler Html
-getJournalR = do
- vd@VD{..} <- getViewData
- let -- XXX like registerReportAsHtml
- inacct = inAccount qopts
- -- injournal = isNothing inacct
- filtering = m /= Any
- -- showlastcolumn = if injournal && not filtering then False else True
- title = case inacct of
- Nothing -> "General Journal"++s2
- Just (a,inclsubs) -> "Transactions in "++T.unpack a++s1++s2
- where s1 = if inclsubs then "" else " (excluding subaccounts)"
- where
- s2 = if filtering then ", filtered" else ""
- maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
- hledgerLayout vd "journal" [hamlet|
- <div .row>
- <h2 #contenttitle>#{title}
- <!-- p>Journal entries record movements of commodities between accounts. -->
- <a #addformlink role="button" style="cursor:pointer; margin-top:1em;" data-toggle="modal" data-target="#addmodal" title="Add a new transaction to the journal" href="#">Add a transaction
- <div .table-responsive>
- ^{maincontent}
- |]
-
-postJournalR :: Handler Html
-postJournalR = postAddForm
-
--- | Render a "TransactionsReport" as html for the formatted journal view.
-journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
-journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|
-<table .transactionsreport .table .table-condensed>
- <thead>
- <th .date style="text-align:left;">
- Date
- <th .description style="text-align:left;">Description
- <th .account style="text-align:left;">Account
- <th .amount style="text-align:right;">Amount
- $forall i <- numberTransactionsReportItems items
- ^{itemAsHtml vd i}
- |]
- where
--- .#{datetransition}
- itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute
- itemAsHtml VD{..} (_, _, _, _, (torig, _, split, _, amt, _)) = [hamlet|
-<tr .title #transaction-#{tindex torig}>
- <td .date nowrap>#{date}
- <td .description colspan=2>#{textElideRight 60 desc}
- <td .amount style="text-align:right;">
- $if showamt
- \#{mixedAmountAsHtml amt}
-$forall p' <- tpostings torig
- <tr .item .posting title="#{show torig}">
- <td .nonhead>
- <td .nonhead>
- <td .nonhead>
- &nbsp;
- <a href="@?{acctlink (paccount p')}##{tindex torig}" title="#{paccount p'}">#{elideAccountName 40 $ paccount p'}
- <td .amount .nonhead style="text-align:right;">#{mixedAmountAsHtml $ pamount p'}
-|]
- where
- acctlink a = (RegisterR, [("q", T.pack $ accountQuery a)])
- -- datetransition | newm = "newmonth"
- -- | newd = "newday"
- -- | otherwise = "" :: String
- (date, desc) = (show $ tdate torig, tdescription torig)
- -- acctquery = (here, [("q", T.pack $ accountQuery acct)])
- showamt = not split || not (isZeroMixedAmount amt)
-
diff --git a/Handler/RegisterR.hs b/Handler/RegisterR.hs
deleted file mode 100644
index 3ae2079..0000000
--- a/Handler/RegisterR.hs
+++ /dev/null
@@ -1,181 +0,0 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes, RecordWildCards #-}
--- | /register handlers.
-
-module Handler.RegisterR where
-
-import Import
-
-import Data.List
-import Data.Maybe
--- import Data.Text (Text)
-import qualified Data.Text as T
-import Safe
-
-import Handler.AddForm
-import Handler.Common
-import Handler.Utils
-
-import Hledger.Data
-import Hledger.Query
-import Hledger.Reports
-import Hledger.Utils
-import Hledger.Cli.CliOptions
-import Hledger.Web.WebOptions
-
--- | The main journal/account register view, with accounts sidebar.
-getRegisterR :: Handler Html
-getRegisterR = do
- vd@VD{..} <- getViewData
- -- staticRootUrl <- (staticRoot . settings) <$> getYesod
- let -- injournal = isNothing inacct
- filtering = m /= Any
- -- title = "Transactions in "++a++s1++s2
- title = T.unpack a++s1++s2
- where
- (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
- s1 = if inclsubs then "" else " (excluding subaccounts)"
- s2 = if filtering then ", filtered" else ""
- maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts
- hledgerLayout vd "register" [hamlet|
- <h2 #contenttitle>#{title}
- <!-- p>Transactions affecting this account, with running balance. -->
- ^{maincontent}
- |]
-
-postRegisterR :: Handler Html
-postRegisterR = postAddForm
-
--- Generate html for an account register, including a balance chart and transaction list.
-registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
-registerReportHtml opts vd r = [hamlet|
- <div .hidden-xs>
- ^{registerChartHtml $ transactionsReportByCommodity r}
- ^{registerItemsHtml opts vd r}
-|]
-
--- Generate html for a transaction list from an "TransactionsReport".
-registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
-registerItemsHtml _ vd (balancelabel,items) = [hamlet|
-<div .table-responsive>
- <table.registerreport .table .table-striped .table-condensed>
- <thead>
- <tr>
- <th style="text-align:left;">
- Date
- <span .glyphicon .glyphicon-chevron-up>
- <th style="text-align:left;">Description
- <th style="text-align:left;">To/From Account(s)
- <th style="text-align:right; white-space:normal;">Amount Out/In
- <th style="text-align:right; white-space:normal;">#{balancelabel'}
- $forall i <- numberTransactionsReportItems items
- ^{itemAsHtml vd i}
- |]
- where
- insomeacct = isJust $ inAccount $ qopts vd
- balancelabel' = if insomeacct then balancelabel else "Total"
-
- -- filtering = m /= Any
- itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute
- itemAsHtml VD{..} (n, newd, newm, _, (torig, tacct, split, acct, amt, bal)) = [hamlet|
-
-<tr ##{tindex torig} .item.#{evenodd}.#{firstposting}.#{datetransition} title="#{show torig}" style="vertical-align:top;">
- <td .date>
- <a href="@{JournalR}#transaction-#{tindex torig}">#{date}
- <td .description title="#{show torig}">#{textElideRight 30 desc}
- <td .account>#{elideRight 40 acct}
- <td .amount style="text-align:right; white-space:nowrap;">
- $if showamt
- \#{mixedAmountAsHtml amt}
- <td .balance style="text-align:right;">#{mixedAmountAsHtml bal}
-|]
-
- where
- evenodd = if even n then "even" else "odd" :: String
- datetransition | newm = "newmonth"
- | newd = "newday"
- | otherwise = "" :: String
- (firstposting, date, desc) = (False, show $ tdate tacct, tdescription tacct)
- -- acctquery = (here, [("q", pack $ accountQuery acct)])
- showamt = not split || not (isZeroMixedAmount amt)
-
--- | 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 :: [(CommoditySymbol, (String, [TransactionsReportItem]))] -> HtmlUrl AppRoute
-registerChartHtml percommoditytxnreports =
- -- have to make sure plot is not called when our container (maincontent)
- -- is hidden, eg with add form toggled
- [hamlet|
-<label #register-chart-label style=""><br>
-<div #register-chart style="height:150px; margin-bottom:1em; display:block;">
-<script type=text/javascript>
- \$(document).ready(function() {
- var $chartdiv = $('#register-chart');
- if ($chartdiv.is(':visible')) {
- \$('#register-chart-label').text('#{charttitle}');
- var seriesData = [
- $forall (c,(_,items)) <- percommoditytxnreports
- /* we render each commodity using two series:
- * one with extra data points added to show a stepped balance line */
- {
- data: [
- $forall i <- reverse items
- [
- #{dayToJsTimestamp $ triDate i},
- #{simpleMixedAmountQuantity $ triCommodityBalance c i}
- ],
- /* [] */
- ],
- label: '#{shownull $ T.unpack c}',
- color: #{colorForCommodity c},
- lines: {
- show: true,
- steps: true,
- },
- points: {
- show: false,
- },
- clickable: false,
- hoverable: false,
- },
- /* and one with the original data, showing one clickable, hoverable point per transaction */
- {
- data: [
- $forall i <- reverse items
- [
- #{dayToJsTimestamp $ triDate i},
- #{simpleMixedAmountQuantity $ triCommodityBalance c i},
- '#{showMixedAmountWithZeroCommodity $ triCommodityAmount c i}',
- '#{showMixedAmountWithZeroCommodity $ triCommodityBalance c i}',
- '#{concat $ intersperse "\\n" $ lines $ show $ triOrigTransaction i}',
- #{tindex $ triOrigTransaction i}
- ],
- /* [] */
- ],
- label: '',
- color: #{colorForCommodity c},
- lines: {
- show: false,
- },
- points: {
- show: true,
- },
- },
- ]
- var plot = registerChart($chartdiv, seriesData);
- \$chartdiv.bind("plotclick", registerChartClick);
- };
- });
-|]
- -- [#{dayToJsTimestamp $ ltrace "\ndate" $ triDate i}, #{ltrace "balancequantity" $ simpleMixedAmountQuantity $ triCommodityBalance c i}, '#{ltrace "balance" $ show $ triCommodityBalance c i}, '#{ltrace "amount" $ show $ triCommodityAmount c i}''],
- where
- charttitle = case maybe "" (fst.snd) $ headMay percommoditytxnreports
- of "" -> ""
- s -> s++":"
- colorForCommodity = fromMaybe 0 . flip lookup commoditiesIndex
- commoditiesIndex = zip (map fst percommoditytxnreports) [0..] :: [(CommoditySymbol,Int)]
- simpleMixedAmountQuantity = maybe 0 aquantity . headMay . amounts
- shownull c = if null c then " " else c
diff --git a/Handler/RootR.hs b/Handler/RootR.hs
deleted file mode 100644
index 4c98c94..0000000
--- a/Handler/RootR.hs
+++ /dev/null
@@ -1,8 +0,0 @@
--- | Site root and misc. handlers.
-
-module Handler.RootR where
-
-import Import
-
-getRootR :: Handler Html
-getRootR = redirect defaultroute where defaultroute = JournalR
diff --git a/Handler/SidebarR.hs b/Handler/SidebarR.hs
deleted file mode 100644
index 1791d9b..0000000
--- a/Handler/SidebarR.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes, RecordWildCards #-}
--- | /sidebar
-
-module Handler.SidebarR where
-
-import Import
-
-import Handler.Common
-
--- | Render just the accounts sidebar, useful when opening the sidebar.
-getSidebarR :: Handler Html
-getSidebarR = do
- vd <- getViewData
- withUrlRenderer [hamlet|^{sidebar vd}|]
-
diff --git a/Handler/Utils.hs b/Handler/Utils.hs
deleted file mode 100644
index 8bf1d66..0000000
--- a/Handler/Utils.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE CPP #-}
--- | Web handler utilities. More of these are in Foundation.hs, where
--- they can be used in the default template.
-
-module Handler.Utils where
-
-import Prelude
-import Data.Time.Calendar
-import Data.Time.Clock
-import Data.Time.Format
-#if !(MIN_VERSION_time(1,5,0))
-import System.Locale (defaultTimeLocale)
-#endif
-
-numbered :: [a] -> [(Int,a)]
-numbered = zip [1..]
-
-dayToJsTimestamp :: Day -> Integer
-dayToJsTimestamp d = read (formatTime defaultTimeLocale "%s" t) * 1000 -- XXX read
- where t = UTCTime d (secondsToDiffTime 0)
diff --git a/Hledger/Web.hs b/Hledger/Web.hs
index 7832298..c6e211f 100644
--- a/Hledger/Web.hs
+++ b/Hledger/Web.hs
@@ -2,12 +2,12 @@
Re-export the modules of the hledger-web program.
-}
-module Hledger.Web (
- module Hledger.Web.WebOptions,
- module Hledger.Web.Main,
- tests_Hledger_Web
- )
-where
+module Hledger.Web
+ ( module Hledger.Web.WebOptions
+ , module Hledger.Web.Main
+ , tests_Hledger_Web
+ ) where
+
import Test.HUnit
import Hledger.Web.WebOptions
diff --git a/Hledger/Web/Application.hs b/Hledger/Web/Application.hs
new file mode 100644
index 0000000..f80b8e1
--- /dev/null
+++ b/Hledger/Web/Application.hs
@@ -0,0 +1,53 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Hledger.Web.Application
+ ( makeApplication
+ , makeFoundation
+ ) where
+
+import Data.IORef (newIORef, writeIORef)
+import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout)
+import Network.HTTP.Client (defaultManagerSettings)
+import Network.HTTP.Conduit (newManager)
+import Yesod.Default.Config
+
+import Hledger.Data (Journal, nulljournal)
+import Hledger.Web.Handler.AddR (getAddR, postAddR)
+import Hledger.Web.Handler.Common
+ (getDownloadR, getFaviconR, getManageR, getRobotsR, getRootR)
+import Hledger.Web.Handler.EditR (getEditR, postEditR)
+import Hledger.Web.Handler.UploadR (getUploadR, postUploadR)
+import Hledger.Web.Handler.JournalR (getJournalR)
+import Hledger.Web.Handler.RegisterR (getRegisterR)
+import Hledger.Web.Import
+import Hledger.Web.WebOptions (WebOpts(serve_))
+
+-- This line actually creates our YesodDispatch instance. It is the second half
+-- of the call to mkYesodData which occurs in Foundation.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.
+makeApplication :: WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application
+makeApplication opts' j' conf' = do
+ foundation <- makeFoundation conf' opts'
+ writeIORef (appJournal foundation) j'
+ logWare <$> toWaiApp foundation
+ where
+ logWare | development = logStdoutDev
+ | serve_ opts' = logStdout
+ | otherwise = id
+
+makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App
+makeFoundation conf opts' = do
+ manager <- newManager defaultManagerSettings
+ s <- staticSite
+ jref <- newIORef nulljournal
+ return $ App conf s manager opts' jref
diff --git a/Hledger/Web/Foundation.hs b/Hledger/Web/Foundation.hs
new file mode 100644
index 0000000..67dd03b
--- /dev/null
+++ b/Hledger/Web/Foundation.hs
@@ -0,0 +1,232 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | 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 where
+
+import Control.Monad (join)
+import qualified Data.ByteString.Char8 as BC
+import Data.Traversable (for)
+import Data.IORef (IORef, readIORef, writeIORef)
+import Data.Maybe (fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Calendar (Day)
+import Network.HTTP.Conduit (Manager)
+import Network.Wai (requestHeaders)
+import System.FilePath (takeFileName)
+import Text.Blaze (Markup)
+import Text.Hamlet (hamletFile)
+import Yesod
+import Yesod.Static
+import Yesod.Default.Config
+
+#ifndef DEVELOPMENT
+import Hledger.Web.Settings (staticDir)
+import Text.Jasmine (minifym)
+import Yesod.Default.Util (addStaticContentExternal)
+#endif
+
+import Hledger
+import Hledger.Cli (CliOpts(..), journalReloadIfChanged)
+import Hledger.Web.Settings (Extra(..), widgetFile)
+import Hledger.Web.Settings.StaticFiles
+import Hledger.Web.WebOptions
+import Hledger.Web.Widget.Common (balanceReportAsHtml)
+
+-- | 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.
+data App = App
+ { settings :: AppConfig DefaultEnv Extra
+ , getStatic :: Static -- ^ Settings for static file serving.
+ , httpManager :: Manager
+ --
+ , appOpts :: WebOpts
+ , appJournal :: IORef Journal
+ }
+
+
+-- This is where we define all of the routes in our application. For a full
+-- explanation of the syntax, please see:
+-- http://www.yesodweb.com/book/handler
+--
+-- 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.
+mkYesodData "App" $(parseRoutesFile "config/routes")
+
+-- | A convenience alias.
+type AppRoute = Route App
+
+#if MIN_VERSION_yesod(1,6,0)
+type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
+#else
+type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
+#endif
+
+-- 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 = ApprootMaster $ appRoot . settings
+
+ makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 ".hledger-web_client_session_key.aes"
+
+ defaultLayout widget = do
+ master <- getYesod
+ here <- fromMaybe RootR <$> getCurrentRoute
+ VD {caps, j, m, opts, q, qopts} <- getViewData
+ msg <- getMessage
+ showSidebar <- shouldShowSidebar
+ hideEmptyAccts <- (== Just "1") . lookup "hideemptyaccts" . reqCookies <$> getRequest
+
+ let ropts = reportopts_ (cliopts_ opts)
+ -- flip the default for items with zero amounts, show them by default
+ ropts' = ropts { empty_ = not (empty_ ropts) }
+ accounts =
+ balanceReportAsHtml (JournalR, RegisterR) here hideEmptyAccts j qopts $
+ balanceReport ropts' m j
+
+ topShowmd = if showSidebar then "col-md-4" else "col-any-0" :: Text
+ topShowsm = if showSidebar then "col-sm-4" else "" :: Text
+ sideShowmd = if showSidebar then "col-md-4" else "col-any-0" :: Text
+ sideShowsm = if showSidebar then "col-sm-4" else "" :: Text
+ mainShowmd = if showSidebar then "col-md-8" else "col-md-12" :: Text
+ mainShowsm = if showSidebar then "col-sm-8" else "col-sm-12" :: Text
+
+ -- 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
+ addStylesheet $ StaticR css_bootstrap_min_css
+ addStylesheet $ StaticR css_bootstrap_datepicker_standalone_min_css
+ -- load these things early, in HEAD:
+ toWidgetHead [hamlet|
+ <script type="text/javascript" src="@{StaticR js_jquery_min_js}">
+ <script type="text/javascript" src="@{StaticR js_typeahead_bundle_min_js}">
+ |]
+ addScript $ StaticR js_bootstrap_min_js
+ addScript $ StaticR js_bootstrap_datepicker_min_js
+ addScript $ StaticR js_jquery_url_js
+ addScript $ StaticR js_jquery_cookie_js
+ addScript $ StaticR js_jquery_hotkeys_js
+ addScript $ StaticR js_jquery_flot_min_js
+ addScript $ StaticR js_jquery_flot_time_min_js
+ addScript $ StaticR js_jquery_flot_tooltip_min_js
+ toWidget [hamlet| \<!--[if lte IE 8]> <script type="text/javascript" src="@{StaticR js_excanvas_min_js}"></script> <![endif]--> |]
+ addStylesheet $ StaticR hledger_css
+ addScript $ StaticR hledger_js
+ $(widgetFile "default-layout")
+
+ withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+#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 = addStaticContentExternal minifym base64md5 staticDir (StaticR . flip StaticRoute [])
+#endif
+
+-- This instance is required to use forms. You can modify renderMessage to
+-- achieve customized and internationalized form validation messages.
+instance RenderMessage App FormMessage where
+ renderMessage _ _ = defaultFormMessage
+
+
+----------------------------------------------------------------------
+-- template and handler utilities
+
+-- view data, used by the add form and handlers
+-- XXX Parameter p - show/hide postings
+
+-- | A bundle of data useful for hledger-web request handlers and templates.
+data ViewData = VD
+ { opts :: WebOpts -- ^ the command-line options at startup
+ , today :: Day -- ^ today's date (for queries containing relative dates)
+ , j :: Journal -- ^ the up-to-date parsed unfiltered journal
+ , q :: Text -- ^ the current q parameter, the main query expression
+ , m :: Query -- ^ a query parsed from the q parameter
+ , qopts :: [QueryOpt] -- ^ query options parsed from the q parameter
+ , caps :: [Capability] -- ^ capabilities enabled for this request
+ } deriving (Show)
+
+instance Show Text.Blaze.Markup where show _ = "<blaze markup>"
+
+-- | Gather data used by handlers and templates in the current request.
+getViewData :: Handler ViewData
+getViewData = do
+ App {appOpts = opts, appJournal} <- getYesod
+ today <- liftIO getCurrentDay
+ let copts = cliopts_ opts
+ (j, merr) <-
+ getCurrentJournal
+ appJournal
+ copts {reportopts_ = (reportopts_ copts) {no_elide_ = True}}
+ today
+ maybe (pure ()) (setMessage . toHtml) merr
+ q <- fromMaybe "" <$> lookupGetParam "q"
+ let (m, qopts) = parseQuery today q
+ caps <- case capabilitiesHeader_ opts of
+ Nothing -> return (capabilities_ opts)
+ Just h -> do
+ hs <- fmap (BC.split ',' . snd) . filter ((== h) . fst) . requestHeaders <$> waiRequest
+ fmap join . for (join hs) $ \x -> case capabilityFromBS x of
+ Left e -> [] <$ addMessage "" ("Unknown permission: " <> toHtml (BC.unpack e))
+ Right c -> pure [c]
+ return VD {opts, today, j, q, m, qopts, caps}
+
+-- | Find out if the sidebar should be visible. Show it, unless there is a
+-- showsidebar cookie set to "0", or a ?sidebar=0 query parameter.
+shouldShowSidebar :: Handler Bool
+shouldShowSidebar = do
+ msidebarparam <- lookupGetParam "sidebar"
+ msidebarcookie <- lookup "showsidebar" . reqCookies <$> getRequest
+ return $ maybe (msidebarcookie /= Just "0") (/="0") msidebarparam
+
+-- | Update our copy of the journal if the file changed. If there is an
+-- error while reloading, keep the old one and return the error, and set a
+-- ui message.
+getCurrentJournal :: IORef Journal -> CliOpts -> Day -> Handler (Journal, Maybe String)
+getCurrentJournal jref opts d = do
+ -- XXX put this inside atomicModifyIORef' for thread safety
+ j <- liftIO (readIORef jref)
+ (ej, changed) <- liftIO $ journalReloadIfChanged opts d j
+ -- re-apply any initial filter specified at startup
+ let initq = queryFromOpts d (reportopts_ opts)
+ case (changed, filterJournalTransactions initq <$> ej) of
+ (False, _) -> return (j, Nothing)
+ (True, Right j') -> do
+ liftIO $ writeIORef jref j'
+ return (j',Nothing)
+ (True, Left e) -> do
+ setMessage "error while reading journal"
+ return (j, Just e)
diff --git a/Hledger/Web/Handler/AddR.hs b/Hledger/Web/Handler/AddR.hs
new file mode 100644
index 0000000..2689540
--- /dev/null
+++ b/Hledger/Web/Handler/AddR.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Hledger.Web.Handler.AddR
+ ( getAddR
+ , postAddR
+ ) where
+
+import Hledger
+import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout)
+import Hledger.Web.Import
+import Hledger.Web.Widget.AddForm (addForm)
+import Hledger.Web.Widget.Common (fromFormSuccess)
+
+getAddR :: Handler ()
+getAddR = postAddR
+
+postAddR :: Handler ()
+postAddR = do
+ VD{caps, j, today} <- getViewData
+ when (CapAdd `notElem` caps) (permissionDenied "Missing the 'add' capability")
+
+ ((res, view), enctype) <- runFormPost $ addForm j today
+ t <- txnTieKnot <$> fromFormSuccess (showForm view enctype) res
+ -- XXX(?) move into balanceTransaction
+ liftIO $ ensureJournalFileExists (journalFilePath j)
+ liftIO $ appendToJournalFileOrStdout (journalFilePath j) (showTransaction t)
+ setMessage "Transaction added."
+ redirect JournalR
+ where
+ showForm view enctype =
+ sendResponse =<< defaultLayout [whamlet|
+ <h2>Add transaction
+ <div .row style="margin-top:1em">
+ <form#addform.form.col-xs-12.col-md-8 method=post enctype=#{enctype}>
+ ^{view}
+ |]
diff --git a/Hledger/Web/Handler/Common.hs b/Hledger/Web/Handler/Common.hs
new file mode 100644
index 0000000..c77edf3
--- /dev/null
+++ b/Hledger/Web/Handler/Common.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hledger.Web.Handler.Common
+ ( getDownloadR
+ , getFaviconR
+ , getManageR
+ , getRobotsR
+ , getRootR
+ ) where
+
+import qualified Data.Text as T
+import Yesod.Default.Handlers (getFaviconR, getRobotsR)
+
+import Hledger (jfiles)
+import Hledger.Web.Import
+import Hledger.Web.Widget.Common (journalFile404)
+
+getRootR :: Handler Html
+getRootR = redirect JournalR
+
+getManageR :: Handler Html
+getManageR = do
+ VD{caps, j} <- getViewData
+ when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability")
+ defaultLayout $ do
+ setTitle "Manage journal"
+ $(widgetFile "manage")
+
+getDownloadR :: FilePath -> Handler TypedContent
+getDownloadR f = do
+ VD{caps, j} <- getViewData
+ when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability")
+ (f', txt) <- journalFile404 f j
+ addHeader "Content-Disposition" ("attachment; filename=\"" <> T.pack f' <> "\"")
+ sendResponse ("text/plain" :: ByteString, toContent txt)
diff --git a/Hledger/Web/Handler/EditR.hs b/Hledger/Web/Handler/EditR.hs
new file mode 100644
index 0000000..8c9eed3
--- /dev/null
+++ b/Hledger/Web/Handler/EditR.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hledger.Web.Handler.EditR
+ ( getEditR
+ , postEditR
+ ) where
+
+import Hledger.Web.Import
+import Hledger.Web.Widget.Common
+ (fromFormSuccess, helplink, journalFile404, writeValidJournal)
+
+editForm :: FilePath -> Text -> Markup -> MForm Handler (FormResult Text, Widget)
+editForm f txt =
+ identifyForm "edit" $ \extra -> do
+ (tRes, tView) <- mreq textareaField fs (Just (Textarea txt))
+ pure (unTextarea <$> tRes, $(widgetFile "edit-form"))
+ where
+ fs = FieldSettings "text" mzero mzero mzero [("class", "form-control"), ("rows", "25")]
+
+getEditR :: FilePath -> Handler ()
+getEditR = postEditR
+
+postEditR :: FilePath -> Handler ()
+postEditR f = do
+ VD {caps, j} <- getViewData
+ when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability")
+
+ (f', txt) <- journalFile404 f j
+ ((res, view), enctype) <- runFormPost (editForm f' txt)
+ text <- fromFormSuccess (showForm view enctype) res
+ writeValidJournal f text >>= \case
+ Left e -> do
+ setMessage $ "Failed to load journal: " <> toHtml e
+ showForm view enctype
+ Right () -> do
+ setMessage $ "Saved journal " <> toHtml f <> "\n"
+ redirect JournalR
+ where
+ showForm view enctype =
+ sendResponse <=< defaultLayout $ do
+ setTitle "Edit journal"
+ [whamlet|<form method=post enctype=#{enctype}>^{view}|]
diff --git a/Hledger/Web/Handler/JournalR.hs b/Hledger/Web/Handler/JournalR.hs
new file mode 100644
index 0000000..fe78de0
--- /dev/null
+++ b/Hledger/Web/Handler/JournalR.hs
@@ -0,0 +1,31 @@
+-- | /journal handlers.
+
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hledger.Web.Handler.JournalR where
+
+import Hledger
+import Hledger.Cli.CliOptions
+import Hledger.Web.Import
+import Hledger.Web.WebOptions
+import Hledger.Web.Widget.AddForm (addModal)
+import Hledger.Web.Widget.Common (accountQuery, mixedAmountAsHtml)
+
+-- | The formatted journal view, with sidebar.
+getJournalR :: Handler Html
+getJournalR = do
+ VD{caps, j, m, opts, qopts, today} <- getViewData
+ when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability")
+ let title = case inAccount qopts of
+ Nothing -> "General Journal"
+ Just (a, inclsubs) -> "Transactions in " <> a <> if inclsubs then "" else " (excluding subaccounts)"
+ title' = title <> if m /= Any then ", filtered" else ""
+ acctlink a = (RegisterR, [("q", accountQuery a)])
+ (_, items) = journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
+
+ defaultLayout $ do
+ setTitle "journal - hledger-web"
+ $(widgetFile "journal")
diff --git a/Hledger/Web/Handler/RegisterR.hs b/Hledger/Web/Handler/RegisterR.hs
new file mode 100644
index 0000000..fafe091
--- /dev/null
+++ b/Hledger/Web/Handler/RegisterR.hs
@@ -0,0 +1,60 @@
+-- | /register handlers.
+
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hledger.Web.Handler.RegisterR where
+
+import Data.List (intersperse)
+import qualified Data.Text as T
+import Text.Hamlet (hamletFile)
+
+import Hledger
+import Hledger.Cli.CliOptions
+import Hledger.Web.Import
+import Hledger.Web.WebOptions
+import Hledger.Web.Widget.AddForm (addModal)
+import Hledger.Web.Widget.Common (mixedAmountAsHtml)
+
+-- | The main journal/account register view, with accounts sidebar.
+getRegisterR :: Handler Html
+getRegisterR = do
+ VD{caps, j, m, opts, qopts, today} <- getViewData
+ when (CapView `notElem` caps) (permissionDenied "Missing the 'view' capability")
+
+ let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
+ s1 = if inclsubs then "" else " (excluding subaccounts)"
+ s2 = if m /= Any then ", filtered" else ""
+ header = a <> s1 <> s2
+
+ let ropts = reportopts_ (cliopts_ opts)
+ acctQuery = fromMaybe Any (inAccountQuery qopts)
+ r@(balancelabel,items) = accountTransactionsReport ropts j m acctQuery
+ balancelabel' = if isJust (inAccount qopts) then balancelabel else "Total"
+ defaultLayout $ do
+ setTitle "register - hledger-web"
+ $(widgetFile "register")
+
+-- | Generate javascript/html for a register balance line chart based on
+-- the provided "TransactionsReportItem"s.
+registerChartHtml :: [(CommoditySymbol, (String, [TransactionsReportItem]))] -> HtmlUrl AppRoute
+registerChartHtml percommoditytxnreports = $(hamletFile "templates/chart.hamlet")
+ -- have to make sure plot is not called when our container (maincontent)
+ -- is hidden, eg with add form toggled
+ where
+ charttitle = case maybe "" (fst . snd) $ listToMaybe percommoditytxnreports of
+ "" -> ""
+ s -> s <> ":"
+ colorForCommodity = fromMaybe 0 . flip lookup commoditiesIndex
+ commoditiesIndex = zip (map fst percommoditytxnreports) [0..] :: [(CommoditySymbol,Int)]
+ simpleMixedAmountQuantity = maybe 0 aquantity . listToMaybe . amounts
+ shownull c = if null c then " " else c
+
+dayToJsTimestamp :: Day -> Integer
+dayToJsTimestamp d =
+ read (formatTime defaultTimeLocale "%s" t) * 1000 -- XXX read
+ where
+ t = UTCTime d (secondsToDiffTime 0)
diff --git a/Hledger/Web/Handler/UploadR.hs b/Hledger/Web/Handler/UploadR.hs
new file mode 100644
index 0000000..c7d02d6
--- /dev/null
+++ b/Hledger/Web/Handler/UploadR.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hledger.Web.Handler.UploadR
+ ( getUploadR
+ , postUploadR
+ ) where
+
+import qualified Data.ByteString.Lazy as BL
+import Data.Conduit (connect)
+import Data.Conduit.Binary (sinkLbs)
+import qualified Data.Text.Encoding as TE
+
+import Hledger.Web.Import
+import Hledger.Web.Widget.Common (fromFormSuccess, journalFile404, writeValidJournal)
+
+uploadForm :: FilePath -> Markup -> MForm Handler (FormResult FileInfo, Widget)
+uploadForm f =
+ identifyForm "upload" $ \extra -> do
+ (res, _) <- mreq fileField fs Nothing
+ -- Ignoring the view - setting the name of the element is enough here
+ pure (res, $(widgetFile "upload-form"))
+ where
+ fs = FieldSettings "file" Nothing (Just "file") (Just "file") []
+
+getUploadR :: FilePath -> Handler ()
+getUploadR = postUploadR
+
+postUploadR :: FilePath -> Handler ()
+postUploadR f = do
+ VD {caps, j} <- getViewData
+ when (CapManage `notElem` caps) (permissionDenied "Missing the 'manage' capability")
+
+ (f', _) <- journalFile404 f j
+ ((res, view), enctype) <- runFormPost (uploadForm f')
+ fi <- fromFormSuccess (showForm view enctype) res
+ lbs <- BL.toStrict <$> connect (fileSource fi) sinkLbs
+
+ -- Try to parse as UTF-8
+ -- XXX Unfortunate - how to parse as system locale?
+ text <- case TE.decodeUtf8' lbs of
+ Left e -> do
+ setMessage $
+ "Encoding error: '" <> toHtml (show e) <> "'. " <>
+ "If your file is not UTF-8 encoded, try the 'edit form', " <>
+ "where the transcoding should be handled by the browser."
+ showForm view enctype
+ Right text -> return text
+ writeValidJournal f text >>= \case
+ Left e -> do
+ setMessage $ "Failed to load journal: " <> toHtml e
+ showForm view enctype
+ Right () -> do
+ setMessage $ "File " <> toHtml f <> " uploaded successfully"
+ redirect JournalR
+ where
+ showForm view enctype =
+ sendResponse <=< defaultLayout $ do
+ setTitle "Upload journal"
+ [whamlet|<form method=post enctype=#{enctype}>^{view}|]
diff --git a/Hledger/Web/Import.hs b/Hledger/Web/Import.hs
new file mode 100644
index 0000000..f2dd18b
--- /dev/null
+++ b/Hledger/Web/Import.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE CPP #-}
+module Hledger.Web.Import
+ ( module Import
+ ) where
+
+import Prelude as Import hiding (head, init, last,
+ readFile, tail, writeFile)
+import Yesod as Import hiding (Route (..))
+
+import Control.Monad as Import
+import Data.Bifunctor as Import
+import Data.ByteString as Import (ByteString)
+import Data.Default as Import
+import Data.Either as Import
+import Data.Foldable as Import
+import Data.List as Import (unfoldr)
+import Data.Maybe as Import
+import Data.Text as Import (Text)
+import Data.Time as Import hiding (parseTime)
+import Data.Traversable as Import
+import Data.Void as Import (Void)
+import Text.Blaze as Import (Markup)
+
+import Hledger.Web.Foundation as Import
+import Hledger.Web.Settings as Import
+import Hledger.Web.Settings.StaticFiles as Import
+import Hledger.Web.WebOptions as Import (Capability(..))
+
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Monoid as Import ((<>))
+#endif
diff --git a/Hledger/Web/Main.hs b/Hledger/Web/Main.hs
index fe9d36d..2a8843f 100644
--- a/Hledger/Web/Main.hs
+++ b/Hledger/Web/Main.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
{-|
hledger-web - a hledger add-on providing a web interface.
@@ -7,32 +8,26 @@ Released under GPL version 3 or later.
-}
-module Hledger.Web.Main
-where
+module Hledger.Web.Main where
--- yesod scaffold imports
-import Yesod.Default.Config --(fromArgs)
--- import Yesod.Default.Main (defaultMain)
-import Settings -- (parseExtra)
-import Application (makeApplication)
-import Data.String
+import Control.Monad (when)
+import Data.String (fromString)
+import qualified Data.Text as T
+import Network.Wai (Application)
import Network.Wai.Handler.Warp (runSettings, defaultSettings, setHost, setPort)
import Network.Wai.Handler.Launch (runHostPortUrl)
---
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
-#endif
-import Control.Monad
-import Data.Default
-import Data.Text (pack)
+import Prelude hiding (putStrLn)
import System.Exit (exitSuccess)
import System.IO (hFlush, stdout)
-import Text.Printf
-import Prelude hiding (putStrLn)
+import Text.Printf (printf)
+import Yesod.Default.Config
+import Yesod.Default.Main (defaultDevelApp)
import Hledger
-import Hledger.Utils.UTF8IOCompat (putStrLn)
import Hledger.Cli hiding (progname,prognameandversion)
+import Hledger.Utils.UTF8IOCompat (putStrLn)
+import Hledger.Web.Application (makeApplication)
+import Hledger.Web.Settings (Extra(..), parseExtra)
import Hledger.Web.WebOptions
@@ -42,30 +37,39 @@ hledgerWebMain = do
when (debug_ (cliopts_ opts) > 0) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show opts)
runWith opts
+hledgerWebDev :: IO (Int, Application)
+hledgerWebDev =
+ withJournalDoWeb defwebopts (\o j -> defaultDevelApp loader $ makeApplication o j)
+ where
+ loader =
+ Yesod.Default.Config.loadConfig
+ (configSettings Development) {csParseExtra = parseExtra}
+
runWith :: WebOpts -> IO ()
runWith opts
- | "help" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStr (showModeUsage webmode) >> exitSuccess
- | "version" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
- | "binary-filename" `inRawOpts` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
- | otherwise = do
- requireJournalFileExists =<< (head `fmap` journalFilePathFromOpts (cliopts_ opts)) -- XXX head should be safe for now
- withJournalDo' opts web
+ | "help" `inRawOpts` rawopts_ (cliopts_ opts) = putStr (showModeUsage webmode) >> exitSuccess
+ | "version" `inRawOpts` rawopts_ (cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
+ | "binary-filename" `inRawOpts` rawopts_ (cliopts_ opts) = putStrLn (binaryfilename progname)
+ | otherwise = withJournalDoWeb opts web
-withJournalDo' :: WebOpts -> (WebOpts -> Journal -> IO ()) -> IO ()
-withJournalDo' opts@WebOpts {cliopts_ = cliopts} cmd = do
- f <- head `fmap` journalFilePathFromOpts cliopts -- XXX head should be safe for now
+-- | A version of withJournalDo specialised for hledger-web.
+-- Disallows the special - file to avoid some bug,
+-- takes WebOpts rather than CliOpts.
+withJournalDoWeb :: WebOpts -> (WebOpts -> Journal -> IO a) -> IO a
+withJournalDoWeb opts@WebOpts {cliopts_ = copts} cmd = do
+ journalpaths <- journalFilePathFromOpts copts
-- https://github.com/simonmichael/hledger/issues/202
- -- -f- gives [Error#yesod-core] <stdin>: hGetContents: illegal operation (handle is closed) for some reason
- -- Also we may be writing to this file. Just disallow it.
- when (f == "-") $ error' "hledger-web doesn't support -f -, please specify a file path"
+ -- -f- gives [Error#yesod-core] <stdin>: hGetContents: illegal operation (handle is closed)
+ -- Also we may try to write to this file. Just disallow -.
+ when ("-" `elem` journalpaths) $ -- always non-empty
+ error' "hledger-web doesn't support -f -, please specify a file path"
+ mapM_ requireJournalFileExists journalpaths
- let fn = cmd opts
- . pivotByOpts cliopts
- . anonymiseByOpts cliopts
- <=< journalApplyValue (reportopts_ cliopts)
- <=< journalAddForecast cliopts
- readJournalFile def f >>= either error' fn
+ -- keep synced with withJournalDo TODO refactor
+ readJournalFiles (inputopts_ copts) journalpaths
+ >>= mapM (journalTransform copts)
+ >>= either error' (cmd opts)
-- | The web command.
web :: WebOpts -> Journal -> IO ()
@@ -76,11 +80,11 @@ web opts j = do
h = host_ opts
p = port_ opts
u = base_url_ opts
- staticRoot = pack <$> file_url_ opts
+ staticRoot = T.pack <$> file_url_ opts
appconfig = AppConfig{appEnv = Development
,appHost = fromString h
,appPort = p
- ,appRoot = pack u
+ ,appRoot = T.pack u
,appExtra = Extra "" Nothing staticRoot
}
app <- makeApplication opts j' appconfig
@@ -90,10 +94,7 @@ web opts j = do
then do
putStrLn "Press ctrl-c to quit"
hFlush stdout
- let warpsettings =
- setHost (fromString h) $
- setPort p $
- defaultSettings
+ let warpsettings = setHost (fromString h) (setPort p defaultSettings)
Network.Wai.Handler.Warp.runSettings warpsettings app
else do
putStrLn "Starting web browser..."
diff --git a/Settings.hs b/Hledger/Web/Settings.hs
index 7598518..56f3795 100644
--- a/Settings.hs
+++ b/Hledger/Web/Settings.hs
@@ -4,26 +4,34 @@
-- 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 Foundation.hs file.
-module Settings where
+module Hledger.Web.Settings where
-import Prelude
+import Data.Default (def)
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+import Data.Yaml
+import Language.Haskell.TH.Syntax (Q, Exp)
+import Text.Hamlet
import Text.Shakespeare.Text (st)
-import Language.Haskell.TH.Syntax
import Yesod.Default.Config
import Yesod.Default.Util
-import Data.Text (Text)
-import Data.Yaml
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
+
+development :: Bool
+development =
+#if DEVELOPMENT
+ True
+#else
+ False
#endif
-import Settings.Development
-import Data.Default (def)
-import Text.Hamlet
+production :: Bool
+production = not development
+
+hledgerorgurl :: Text
+hledgerorgurl = "http://hledger.org"
-hledgerorgurl, manualurl :: String
-hledgerorgurl = "http://hledger.org"
-manualurl = hledgerorgurl++"/manual"
+manualurl :: Text
+manualurl = hledgerorgurl <> "/manual"
-- | The default IP address to listen on. May be overridden with --host.
defhost :: String
diff --git a/Settings/StaticFiles.hs b/Hledger/Web/Settings/StaticFiles.hs
index 505565c..a63a084 100644
--- a/Settings/StaticFiles.hs
+++ b/Hledger/Web/Settings/StaticFiles.hs
@@ -1,12 +1,10 @@
{-# LANGUAGE TemplateHaskell #-}
-module Settings.StaticFiles where
+module Hledger.Web.Settings.StaticFiles where
-import Prelude (IO, putStrLn, (++), (>>), return)
import System.IO (stdout, hFlush)
-import Yesod.Static
-import qualified Yesod.Static as Static
-import Settings (staticDir)
-import Settings.Development
+import Yesod.Static (Static, embed, publicFiles, staticDevel)
+
+import Hledger.Web.Settings (staticDir, development)
-- | use this to create your static file serving site
-- staticSite :: IO Static.Static
@@ -20,14 +18,14 @@ import Settings.Development
-- $(staticFiles Settings.staticDir)
-staticSite :: IO Static.Static
+staticSite :: IO Static
staticSite =
if development
then (do
putStrLn ("Using web files from: " ++ staticDir ++ "/") >> hFlush stdout
- Static.staticDevel staticDir)
+ staticDevel staticDir)
else (do
-- putStrLn "Using built-in web files" >> hFlush stdout
- return $(Static.embed staticDir))
+ return $(embed staticDir))
$(publicFiles staticDir)
diff --git a/Hledger/Web/WebOptions.hs b/Hledger/Web/WebOptions.hs
index a6964a9..a24f07a 100644
--- a/Hledger/Web/WebOptions.hs
+++ b/Hledger/Web/WebOptions.hs
@@ -1,16 +1,19 @@
{-# LANGUAGE CPP #-}
-module Hledger.Web.WebOptions
-where
-import Prelude
-import Data.Default
-#if !MIN_VERSION_base(4,8,0)
-import Data.Functor.Compat ((<$>))
-#endif
-import Data.Maybe
-import System.Environment
+{-# LANGUAGE OverloadedStrings #-}
+module Hledger.Web.WebOptions where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BC
+import Data.CaseInsensitive (CI, mk)
+import Control.Monad (join)
+import Data.Default (Default(def))
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Text (Text)
+import System.Environment (getArgs)
-import Hledger.Cli hiding (progname,version,prognameandversion)
-import Settings
+import Hledger.Cli hiding (progname, version)
+import Hledger.Web.Settings (defhost, defport, defbaseurl)
progname, version :: String
progname = "hledger-web"
@@ -22,81 +25,137 @@ version = ""
prognameandversion :: String
prognameandversion = progname ++ " " ++ version :: String
-webflags :: [Flag [([Char], [Char])]]
-webflags = [
- flagNone ["serve","server"] (setboolopt "serve") ("serve and log requests, don't browse or auto-exit")
- ,flagReq ["host"] (\s opts -> Right $ setopt "host" s opts) "IPADDR" ("listen on this IP address (default: "++defhost++")")
- ,flagReq ["port"] (\s opts -> Right $ setopt "port" s opts) "PORT" ("listen on this TCP port (default: "++show defport++")")
- ,flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "BASEURL" ("set the base url (default: http://IPADDR:PORT)")
- ,flagReq ["file-url"] (\s opts -> Right $ setopt "file-url" s opts) "FILEURL" ("set the static files url (default: BASEURL/static)")
- ]
+webflags :: [Flag [(String, String)]]
+webflags =
+ [ flagNone
+ ["serve", "server"]
+ (setboolopt "serve")
+ "serve and log requests, don't browse or auto-exit"
+ , flagReq
+ ["host"]
+ (\s opts -> Right $ setopt "host" s opts)
+ "IPADDR"
+ ("listen on this IP address (default: " ++ defhost ++ ")")
+ , flagReq
+ ["port"]
+ (\s opts -> Right $ setopt "port" s opts)
+ "PORT"
+ ("listen on this TCP port (default: " ++ show defport ++ ")")
+ , flagReq
+ ["base-url"]
+ (\s opts -> Right $ setopt "base-url" s opts)
+ "BASEURL"
+ "set the base url (default: http://IPADDR:PORT)"
+ , flagReq
+ ["file-url"]
+ (\s opts -> Right $ setopt "file-url" s opts)
+ "FILEURL"
+ "set the static files url (default: BASEURL/static)"
+ , flagReq
+ ["capabilities"]
+ (\s opts -> Right $ setopt "capabilities" s opts)
+ "CAP,CAP2"
+ "enable these capabilities - comma-separated, possible values are: view, add, manage (default: view,add)"
+ , flagReq
+ ["capabilities-header"]
+ (\s opts -> Right $ setopt "capabilities-header" s opts)
+ "HEADER"
+ "read enabled capabilities from a HTTP header (e.g. X-Sandstorm-Permissions, disabled by default)"
+ ]
-webmode :: Mode [([Char], [Char])]
-webmode = (mode "hledger-web" [("command","web")]
- "start serving the hledger web interface"
- (argsFlag "[PATTERNS]") []){
- modeGroupFlags = Group {
- groupUnnamed = webflags
- ,groupHidden = [flagNone ["binary-filename"] (setboolopt "binary-filename") "show the download filename for this executable, and exit"]
- ,groupNamed = [generalflagsgroup1]
- }
- ,modeHelpSuffix=[
- -- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window curses ui."
- ]
- }
+webmode :: Mode [(String, String)]
+webmode =
+ (mode
+ "hledger-web"
+ [("command", "web")]
+ "start serving the hledger web interface"
+ (argsFlag "[PATTERNS]")
+ [])
+ { modeGroupFlags =
+ Group
+ { groupUnnamed = webflags
+ , groupHidden =
+ [ flagNone
+ ["binary-filename"]
+ (setboolopt "binary-filename")
+ "show the download filename for this executable, and exit"
+ ]
+ , groupNamed = [generalflagsgroup1]
+ }
+ , modeHelpSuffix = []
+ }
-- hledger-web options, used in hledger-web and above
-data WebOpts = WebOpts {
- serve_ :: Bool
- ,host_ :: String
- ,port_ :: Int
- ,base_url_ :: String
- ,file_url_ :: Maybe String
- ,cliopts_ :: CliOpts
- } deriving (Show)
+data WebOpts = WebOpts
+ { serve_ :: Bool
+ , host_ :: String
+ , port_ :: Int
+ , base_url_ :: String
+ , file_url_ :: Maybe String
+ , capabilities_ :: [Capability]
+ , capabilitiesHeader_ :: Maybe (CI ByteString)
+ , cliopts_ :: CliOpts
+ } deriving (Show)
defwebopts :: WebOpts
-defwebopts = WebOpts
- def
- def
- def
- def
- def
- def
+defwebopts = WebOpts def def def def def [CapView, CapAdd] Nothing def
--- instance Default WebOpts where def = defwebopts
+instance Default WebOpts where def = defwebopts
rawOptsToWebOpts :: RawOpts -> IO WebOpts
-rawOptsToWebOpts rawopts = checkWebOpts <$> do
- cliopts <- rawOptsToCliOpts rawopts
- let
- h = fromMaybe defhost $ maybestringopt "host" rawopts
- p = fromMaybe defport $ maybeintopt "port" rawopts
- b = maybe (defbaseurl h p) stripTrailingSlash $ maybestringopt "base-url" rawopts
- return defwebopts {
- serve_ = boolopt "serve" rawopts
- ,host_ = h
- ,port_ = p
- ,base_url_ = b
- ,file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
- ,cliopts_ = cliopts
- }
+rawOptsToWebOpts rawopts =
+ checkWebOpts <$> do
+ cliopts <- rawOptsToCliOpts rawopts
+ let h = fromMaybe defhost $ maybestringopt "host" rawopts
+ p = fromMaybe defport $ maybeintopt "port" rawopts
+ b =
+ maybe (defbaseurl h p) stripTrailingSlash $
+ maybestringopt "base-url" rawopts
+ caps' = join $ T.splitOn "," . T.pack <$> listofstringopt "capabilities" rawopts
+ caps = case traverse capabilityFromText caps' of
+ Left e -> error' ("Unknown capability: " ++ T.unpack e)
+ Right [] -> [CapView, CapAdd]
+ Right xs -> xs
+ return
+ defwebopts
+ { serve_ = boolopt "serve" rawopts
+ , host_ = h
+ , port_ = p
+ , base_url_ = b
+ , file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
+ , capabilities_ = caps
+ , capabilitiesHeader_ = mk . BC.pack <$> maybestringopt "capabilities-header" rawopts
+ , cliopts_ = cliopts
+ }
where
- stripTrailingSlash = reverse . dropWhile (=='/') . reverse -- yesod don't like it
+ stripTrailingSlash = reverse . dropWhile (== '/') . reverse -- yesod don't like it
checkWebOpts :: WebOpts -> WebOpts
-checkWebOpts wopts =
- either usageError (const wopts) $ do
- let h = host_ wopts
- if any (not . (`elem` ".0123456789")) h
- then Left $ "--host requires an IP address, not "++show h
- else Right ()
+checkWebOpts wopts = do
+ let h = host_ wopts
+ if any (`notElem` (".0123456789" :: String)) h
+ then usageError $ "--host requires an IP address, not " ++ show h
+ else wopts
getHledgerWebOpts :: IO WebOpts
---getHledgerWebOpts = processArgs webmode >>= return . decodeRawOpts >>= rawOptsToWebOpts
getHledgerWebOpts = do
- args <- getArgs >>= expandArgsAt
- let args' = replaceNumericFlags args
- let cmdargopts = either usageError id $ process webmode args'
- rawOptsToWebOpts $ decodeRawOpts cmdargopts
+ args <- fmap replaceNumericFlags . expandArgsAt =<< getArgs
+ rawOptsToWebOpts . decodeRawOpts . either usageError id $ process webmode args
+
+data Capability
+ = CapView
+ | CapAdd
+ | CapManage
+ deriving (Eq, Ord, Bounded, Enum, Show)
+
+capabilityFromText :: Text -> Either Text Capability
+capabilityFromText "view" = Right CapView
+capabilityFromText "add" = Right CapAdd
+capabilityFromText "manage" = Right CapManage
+capabilityFromText x = Left x
+capabilityFromBS :: ByteString -> Either ByteString Capability
+capabilityFromBS "view" = Right CapView
+capabilityFromBS "add" = Right CapAdd
+capabilityFromBS "manage" = Right CapManage
+capabilityFromBS x = Left x
diff --git a/Hledger/Web/Widget/AddForm.hs b/Hledger/Web/Widget/AddForm.hs
new file mode 100644
index 0000000..c66d276
--- /dev/null
+++ b/Hledger/Web/Widget/AddForm.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hledger.Web.Widget.AddForm
+ ( addForm
+ , addModal
+ ) where
+
+import Control.Monad.State.Strict (evalStateT)
+import Data.Bifunctor (first)
+import Data.List (dropWhileEnd, nub, sort, unfoldr)
+import Data.Maybe (isJust)
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (Day)
+import Text.Blaze.Internal (Markup, preEscapedString)
+import Text.JSON
+import Text.Megaparsec (eof, parseErrorPretty, runParser)
+import Yesod
+
+import Hledger
+import Hledger.Web.Settings (widgetFile)
+
+addModal ::
+ ( MonadWidget m
+ , r ~ Route (HandlerSite m)
+#if MIN_VERSION_yesod(1,6,0)
+ , m ~ WidgetFor (HandlerSite m)
+#else
+ , m ~ WidgetT (HandlerSite m) IO
+#endif
+ , RenderMessage (HandlerSite m) FormMessage
+ )
+ => r -> Journal -> Day -> m ()
+addModal addR j today = do
+ (addView, addEnctype) <- generateFormPost (addForm j today)
+ [whamlet|
+<div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true">
+ <div .modal-dialog .modal-lg>
+ <div .modal-content>
+ <div .modal-header>
+ <button type="button" .close data-dismiss="modal" aria-hidden="true">&times;
+ <h3 .modal-title #addLabel>Add a transaction
+ <div .modal-body>
+ <form#addform.form action=@{addR} method=POST enctype=#{addEnctype}>
+ ^{addView}
+|]
+
+addForm ::
+ (site ~ HandlerSite m, RenderMessage site FormMessage, MonadHandler m)
+ => Journal
+ -> Day
+ -> Markup
+#if MIN_VERSION_yesod(1,6,0)
+ -> MForm m (FormResult Transaction, WidgetFor site ())
+#else
+ -> MForm m (FormResult Transaction, WidgetT site IO ())
+#endif
+addForm j today = identifyForm "add" $ \extra -> do
+ (dateRes, dateView) <- mreq dateField dateFS Nothing
+ (descRes, descView) <- mreq textField descFS Nothing
+ (acctRes, _) <- mreq listField acctFS Nothing
+ (amtRes, _) <- mreq listField amtFS Nothing
+
+ let (msgs', postRes) = case validatePostings <$> acctRes <*> amtRes of
+ FormSuccess (Left es) -> (es, FormFailure ["Postings validation failed"])
+ FormSuccess (Right xs) -> ([], FormSuccess xs)
+ FormMissing -> ([], FormMissing)
+ FormFailure es -> ([], FormFailure es)
+ msgs = zip [(1 :: Int)..] $ msgs' ++ replicate (4 - length msgs') ("", "", Nothing, Nothing)
+
+ let descriptions = sort $ nub $ tdescription <$> jtxns j
+ escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>" -- #236
+ listToJsonValueObjArrayStr = preEscapedString . escapeJSSpecialChars .
+ encode . JSArray . fmap (\a -> JSObject $ toJSObject [("value", showJSON a)])
+ journals = fst <$> jfiles j
+
+ pure (makeTransaction <$> dateRes <*> descRes <*> postRes, $(widgetFile "add-form"))
+ where
+ makeTransaction date desc postings =
+ nulltransaction {tdate = date, tdescription = desc, tpostings = postings}
+
+ dateFS = FieldSettings "date" Nothing Nothing (Just "date")
+ [("class", "form-control input-lg"), ("placeholder", "Date")]
+ descFS = FieldSettings "desc" Nothing Nothing (Just "description")
+ [("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")]
+ acctFS = FieldSettings "amount" Nothing Nothing (Just "account") []
+ amtFS = FieldSettings "amount" Nothing Nothing (Just "amount") []
+ dateField = checkMMap (pure . validateDate) (T.pack . show) textField
+ validateDate s =
+ first (const ("Invalid date format" :: Text)) $
+ fixSmartDateStrEither' today (T.strip s)
+
+ listField = Field
+ { fieldParse = const . pure . Right . Just . dropWhileEnd T.null
+ , fieldView = error "Don't render using this!"
+ , fieldEnctype = UrlEncoded
+ }
+
+validatePostings :: [Text] -> [Text] -> Either [(Text, Text, Maybe Text, Maybe Text)] [Posting]
+validatePostings a b =
+ case traverse id $ (\(_, _, x) -> x) <$> postings of
+ Left _ -> Left $ foldr catPostings [] postings
+ Right [] -> Left
+ [ ("", "", Just "Missing account", Just "Missing amount")
+ , ("", "", Just "Missing account", Nothing)
+ ]
+ Right [p] -> Left
+ [ (paccount p, T.pack . showMixedAmountWithoutPrice $ pamount p, Nothing, Nothing)
+ , ("", "", Just "Missing account", Nothing)
+ ]
+ Right xs -> Right xs
+ where
+ postings = unfoldr go (True, a, b)
+
+ go (_, x:xs, y:ys) = Just ((x, y, zipPosting (validateAccount x) (validateAmount y)), (True, xs, ys))
+ go (True, x:y:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Left "Missing amount")), (True, y:xs, []))
+ go (True, x:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Right missingamt)), (False, xs, []))
+ go (False, x:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Left "Missing amount")), (False, xs, []))
+ go (_, [], y:ys) = Just (("", y, zipPosting (Left "Missing account") (validateAmount y)), (False, [], ys))
+ go (_, [], []) = Nothing
+
+ zipPosting = zipEither (\acc amt -> nullposting {paccount = acc, pamount = Mixed [amt]})
+
+ catPostings (t, t', Left (e, e')) xs = (t, t', e, e') : xs
+ catPostings (t, t', Right _) xs = (t, t', Nothing, Nothing) : xs
+
+ errorToFormMsg = first (("Invalid value: " <>) . T.pack . parseErrorPretty)
+ validateAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip
+ validateAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip
+
+-- Modification of Align, from the `these` package
+zipEither :: (a -> a' -> r) -> Either e a -> Either e' a' -> Either (Maybe e, Maybe e') r
+zipEither f a b = case (a, b) of
+ (Right a', Right b') -> Right (f a' b')
+ (Left a', Right _) -> Left (Just a', Nothing)
+ (Right _, Left b') -> Left (Nothing, Just b')
+ (Left a', Left b') -> Left (Just a', Just b')
diff --git a/Hledger/Web/Widget/Common.hs b/Hledger/Web/Widget/Common.hs
new file mode 100644
index 0000000..6646c72
--- /dev/null
+++ b/Hledger/Web/Widget/Common.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Hledger.Web.Widget.Common
+ ( accountQuery
+ , accountOnlyQuery
+ , balanceReportAsHtml
+ , helplink
+ , mixedAmountAsHtml
+ , fromFormSuccess
+ , writeValidJournal
+ , journalFile404
+ ) where
+
+import Data.Default (def)
+import Data.Foldable (find, for_)
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.FilePath (takeFileName)
+import Text.Blaze ((!), textValue)
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+import Text.Blaze.Internal (preEscapedString)
+import Text.Hamlet (hamletFile)
+import Yesod
+
+import Hledger
+import Hledger.Cli.Utils (writeFileWithBackupIfChanged)
+import Hledger.Web.Settings (manualurl)
+
+#if MIN_VERSION_yesod(1,6,0)
+journalFile404 :: FilePath -> Journal -> HandlerFor m (FilePath, Text)
+#else
+journalFile404 :: FilePath -> Journal -> HandlerT m IO (FilePath, Text)
+#endif
+journalFile404 f j =
+ case find ((== f) . fst) (jfiles j) of
+ Just (_, txt) -> pure (takeFileName f, txt)
+ Nothing -> notFound
+
+fromFormSuccess :: Applicative m => m a -> FormResult a -> m a
+fromFormSuccess h FormMissing = h
+fromFormSuccess h (FormFailure _) = h
+fromFormSuccess _ (FormSuccess a) = pure a
+
+writeValidJournal :: MonadHandler m => FilePath -> Text -> m (Either String ())
+writeValidJournal f txt =
+ liftIO (readJournal def (Just f) txt) >>= \case
+ Left e -> return (Left e)
+ Right _ -> do
+ _ <- liftIO (writeFileWithBackupIfChanged f txt)
+ return (Right ())
+
+
+-- | Link to a topic in the manual.
+helplink :: Text -> Text -> HtmlUrl r
+helplink topic label _ = H.a ! A.href u ! A.target "hledgerhelp" $ toHtml label
+ where u = textValue $ manualurl <> if T.null topic then "" else T.cons '#' topic
+
+-- | Render a "BalanceReport" as html.
+balanceReportAsHtml :: Eq r => (r, r) -> r -> Bool -> Journal -> [QueryOpt] -> BalanceReport -> HtmlUrl r
+balanceReportAsHtml (journalR, registerR) here hideEmpty j qopts (items, total) =
+ $(hamletFile "templates/balance-report.hamlet")
+ where
+ l = ledgerFromJournal Any j
+ indent a = preEscapedString $ concat $ replicate (2 + 2 * a) "&nbsp;"
+ hasSubAccounts acct = maybe True (not . null . asubs) (ledgerAccount l acct)
+ matchesAcctSelector acct = Just True == ((`matchesAccount` acct) <$> inAccountQuery qopts)
+
+accountQuery :: AccountName -> Text
+accountQuery = ("inacct:" <>) . quoteIfSpaced
+
+accountOnlyQuery :: AccountName -> Text
+accountOnlyQuery = ("inacctonly:" <>) . quoteIfSpaced
+
+mixedAmountAsHtml :: MixedAmount -> HtmlUrl a
+mixedAmountAsHtml b _ =
+ for_ (lines (showMixedAmountWithoutPrice b)) $ \t -> do
+ H.span ! A.class_ c $ toHtml t
+ H.br
+ where
+ c = case isNegativeMixedAmount b of
+ Just True -> "negative amount"
+ _ -> "positive amount"
diff --git a/Import.hs b/Import.hs
deleted file mode 100644
index c3f3736..0000000
--- a/Import.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-# LANGUAGE CPP #-}
-module Import
- ( module Import
- ) where
-
-import Prelude as Import hiding (head, init, last,
- readFile, tail, writeFile)
-import Yesod as Import hiding (Route (..))
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative as Import (pure, (<$>), (<*>))
-#endif
-import Data.Text as Import (Text)
-
-import Foundation as Import
-import Settings as Import
-import Settings.Development as Import
-import Settings.StaticFiles as Import
-
-#if !(MIN_VERSION_base(4,11,0))
-import Data.Monoid as Import ((<>))
-#endif
diff --git a/Settings/Development.hs b/Settings/Development.hs
deleted file mode 100644
index 3d42292..0000000
--- a/Settings/Development.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# LANGUAGE CPP #-}
-module Settings.Development where
-
-import Prelude
-
-development :: Bool
-development =
-#if DEVELOPMENT
- True
-#else
- False
-#endif
-
-production :: Bool
-production = not development
diff --git a/config/routes b/config/routes
index 805b992..f33b124 100644
--- a/config/routes
+++ b/config/routes
@@ -1,10 +1,13 @@
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/static StaticR Static getStatic
+
/ RootR GET
-/journal JournalR GET POST
-/register RegisterR GET POST
-/sidebar SidebarR GET
+/journal JournalR GET
+/register RegisterR GET
+/add AddR GET POST
--- /accounts AccountsR GET
--- /api/accounts AccountsJsonR GET
+/manage ManageR GET
+/edit/#FilePath EditR GET POST
+/upload/#FilePath UploadR GET POST
+/download/#FilePath DownloadR GET
diff --git a/hledger-web.1 b/hledger-web.1
index 09c1f70..0bfa557 100644
--- a/hledger-web.1
+++ b/hledger-web.1
@@ -1,5 +1,5 @@
-.TH "hledger\-web" "1" "April 2018" "hledger\-web 1.9.1" "hledger User Manuals"
+.TH "hledger\-web" "1" "June 2018" "hledger\-web 1.9.99" "hledger User Manuals"
diff --git a/hledger-web.cabal b/hledger-web.cabal
index 3b389fe..48ed375 100644
--- a/hledger-web.cabal
+++ b/hledger-web.cabal
@@ -2,10 +2,10 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: 1872196bf7e9ff50fae0f3ea64ea81d1155799a2779617be58c9acf7f6aabce8
+-- hash: 819abf18972b92028b9ccb3e8b1c5404368f8ca74e855c6fa226884dd01995a8
name: hledger-web
-version: 1.9.2
+version: 1.10
synopsis: Web interface for the hledger accounting tool
description: This is hledger's web interface.
It provides a more user-friendly and collaborative UI than the
@@ -25,7 +25,7 @@ author: Simon Michael <simon@joyful.com>
maintainer: Simon Michael <simon@joyful.com>
license: GPL-3
license-file: LICENSE
-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.1
+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1
build-type: Simple
cabal-version: >= 1.10
extra-source-files:
@@ -38,7 +38,6 @@ extra-source-files:
hledger-web.1
hledger-web.info
hledger-web.txt
- messages/en.msg
README
static/css/bootstrap-datepicker.standalone.min.css
static/css/bootstrap-theme.css
@@ -97,8 +96,16 @@ extra-source-files:
static/js/jquery.url.js
static/js/typeahead.bundle.js
static/js/typeahead.bundle.min.js
+ templates/add-form.hamlet
+ templates/balance-report.hamlet
+ templates/chart.hamlet
templates/default-layout-wrapper.hamlet
templates/default-layout.hamlet
+ templates/edit-form.hamlet
+ templates/journal.hamlet
+ templates/manage.hamlet
+ templates/register.hamlet
+ templates/upload-form.hamlet
source-repository head
type: git
@@ -120,50 +127,52 @@ flag threaded
default: True
library
+ hs-source-dirs:
+ ./.
exposed-modules:
- Application
- Foundation
- Handler.AddForm
- Handler.Common
- Handler.JournalR
- Handler.RegisterR
- Handler.RootR
- Handler.SidebarR
- Handler.Utils
Hledger.Web
+ Hledger.Web.Application
+ Hledger.Web.Foundation
+ Hledger.Web.Handler.AddR
+ Hledger.Web.Handler.Common
+ Hledger.Web.Handler.EditR
+ Hledger.Web.Handler.JournalR
+ Hledger.Web.Handler.RegisterR
+ Hledger.Web.Handler.UploadR
+ Hledger.Web.Import
Hledger.Web.Main
+ Hledger.Web.Settings
+ Hledger.Web.Settings.StaticFiles
Hledger.Web.WebOptions
- Import
- Settings
- Settings.Development
- Settings.StaticFiles
+ Hledger.Web.Widget.AddForm
+ Hledger.Web.Widget.Common
other-modules:
Paths_hledger_web
- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans
- cpp-options: -DVERSION="1.9.2"
+ ghc-options: -Wall -fwarn-tabs
+ cpp-options: -DVERSION="1.10"
build-depends:
HUnit
, base >=4.8 && <4.12
- , base-compat >=0.8.1
, blaze-html
, blaze-markup
, bytestring
+ , case-insensitive
, clientsession
, cmdargs >=0.10
+ , conduit
, conduit-extra >=1.1
, data-default
, directory
, filepath
, hjsmin
- , hledger >=1.9.1 && <2.0
- , hledger-lib >=1.9.1 && <2.0
+ , hledger >=1.10 && <1.11
+ , hledger-lib >=1.10 && <1.11
, http-client
, http-conduit
, json
- , megaparsec >=5.0
+ , megaparsec >=6.4.1
, mtl
- , parsec >=3
- , safe >=0.2
+ , semigroups
, shakespeare >=2.0.2.2
, template-haskell
, text >=1.2
@@ -178,10 +187,8 @@ library
, yesod-core >=1.4 && <1.7
, yesod-form >=1.4 && <1.7
, yesod-static >=1.4 && <1.7
- if (flag(dev)) || (flag(library-only))
- cpp-options: -DDEVELOPMENT
- if flag(dev)
- ghc-options: -O0
+ if impl(ghc >=8)
+ ghc-options: -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints
default-language: Haskell2010
executable hledger-web
@@ -190,109 +197,15 @@ executable hledger-web
Paths_hledger_web
hs-source-dirs:
app
- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans
- cpp-options: -DVERSION="1.9.2"
+ ghc-options: -Wall -fwarn-tabs
+ cpp-options: -DVERSION="1.10"
build-depends:
- HUnit
- , base >=4.8 && <4.12
- , base-compat >=0.8.1
- , blaze-html
- , blaze-markup
- , bytestring
- , clientsession
- , cmdargs >=0.10
- , conduit-extra >=1.1
- , data-default
- , directory
- , filepath
- , hjsmin
- , hledger >=1.9.1 && <2.0
- , hledger-lib >=1.9.1 && <2.0
+ base
, hledger-web
- , http-client
- , http-conduit
- , json
- , megaparsec >=5.0
- , mtl
- , parsec >=3
- , safe >=0.2
- , shakespeare >=2.0.2.2
- , template-haskell
- , text >=1.2
- , time >=1.5
- , transformers
- , wai
- , wai-extra
- , wai-handler-launch >=1.3
- , warp
- , yaml
- , yesod >=1.4 && <1.7
- , yesod-core >=1.4 && <1.7
- , yesod-form >=1.4 && <1.7
- , yesod-static >=1.4 && <1.7
- if (flag(dev)) || (flag(library-only))
- cpp-options: -DDEVELOPMENT
- if flag(dev)
- ghc-options: -O0
+ if impl(ghc >=8)
+ ghc-options: -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints
if flag(library-only)
buildable: False
if flag(threaded)
ghc-options: -threaded
default-language: Haskell2010
-
-test-suite test
- type: exitcode-stdio-1.0
- main-is: main.hs
- other-modules:
- HomeTest
- TestImport
- Paths_hledger_web
- hs-source-dirs:
- tests
- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans
- cpp-options: -DVERSION="1.9.2"
- build-depends:
- HUnit
- , base >=4.8 && <4.12
- , base-compat >=0.8.1
- , blaze-html
- , blaze-markup
- , bytestring
- , clientsession
- , cmdargs >=0.10
- , conduit-extra >=1.1
- , data-default
- , directory
- , filepath
- , hjsmin
- , hledger >=1.9.1 && <2.0
- , hledger-lib >=1.9.1 && <2.0
- , hledger-web
- , hspec
- , http-client
- , http-conduit
- , json
- , megaparsec >=5.0
- , mtl
- , parsec >=3
- , safe >=0.2
- , shakespeare >=2.0.2.2
- , template-haskell
- , text >=1.2
- , time >=1.5
- , transformers
- , wai
- , wai-extra
- , wai-handler-launch >=1.3
- , warp
- , yaml
- , yesod >=1.4 && <1.7
- , yesod-core >=1.4 && <1.7
- , yesod-form >=1.4 && <1.7
- , yesod-static >=1.4 && <1.7
- , yesod-test
- if (flag(dev)) || (flag(library-only))
- cpp-options: -DDEVELOPMENT
- if flag(dev)
- ghc-options: -O0
- default-language: Haskell2010
diff --git a/hledger-web.info b/hledger-web.info
index 0be780d..db7d44b 100644
--- a/hledger-web.info
+++ b/hledger-web.info
@@ -3,8 +3,8 @@ This is hledger-web.info, produced by makeinfo version 6.5 from stdin.

File: hledger-web.info, Node: Top, Next: OPTIONS, Up: (dir)
-hledger-web(1) hledger-web 1.9.1
-********************************
+hledger-web(1) hledger-web 1.9.99
+*********************************
hledger-web is hledger's web interface. It starts a simple web
application for browsing and adding transactions, and optionally opens
@@ -209,7 +209,7 @@ this, insert a '--' argument before.)

Tag Table:
Node: Top72
-Node: OPTIONS3156
-Ref: #options3241
+Node: OPTIONS3158
+Ref: #options3243

End Tag Table
diff --git a/hledger-web.txt b/hledger-web.txt
index 79244ea..d0067a7 100644
--- a/hledger-web.txt
+++ b/hledger-web.txt
@@ -248,4 +248,4 @@ SEE ALSO
-hledger-web 1.9.1 April 2018 hledger-web(1)
+hledger-web 1.9.99 June 2018 hledger-web(1)
diff --git a/messages/en.msg b/messages/en.msg
deleted file mode 100644
index e928c34..0000000
--- a/messages/en.msg
+++ /dev/null
@@ -1 +0,0 @@
-Hello: Hello
diff --git a/static/hledger.css b/static/hledger.css
index 8aa843a..7864ec1 100644
--- a/static/hledger.css
+++ b/static/hledger.css
@@ -20,37 +20,6 @@
/*------------------------------------------------------------------------------------------*/
/* 4. typeahead styles */
-/*
-.typeahead,
-.tt-query,
-.tt-hint {
- width: 396px;
- height: 30px;
- padding: 8px 12px;
- font-size: 24px;
- line-height: 30px;
- border: 2px solid #ccc;
- -webkit-border-radius: 8px;
- -moz-border-radius: 8px;
- border-radius: 8px;
- outline: none;
-}
-
-.typeahead {
- background-color: #fff;
-}
-
-.typeahead:focus {
- border: 2px solid #0097cf;
-}
-
-.tt-query {
- -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075);
- -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075);
- box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075);
-}
-
-*/
.tt-hint {
color: #bbb;
}
@@ -70,9 +39,6 @@
max-height:300px;
}
-.tt-suggestions {
-}
-
.tt-suggestion {
padding: 3px 20px;
font-size: 18px;
@@ -82,7 +48,6 @@
.tt-suggestion.tt-cursor {
color: #fff;
background-color: #0097cf;
-
}
.tt-suggestion p {
@@ -100,7 +65,7 @@ code {
ul {
list-style-type: none;
- padding: 0;
+ padding: 0;
}
#main-content {
@@ -136,51 +101,37 @@ ul {
#sidebar-menu .main-menu a {
display: inline;
- font-size: 16px;
- font-weight: 500;
- color: #2F2F2F;
- padding: 4px 20px;
+ font-size: 16px;
+ font-weight: 500;
+ color: #2F2F2F;
+ padding: 4px 20px;
}
#sidebar-menu .main-menu a:hover {
- color: #11427D;
- text-decoration: none;
- background-color: transparent;
+ color: #11427D;
+ text-decoration: none;
+ background-color: transparent;
}
-#sidebar-menu .main-menu .only{
+#sidebar-menu .main-menu .only {
visibility: hidden;
padding: 1px;
}
-#sidebar-menu .main-menu tr:hover > td > div > .only {
+#sidebar-menu .main-menu tr:hover .only {
visibility: visible;
}
-#sidebar-menu .main-menu .only:hover{
- border-left: none;
-}
-#sidebar-menu .main-menu .balance {
- float: right;
-}
-
-#sidebar-menu .main-menu .total {
- border-left: none;
- border-right: none;
- border-bottom: none;
- border-top: 1px solid black;
-}
-
-#sidebar-menu .main-menu .inacct {
+#sidebar-menu .main-menu .inacct, #sidebar-menu .main-menu .inacct .acct-name {
font-weight: bold;
- color: #11427D;
+ color: #11427D;
background-color: #f9f9f9;
}
#sidebar-menu .main-menu .amount {
float: right;
overflow-x:auto;
- font-weight: 500 !important;
+ font-weight: 500 !important;
}
#sidebar-menu .main-menu .acct {
@@ -188,7 +139,7 @@ ul {
vertical-align:bottom;
}
-.transactionsreport .nonhead {
+.transactionsreport .posting td {
border: none !important;
}
@@ -200,24 +151,6 @@ ul {
whitespace: nowrap;
}
-#main-content {
- /*
- -webkit-transition: width 0.3s ease, margin 0.3s ease;
- -moz-transition: width 0.3s ease, margin 0.3s ease;
- -o-transition: width 0.3s ease, margin 0.3s ease;
- transition: width 0.3s ease, margin 0.3s ease;
-*/
-}
-
-#sidebar-menu {
- /*
- -webkit-transition: width 0.3s ease, margin 0.3s ease,opacity 0.3s ease,height 1s ease 1s;
- -moz-transition: width 0.3s ease, margin 0.3s ease,opacity 0.3s ease,height 1s ease 1s;
- -o-transition: width 0.3s ease, margin 0.3s ease,opacity 0.3s ease,height 1s ease 1s;
- transition: width 0.3s ease, margin 0.3s ease,opacity 0.3s ease,height 1s ease 1s;
-*/
-}
-
.col-any-0 {
width:0 !important;
height:0 !important;
@@ -229,10 +162,6 @@ ul {
font-size:large;
}
-#searchbar {
- width: 100% !important;
-}
-
@media screen and (max-width: 768px) {
.row-offcanvas {
position: relative;
diff --git a/static/hledger.js b/static/hledger.js
index dc62d85..88647da 100644
--- a/static/hledger.js
+++ b/static/hledger.js
@@ -4,9 +4,13 @@
// STARTUP
$(document).ready(function() {
- // cache the input element as a variable
- // for minor performance benefits
- var dateEl = $('#dateWrap');
+ // date picker
+ // http://bootstrap-datepicker.readthedocs.io/en/latest/options.html
+ var dateEl = $('#dateWrap').datepicker({
+ showOnFocus: false,
+ autoclose: true,
+ format: 'yyyy-mm-dd'
+ });;
// ensure add form always focuses its first field
$('#addmodal')
@@ -18,36 +22,22 @@ $(document).ready(function() {
dateEl.datepicker('hide');
});
- // show add form if ?add=1
- if ($.url.param('add')) { addformShow(true); }
-
- // date picker
- // http://bootstrap-datepicker.readthedocs.io/en/latest/options.html
- dateEl.datepicker({
- showOnFocus: false,
- autoclose: true,
- format: 'yyyy-mm-dd'
- });
-
- // sidebar account hover handlers
- $('#sidebar td a').mouseenter(function(){ $(this).parent().addClass('mouseover'); });
- $('#sidebar td').mouseleave(function(){ $(this).removeClass('mouseover'); });
-
// keyboard shortcuts
// 'body' seems to hold focus better than document in FF
$('body').bind('keydown', 'h', function(){ $('#helpmodal').modal('toggle'); return false; });
$('body').bind('keydown', 'shift+/', function(){ $('#helpmodal').modal('toggle'); return false; });
$('body').bind('keydown', 'j', function(){ location.href = document.hledgerWebBaseurl+'/journal'; return false; });
$('body').bind('keydown', 's', function(){ sidebarToggle(); return false; });
+ $('body').bind('keydown', 'e', function(){ emptyAccountsToggle(); return false; });
$('body').bind('keydown', 'a', function(){ addformShow(); return false; });
$('body').bind('keydown', 'n', function(){ addformShow(); return false; });
$('body').bind('keydown', 'f', function(){ $('#searchform input').focus(); return false; });
+ $('body, #addform input, #addform select').bind('keydown', 'ctrl++', addformAddPosting);
$('body, #addform input, #addform select').bind('keydown', 'ctrl+shift+=', addformAddPosting);
$('body, #addform input, #addform select').bind('keydown', 'ctrl+=', addformAddPosting);
$('body, #addform input, #addform select').bind('keydown', 'ctrl+-', addformDeletePosting);
$('.amount-input:last').keypress(addformAddPosting);
-
// highlight the entry from the url hash
if (window.location.hash && $(window.location.hash)[0]) {
$(window.location.hash).addClass('highlighted');
@@ -78,10 +68,9 @@ function registerChart($container, series) {
position: 'sw'
},
grid: {
- markings:
- function (axes) {
+ markings: function () {
var now = Date.now();
- var markings = [
+ return [
{
xaxis: { to: now }, // past
yaxis: { to: 0 }, // <0
@@ -103,7 +92,6 @@ function registerChart($container, series) {
lineWidth:1
},
];
- return markings;
},
hoverable: true,
autoHighlight: true,
@@ -127,15 +115,16 @@ function registerChart($container, series) {
}
function registerChartClick(ev, pos, item) {
- if (item) {
- targetselector = '#'+item.series.data[item.dataIndex][5];
- $target = $(targetselector);
- if ($target.length) {
- window.location.hash = targetselector;
- $('html, body').animate({
- scrollTop: $target.offset().top
- }, 1000);
- }
+ if (!item) {
+ return;
+ }
+ var targetselector = '#' + item.series.data[item.dataIndex][5];
+ var $target = $(targetselector);
+ if ($target.length) {
+ window.location.hash = targetselector;
+ $('html, body').animate({
+ scrollTop: $target.offset().top
+ }, 1000);
}
}
@@ -174,59 +163,46 @@ function focus($el) {
// Insert another posting row in the add form.
function addformAddPosting() {
- $('.amount-input:last').off('keypress');
- // do nothing if it's not currently visible
- if (!$('#addform').is(':visible')) return;
- // save a copy of last row
- var lastrow = $('#addform .form-group:last').clone();
+ if (!$('#addform').is(':visible')) {
+ return;
+ }
- // replace the submit button with an amount field, clear and renumber it, add the keybindings
- var num = $('#addform .account-group').length;
+ var prevLastRow = $('#addform .account-group:last');
+ prevLastRow.off('keypress');
- // insert the new last row
- $('#addform .account-postings').append(lastrow);
- // TODO: Enable typehead on dynamically created inputs
+ // Clone the currently last row
+ $('#addform .account-postings').append(prevLastRow.clone());
+ var num = $('#addform .account-group').length;
- var $acctinput = $('.account-input:last');
- var $amntinput = $('.amount-input:last');
// clear and renumber the field, add keybindings
- $acctinput
+ // XXX Enable typehead on dynamically created inputs
+ $('.amount-input:last')
.val('')
- .prop('id','account'+(num+1))
- .prop('name','account'+(num+1))
- .prop('placeholder','Account '+(num+1));
- //lastrow.find('input') // not :last this time
- $acctinput
- .bind('keydown', 'ctrl+shift+=', addformAddPosting)
- .bind('keydown', 'ctrl+=', addformAddPosting)
- .bind('keydown', 'ctrl+-', addformDeletePosting);
-
- $amntinput
- .val('')
- .prop('id','amount'+(num+1))
- .prop('name','amount'+(num+1))
- .prop('placeholder','Amount '+(num+1))
+ .prop('placeholder','Amount ' + num)
.keypress(addformAddPosting);
- $acctinput
+ $('.account-input:last')
+ .val('')
+ .prop('placeholder', 'Account ' + num)
+ .bind('keydown', 'ctrl++', addformAddPosting)
.bind('keydown', 'ctrl+shift+=', addformAddPosting)
.bind('keydown', 'ctrl+=', addformAddPosting)
.bind('keydown', 'ctrl+-', addformDeletePosting);
-
}
// Remove the add form's last posting row, if empty, keeping at least two.
function addformDeletePosting() {
- var num = $('#addform .account-group').length;
- if (num <= 2) return;
+ if ($('#addform .account-group').length <= 2) {
+ return;
+ }
// remember if the last row's field or button had focus
var focuslost =
$('.account-input:last').is(':focus')
|| $('.amount-input:last').is(':focus');
// delete last row
$('#addform .account-group:last').remove();
- if(focuslost){
- focus($('account-input:last'));
+ if (focuslost) {
+ focus($('.account-input:last'));
}
// Rebind keypress
$('.amount-input:last').keypress(addformAddPosting);
@@ -242,46 +218,7 @@ function sidebarToggle() {
$.cookie('showsidebar', $('#sidebar-menu').hasClass('col-any-0') ? '0' : '1');
}
-//----------------------------------------------------------------------
-// MISC
-
-function enableTypeahead($el, suggester) {
- return $el.typeahead(
- {
- highlight: true
- },
- {
- source: suggester.ttAdapter()
- }
- );
+function emptyAccountsToggle() {
+ $('.acct.empty').parent().toggleClass('hide');
+ $.cookie('hideemptyaccts', $.cookie('hideemptyaccts') === '1' ? '0' : '1')
}
-
-// function journalSelect(ev) {
-// var textareas = $('textarea', $('form#editform'));
-// for (i=0; i<textareas.length; i++) {
-// textareas[i].style.display = 'none';
-// textareas[i].disabled = true;
-// }
-// var targ = getTarget(ev);
-// if (targ.value) {
-// var journalid = targ.value+'_textarea';
-// var textarea = document.getElementById(journalid);
-// }
-// else {
-// var textarea = textareas[0];
-// }
-// textarea.style.display = 'block';
-// textarea.disabled = false;
-// return true;
-// }
-
-// // Get the current event's target in a robust way.
-// // http://www.quirksmode.org/js/events_properties.html
-// function getTarget(ev) {
-// var targ;
-// if (!ev) var ev = window.event;
-// if (ev.target) targ = ev.target;
-// else if (ev.srcElement) targ = ev.srcElement;
-// if (targ.nodeType == 3) targ = targ.parentNode;
-// return targ;
-// }
diff --git a/templates/add-form.hamlet b/templates/add-form.hamlet
new file mode 100644
index 0000000..4faa7d9
--- /dev/null
+++ b/templates/add-form.hamlet
@@ -0,0 +1,71 @@
+<script>
+ jQuery(document).ready(function() {
+ descriptionsSuggester = new Bloodhound({
+ local:#{listToJsonValueObjArrayStr descriptions},
+ limit:100,
+ datumTokenizer: function(d) { return [d.value]; },
+ queryTokenizer: function(q) { return [q]; }
+ });
+ descriptionsSuggester.initialize();
+
+ accountsSuggester = new Bloodhound({
+ local:#{listToJsonValueObjArrayStr (journalAccountNamesDeclaredOrImplied j)},
+ limit:100,
+ datumTokenizer: function(d) { return [d.value]; },
+ queryTokenizer: function(q) { return [q]; }
+ });
+ accountsSuggester.initialize();
+
+ jQuery('input[name=description]').typeahead({ highlight: true }, { source: descriptionsSuggester.ttAdapter() });
+ jQuery('input[name=account]').typeahead({ highlight: true }, { source: accountsSuggester.ttAdapter() });
+ });
+^{extra}
+
+<div .form-group>
+ <div .row>
+ <div .col-md-3 .col-xs-6 .col-sm-6 :isJust (fvErrors dateView):.has-error>
+ <div #dateWrap .form-group.input-group.date>
+ ^{fvInput dateView}
+ <div .input-group-addon>
+ <span .glyphicon .glyphicon-th>
+ $maybe err <- fvErrors dateView
+ <span .help-block .error-block>#{err}
+ <div .col-md-9 .col-xs-6 .col-sm-6 :isJust (fvErrors descView):.has-error>
+ <div .form-group>
+ ^{fvInput descView}
+ $maybe err <- fvErrors descView
+ <span .help-block .error-block>#{err}
+ <div .row>
+ <div .col-md-3 .col-xs-6 .col-sm-6>
+ <div .col-md-9 .col-xs-6 .col-sm-6>
+
+<div .account-postings>
+ $forall (n, (acc, amt, accE, amtE)) <- msgs
+ <div .form-group .row .account-group>
+ <div .col-md-8 .col-xs-8 .col-sm-8 :isJust accE:.has-error>
+ <input .account-input.form-control.input-lg.typeahead type=text
+ name=account placeholder="Account #{n}" value="#{acc}">
+ $maybe err <- accE
+ <span .help-block .error-block>_{err}
+ <div .col-md-4 .col-xs-4 .col-sm-4 :isJust amtE:.has-error>
+ <input .amount-input.form-control.input-lg type=text
+ name=amount placeholder="Amount #{n}" value="#{amt}">
+ $maybe err <- amtE
+ <span .help-block .error-block>_{err}
+
+<div .row>
+ <div .col-md-8 .col-xs-8 .col-sm-8>
+ <div .col-md-4 .col-xs-4 .col-sm-4>
+ <button type=submit .btn .btn-default .btn-lg name=submit>add
+
+$if length journals > 1
+ <br>
+ <span .input-lg>to:
+ <select #journalselect .form-control.input-lg name=journal style="width:auto; display:inline-block;">
+ $forall p <- journals
+ <option value=#{p}>#{p}
+<span .small style="padding-left:2em;">
+ Enter a value in the last field for #
+ <a href="#" onclick="addformAddPosting(); return false;">
+ more
+ \ (or ctrl +, ctrl -)
diff --git a/templates/balance-report.hamlet b/templates/balance-report.hamlet
new file mode 100644
index 0000000..2476c36
--- /dev/null
+++ b/templates/balance-report.hamlet
@@ -0,0 +1,25 @@
+<tr :here == journalR:.inacct>
+ <td .top .acct>
+ <a href=@{journalR} :here == journalR:.inacct
+ title="Show general journal entries, most recent first">
+ Journal
+ <td .top>
+$forall (acct, adisplay, aindent, abal) <- items
+ <tr
+ :matchesAcctSelector acct:.inacct
+ :isZeroMixedAmount abal && hideEmpty:.hide>
+ <td .acct :isZeroMixedAmount abal:.empty>
+ <div .ff-wrapper>
+ \#{indent aindent}
+ <a.acct-name href="@?{(registerR, [("q", accountQuery acct)])}"
+ title="Show transactions affecting this account and subaccounts">
+ #{adisplay}
+ $if hasSubAccounts acct
+ <a href="@?{(registerR, [("q", accountOnlyQuery acct)])}" .only.hidden-sm.hidden-xs
+ title="Show transactions affecting this account but not subaccounts">only
+ <td>
+ ^{mixedAmountAsHtml abal}
+<tr .total>
+ <td>
+ <td>
+ ^{mixedAmountAsHtml total}
diff --git a/templates/chart.hamlet b/templates/chart.hamlet
new file mode 100644
index 0000000..347490d
--- /dev/null
+++ b/templates/chart.hamlet
@@ -0,0 +1,59 @@
+<label #register-chart-label style=""><br>
+<div #register-chart style="height:150px; margin-bottom:1em; display:block;">
+<script type=text/javascript>
+ \$(document).ready(function() {
+ var $chartdiv = $('#register-chart');
+ if ($chartdiv.is(':visible')) {
+ \$('#register-chart-label').text('#{charttitle}');
+ var seriesData = [
+ $forall (c,(_,items)) <- percommoditytxnreports
+ /* we render each commodity using two series:
+ * one with extra data points added to show a stepped balance line */
+ {
+ data: [
+ $forall i <- reverse items
+ [
+ #{dayToJsTimestamp $ triDate i},
+ #{simpleMixedAmountQuantity $ triCommodityBalance c i}
+ ],
+ ],
+ label: '#{shownull $ T.unpack c}',
+ color: #{colorForCommodity c},
+ lines: {
+ show: true,
+ steps: true,
+ },
+ points: {
+ show: false,
+ },
+ clickable: false,
+ hoverable: false,
+ },
+ /* and one with the original data, showing one clickable, hoverable point per transaction */
+ {
+ data: [
+ $forall i <- reverse items
+ [
+ #{dayToJsTimestamp $ triDate i},
+ #{simpleMixedAmountQuantity $ triCommodityBalance c i},
+ '#{showMixedAmountWithZeroCommodity $ triCommodityAmount c i}',
+ '#{showMixedAmountWithZeroCommodity $ triCommodityBalance c i}',
+ '#{concat $ intersperse "\\n" $ lines $ show $ triOrigTransaction i}',
+ #{tindex $ triOrigTransaction i}
+ ],
+ /* [] */
+ ],
+ label: '',
+ color: #{colorForCommodity c},
+ lines: {
+ show: false,
+ },
+ points: {
+ show: true,
+ },
+ },
+ ]
+ var plot = registerChart($chartdiv, seriesData);
+ \$chartdiv.bind("plotclick", registerChartClick);
+ };
+ });
diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet
index dfdee37..c196433 100644
--- a/templates/default-layout-wrapper.hamlet
+++ b/templates/default-layout-wrapper.hamlet
@@ -29,7 +29,7 @@ $newline never
<div .row .row-offcanvas .row-offcanvas-left>
^{pageBody pc}
<footer>
- #{extraCopyright $ appExtra $ settings master}
+ #{extraCopyright $ appExtra $ settings master}
$maybe analytics <- extraAnalytics $ appExtra $ settings master
<script>
@@ -47,61 +47,3 @@ $newline never
<script>
window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})})
\<![endif]-->
-
- <div .modal.fade #helpmodal tabindex="-1" role="dialog" aria-labelledby="helpLabel" aria-hidden="true">
- <div .modal-dialog .modal-lg>
- <div .modal-content>
- <div .modal-header>
- <button type="button" .close data-dismiss="modal" aria-hidden="true">&times;
- <h3 .modal-title #helpLabel>Help
- <div .modal-body>
- <div .row>
- <div .col-xs-6>
- <p>
- <b>Keyboard shortcuts
- <ul>
- <li> <code>h</code> or maybe <code>?</code> - view this help (escape or click to exit)
- <li> <code>j</code> - go to the Journal view (home)
- <li> <code>a</code> - add a transaction (escape to cancel)
- <li> <code>s</code> - toggle sidebar
- <li> <code>f</code> - focus search form ("find")
- <p>
- <b>General
- <ul>
- <li> The Journal view shows general journal entries, representing zero-sum movements of money (or other commodity) between hierarchical accounts
- <li> The sidebar shows the resulting accounts and their final balances
- <li> Parent account balances include subaccount balances
- <li> Multiple currencies in balances are displayed one above the other
- <li> Click account name links to see transactions affecting that account, with running balance
- <li> Click date links to see journal entries on that date
- <div .col-xs-6>
- <p>
- <b>Search
- <ul>
- <li> <code>acct:REGEXP</code> - filter on to/from account
- <li> <code>desc:REGEXP</code> - filter on description
- <li> <code>date:PERIODEXP</code>, <code>date2:PERIODEXP</code> - filter on date or secondary date
- <li> <code>code:REGEXP</code> - filter on transaction's code (eg check number)
- <li> <code>status:*</code>, <code>status:!</code>, <code>status:</code> - filter on transaction's cleared status (cleared, pending, uncleared)
- <!-- <li> <code>empty:BOOL</code> - filter on whether amount is zero -->
- <li> <code>amt:N</code>, <code>amt:&lt;N</code>, <code>amt:&gt;N</code> - filter on the unsigned amount magnitude. Or with a sign before N, filter on the signed value. (Single-commodity amounts only.)
- <li> <code>cur:REGEXP</code> - filter on the currency/commodity symbol (must match all of it). Dollar sign must be written as <code>\$</code>
- <li> <code>tag:NAME</code>, <code>tag:NAME=REGEX</code> - filter on tag name, or tag name and value
- <!-- <li> <code>depth:N</code> - filter out accounts below this depth -->
- <li> <code>real:BOOL</code> - filter on postings' real/virtual-ness
- <li> Enclose search patterns containing spaces in single or double quotes
- <li> Prepend <code>not:</code> to negate a search term
- <li> Multiple search terms on different fields are AND'ed, multiple search terms on the same field are OR'ed
- <li> These search terms also work with command-line hledger
-
- <div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true">
- <div .modal-dialog .modal-lg>
- <div .modal-content>
- <div .modal-header>
- <button type="button" .close data-dismiss="modal" aria-hidden="true">&times;
- <h3 .modal-title #addLabel>Add a transaction
- <div .modal-body>
- $maybe m <- lastmsg
- $if isPrefixOf "Errors" (renderHtml m)
- <div #message>#{m}
- ^{addform staticRootUrl vd}
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet
index 14183ea..8f857b7 100644
--- a/templates/default-layout.hamlet
+++ b/templates/default-layout.hamlet
@@ -1,4 +1,81 @@
-$maybe m <- lastmsg
- $if not $ isPrefixOf "Errors" (renderHtml m)
- <div #message>#{m}
-^{widget}
+
+<div#spacer .col-xs-2.#{topShowsm}.#{topShowmd}>
+ <h1>
+ <button .visible-xs.btn.btn-default type="button" data-toggle="offcanvas">
+ <span .glyphicon.glyphicon-align-left.tgl-icon>
+
+<div#topbar .col-md-8 .col-sm-8 .col-xs-10>
+ <h1>#{takeFileName (journalFilePath j)}
+
+$if elem CapView caps
+ <div#sidebar-menu .sidebar-offcanvas.#{sideShowmd}.#{sideShowsm}>
+ <table .main-menu .table>
+ ^{accounts}
+
+<div#main-content .col-xs-12.#{mainShowmd}.#{mainShowsm}>
+ $maybe m <- msg
+ <div #message .alert.alert-info>#{m}
+ $if elem CapView caps
+ <form#searchform.input-group method=GET>
+ <input .form-control name=q value=#{q} placeholder="Search"
+ title="Enter hledger search patterns to filter the data below">
+ <div .input-group-btn>
+ $if not (T.null q)
+ <a href=@{here} .btn .btn-default title="Clear search terms">
+ <span .glyphicon .glyphicon-remove-circle>
+ <button .btn .btn-default type=submit title="Apply search terms">
+ <span .glyphicon .glyphicon-search>
+ $if elem CapManage caps
+ <a href="@{ManageR}" .btn.btn-default title="Manage journal files">
+ <span .glyphicon .glyphicon-wrench>
+ <button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal"
+ title="Show search and general help">
+ <span .glyphicon .glyphicon-question-sign>
+ ^{widget}
+
+<div .modal.fade #helpmodal tabindex="-1" role="dialog" aria-labelledby="helpLabel" aria-hidden="true">
+ <div .modal-dialog .modal-lg>
+ <div .modal-content>
+ <div .modal-header>
+ <button type="button" .close data-dismiss="modal" aria-hidden="true">&times;
+ <h3 .modal-title #helpLabel>Help
+ <div .modal-body>
+ <div .row>
+ <div .col-xs-6>
+ <p>
+ <b>Keyboard shortcuts
+ <ul>
+ <li> <code>h</code> or maybe <code>?</code> - view this help (escape or click to exit)
+ <li> <code>j</code> - go to the Journal view (home)
+ <li> <code>a</code> - add a transaction (escape to cancel)
+ <li> <code>s</code> - toggle sidebar
+ <li> <code>f</code> - focus search form ("find")
+ <li> <code>e</code> - hide empty accounts in sidebar
+ <p>
+ <b>General
+ <ul>
+ <li> The Journal view shows general journal entries, representing zero-sum movements of money (or other commodity) between hierarchical accounts
+ <li> The sidebar shows the resulting accounts and their final balances
+ <li> Parent account balances include subaccount balances
+ <li> Multiple currencies in balances are displayed one above the other
+ <li> Click account name links to see transactions affecting that account, with running balance
+ <li> Click date links to see journal entries on that date
+ <div .col-xs-6>
+ <p>
+ <b>Search
+ <ul>
+ <li> <code>acct:REGEXP</code> - filter on to/from account
+ <li> <code>desc:REGEXP</code> - filter on description
+ <li> <code>date:PERIODEXP</code>, <code>date2:PERIODEXP</code> - filter on date or secondary date
+ <li> <code>code:REGEXP</code> - filter on transaction's code (eg check number)
+ <li> <code>status:*</code>, <code>status:!</code>, <code>status:</code> - filter on transaction's cleared status (cleared, pending, uncleared)
+ <!-- <li> <code>empty:BOOL</code> - filter on whether amount is zero -->
+ <li> <code>amt:N</code>, <code>amt:&lt;N</code>, <code>amt:&gt;N</code> - filter on the unsigned amount magnitude. Or with a sign before N, filter on the signed value. (Single-commodity amounts only.)
+ <li> <code>cur:REGEXP</code> - filter on the currency/commodity symbol (must match all of it). Dollar sign must be written as <code>\$</code>
+ <li> <code>tag:NAME</code>, <code>tag:NAME=REGEX</code> - filter on tag name, or tag name and value
+ <!-- <li> <code>depth:N</code> - filter out accounts below this depth -->
+ <li> <code>real:BOOL</code> - filter on postings' real/virtual-ness
+ <li> Enclose search patterns containing spaces in single or double quotes
+ <li> Prepend <code>not:</code> to negate a search term
+ <li> Multiple search terms on different fields are AND'ed, multiple search terms on the same field are OR'ed
+ <li> These search terms also work with command-line hledger
diff --git a/templates/edit-form.hamlet b/templates/edit-form.hamlet
new file mode 100644
index 0000000..afda31b
--- /dev/null
+++ b/templates/edit-form.hamlet
@@ -0,0 +1,17 @@
+#{extra}
+<h2>
+ Edit file #
+ <i>#{f}
+<div.alert.alert-danger>
+ Are you sure? This will overwrite your journal!
+<table.table.table-condensed>
+ <tr>
+ <td colspan=2 style="border:0">
+ ^{fvInput tView}
+ <tr>
+ <td style="border:0">
+ <span.help>
+ ^{helplink "file-format" "File format help"}
+ <td .text-right style="border:0">
+ <a.btn.btn-default href="@{ManageR}">Go back
+ <input.btn.btn-default type=submit value="Save">
diff --git a/templates/journal.hamlet b/templates/journal.hamlet
new file mode 100644
index 0000000..6608e9a
--- /dev/null
+++ b/templates/journal.hamlet
@@ -0,0 +1,39 @@
+<h2>
+ #{title'}
+
+$if elem CapAdd caps
+ <a #addformlink href="#" role="button" style="cursor:pointer; margin-top:1em;"
+ data-toggle="modal" data-target="#addmodal" title="Add a new transaction to the journal">
+ Add a transaction
+
+<div .table-responsive>
+ <table .transactionsreport .table .table-condensed>
+ <thead>
+ <th .date style="text-align:left;">Date
+ <th .description style="text-align:left;">Description
+ <th .account style="text-align:left;">Account
+ <th .amount style="text-align:right;">Amount
+
+ $forall (torig, _, split, _, amt, _) <- items
+ <tr .title #transaction-#{tindex torig}>
+ <td .date nowrap>
+ #{show (tdate torig)}
+ <td colspan=2>
+ #{textElideRight 60 (tdescription torig)}
+ <td .amount style="text-align:right;">
+ $if not split && not (isZeroMixedAmount amt)
+ ^{mixedAmountAsHtml amt}
+
+ $forall Posting { paccount = acc, pamount = amt } <- tpostings torig
+ <tr .posting title="#{show torig}">
+ <td>
+ <td>
+ <td>
+ &nbsp;
+ <a href="@?{acctlink acc}##{tindex torig}" title="#{acc}">
+ #{elideAccountName 40 acc}
+ <td .amount style="text-align:right;">
+ ^{mixedAmountAsHtml amt}
+
+$if elem CapAdd caps
+ ^{addModal AddR j today}
diff --git a/templates/manage.hamlet b/templates/manage.hamlet
new file mode 100644
index 0000000..a8b107e
--- /dev/null
+++ b/templates/manage.hamlet
@@ -0,0 +1,22 @@
+<h2>
+ Your journal's files
+
+<div.row>
+ <div .col-xs-12.col-sm-8.col-md-6>
+ <table .table.table-condensed>
+ <thead>
+ <th>
+ File
+ <th>
+ <tbody>
+ $forall (path, _) <- jfiles j
+ <tr>
+ <td style="vertical-align:middle">
+ #{path}
+ <td style="text-align:right">
+ <a.btn.btn-default href=@{EditR path}>
+ Edit
+ <a.btn.btn-default href=@{UploadR path}>
+ Upload
+ <a.btn.btn-default href=@{DownloadR path}>
+ Download
diff --git a/templates/register.hamlet b/templates/register.hamlet
new file mode 100644
index 0000000..6b34872
--- /dev/null
+++ b/templates/register.hamlet
@@ -0,0 +1,37 @@
+<h2>
+ #{header}
+
+<div .hidden-xs>
+ ^{registerChartHtml $ transactionsReportByCommodity r}
+
+<div.table-responsive>
+ <table .table.table-striped.table-condensed>
+ <thead>
+ <tr>
+ <th style="text-align:left;">
+ Date
+ <span .glyphicon.glyphicon-chevron-up>
+ <th style="text-align:left;">Description
+ <th style="text-align:left;">To/From Account(s)
+ <th style="text-align:right; white-space:normal;">Amount Out/In
+ <th style="text-align:right; white-space:normal;">
+ #{balancelabel'}
+
+ <tbody>
+ $forall (torig, tacct, split, acct, amt, bal) <- items
+ <tr ##{tindex torig} title="#{show torig}" style="vertical-align:top;">
+ <td .date>
+ <a href="@{JournalR}#transaction-#{tindex torig}">
+ #{show (tdate tacct)}
+ <td title="#{show torig}">
+ #{textElideRight 30 (tdescription tacct)}
+ <td .account>
+ #{elideRight 40 acct}
+ <td .amount style="text-align:right; white-space:nowrap;">
+ $if not split || not (isZeroMixedAmount amt)
+ ^{mixedAmountAsHtml amt}
+ <td style="text-align:right;">
+ ^{mixedAmountAsHtml bal}
+
+$if elem CapAdd caps
+ ^{addModal AddR j today}
diff --git a/templates/upload-form.hamlet b/templates/upload-form.hamlet
new file mode 100644
index 0000000..e6896c4
--- /dev/null
+++ b/templates/upload-form.hamlet
@@ -0,0 +1,14 @@
+<h2>
+ Upload to file #
+ <i>#{f}
+<div.alert.alert-danger>
+ Are you sure? This will overwrite your journal!
+<div.form-group>
+ <label .btn.btn-primary for="file">
+ <input type=file id=file name=file style="display:none"
+ onchange="\$('#file-info').html(this.files[0].name)" />
+ Select file
+ <span .label.label-info id="file-info">
+<div.form-group>
+ <input .btn.btn-default type=submit value="Upload">
+#{extra}
diff --git a/tests/HomeTest.hs b/tests/HomeTest.hs
deleted file mode 100644
index ad762a3..0000000
--- a/tests/HomeTest.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module HomeTest
- ( homeSpecs
- ) where
-
-import TestImport
-
-homeSpecs :: Specs
-homeSpecs =
- ydescribe "Some hledger-web tests" $
-
- yit "serves a reasonable-looking register page" $ do
- get RegisterR
- statusIs 200
- bodyContains "accounts"
-
- -- post "/" $ do
- -- addNonce
- -- fileByLabel "Choose a file" "tests/main.hs" "text/plain" -- talk about self-reference
- -- byLabel "What's on the file?" "Some Content"
-
- -- statusIs 200
- -- htmlCount ".message" 1
- -- htmlAllContain ".message" "Some Content"
- -- htmlAllContain ".message" "text/plain"
diff --git a/tests/TestImport.hs b/tests/TestImport.hs
deleted file mode 100644
index 19d1f3e..0000000
--- a/tests/TestImport.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module TestImport
- ( module Yesod.Test
- , module Foundation
- , Specs
- ) where
-
-import Yesod.Test
-
-import Foundation
-
-type Specs = YesodSpec App
diff --git a/tests/main.hs b/tests/main.hs
deleted file mode 100644
index a6e0ed4..0000000
--- a/tests/main.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Main where
-
-import Import
-import Yesod.Default.Config
-import Yesod.Test
-import Test.Hspec (hspec)
-import Application (makeFoundation)
-import Hledger.Web.WebOptions (defwebopts)
-
-import HomeTest
-
-main :: IO ()
-main = do
- conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing)
- { csParseExtra = parseExtra
- }
- foundation <- makeFoundation conf defwebopts
- hspec $ do
- yesodSpec foundation $ do
- homeSpecs