web: Add /manage page, implement /edit, /upload, and /download

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

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
+      hledger-web
-    , 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
   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
+      hledger-web
-    , 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
     , 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

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:

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

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
+    let ropts = reportopts_ (cliopts_ opts)
-        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
+        topShowmd = if showSidebar then "col-md-4" else "col-any-0" :: Text
-        topShowsm = if showsidebar then "col-sm-4" else "" :: Text
+        topShowsm = if showSidebar then "col-sm-4" else "" :: Text
-        sideShowmd = if showsidebar then "col-md-4" else "col-any-0" :: Text
+        sideShowmd = if showSidebar then "col-md-4" else "col-any-0" :: Text
-        sideShowsm = if showsidebar then "col-sm-4" else "" :: Text
+        sideShowsm = if showSidebar then "col-sm-4" else "" :: Text
-        mainShowmd = if showsidebar then "col-md-8" else "col-md-12" :: 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
+        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
+  y <- getYesod
-  let opts@WebOpts {cliopts_ = copts@CliOpts {reportopts_ = ropts}} = appOpts
   today <- liftIO getCurrentDay
-  (j, merr) <- getCurrentJournal jref copts {reportopts_ = ropts {no_elide_ = True}} today
+  let copts = cliopts_ (appOpts y)
-  case merr of
+  (j, merr) <-
-    Just err -> setMessage (toHtml err)
+    getCurrentJournal
-    Nothing -> pure ()
+      (appJournal y)
+      copts {reportopts_ = (reportopts_ copts) {no_elide_ = True}}
+      today
+  maybe (pure ()) (setMessage . toHtml) merr
   q <- fromMaybe "" <$> lookupGetParam "q"
-  a <- fromMaybe "" <$> lookupGetParam "a"
+  let (querymatcher, queryopts) = parseQuery today q
-  showsidebar <- shouldShowSidebar
   return
-    (viewdataWithDateAndParams today q a)
+    VD
-    {j, opts, showsidebar, today}
+    { 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)

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 :: Handler ()
-getAddR = do
+getAddR = postAddR
-  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}|]
 
-postAddR :: Handler Html
+postAddR :: Handler ()
 postAddR = do
   VD{j, today} <- getViewData
   ((res, view), enctype) <- runFormPost $ addForm j today
-  case res of
+  t <- txnTieKnot <$> fromFormSuccess (showForm view enctype) res
-    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
   -- XXX(?) move into balanceTransaction
-        ensureJournalFileExists (journalFilePath j)
+  liftIO $ ensureJournalFileExists (journalFilePath j)
-        appendToJournalFileOrStdout (journalFilePath j) (showTransaction $ txnTieKnot t)
+  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}
+      |]

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)

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
+editForm :: FilePath -> Text -> Markup -> MForm Handler (FormResult Text, Widget)
-import Hledger.Cli.Utils
+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)
+getEditR :: FilePath -> Handler ()
-editForm journals = identifyForm "import" $ \extra -> do
+getEditR = postEditR
-  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 :: Handler Html
+postEditR :: FilePath -> Handler ()
-getEditR = do
+postEditR f = do
   VD {j} <- getViewData
-  (view, enctype) <- generateFormPost (editForm $ jfiles j)
+  (f', txt) <- journalFile404 f j
-  defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|]
+  ((res, view), enctype) <- runFormPost (editForm f' txt)
-
+  text <- fromFormSuccess (showForm view enctype) res
-postEditR :: Handler Html
+  writeValidJournal f text >>= \case
-postEditR = do
+    Left e -> do
-  VD {j} <- getViewData
+      setMessage $ "Failed to load journal: " <> toHtml e
-  ((res, view), enctype) <- runFormPost (editForm $ jfiles j)
+      showForm view enctype
-  case res of
+    Right () -> do
-    FormMissing -> defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|]
+      setMessage $ "Saved journal " <> toHtml f <> "\n"
-    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)
       redirect JournalR
+  where
+    showForm view enctype =
+      sendResponse <=< defaultLayout $ do
+        setTitle "Edit journal"
+        [whamlet|<form method=post enctype=#{enctype}>^{view}|]

hledger-web/src/Handler/ImportR.hs

@@ -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

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|<form method=post enctype=#{enctype}>^{view}|]

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

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}
 

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 :: Eq r => (r, r) -> r -> Journal -> [QueryOpt] -> BalanceReport -> HtmlUrl r
-balanceReportAsHtml registerR j qopts (items, total) = [hamlet|
+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>

hledger-web/templates/default-layout.hamlet

@@ -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">

hledger-web/templates/edit-form.hamlet

@@ -1,22 +1,17 @@
-<form#editform method=POST style=display:none;>
+#{extra}
-  <h2#contenttitle>Edit journal
+<h2>
-  <table.form>
+  Edit file #
-    $if length (jfiles j) > 1
+  <i>#{f}
+<div.alert.alert-danger>
+  Are you sure? This will overwrite your journal!
+<table.table.table-condensed>
   <tr>
-        <td colspan=2>
+    <td colspan=2 style="border:0">
-          Editing ^{journalselect (fmap (T.unpack . snd) (jfiles j))}
+      ^{fvInput tView}
   <tr>
-      <td colspan=2>
+    <td style="border:0">
-        <!-- 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>
       <span.help>
-          ^{helplink "file-format" "file format help"}
+        ^{helplink "file-format" "File format help"}
-      <td>
+    <td .text-right style="border:0">
-        <span.help>
+      <a.btn.btn-default href="@{ManageR}">Go back
-          Are you sure ? This will overwrite the journal. #
+      <input.btn.btn-default type=submit value="Save">
-        <input type=submit name=submit value="save">
-        <a href="#" onclick="return editformToggle(event)">cancel

hledger-web/templates/import-form.hamlet

@@ -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

hledger-web/templates/journal.hamlet

@@ -1,6 +1,5 @@
-<div .row>
+<h2 #contenttitle>#{title'}
-  <h2 #contenttitle>#{title'}
+<a #addformlink href="#" role="button" style="cursor:pointer; margin-top:1em;"
-  <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
 

hledger-web/templates/manage.hamlet

@@ -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
+              &nbsp;&nbsp;
+              <a href=@{UploadR path}>
+                Upload
+              &nbsp;&nbsp;
+              <a href=@{DownloadR path}>
+                Download

hledger-web/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}