diff --git a/hledger-web/config/routes b/hledger-web/config/routes index bc49cf0d2..f33b12441 100644 --- a/hledger-web/config/routes +++ b/hledger-web/config/routes @@ -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 diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 09cfe8df3..4bd71d581 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -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 diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml index a44b2037d..2ad07afc3 100644 --- a/hledger-web/package.yaml +++ b/hledger-web/package.yaml @@ -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: diff --git a/hledger-web/src/Application.hs b/hledger-web/src/Application.hs index 697316d64..9bf548ca2 100644 --- a/hledger-web/src/Application.hs +++ b/hledger-web/src/Application.hs @@ -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 diff --git a/hledger-web/src/Foundation.hs b/hledger-web/src/Foundation.hs index 24fe05062..6b82e4381 100644 --- a/hledger-web/src/Foundation.hs +++ b/hledger-web/src/Foundation.hs @@ -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 _ = "" --- | 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) diff --git a/hledger-web/src/Handler/AddR.hs b/hledger-web/src/Handler/AddR.hs index c6509c054..fdf25040c 100644 --- a/hledger-web/src/Handler/AddR.hs +++ b/hledger-web/src/Handler/AddR.hs @@ -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|
^{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|
^{view}|] - FormFailure _ -> defaultLayout [whamlet|
^{view}|] - FormSuccess t -> do - liftIO $ do - -- XXX(?) move into balanceTransaction - ensureJournalFileExists (journalFilePath j) - appendToJournalFileOrStdout (journalFilePath j) (showTransaction $ txnTieKnot t) - setMessage "Transaction added." - redirect JournalR - + 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| +

Add transaction +
+ + ^{view} + |] diff --git a/hledger-web/src/Handler/Common.hs b/hledger-web/src/Handler/Common.hs index 2dc311d46..814148150 100644 --- a/hledger-web/src/Handler/Common.hs +++ b/hledger-web/src/Handler/Common.hs @@ -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) diff --git a/hledger-web/src/Handler/EditR.hs b/hledger-web/src/Handler/EditR.hs index b815f6c3f..71a3bb7e5 100644 --- a/hledger-web/src/Handler/EditR.hs +++ b/hledger-web/src/Handler/EditR.hs @@ -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} -

- ^{fvInput jView}
- ^{fvInput tView} - - |]) +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|^{view}|] - -postEditR :: Handler Html -postEditR = do - VD {j} <- getViewData - ((res, view), enctype) <- runFormPost (editForm $ jfiles j) - case res of - FormMissing -> defaultLayout [whamlet|^{view}|] - FormFailure _ -> defaultLayout [whamlet|^{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|^{view}|] diff --git a/hledger-web/src/Handler/ImportR.hs b/hledger-web/src/Handler/ImportR.hs deleted file mode 100644 index 60cf407d4..000000000 --- a/hledger-web/src/Handler/ImportR.hs +++ /dev/null @@ -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} -

- Hello, my name is # - ^{fvInput view} - - |]) - -getImportR :: Handler Html -getImportR = do - (view, enctype) <- generateFormPost importForm - defaultLayout [whamlet|^{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|^{view}|] - FormFailure _ -> defaultLayout [whamlet|^{view}|] - FormSuccess _ -> do - setMessage "File uploaded successfully" - redirect JournalR diff --git a/hledger-web/src/Handler/UploadR.hs b/hledger-web/src/Handler/UploadR.hs new file mode 100644 index 000000000..29b2a1f2b --- /dev/null +++ b/hledger-web/src/Handler/UploadR.hs @@ -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|^{view}|] diff --git a/hledger-web/src/Import.hs b/hledger-web/src/Import.hs index dc8d8afc3..e5e41abf3 100644 --- a/hledger-web/src/Import.hs +++ b/hledger-web/src/Import.hs @@ -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 diff --git a/hledger-web/src/Widget/AddForm.hs b/hledger-web/src/Widget/AddForm.hs index edfeab86a..5cb8f3675 100644 --- a/hledger-web/src/Widget/AddForm.hs +++ b/hledger-web/src/Widget/AddForm.hs @@ -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} diff --git a/hledger-web/src/Widget/Common.hs b/hledger-web/src/Widget/Common.hs index 93c142ff5..7a26c0a4a 100644 --- a/hledger-web/src/Widget/Common.hs +++ b/hledger-web/src/Widget/Common.hs @@ -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| + + + + Journal + $forall (acct, adisplay, aindent, abal) <- items diff --git a/hledger-web/templates/default-layout.hamlet b/hledger-web/templates/default-layout.hamlet index ebc742d7d..e0cc684a7 100644 --- a/hledger-web/templates/default-layout.hamlet +++ b/hledger-web/templates/default-layout.hamlet @@ -1,5 +1,3 @@ -$maybe m <- msg -

#{m}

@@ -11,15 +9,11 @@ $maybe m <- msg
- - - -
- - Journal - ^{accounts} -
- Editing ^{journalselect (fmap (T.unpack . snd) (jfiles j))} -
- - $forall f <- jfiles j -