web: Split long functions, remove unused parameters

hledger-web/Foundation.hs

@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE CPP, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RecordWildCards, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
 -- | Define the web application's foundation, in the usual Yesod style.
 --   See a default Yesod app's comments for more details of each part.
 
@@ -21,7 +21,7 @@ import Yesod.Static
 import Yesod.Default.Config
 
 import Settings.StaticFiles
-import Settings (staticRoot, widgetFile, Extra (..))
+import Settings (widgetFile, Extra (..))
 #ifndef DEVELOPMENT
 import Settings (staticDir)
 import Text.Jasmine (minifym)
@@ -115,7 +115,6 @@ instance Yesod App where
             addScript $ StaticR hledger_js
             $(widgetFile "default-layout")
 
-        staticRootUrl <- (staticRoot . settings) <$> getYesod
         withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
 #ifndef DEVELOPMENT
@@ -180,25 +179,18 @@ viewdataWithDateAndParams d q a =
 
 -- | Gather data used by handlers and templates in the current request.
 getViewData :: Handler ViewData
-getViewData = do
+getViewData = getCurrentRoute >>= \case
-  mhere      <- getCurrentRoute
-  case mhere of
     Nothing -> return nullviewdata
     Just here -> do
-      app        <- getYesod
+      App {appOpts, appJournal} <- getYesod
-      let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app
+      let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts
       today      <- liftIO getCurrentDay
-      (j, merr)  <- getCurrentJournal app copts{reportopts_=ropts{no_elide_=True}} today
+      (j, merr)  <- getCurrentJournal appJournal copts{reportopts_=ropts{no_elide_=True}} today
       lastmsg    <- getLastMessage
       let msg = maybe lastmsg (Just . toHtml) merr
       q          <- fromMaybe "" <$> lookupGetParam "q"
       a          <- fromMaybe "" <$> lookupGetParam "a"
-      -- sidebar visibility: show it, unless there is a showsidebar cookie
+      showsidebar <- shouldShowSidebar
-      -- set to "0", or a ?sidebar=0 query parameter.
-      msidebarparam <- lookupGetParam "sidebar"
-      msidebarcookie <- reqCookies <$> getRequest >>= return . lookup "showsidebar"
-      let showsidebar = maybe (msidebarcookie /= Just "0") (/="0") msidebarparam
-
       return (viewdataWithDateAndParams today q a){
                    opts=opts
                   ,msg=msg
@@ -207,14 +199,22 @@ getViewData = do
                   ,j=j
                   ,showsidebar=showsidebar
                   }
-        where
+
+-- | Find out if the sidebar should be visible. Show it, unless there is a
+-- showsidebar cookie set to "0", or a ?sidebar=0 query parameter.
+shouldShowSidebar :: Handler Bool
+shouldShowSidebar = do
+  msidebarparam <- lookupGetParam "sidebar"
+  msidebarcookie <- lookup "showsidebar" . reqCookies <$> getRequest
+  return $ maybe (msidebarcookie /= Just "0") (/="0") msidebarparam
+
 -- | Update our copy of the journal if the file changed. If there is an
 -- error while reloading, keep the old one and return the error, and set a
 -- ui message.
-          getCurrentJournal :: App -> CliOpts -> Day -> Handler (Journal, Maybe String)
+getCurrentJournal :: IORef Journal -> CliOpts -> Day -> Handler (Journal, Maybe String)
-          getCurrentJournal app opts d = do
+getCurrentJournal jref opts d = do
   -- XXX put this inside atomicModifyIORef' for thread safety
-            j <- liftIO $ readIORef $ appJournal app
+  j <- liftIO (readIORef jref)
   (ej, changed) <- liftIO $ journalReloadIfChanged opts d j
   -- re-apply any initial filter specified at startup
   let initq = queryFromOpts d $ reportopts_ opts
@@ -222,9 +222,11 @@ getViewData = do
   if not changed
     then return (j,Nothing)
     else case ej' of
