mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-19 10:17:35 +03:00
web: Add /manage page, implement /edit, /upload, and /download
This commit is contained in:
parent
cc1241fa20
commit
c952ab881b
@ -1,9 +1,13 @@
|
||||
/favicon.ico FaviconR GET
|
||||
/robots.txt RobotsR GET
|
||||
/static StaticR Static getStatic
|
||||
|
||||
/ RootR GET
|
||||
/journal JournalR GET
|
||||
/register RegisterR GET
|
||||
/add AddR GET POST
|
||||
/edit EditR GET POST
|
||||
/import ImportR GET POST
|
||||
|
||||
/manage ManageR GET
|
||||
/edit/#FilePath EditR GET POST
|
||||
/upload/#FilePath UploadR GET POST
|
||||
/download/#FilePath DownloadR GET
|
||||
|
@ -2,7 +2,7 @@
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: f9b958b9292d00ff739999dbd9f5a467b38eac93caa7d16950e03c4c15737b4c
|
||||
-- hash: 979ca4df732320e72b08f7b8422b1b45104ae64053d58f08ec06a62475c42981
|
||||
|
||||
name: hledger-web
|
||||
version: 1.9.99
|
||||
@ -96,8 +96,15 @@ extra-source-files:
|
||||
static/js/jquery.url.js
|
||||
static/js/typeahead.bundle.js
|
||||
static/js/typeahead.bundle.min.js
|
||||
templates/add-form.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
|
||||
@ -139,18 +146,19 @@ library
|
||||
Widget.AddForm
|
||||
Widget.Common
|
||||
other-modules:
|
||||
Handler.UploadR
|
||||
Paths_hledger_web
|
||||
ghc-options: -Wall
|
||||
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -fwarn-tabs
|
||||
cpp-options: -DVERSION="1.9.99"
|
||||
build-depends:
|
||||
HUnit
|
||||
, base >=4.8 && <4.12
|
||||
, base-compat-batteries >=0.10.1 && <0.11
|
||||
, blaze-html
|
||||
, blaze-markup
|
||||
, bytestring
|
||||
, clientsession
|
||||
, cmdargs >=0.10
|
||||
, conduit
|
||||
, conduit-extra >=1.1
|
||||
, data-default
|
||||
, directory
|
||||
@ -163,8 +171,6 @@ library
|
||||
, json
|
||||
, megaparsec >=6.4.1
|
||||
, mtl
|
||||
, parsec >=3
|
||||
, safe >=0.2
|
||||
, shakespeare >=2.0.2.2
|
||||
, template-haskell
|
||||
, text >=1.2
|
||||
@ -194,43 +200,7 @@ executable hledger-web
|
||||
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -fwarn-tabs
|
||||
cpp-options: -DVERSION="1.9.99"
|
||||
build-depends:
|
||||
HUnit
|
||||
, base >=4.8 && <4.12
|
||||
, base-compat-batteries >=0.10.1 && <0.11
|
||||
, blaze-html
|
||||
, blaze-markup
|
||||
, bytestring
|
||||
, clientsession
|
||||
, cmdargs >=0.10
|
||||
, conduit-extra >=1.1
|
||||
, data-default
|
||||
, directory
|
||||
, filepath
|
||||
, hjsmin
|
||||
, hledger >=1.9.99 && <2.0
|
||||
, hledger-lib >=1.9.99 && <2.0
|
||||
, hledger-web
|
||||
, http-client
|
||||
, http-conduit
|
||||
, json
|
||||
, megaparsec >=6.4.1
|
||||
, 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
|
||||
hledger-web
|
||||
if (flag(dev)) || (flag(library-only))
|
||||
cpp-options: -DDEVELOPMENT
|
||||
if flag(dev)
|
||||
@ -250,47 +220,11 @@ test-suite test
|
||||
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
|
||||
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -fwarn-tabs
|
||||
cpp-options: -DVERSION="1.9.99"
|
||||
build-depends:
|
||||
HUnit
|
||||
, base >=4.8 && <4.12
|
||||
, base-compat-batteries >=0.10.1 && <0.11
|
||||
, blaze-html
|
||||
, blaze-markup
|
||||
, bytestring
|
||||
, clientsession
|
||||
, cmdargs >=0.10
|
||||
, conduit-extra >=1.1
|
||||
, data-default
|
||||
, directory
|
||||
, filepath
|
||||
, hjsmin
|
||||
, hledger >=1.9.99 && <2.0
|
||||
, hledger-lib >=1.9.99 && <2.0
|
||||
, hledger-web
|
||||
hledger-web
|
||||
, hspec
|
||||
, http-client
|
||||
, http-conduit
|
||||
, json
|
||||
, megaparsec >=6.4.1
|
||||
, 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
|
||||
|
@ -60,43 +60,6 @@ flags:
|
||||
manual: false
|
||||
default: true
|
||||
|
||||
dependencies:
|
||||
- hledger-lib >=1.9.99 && <2.0
|
||||
- hledger >=1.9.99 && <2.0
|
||||
- base >=4.8 && <4.12
|
||||
- base-compat-batteries >=0.10.1 && <0.11
|
||||
- blaze-html
|
||||
- blaze-markup
|
||||
- bytestring
|
||||
- clientsession
|
||||
- cmdargs >=0.10
|
||||
- data-default
|
||||
- directory
|
||||
- filepath
|
||||
- hjsmin
|
||||
- http-conduit
|
||||
- http-client
|
||||
- HUnit
|
||||
- conduit-extra >=1.1
|
||||
- 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
|
||||
- json
|
||||
- megaparsec >=6.4.1
|
||||
- mtl
|
||||
- parsec >=3
|
||||
|
||||
when:
|
||||
- condition: (flag(dev)) || (flag(library-only))
|
||||
@ -133,6 +96,41 @@ library:
|
||||
- Settings.StaticFiles
|
||||
- Widget.AddForm
|
||||
- Widget.Common
|
||||
dependencies:
|
||||
- hledger-lib >=1.9.99 && <2.0
|
||||
- hledger >=1.9.99 && <2.0
|
||||
- base >=4.8 && <4.12
|
||||
- blaze-html
|
||||
- blaze-markup
|
||||
- bytestring
|
||||
- clientsession
|
||||
- cmdargs >=0.10
|
||||
- conduit
|
||||
- conduit-extra >=1.1
|
||||
- data-default
|
||||
- directory
|
||||
- filepath
|
||||
- hjsmin
|
||||
- http-conduit
|
||||
- http-client
|
||||
- json
|
||||
- megaparsec >=6.4.1
|
||||
- mtl
|
||||
- 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
|
||||
- HUnit
|
||||
|
||||
executables:
|
||||
hledger-web:
|
||||
|
@ -1,5 +1,9 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Application
|
||||
( makeApplication
|
||||
, getApplicationDev
|
||||
@ -17,9 +21,10 @@ import Yesod.Default.Config
|
||||
import Yesod.Default.Main (defaultDevelApp)
|
||||
|
||||
import Handler.AddR (getAddR, postAddR)
|
||||
import Handler.Common (getFaviconR, getRobotsR, getRootR)
|
||||
import Handler.Common
|
||||
(getDownloadR, getFaviconR, getManageR, getRobotsR, getRootR)
|
||||
import Handler.EditR (getEditR, postEditR)
|
||||
import Handler.ImportR (getImportR, postImportR)
|
||||
import Handler.UploadR (getUploadR, postUploadR)
|
||||
import Handler.JournalR (getJournalR)
|
||||
import Handler.RegisterR (getRegisterR)
|
||||
import Hledger.Data (Journal, nulljournal)
|
||||
@ -41,7 +46,7 @@ makeApplication :: WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Applic
|
||||
makeApplication opts' j' conf' = do
|
||||
foundation <- makeFoundation conf' opts'
|
||||
writeIORef (appJournal foundation) j'
|
||||
logWare <$> toWaiAppPlain foundation
|
||||
logWare <$> toWaiApp foundation
|
||||
where
|
||||
logWare | development = logStdoutDev
|
||||
| serve_ opts' = logStdout
|
||||
|
@ -1,5 +1,16 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE CPP, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
|
||||
{-# 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.
|
||||
|
||||
@ -86,21 +97,23 @@ instance Yesod App where
|
||||
defaultLayout widget = do
|
||||
master <- getYesod
|
||||
here <- fromMaybe RootR <$> getCurrentRoute
|
||||
VD {am, j, opts, q, qopts, showsidebar} <- getViewData
|
||||
VD {j, m, opts, q, qopts} <- getViewData
|
||||
msg <- getMessage
|
||||
showSidebar <- shouldShowSidebar
|
||||
|
||||
let journalcurrent = if here == JournalR then "inacct" else "" :: Text
|
||||
ropts = reportopts_ (cliopts_ opts)
|
||||
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 RegisterR j qopts $ balanceReport ropts' am j
|
||||
accounts =
|
||||
balanceReportAsHtml (JournalR, RegisterR) here 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
|
||||
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
|
||||
@ -158,50 +171,33 @@ data ViewData = VD
|
||||
, 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
|
||||
, am :: Query -- ^ a query parsed from the accounts sidebar query expr ("a" parameter)
|
||||
, aopts :: [QueryOpt] -- ^ query options parsed from the accounts sidebar query expr
|
||||
, 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 -> Text -> Text -> ViewData
|
||||
viewdataWithDateAndParams d q a =
|
||||
let (querymatcher, queryopts) = parseQuery d q
|
||||
(acctsmatcher, acctsopts) = parseQuery d a
|
||||
in VD
|
||||
{ opts = defwebopts
|
||||
, today = d
|
||||
, j = nulljournal
|
||||
, q = q
|
||||
, m = querymatcher
|
||||
, qopts = queryopts
|
||||
, am = acctsmatcher
|
||||
, aopts = acctsopts
|
||||
, showsidebar = True
|
||||
}
|
||||
|
||||
-- | Gather data used by handlers and templates in the current request.
|
||||
getViewData :: Handler ViewData
|
||||
getViewData = do
|
||||
App {appOpts, appJournal = jref} <- getYesod
|
||||
let opts@WebOpts {cliopts_ = copts@CliOpts {reportopts_ = ropts}} = appOpts
|
||||
y <- getYesod
|
||||
today <- liftIO getCurrentDay
|
||||
(j, merr) <- getCurrentJournal jref copts {reportopts_ = ropts {no_elide_ = True}} today
|
||||
case merr of
|
||||
Just err -> setMessage (toHtml err)
|
||||
Nothing -> pure ()
|
||||
let copts = cliopts_ (appOpts y)
|
||||
(j, merr) <-
|
||||
getCurrentJournal
|
||||
(appJournal y)
|
||||
copts {reportopts_ = (reportopts_ copts) {no_elide_ = True}}
|
||||
today
|
||||
maybe (pure ()) (setMessage . toHtml) merr
|
||||
q <- fromMaybe "" <$> lookupGetParam "q"
|
||||
a <- fromMaybe "" <$> lookupGetParam "a"
|
||||
showsidebar <- shouldShowSidebar
|
||||
let (querymatcher, queryopts) = parseQuery today q
|
||||
return
|
||||
(viewdataWithDateAndParams today q a)
|
||||
{j, opts, showsidebar, today}
|
||||
VD
|
||||
{ opts = appOpts y
|
||||
, today = today
|
||||
, j = j
|
||||
, q = q
|
||||
, m = querymatcher
|
||||
, qopts = queryopts
|
||||
}
|
||||
|
||||
-- | 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.
|
||||
@ -221,10 +217,9 @@ getCurrentJournal jref opts d = do
|
||||
(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
|
||||
else case filterJournalTransactions initq <$> ej of
|
||||
Right j' -> do
|
||||
liftIO $ writeIORef jref j'
|
||||
return (j',Nothing)
|
||||
|
@ -14,25 +14,26 @@ import Import
|
||||
import Hledger
|
||||
import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout)
|
||||
import Widget.AddForm (addForm)
|
||||
import Widget.Common (fromFormSuccess)
|
||||
|
||||
getAddR :: Handler Html
|
||||
getAddR = do
|
||||
VD {j, today} <- getViewData
|
||||
(view, enctype) <- generateFormPost $ addForm j today
|
||||
defaultLayout [whamlet|<div .row><form class="addform form col-xs-12" method=post enctype=#{enctype}>^{view}|]
|
||||
getAddR :: Handler ()
|
||||
getAddR = postAddR
|
||||
|
||||
postAddR :: Handler Html
|
||||
postAddR :: Handler ()
|
||||
postAddR = do
|
||||
VD{j, today} <- getViewData
|
||||
((res, view), enctype) <- runFormPost $ addForm j today
|
||||
case res of
|
||||
FormMissing -> defaultLayout [whamlet|<div .row><form class="addform form col-xs-12" method=post enctype=#{enctype}>^{view}|]
|
||||
FormFailure _ -> defaultLayout [whamlet|<div .row><form class="addform form col-xs-12" method=post enctype=#{enctype}>^{view}|]
|
||||
FormSuccess t -> do
|
||||
liftIO $ do
|
||||
t <- txnTieKnot <$> fromFormSuccess (showForm view enctype) res
|
||||
-- XXX(?) move into balanceTransaction
|
||||
ensureJournalFileExists (journalFilePath j)
|
||||
appendToJournalFileOrStdout (journalFilePath j) (showTransaction $ txnTieKnot t)
|
||||
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}
|
||||
|]
|
||||
|
@ -1,11 +1,36 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.Common
|
||||
( getRootR
|
||||
( getDownloadR
|
||||
, getFaviconR
|
||||
, getManageR
|
||||
, getRobotsR
|
||||
, getRootR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Yesod.Default.Handlers (getFaviconR, getRobotsR)
|
||||
|
||||
import Hledger (jfiles)
|
||||
import Widget.Common (journalFile404)
|
||||
|
||||
getRootR :: Handler Html
|
||||
getRootR = redirect JournalR
|
||||
|
||||
getManageR :: Handler Html
|
||||
getManageR = do
|
||||
VD{j} <- getViewData
|
||||
defaultLayout $ do
|
||||
setTitle "Manage journal"
|
||||
$(widgetFile "manage")
|
||||
|
||||
getDownloadR :: FilePath -> Handler TypedContent
|
||||
getDownloadR f = do
|
||||
(f', txt) <- journalFile404 f . j =<< getViewData
|
||||
addHeader "Content-Disposition" ("attachment; filename=\"" <> T.pack f' <> "\"")
|
||||
sendResponse ("text/plain" :: ByteString, toContent txt)
|
||||
|
@ -1,7 +1,9 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.EditR
|
||||
( getEditR
|
||||
@ -10,40 +12,34 @@ module Handler.EditR
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Widget.Common (fromFormSuccess, helplink, journalFile404, writeValidJournal)
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli.Utils
|
||||
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")]
|
||||
|
||||
editForm :: [(FilePath, Text)] -> Markup -> MForm Handler (FormResult (FilePath, Text), Widget)
|
||||
editForm journals = identifyForm "import" $ \extra -> do
|
||||
let files = fst <$> journals
|
||||
(jRes, jView) <- mreq (selectFieldList ((\x -> (T.pack x, x)) <$> files)) "journal" (listToMaybe files)
|
||||
(tRes, tView) <- mreq textareaField "text" (Textarea . snd <$> listToMaybe journals)
|
||||
pure ((,) <$> jRes <*> (unTextarea <$> tRes), [whamlet|
|
||||
#{extra}
|
||||
<p>
|
||||
^{fvInput jView}<br>
|
||||
^{fvInput tView}
|
||||
<input type=submit value="Introduce myself">
|
||||
|])
|
||||
getEditR :: FilePath -> Handler ()
|
||||
getEditR = postEditR
|
||||
|
||||
getEditR :: Handler Html
|
||||
getEditR = do
|
||||
postEditR :: FilePath -> Handler ()
|
||||
postEditR f = do
|
||||
VD {j} <- getViewData
|
||||
(view, enctype) <- generateFormPost (editForm $ jfiles j)
|
||||
defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|]
|
||||
|
||||
postEditR :: Handler Html
|
||||
postEditR = do
|
||||
VD {j} <- getViewData
|
||||
((res, view), enctype) <- runFormPost (editForm $ jfiles j)
|
||||
case res of
|
||||
FormMissing -> defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|]
|
||||
FormFailure _ -> defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|]
|
||||
FormSuccess (journalPath, text) -> do
|
||||
-- try to avoid unnecessary backups or saving invalid data
|
||||
_ <- liftIO $ first T.pack <$> readJournal def (Just journalPath) text
|
||||
_ <- liftIO $ writeFileWithBackupIfChanged journalPath text
|
||||
setMessage $ toHtml (printf "Saved journal %s\n" journalPath :: String)
|
||||
(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}|]
|
||||
|
@ -1,36 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Handler.ImportR
|
||||
( getImportR
|
||||
, postImportR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
importForm :: Markup -> MForm Handler (FormResult FileInfo, Widget)
|
||||
importForm = identifyForm "import" $ \extra -> do
|
||||
(res, view) <- mreq fileField "file" Nothing
|
||||
pure (res, [whamlet|
|
||||
#{extra}
|
||||
<p>
|
||||
Hello, my name is #
|
||||
^{fvInput view}
|
||||
<input type=submit value="Introduce myself">
|
||||
|])
|
||||
|
||||
getImportR :: Handler Html
|
||||
getImportR = do
|
||||
(view, enctype) <- generateFormPost importForm
|
||||
defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|]
|
||||
|
||||
-- | Handle a post from the journal import form.
|
||||
postImportR :: Handler Html
|
||||
postImportR = do
|
||||
((res, view), enctype) <- runFormPost importForm
|
||||
case res of
|
||||
FormMissing -> defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|]
|
||||
FormFailure _ -> defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|]
|
||||
FormSuccess _ -> do
|
||||
setMessage "File uploaded successfully"
|
||||
redirect JournalR
|
62
hledger-web/src/Handler/UploadR.hs
Normal file
62
hledger-web/src/Handler/UploadR.hs
Normal file
@ -0,0 +1,62 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.UploadR
|
||||
( getUploadR
|
||||
, postUploadR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Conduit (connect)
|
||||
import Data.Conduit.Binary (sinkLbs)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
|
||||
import 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 {j} <- getViewData
|
||||
(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}|]
|
@ -7,9 +7,9 @@ import Prelude as Import hiding (head, init, last,
|
||||
readFile, tail, writeFile)
|
||||
import Yesod as Import hiding (Route (..))
|
||||
|
||||
import Control.Arrow as Import ((&&&))
|
||||
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
|
||||
@ -20,7 +20,6 @@ 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 Text.Printf as Import (printf)
|
||||
|
||||
import Foundation as Import
|
||||
import Settings as Import
|
||||
|
@ -53,7 +53,6 @@ addForm j today = identifyForm "add" $ \extra -> do
|
||||
|
||||
pure (makeTransaction <$> dateRes <*> descRes <*> postRes, $(widgetFile "add-form"))
|
||||
where
|
||||
|
||||
makeTransaction date desc postings =
|
||||
nulltransaction {tdate = date, tdescription = desc, tpostings = postings}
|
||||
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
@ -10,31 +11,64 @@ module Widget.Common
|
||||
, helplink
|
||||
, mixedAmountAsHtml
|
||||
, numberTransactionsReportItems
|
||||
, fromFormSuccess
|
||||
, writeValidJournal
|
||||
, journalFile404
|
||||
) where
|
||||
|
||||
import Data.Foldable (for_)
|
||||
import Data.Default (def)
|
||||
import Data.Foldable (find, for_)
|
||||
import Data.List (mapAccumL)
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar (Day, toGregorian)
|
||||
import Text.Blaze
|
||||
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 Yesod
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli.Utils (writeFileWithBackupIfChanged)
|
||||
import Settings (manualurl)
|
||||
|
||||
journalFile404 :: FilePath -> Journal -> HandlerFor m (FilePath, Text)
|
||||
journalFile404 f j =
|
||||
case find ((== f) . fst) (jfiles j) of
|
||||
Just (_, txt) -> pure (takeFileName f, txt)
|
||||
Nothing -> notFound
|
||||
|
||||
fromFormSuccess :: HandlerFor m a -> FormResult a -> HandlerFor m a
|
||||
fromFormSuccess h FormMissing = h
|
||||
fromFormSuccess h (FormFailure _) = h
|
||||
fromFormSuccess _ (FormSuccess a) = return 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
|
||||
-- And write to the file
|
||||
_ <- 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 :: r -> Journal -> [QueryOpt] -> BalanceReport -> HtmlUrl r
|
||||
balanceReportAsHtml registerR j qopts (items, total) = [hamlet|
|
||||
balanceReportAsHtml :: Eq r => (r, r) -> r -> Journal -> [QueryOpt] -> BalanceReport -> HtmlUrl r
|
||||
balanceReportAsHtml (journalR, registerR) here j qopts (items, total) = [hamlet|
|
||||
<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 .#{inacctClass acct}>
|
||||
<td .acct>
|
||||
|
@ -1,5 +1,3 @@
|
||||
$maybe m <- msg
|
||||
<div #message .alert-primary>#{m}
|
||||
|
||||
<div#spacer .col-xs-2.#{topShowsm}.#{topShowmd}>
|
||||
<h1>
|
||||
@ -11,15 +9,11 @@ $maybe m <- msg
|
||||
|
||||
<div #sidebar-menu .sidebar-offcanvas.#{sideShowmd}.#{sideShowsm}>
|
||||
<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}
|
||||
|
||||
<div #main-content .col-xs-12.#{mainShowmd}.#{mainShowsm}>
|
||||
<div .col-xs-12.#{mainShowmd}.#{mainShowsm}>
|
||||
$maybe m <- msg
|
||||
<div #message .alert.alert-info>#{m}
|
||||
<div .row>
|
||||
<form#searchform .form-inline method=GET>
|
||||
<div .form-group .col-md-12 .col-sm-12 .col-xs-12>
|
||||
@ -34,6 +28,8 @@ $maybe m <- msg
|
||||
<span .glyphicon .glyphicon-search>
|
||||
<button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal"
|
||||
title="Show search and general help">?
|
||||
<a href="@{ManageR}" .btn.btn-default title="Manage journal files">
|
||||
<span .glyphicon .glyphicon-wrench>
|
||||
^{widget}
|
||||
|
||||
<div .modal.fade #helpmodal tabindex="-1" role="dialog" aria-labelledby="helpLabel" aria-hidden="true">
|
||||
|
@ -1,22 +1,17 @@
|
||||
<form#editform method=POST style=display:none;>
|
||||
<h2#contenttitle>Edit journal
|
||||
<table.form>
|
||||
$if length (jfiles j) > 1
|
||||
#{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>
|
||||
Editing ^{journalselect (fmap (T.unpack . snd) (jfiles j))}
|
||||
<td colspan=2 style="border:0">
|
||||
^{fvInput tView}
|
||||
<tr>
|
||||
<td colspan=2>
|
||||
<!-- XXX textarea ids are unquoted journal file paths here, not valid html -->
|
||||
$forall f <- jfiles j
|
||||
<textarea id=#{fst f}_textarea name=text rows=25 cols=80 style=display:none; disabled=disabled>
|
||||
\#{snd f}
|
||||
<tr#addbuttonrow>
|
||||
<td>
|
||||
<td style="border:0">
|
||||
<span.help>
|
||||
^{helplink "file-format" "file format help"}
|
||||
<td>
|
||||
<span.help>
|
||||
Are you sure ? This will overwrite the journal. #
|
||||
<input type=submit name=submit value="save">
|
||||
<a href="#" onclick="return editformToggle(event)">cancel
|
||||
^{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">
|
||||
|
@ -1,7 +0,0 @@
|
||||
<form#importform method=POST style=display:none;>
|
||||
<table.form>
|
||||
<tr>
|
||||
<td>
|
||||
<input type=file name=file>
|
||||
<input type=submit name=submit value="import from file">
|
||||
<a href="#" onclick="return importformToggle(event)">cancel
|
@ -1,4 +1,3 @@
|
||||
<div .row>
|
||||
<h2 #contenttitle>#{title'}
|
||||
<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">
|
||||
|
24
hledger-web/templates/manage.hamlet
Normal file
24
hledger-web/templates/manage.hamlet
Normal file
@ -0,0 +1,24 @@
|
||||
<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>
|
||||
#{path}
|
||||
<td style="text-align:right">
|
||||
<a href=@{EditR path}>
|
||||
Edit
|
||||
|
||||
<a href=@{UploadR path}>
|
||||
Upload
|
||||
|
||||
<a href=@{DownloadR path}>
|
||||
Download
|
14
hledger-web/templates/upload-form.hamlet
Normal file
14
hledger-web/templates/upload-form.hamlet
Normal file
@ -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}
|
Loading…
Reference in New Issue
Block a user