From 4faf0d8b4a7115b5c88fc2c493655b3843ce14f7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jakub=20Z=C3=A1rybnick=C3=BD?= <jakub.zarybnicky@inuits.eu>
Date: Sat, 9 Jun 2018 15:31:41 +0200
Subject: [PATCH] web: Resurrect ImportForm and EditForm

---
 hledger-web/Application.hs               | 23 ++++----
 hledger-web/Handler/Common.hs            | 46 ---------------
 hledger-web/Handler/EditForm.hs          | 75 ------------------------
 hledger-web/Handler/EditR.hs             | 46 +++++++++++++++
 hledger-web/Handler/ImportForm.hs        | 18 ------
 hledger-web/Handler/ImportR.hs           | 29 +++++++++
 hledger-web/Import.hs                    |  1 +
 hledger-web/config/routes                |  2 +
 hledger-web/hledger-web.cabal            |  2 +
 hledger-web/package.yaml                 |  4 +-
 hledger-web/templates/edit-form.hamlet   | 24 ++++++++
 hledger-web/templates/import-form.hamlet |  9 +++
 12 files changed, 127 insertions(+), 152 deletions(-)
 delete mode 100644 hledger-web/Handler/EditForm.hs
 create mode 100644 hledger-web/Handler/EditR.hs
 delete mode 100644 hledger-web/Handler/ImportForm.hs
 create mode 100644 hledger-web/Handler/ImportR.hs
 create mode 100644 hledger-web/templates/edit-form.hamlet
 create mode 100644 hledger-web/templates/import-form.hamlet

diff --git a/hledger-web/Application.hs b/hledger-web/Application.hs
index ca87b20b3..f8809a2e6 100644
--- a/hledger-web/Application.hs
+++ b/hledger-web/Application.hs
@@ -17,9 +17,9 @@ import Yesod.Default.Config
 import Yesod.Default.Main (defaultDevelApp)
 import Yesod.Default.Handlers (getFaviconR, getRobotsR)
 
--- Import all relevant handler modules here.
--- Don't forget to add new modules to your cabal file!
 import Handler.AddR (postAddR)
+import Handler.EditR (postEditR)
+import Handler.ImportR (postImportR)
 import Handler.JournalR (getJournalR)
 import Handler.RegisterR (getRegisterR)
 import Handler.RootR (getRootR)
@@ -41,30 +41,29 @@ mkYesodDispatch "App" resourcesApp
 -- 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
+makeApplication opts' j' conf' = do
+    foundation <- makeFoundation conf' opts'
+    writeIORef (appJournal foundation) j'
+    logWare <$> toWaiAppPlain foundation
   where
     logWare | development  = logStdoutDev
-            | serve_ opts  = logStdout
+            | serve_ opts'  = logStdout
             | otherwise    = id
 
 makeFoundation :: AppConfig DefaultEnv Extra -> WebOpts -> IO App
-makeFoundation conf opts = do
+makeFoundation conf opts' = do
     manager <- newManager defaultManagerSettings
     s <- staticSite
     jref <- newIORef nulljournal