-                    Right j' -> do liftIO $ writeIORef (appJournal app) j'
+           Right j' -> do
+             liftIO $ writeIORef jref j'
              return (j',Nothing)
-                    Left e   -> do setMessage "error while reading"
+           Left e -> do
+             setMessage "error while reading journal"
              return (j, Just e)
 
 -- | Get the message that was set by the last request, in a
@@ -235,8 +237,8 @@ getLastMessage = cached getMessage
 -- add form dialog, part of the default template
 
 -- | Add transaction form.
-addform :: Text -> ViewData -> HtmlUrl AppRoute
+addform :: ViewData -> HtmlUrl AppRoute
-addform _ vd@VD{..} = [hamlet|
+addform VD{..} = [hamlet|
 
 <script>
   jQuery(document).ready(function() {
@@ -281,7 +283,7 @@ addform _ vd@VD{..} = [hamlet|
     <input #description required .typeahead .form-control .input-lg type=text size=40 name=description placeholder="Description">
  <div .account-postings>
   $forall n <- postingnums
-    ^{postingfields vd n}
+    ^{postingfields n}
  <div .col-md-8 .col-xs-8 .col-sm-8>
  <div .col-md-4 .col-xs-4 .col-sm-4>
   <button type=submit .btn .btn-default .btn-lg name=submit>add
@@ -303,8 +305,8 @@ addform _ vd@VD{..} = [hamlet|
   numpostings = 4
   postingnums = [1..numpostings]
   filepaths = map fst $ jfiles j
-  postingfields :: ViewData -> Int -> HtmlUrl AppRoute
+  postingfields :: Int -> HtmlUrl AppRoute
-  postingfields _ n = [hamlet|
+  postingfields n = [hamlet|
 <div .form-group .row .account-group ##{grpvar}>
  <div .col-md-8 .col-xs-8 .col-sm-8>
   <input ##{acctvar} .account-input .typeahead .form-control .input-lg type=text name=#{acctvar} placeholder="#{acctph}">

hledger-web/Handler/AddForm.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, TypeFamilies #-}
+{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, ScopedTypeVariables, TypeFamilies #-}
 -- | Add form data & handler. (The layout and js are defined in
 -- Foundation so that the add form can be in the default layout for
 -- all views.)
@@ -8,13 +8,12 @@ module Handler.AddForm where
 import Import
 
 import Control.Monad.State.Strict (evalStateT)
-import Data.Either (lefts, rights)
+import Data.List (sortBy)
-import Data.List (sort)
-import Data.Maybe (fromMaybe, maybeToList)
 import qualified Data.Text as T
 import Data.Time.Calendar
 import Data.Void (Void)
 import Safe (headMay)
+import Text.Blaze (ToMarkup)
 import Text.Megaparsec
 import Text.Megaparsec.Char
 
@@ -30,31 +29,26 @@ data AddForm = AddForm
     , addFormJournalFile  :: Maybe Text
     } deriving Show
 
-postAddForm :: Handler Html
+addForm :: Day -> Journal -> FormInput Handler AddForm
-postAddForm = do
+addForm today j = AddForm
-  let showErrors errs = do
+    <$> ireq (checkMMap (pure . validateDate) (T.pack . show) textField) "date"
-        setMessage [shamlet|
+    <*> iopt textField "description"
-                    Errors:<br>
+    <*> iopt (check validateJournalFile textField) "journal"
-                    $forall e<-errs
+  where
-                     \#{e}<br>
+    validateJournalFile :: Text -> Either FormMessage Text
-                   |]
-  -- 1. process the fixed fields with yesod-form
-
-  VD{..} <- getViewData
-  let validateJournalFile :: Text -> Either FormMessage Text
     validateJournalFile f
       | T.unpack f `elem` journalFilePaths j = Right f
       | otherwise = Left $ MsgInvalidEntry $ "the selected journal file \"" <> f <> "\"is unknown"
-
     validateDate :: Text -> Either FormMessage Day
     validateDate s = case fixSmartDateStrEither' today (T.strip s) of
       Right d  -> Right d
       Left _   -> Left $ MsgInvalidEntry $ "could not parse date \"" <> s <> "\":"
 
-  formresult <- runInputPostResult $ AddForm
+postAddForm :: Handler Html
-    <$> ireq (checkMMap (pure . validateDate) (T.pack . show) textField) "date"
+postAddForm = do
-    <*> iopt textField "description"
+  -- 1. process the fixed fields with yesod-form
-    <*> iopt (check validateJournalFile textField) "journal"
+  VD{..} <- getViewData
+  formresult <- runInputPostResult (addForm today j)
 
   ok <- case formresult of
     FormMissing      -> showErrors ["there is no form data" :: Text] >> return False
@@ -72,16 +66,8 @@ postAddForm = do
       -- getting either errors or a balanced transaction
 
       (params,_) <- runRequestBody
-      let numberedParams s =
+      let acctparams = parseNumberedParameters "account" params
-            reverse $ dropWhile (T.null . snd) $ reverse $ sort
+          amtparams  = parseNumberedParameters "amount" params
-            [ (n,v) | (k,v) <- params
-                    , let en = parsewith (paramnamep s) k :: Either (ParseError Char Void) Int
-                    , isRight en
-                    , let Right n = en
-                    ]
-            where paramnamep s = do {string s; n <- some digitChar; eof; return (read n :: Int)}
-          acctparams = numberedParams "account"
-          amtparams  = numberedParams "amount"
           num = length acctparams
           paramErrs | num == 0 = ["at least one posting must be entered"]
                     | map fst acctparams == [1..num] &&
@@ -105,12 +91,32 @@ postAddForm = do
        Left errs -> showErrors errs >> return False
        Right t -> do
         -- 3. all fields look good and form a balanced transaction; append it to the file
-        liftIO $ do ensureJournalFileExists journalfile
+        liftIO (appendTransaction journalfile t)
-                    appendToJournalFileOrStdout journalfile $
-                      showTransaction $
-                      txnTieKnot -- XXX move into balanceTransaction
-                      t
         setMessage [shamlet|<span>Transaction added.|]
         return True
 
   if ok then redirect JournalR else redirect (JournalR, [("add","1")])
+
+parseNumberedParameters :: Text -> [(Text, Text)] -> [(Int, Text)]
+parseNumberedParameters s =
+  reverse . dropWhile (T.null . snd) . sortBy (flip compare) . mapMaybe parseNum
+  where
+    parseNum :: (Text, Text) -> Maybe (Int, Text)
+    parseNum (k, v) = case parsewith paramnamep k of
+      Left (_ :: ParseError Char Void) -> Nothing
+      Right k' -> Just (k', v)
+    paramnamep = string s *> (read <$> some digitChar) <* eof
+
+-- XXX move into balanceTransaction
+appendTransaction :: FilePath -> Transaction -> IO ()
+appendTransaction journalfile t = do
+  ensureJournalFileExists journalfile
+  appendToJournalFileOrStdout journalfile $
+    showTransaction (txnTieKnot t)
+
+showErrors :: ToMarkup a => [a] -> Handler ()
+showErrors errs = setMessage [shamlet|
+Errors:<br>
+$forall e<-errs
+  \#{e}<br>
+|]

hledger-web/Handler/JournalR.hs

@@ -26,7 +26,7 @@ getJournalR = do
                   where s1 = if inclsubs then "" else " (excluding subaccounts)"
                 where
                   s2 = if m /= Any then ", filtered" else ""
-      maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
+      maincontent = journalTransactionsReportAsHtml vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
   hledgerLayout vd "journal" [hamlet|
        <div .row>
         <h2 #contenttitle>#{title}
@@ -40,8 +40,8 @@ postJournalR :: Handler Html
 postJournalR = postAddForm
 
 -- | Render a "TransactionsReport" as html for the formatted journal view.
-journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
+journalTransactionsReportAsHtml :: ViewData -> TransactionsReport -> HtmlUrl AppRoute
-journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|
+journalTransactionsReportAsHtml vd (_,items) = [hamlet|
 <table .transactionsreport .table .table-condensed>
  <thead>
   <th .date style="text-align:left;">

hledger-web/Handler/RegisterR.hs

@@ -7,7 +7,6 @@ import Import
 
 import Data.Time
 import Data.List (intersperse)
-import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import Safe (headMay)
 
@@ -32,22 +31,22 @@ getRegisterR = do
           s2 = if m /= Any then ", filtered" else ""
   hledgerLayout vd "register" $ do
     _ <- [hamlet|<h2 #contenttitle>#{title}|]
-    registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts
+    registerReportHtml vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts
 
 postRegisterR :: Handler Html
 postRegisterR = postAddForm
 
 -- | Generate html for an account register, including a balance chart and transaction list.
-registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
+registerReportHtml :: ViewData -> TransactionsReport -> HtmlUrl AppRoute
-registerReportHtml opts vd r = [hamlet|
+registerReportHtml vd r = [hamlet|
  <div .hidden-xs>
   ^{registerChartHtml $ transactionsReportByCommodity r}
- ^{registerItemsHtml opts vd r}
+ ^{registerItemsHtml vd r}
 |]
 
 -- | Generate html for a transaction list from an "TransactionsReport".
-registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
+registerItemsHtml :: ViewData -> TransactionsReport -> HtmlUrl AppRoute
-registerItemsHtml _ vd (balancelabel,items) = [hamlet|
+registerItemsHtml vd (balancelabel,items) = [hamlet|
 <div .table-responsive>
  <table.registerreport .table .table-striped .table-condensed>
   <thead>

hledger-web/Import.hs

@@ -7,6 +7,9 @@ import           Prelude              as Import hiding (head, init, last,
                                                  readFile, tail, writeFile)
 import           Yesod                as Import hiding (Route (..))
 
+import           Data.Bifunctor       as Import (first, second, bimap)
+import           Data.Either          as Import (lefts, rights)
+import           Data.Maybe           as Import (fromMaybe, maybeToList, mapMaybe, isJust)
 import           Data.Text            as Import (Text)
 
 import           Foundation           as Import

hledger-web/templates/default-layout-wrapper.hamlet

@@ -104,4 +104,4 @@ $newline never
                 $maybe m <- lastmsg
                   $if isPrefixOf "Errors" (renderHtml m)
                     <div #message>#{m}
-                ^{addform staticRootUrl vd}
+                ^{addform vd}