-    return $ App conf s manager opts jref
+    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)
+  j' <- either error' id <$> readJournalFile def f
+  defaultDevelApp loader (makeApplication defwebopts j')
   where
     loader = Yesod.Default.Config.loadConfig (configSettings Development)
         { csParseExtra = parseExtra
diff --git a/hledger-web/Handler/Common.hs b/hledger-web/Handler/Common.hs
index fad5fe281..5543866ad 100644
--- a/hledger-web/Handler/Common.hs
+++ b/hledger-web/Handler/Common.hs
@@ -114,52 +114,6 @@ searchform VD{q, here} = [hamlet|
       <button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal" title="Show search and general help">?
 |]
 
--- -- | 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 :: Text -> Text -> HtmlUrl AppRoute
 helplink topic label = [hamlet|
diff --git a/hledger-web/Handler/EditForm.hs b/hledger-web/Handler/EditForm.hs
deleted file mode 100644
index 6d6807e80..000000000
--- a/hledger-web/Handler/EditForm.hs
+++ /dev/null
@@ -1,75 +0,0 @@
--- -- | Handle a post from the journal edit form.
--- handleEdit :: Handler Html
--- handleEdit = do
---   VD{..} <- getViewData
---   -- get form input values, or validation errors.
---   -- getRequest >>= liftIO (reqRequestBody req) >>= mtrace
---   mtext <- lookupPostParam "text"
---   mtrace "--------------------------"
---   mtrace (journalFilePaths j)
---   mjournalpath <- lookupPostParam "journal"
---   let etext = maybe (Left "No value provided") (Right . unpack) mtext
---       ejournalpath = maybe
---                        (Right $ journalFilePath j)
---                        (\f -> let f' = unpack f in
---                               if f' `elem` dbg0 "paths2" (journalFilePaths j)
---                               then Right f'
---                               else Left ("unrecognised journal file path"::String))
---                        mjournalpath
---       estrs = [etext, ejournalpath]
---       errs = lefts estrs
---       [text,journalpath] = rights estrs
---   -- display errors or perform edit
---   if not $ null errs
---    then do
---     setMessage $ toHtml (intercalate "; " errs :: String)
---     redirect JournalR
-
--- -- | Handle a post from the journal edit form.
--- handleEdit :: Handler Html
--- handleEdit = do
---   VD{..} <- getViewData
---   -- get form input values, or validation errors.
---   -- getRequest >>= liftIO (reqRequestBody req) >>= mtrace
---   mtext <- lookupPostParam "text"
---   mjournalpath <- lookupPostParam "journal"
---   let etext = maybe (Left "No value provided") (Right . unpack) mtext
---       ejournalpath = maybe
---                        (Right $ journalFilePath j)
---                        (\f -> let f' = unpack f in
---                               if f' `elem` journalFilePaths j
---                               then Right f'
---                               else Left ("unrecognised journal file path"::String))
---                        mjournalpath
---       estrs = [etext, ejournalpath]
---       errs = lefts estrs
---       [text,journalpath] = rights estrs
---   -- display errors or perform edit
---   if not $ null errs
---    then do
---     setMessage $ toHtml (intercalate "; " errs :: String)
---     redirect JournalR
-
---    else do
---     -- try to avoid unnecessary backups or saving invalid data
---     filechanged' <- liftIO $ journalSpecifiedFileIsNewer j journalpath
---     told <- liftIO $ readFileStrictly journalpath
---     let tnew = filter (/= '\r') text
---         changed = tnew /= told || filechanged'
---     if not changed
---      then do
---        setMessage "No change"
---        redirect JournalR
---      else do
---       jE <- liftIO $ readJournal def (Just journalpath) tnew
---       either
---        (\e -> do
---           setMessage $ toHtml e
---           redirect JournalR)
---        (const $ do
---           liftIO $ writeFileWithBackup journalpath tnew
---           setMessage $ toHtml (printf "Saved journal %s\n" (show journalpath) :: String)
---           redirect JournalR)
---        jE
-
-
diff --git a/hledger-web/Handler/EditR.hs b/hledger-web/Handler/EditR.hs
new file mode 100644
index 000000000..58657c8dc
--- /dev/null
+++ b/hledger-web/Handler/EditR.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Handler.EditR
+  ( postEditR
+  ) where
+
+import Import
+
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Except
+import qualified Data.Text as T
+import Text.Printf (printf)
+
+import Handler.Common (showErrors)
+
+import Hledger
+import Hledger.Cli.Utils
+
+-- | Handle a post from the journal edit form.
+postEditR :: Handler ()
+postEditR = runE $ do
+  VD {j} <- lift getViewData
+  -- get form input values, or validation errors.
+  text <- ExceptT $ maybe (Left "No value provided") Right <$> lookupPostParam "text"
+  journalpath <- ExceptT $ maybe
+    (Right . T.pack $ journalFilePath j)
+    (\f ->
+       if T.unpack f `elem` journalFilePaths j
+         then Right f
+         else Left "unrecognised journal file path") <$>
+    lookupPostParam "journal"
+  -- try to avoid unnecessary backups or saving invalid data
+  let tnew = T.filter (/= '\r') text
+
+  jE <- liftIO $ readJournal def (Just $ T.unpack journalpath) tnew
+  _ <- ExceptT . pure $ first T.pack jE
+  _ <- liftIO $ writeFileWithBackupIfChanged (T.unpack journalpath) tnew
+  setMessage $ toHtml (printf "Saved journal %s\n" (show journalpath) :: String)
+  redirect JournalR
+  where
+    runE :: ExceptT Text Handler () -> Handler ()
+    runE f = runExceptT f >>= \case
+      Left e -> showErrors [e] >> redirect JournalR
+      Right x -> pure x
diff --git a/hledger-web/Handler/ImportForm.hs b/hledger-web/Handler/ImportForm.hs
deleted file mode 100644
index 1f509f0c5..000000000
--- a/hledger-web/Handler/ImportForm.hs
+++ /dev/null
@@ -1,18 +0,0 @@
--- -- | Handle a post from the journal import form.
--- handleImport :: Handler Html
--- handleImport = do
---   setMessage "can't handle file upload yet"
---   redirect JournalR
---   -- -- get form input values, or basic validation errors. E means an Either value.
---   -- fileM <- runFormPost $ maybeFileInput "file"
---   -- let fileE = maybe (Left "No file provided") Right fileM
---   -- -- display errors or import transactions
---   -- case fileE of
---   --  Left errs -> do
---   --   setMessage errs
---   --   redirect JournalR
-
---   --  Right s -> do
---   --    setMessage s
---   --    redirect JournalR
-
diff --git a/hledger-web/Handler/ImportR.hs b/hledger-web/Handler/ImportR.hs
new file mode 100644
index 000000000..c209639f1
--- /dev/null
+++ b/hledger-web/Handler/ImportR.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Handler.ImportR
+  ( postImportR
+  ) where
+
+import Import
+
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Except
+
+import Handler.Common (showErrors)
+
+-- | Handle a post from the journal import form.
+postImportR :: Handler ()
+postImportR = runE $ do
+  ((res, _), _) <- lift . runFormPost . renderDivs $ areq fileField "file" Nothing
+  case res of
+    FormMissing -> throwE ["No file provided"]
+    FormFailure es -> throwE es
+    FormSuccess _ -> do
+     setMessage "File uploaded successfully"
+     redirect JournalR
+  where
+    runE :: ExceptT [Text] Handler () -> Handler ()
+    runE f = runExceptT f >>= \case
+      Left e -> showErrors e >> redirect JournalR
+      Right x -> pure x
diff --git a/hledger-web/Import.hs b/hledger-web/Import.hs
index af797ba9a..54994bb9a 100644
--- a/hledger-web/Import.hs
+++ b/hledger-web/Import.hs
@@ -9,6 +9,7 @@ import           Yesod                as Import hiding (Route (..))
 
 import           Control.Monad        as Import (when, unless, void)
 import           Data.Bifunctor       as Import (first, second, bimap)
+import           Data.Default         as Import (Default(def))
 import           Data.Either          as Import (lefts, rights, partitionEithers)
 import           Data.Maybe           as Import (fromMaybe, maybeToList, mapMaybe, isJust)
 import           Data.Text            as Import (Text)
diff --git a/hledger-web/config/routes b/hledger-web/config/routes
index 4b918f285..ffd8ce11f 100644
--- a/hledger-web/config/routes
+++ b/hledger-web/config/routes
@@ -6,6 +6,8 @@
 /register        RegisterR       GET
 /sidebar         SidebarR        GET
 /add             AddR            POST
+/edit            EditR           POST
+/import          ImportR         POST
 
 -- /accounts        AccountsR       GET
 -- /api/accounts    AccountsJsonR   GET
diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal
index bb558cc6d..063eff6a1 100644
--- a/hledger-web/hledger-web.cabal
+++ b/hledger-web/hledger-web.cabal
@@ -125,6 +125,8 @@ library
       Handler.AddForm
       Handler.AddR
       Handler.Common
+      Handler.EditR
+      Handler.ImportR
       Handler.JournalR
       Handler.RegisterR
       Handler.RootR
diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml
index 5f3416930..58f8087cf 100644
--- a/hledger-web/package.yaml
+++ b/hledger-web/package.yaml
@@ -118,8 +118,10 @@ library:
   - Application
   - Foundation
   - Handler.AddForm
-  - Handler.Common
   - Handler.AddR
+  - Handler.Common
+  - Handler.EditR
+  - Handler.ImportR
   - Handler.JournalR
   - Handler.RegisterR
   - Handler.RootR
diff --git a/hledger-web/templates/edit-form.hamlet b/hledger-web/templates/edit-form.hamlet
new file mode 100644
index 000000000..22bef0577
--- /dev/null
+++ b/hledger-web/templates/edit-form.hamlet
@@ -0,0 +1,24 @@
+<form#editform method=POST style=display:none;>
+  <h2#contenttitle>Edit journal
+  <table.form>
+    $if length (jfiles j) > 1
+     <tr>
+       <td colspan=2>
+         Editing ^{journalselect (fmap (T.unpack . snd) (jfiles j))}
+    <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>
+        <span.help>
+          ^{helplink "file-format" "file format help"}
+      <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
diff --git a/hledger-web/templates/import-form.hamlet b/hledger-web/templates/import-form.hamlet
new file mode 100644
index 000000000..f7899a086
--- /dev/null
+++ b/hledger-web/templates/import-form.hamlet
@@ -0,0 +1,9 @@
+<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