web: Add yesod-form-generated AddForm, add GET & POST /add
This commit is contained in:
		
							parent
							
								
									ee36b529e7
								
							
						
					
					
						commit
						cc1241fa20
					
				| @ -4,9 +4,6 @@ | ||||
| /                RootR           GET | ||||
| /journal         JournalR        GET | ||||
| /register        RegisterR       GET | ||||
| /add             AddR            POST | ||||
| /edit            EditR           POST | ||||
| /import          ImportR         POST | ||||
| 
 | ||||
| -- /accounts        AccountsR       GET | ||||
| -- /api/accounts    AccountsJsonR   GET | ||||
| /add             AddR            GET POST | ||||
| /edit            EditR           GET POST | ||||
| /import          ImportR         GET POST | ||||
|  | ||||
| @ -123,14 +123,12 @@ library | ||||
|   exposed-modules: | ||||
|       Application | ||||
|       Foundation | ||||
|       Handler.AddForm | ||||
|       Handler.AddR | ||||
|       Handler.Common | ||||
|       Handler.EditR | ||||
|       Handler.ImportR | ||||
|       Handler.JournalR | ||||
|       Handler.RegisterR | ||||
|       Handler.RootR | ||||
|       Hledger.Web | ||||
|       Hledger.Web.Main | ||||
|       Hledger.Web.WebOptions | ||||
| @ -138,6 +136,8 @@ library | ||||
|       Settings | ||||
|       Settings.Development | ||||
|       Settings.StaticFiles | ||||
|       Widget.AddForm | ||||
|       Widget.Common | ||||
|   other-modules: | ||||
|       Paths_hledger_web | ||||
|   ghc-options: -Wall | ||||
|  | ||||
| @ -118,14 +118,12 @@ library: | ||||
|   exposed-modules: | ||||
|   - Application | ||||
|   - Foundation | ||||
|   - Handler.AddForm | ||||
|   - Handler.AddR | ||||
|   - Handler.Common | ||||
|   - Handler.EditR | ||||
|   - Handler.ImportR | ||||
|   - Handler.JournalR | ||||
|   - Handler.RegisterR | ||||
|   - Handler.RootR | ||||
|   - Hledger.Web | ||||
|   - Hledger.Web.Main | ||||
|   - Hledger.Web.WebOptions | ||||
| @ -133,6 +131,8 @@ library: | ||||
|   - Settings | ||||
|   - Settings.Development | ||||
|   - Settings.StaticFiles | ||||
|   - Widget.AddForm | ||||
|   - Widget.Common | ||||
| 
 | ||||
| executables: | ||||
|   hledger-web: | ||||
|  | ||||
| @ -15,15 +15,13 @@ import Network.HTTP.Client (defaultManagerSettings) | ||||
| import Network.HTTP.Conduit (newManager) | ||||
| import Yesod.Default.Config | ||||
| import Yesod.Default.Main (defaultDevelApp) | ||||
| import Yesod.Default.Handlers (getFaviconR, getRobotsR) | ||||
| 
 | ||||
| import Handler.AddR (postAddR) | ||||
| import Handler.EditR (postEditR) | ||||
| import Handler.ImportR (postImportR) | ||||
| import Handler.AddR (getAddR, postAddR) | ||||
| import Handler.Common (getFaviconR, getRobotsR, getRootR) | ||||
| import Handler.EditR (getEditR, postEditR) | ||||
| import Handler.ImportR (getImportR, postImportR) | ||||
| import Handler.JournalR (getJournalR) | ||||
| import Handler.RegisterR (getRegisterR) | ||||
| import Handler.RootR (getRootR) | ||||
| 
 | ||||
| import Hledger.Data (Journal, nulljournal) | ||||
| import Hledger.Read (readJournalFile) | ||||
| import Hledger.Utils (error') | ||||
|  | ||||
| @ -6,7 +6,6 @@ | ||||
| module Foundation where | ||||
| 
 | ||||
| import Data.IORef (IORef, readIORef, writeIORef) | ||||
| import Data.List (isPrefixOf) | ||||
| import Data.Maybe (fromMaybe) | ||||
| import Data.Text (Text) | ||||
| import qualified Data.Text as T | ||||
| @ -14,16 +13,15 @@ import Data.Time.Calendar (Day) | ||||
| import Network.HTTP.Conduit (Manager) | ||||
| import System.FilePath (takeFileName) | ||||
| import Text.Blaze (Markup) | ||||
| import Text.Blaze.Html.Renderer.String (renderHtml) | ||||
| import Text.Hamlet (hamletFile) | ||||
| import Yesod | ||||
| import Yesod.Static | ||||
| import Yesod.Default.Config | ||||
| 
 | ||||
| import Handler.AddForm | ||||
| import Handler.Common (balanceReportAsHtml) | ||||
| import Settings (Extra(..), widgetFile) | ||||
| import Settings.StaticFiles | ||||
| import Settings (widgetFile, Extra (..)) | ||||
| import Widget.Common (balanceReportAsHtml) | ||||
| 
 | ||||
| #ifndef DEVELOPMENT | ||||
| import Settings (staticDir) | ||||
| import Text.Jasmine (minifym) | ||||
| @ -87,7 +85,8 @@ instance Yesod App where | ||||
| 
 | ||||
|   defaultLayout widget = do | ||||
|     master <- getYesod | ||||
|     VD{am, here, j, opts, q, qopts, showsidebar} <- getViewData | ||||
|     here <- fromMaybe RootR <$> getCurrentRoute | ||||
|     VD {am, j, opts, q, qopts, showsidebar} <- getViewData | ||||
|     msg <- getMessage | ||||
| 
 | ||||
|     let journalcurrent = if here == JournalR then "inacct" else "" :: Text | ||||
| @ -152,9 +151,8 @@ instance RenderMessage App FormMessage where | ||||
| -- XXX Parameter p - show/hide postings | ||||
| 
 | ||||
| -- | A bundle of data useful for hledger-web request handlers and templates. | ||||
| data ViewData = VD { | ||||
|      opts         :: WebOpts    -- ^ the command-line options at startup | ||||
|     ,here         :: AppRoute   -- ^ the current route | ||||
| data ViewData = VD | ||||
|   { opts         :: WebOpts    -- ^ the command-line options at startup | ||||
|   , today        :: Day        -- ^ today's date (for queries containing relative dates) | ||||
|   , j            :: Journal    -- ^ the up-to-date parsed unfiltered journal | ||||
|   , q            :: Text       -- ^ the current q parameter, the main query expression | ||||
| @ -178,7 +176,6 @@ viewdataWithDateAndParams d q a = | ||||
|       (acctsmatcher, acctsopts) = parseQuery d a | ||||
|   in VD | ||||
|      { opts = defwebopts | ||||
|      , here = RootR | ||||
|      , today = d | ||||
|      , j = nulljournal | ||||
|      , q = q | ||||
| @ -191,9 +188,7 @@ viewdataWithDateAndParams d q a = | ||||
| 
 | ||||
| -- | Gather data used by handlers and templates in the current request. | ||||
| getViewData :: Handler ViewData | ||||
| getViewData = getCurrentRoute >>= \case | ||||
|   Nothing -> return nullviewdata | ||||
|   Just here -> do | ||||
| getViewData = do | ||||
|   App {appOpts, appJournal = jref} <- getYesod | ||||
|   let opts@WebOpts {cliopts_ = copts@CliOpts {reportopts_ = ropts}} = appOpts | ||||
|   today <- liftIO getCurrentDay | ||||
| @ -206,7 +201,7 @@ getViewData = getCurrentRoute >>= \case | ||||
|   showsidebar <- shouldShowSidebar | ||||
|   return | ||||
|     (viewdataWithDateAndParams today q a) | ||||
|       {here, j, opts, showsidebar, today} | ||||
|     {j, opts, showsidebar, today} | ||||
| 
 | ||||
| -- | 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. | ||||
|  | ||||
| @ -1,61 +0,0 @@ | ||||
| -- | 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.) | ||||
| 
 | ||||
| {-# LANGUAGE FlexibleContexts #-} | ||||
| {-# LANGUAGE OverloadedStrings #-} | ||||
| {-# LANGUAGE QuasiQuotes #-} | ||||
| {-# LANGUAGE TemplateHaskell #-} | ||||
| 
 | ||||
| module Handler.AddForm | ||||
|   ( AddForm(..) | ||||
|   , addForm | ||||
|   , addFormHamlet | ||||
|   ) where | ||||
| 
 | ||||
| import Data.List (sort, nub) | ||||
| import Data.Semigroup ((<>)) | ||||
| import Data.Text (Text) | ||||
| import qualified Data.Text as T | ||||
| import Data.Time.Calendar | ||||
| import Text.Blaze.Internal (preEscapedString) | ||||
| import Text.Hamlet (hamletFile) | ||||
| import Text.JSON | ||||
| import Yesod (HtmlUrl, HandlerSite, RenderMessage) | ||||
| import Yesod.Form | ||||
| 
 | ||||
| import Hledger | ||||
| 
 | ||||
| -- Part of the data required from the add form. | ||||
| -- Don't know how to handle the variable posting fields with yesod-form yet. | ||||
| -- XXX Variable postings fields | ||||
| data AddForm = AddForm | ||||
|     { addFormDate         :: Day | ||||
|     , addFormDescription  :: Maybe Text | ||||
|     , addFormJournalFile  :: Maybe Text | ||||
|     } deriving Show | ||||
| 
 | ||||
| addForm :: (RenderMessage (HandlerSite m) FormMessage, Monad m) => Day -> Journal -> FormInput m AddForm | ||||
| addForm today j = AddForm | ||||
|     <$> ireq (checkMMap (pure . validateDate) (T.pack . show) textField) "date" | ||||
|     <*> iopt textField "description" | ||||
|     <*> iopt (check validateJournalFile textField) "journal" | ||||
|   where | ||||
|     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 <> "\":" | ||||
| 
 | ||||
| addFormHamlet :: Journal -> t -> HtmlUrl t | ||||
| addFormHamlet j r = $(hamletFile "templates/add-form.hamlet") | ||||
|  where | ||||
|   descriptions = sort $ nub $ tdescription <$> jtxns j | ||||
|   accts = journalAccountNamesDeclaredOrImplied j | ||||
|   escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>" -- #236 | ||||
|   listToJsonValueObjArrayStr as  = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as | ||||
|   postingnums = [1..4 :: Int] | ||||
|   filepaths = fst <$> jfiles j | ||||
| @ -1,85 +1,38 @@ | ||||
| {-# LANGUAGE LambdaCase #-} | ||||
| {-# LANGUAGE FlexibleContexts #-} | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
| {-# LANGUAGE OverloadedStrings #-} | ||||
| {-# LANGUAGE QuasiQuotes #-} | ||||
| {-# LANGUAGE ScopedTypeVariables #-} | ||||
| 
 | ||||
| module Handler.AddR | ||||
|   ( postAddR | ||||
|   ( getAddR | ||||
|   , postAddR | ||||
|   ) where | ||||
| 
 | ||||
| import Import | ||||
| 
 | ||||
| import Control.Monad.State.Strict (evalStateT) | ||||
| import Data.List (dropWhileEnd, sort) | ||||
| import qualified Data.Text as T | ||||
| import Data.Void (Void) | ||||
| import Safe (headMay) | ||||
| import Text.Megaparsec | ||||
| import Text.Megaparsec.Char | ||||
| 
 | ||||
| import Handler.AddForm (AddForm(..), addForm) | ||||
| import Handler.Common (showErrors) | ||||
| 
 | ||||
| import Hledger | ||||
| import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout) | ||||
| import Widget.AddForm (addForm) | ||||
| 
 | ||||
| postAddR :: Handler () | ||||
| 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}|] | ||||
| 
 | ||||
| postAddR :: Handler Html | ||||
| postAddR = do | ||||
|   VD{today, j} <- getViewData | ||||
|   -- 1. process the fixed fields with yesod-form | ||||
|   runInputPostResult (addForm today j) >>= \case | ||||
|     FormMissing      -> bail ["there is no form data"] | ||||
|     FormFailure errs -> bail errs | ||||
|     FormSuccess form -> do | ||||
|       let journalfile = maybe (journalFilePath j) T.unpack $ addFormJournalFile form | ||||
|       -- 2. the fixed fields look good; now process the posting fields adhocly, | ||||
|       -- getting either errors or a balanced transaction | ||||
|       (params,_) <- runRequestBody | ||||
|       let acctparams = parseNumberedParameters "account" params | ||||
|           amtparams  = parseNumberedParameters "amount" params | ||||
|           pnum = length acctparams | ||||
|       when (pnum == 0) (bail ["at least one posting must be entered"]) | ||||
|       when (map fst acctparams /= [1..pnum] || map fst amtparams `notElem` [[1..pnum], [1..pnum-1]]) | ||||
|         (bail ["the posting parameters are malformed"]) | ||||
| 
 | ||||
|       let eaccts = runParser (accountnamep <* eof) "" . textstrip  . snd <$> acctparams | ||||
|           eamts  = runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd <$> amtparams | ||||
|           (acctErrs, accts) = partitionEithers eaccts | ||||
|           (amtErrs, amts')  = partitionEithers eamts | ||||
|           amts | length amts' == pnum = amts' | ||||
|                | otherwise = amts' ++ [missingamt] | ||||
|           errs = T.pack . parseErrorPretty <$> acctErrs ++ amtErrs | ||||
|       unless (null errs) (bail errs) | ||||
| 
 | ||||
|       let etxn = balanceTransaction Nothing $ nulltransaction | ||||
|             { tdate = addFormDate form | ||||
|             , tdescription = fromMaybe "" $ addFormDescription form | ||||
|             , tpostings = (\(ac, am) -> nullposting {paccount = ac, pamount = Mixed [am]}) <$> zip accts amts | ||||
|             } | ||||
|       case etxn of | ||||
|        Left errs' -> bail (fmap T.pack . maybeToList . headMay $ lines errs') | ||||
|        Right t -> do | ||||
|         -- 3. all fields look good and form a balanced transaction; append it to the file | ||||
|         liftIO (appendTransaction journalfile t) | ||||
|   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 | ||||
|         -- XXX(?) move into balanceTransaction | ||||
|         ensureJournalFileExists (journalFilePath j) | ||||
|         appendToJournalFileOrStdout (journalFilePath j) (showTransaction $ txnTieKnot t) | ||||
|       setMessage "Transaction added." | ||||
|       redirect JournalR | ||||
|   where | ||||
|     bail :: [Text] -> Handler () | ||||
|     bail xs = showErrors xs >> redirect (JournalR, [("add","1")]) | ||||
| 
 | ||||
| parseNumberedParameters :: Text -> [(Text, Text)] -> [(Int, Text)] | ||||
| parseNumberedParameters s = | ||||
|   dropWhileEnd (T.null . snd) . sort . 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) | ||||
|  | ||||
| @ -1,111 +1,11 @@ | ||||
| {-# LANGUAGE CPP, OverloadedStrings, QuasiQuotes, NamedFieldPuns #-} | ||||
| -- | Common page components and rendering helpers. | ||||
| -- For global page layout, see Application.hs. | ||||
| module Handler.Common | ||||
|   ( getRootR | ||||
|   , getFaviconR | ||||
|   , getRobotsR | ||||
|   ) where | ||||
| 
 | ||||
| module Handler.Common where | ||||
| import Import | ||||
| import Yesod.Default.Handlers (getFaviconR, getRobotsR) | ||||
| 
 | ||||
| import Data.Semigroup ((<>)) | ||||
| import Data.Text (Text) | ||||
| import qualified Data.Text as T | ||||
| import Data.Time.Calendar (Day, toGregorian) | ||||
| import Text.Blaze (ToMarkup) | ||||
| import Text.Blaze.Internal (preEscapedString) | ||||
| import Yesod | ||||
| 
 | ||||
| import Settings (manualurl) | ||||
| 
 | ||||
| import Hledger | ||||
| 
 | ||||
| -- -- | Navigation link, preserving parameters and possibly highlighted. | ||||
| -- navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute | ||||
| -- navlink VD{..} s dest title = [hamlet| | ||||
| -- <a##{s}link.#{style} href=@?{u'} title="#{title}">#{s} | ||||
| -- |] | ||||
| --   where u' = (dest, if null q then [] else [("q", pack q)]) | ||||
| --         style | dest == here = "navlinkcurrent" | ||||
| --               | otherwise    = "navlink" :: Text | ||||
| 
 | ||||
| -- -- | Links to the various journal editing forms. | ||||
| -- editlinks :: HtmlUrl AppRoute | ||||
| -- editlinks = [hamlet| | ||||
| -- <a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit | ||||
| -- \ | # | ||||
| -- <a#addformlink href="#" onclick="return addformToggle(event)" title="Toggle transaction add form">add | ||||
| -- <a#importformlink href="#" onclick="return importformToggle(event)" style="display:none;">import transactions | ||||
| -- |] | ||||
| 
 | ||||
| -- | Link to a topic in the manual. | ||||
| helplink :: Text -> Text -> HtmlUrl r | ||||
| helplink topic label = [hamlet|<a href=#{u} target=hledgerhelp>#{label}|] | ||||
|   where u = manualurl <> if T.null topic then "" else T.cons '#' topic | ||||
| 
 | ||||
| ---------------------------------------------------------------------- | ||||
| -- hledger report renderers | ||||
| 
 | ||||
| -- | Render a "BalanceReport" as html. | ||||
| balanceReportAsHtml :: r -> Journal -> [QueryOpt] -> BalanceReport -> HtmlUrl r | ||||
| balanceReportAsHtml registerR j qopts (items, total) = [hamlet| | ||||
| $forall (acct, adisplay, aindent, abal) <- items | ||||
|   <tr .#{inacctClass acct}> | ||||
|     <td .acct> | ||||
|       <div .ff-wrapper> | ||||
|         \#{indent aindent} | ||||
|         <a href="@?{acctLink acct}" .#{inacctClass acct} | ||||
|            title="Show transactions affecting this account and subaccounts"> | ||||
|           #{adisplay} | ||||
|         $if hasSubs acct | ||||
|           <a href="@?{acctOnlyLink acct}" .only .hidden-sm .hidden-xs | ||||
|              title="Show transactions affecting this account but not subaccounts">only | ||||
|     <td> | ||||
|       ^{mixedAmountAsHtml abal} | ||||
| <tr .total> | ||||
|   <td> | ||||
|   <td> | ||||
|     ^{mixedAmountAsHtml total} | ||||
| |] where | ||||
|   l = ledgerFromJournal Any j | ||||
|   inacctClass acct = case inAccountQuery qopts of | ||||
|     Just m' -> if m' `matchesAccount` acct then "inacct" else "" | ||||
|     Nothing -> "" :: Text | ||||
|   hasSubs acct = maybe True (not . null . asubs) (ledgerAccount l acct) | ||||
|   indent a = preEscapedString $ concat $ replicate (2 + 2 * a) " " | ||||
|   acctLink acct = (registerR, [("q", accountQuery acct)]) | ||||
|   acctOnlyLink acct = (registerR, [("q", accountOnlyQuery acct)]) | ||||
| 
 | ||||
| accountQuery :: AccountName -> Text | ||||
| accountQuery = ("inacct:" <>) .  quoteIfSpaced | ||||
| 
 | ||||
| accountOnlyQuery :: AccountName -> Text | ||||
| accountOnlyQuery = ("inacctonly:" <>) . quoteIfSpaced | ||||
| 
 | ||||
| numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int, Bool, Bool, TransactionsReportItem)] | ||||
| numberTransactionsReportItems [] = [] | ||||
| numberTransactionsReportItems items = number 0 nulldate items | ||||
|   where | ||||
|     number :: Int -> Day -> [TransactionsReportItem] -> [(Int, Bool, Bool, TransactionsReportItem)] | ||||
|     number _ _ [] = [] | ||||
|     number n prevd (i@(t, _, _, _, _, _):rest) = (n+1, newday, newmonth, i): number (n+1) d rest | ||||
|       where | ||||
|         d = tdate t | ||||
|         newday = d /= prevd | ||||
|         newmonth = dm /= prevdm || dy /= prevdy | ||||
|         (dy, dm, _) = toGregorian d | ||||
|         (prevdy, prevdm, _) = toGregorian prevd | ||||
| 
 | ||||
| mixedAmountAsHtml :: MixedAmount -> HtmlUrl a | ||||
| mixedAmountAsHtml b = [hamlet| | ||||
| $forall t <- ts | ||||
|   <span .#{c}>#{t} | ||||
|   <br> | ||||
| |] where | ||||
|   ts = lines (showMixedAmountWithoutPrice b) | ||||
|   c = case isNegativeMixedAmount b of | ||||
|     Just True -> "negative amount" :: Text | ||||
|     _         -> "positive amount" | ||||
| 
 | ||||
| showErrors :: ToMarkup a => [a] -> HandlerFor m () | ||||
| showErrors errs = setMessage [shamlet| | ||||
| Errors:<br> | ||||
| $forall e <- errs | ||||
|   \#{e}<br> | ||||
| |] | ||||
| getRootR :: Handler Html | ||||
| getRootR = redirect JournalR | ||||
|  | ||||
| @ -1,46 +1,49 @@ | ||||
| {-# LANGUAGE LambdaCase #-} | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
| {-# LANGUAGE OverloadedStrings #-} | ||||
| {-# LANGUAGE QuasiQuotes #-} | ||||
| {-# LANGUAGE ScopedTypeVariables #-} | ||||
| 
 | ||||
| module Handler.EditR | ||||
|   ( postEditR | ||||
|   ( getEditR | ||||
|   , 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 | ||||
| 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"> | ||||
|   |]) | ||||
| 
 | ||||
|   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) | ||||
| getEditR :: Handler Html | ||||
| getEditR = 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) | ||||
|       redirect JournalR | ||||
|   where | ||||
|     runE :: ExceptT Text Handler () -> Handler () | ||||
|     runE f = runExceptT f >>= \case | ||||
|       Left e -> showErrors [e] >> redirect JournalR | ||||
|       Right x -> pure x | ||||
|  | ||||
| @ -1,29 +1,36 @@ | ||||
| {-# LANGUAGE LambdaCase #-} | ||||
| {-# LANGUAGE OverloadedStrings #-} | ||||
| {-# LANGUAGE QuasiQuotes #-} | ||||
| 
 | ||||
| module Handler.ImportR | ||||
|   ( postImportR | ||||
|   ( getImportR | ||||
|   , postImportR | ||||
|   ) where | ||||
| 
 | ||||
| import Import | ||||
| 
 | ||||
| import Control.Monad.Trans (lift) | ||||
| import Control.Monad.Trans.Except | ||||
| 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"> | ||||
|   |]) | ||||
| 
 | ||||
| import Handler.Common (showErrors) | ||||
| 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 () | ||||
| postImportR = runE $ do | ||||
|   ((res, _), _) <- lift . runFormPost . renderDivs $ areq fileField "file" Nothing | ||||
| postImportR :: Handler Html | ||||
| postImportR = do | ||||
|   ((res, view), enctype) <- runFormPost importForm | ||||
|   case res of | ||||
|     FormMissing -> throwE ["No file provided"] | ||||
|     FormFailure es -> throwE es | ||||
|     FormMissing -> defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|] | ||||
|     FormFailure _ -> defaultLayout [whamlet|<form enctype=#{enctype}>^{view}|] | ||||
|     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 | ||||
|  | ||||
| @ -9,21 +9,17 @@ module Handler.JournalR where | ||||
| 
 | ||||
| import Import | ||||
| 
 | ||||
| import Handler.Common (accountQuery, mixedAmountAsHtml) | ||||
| 
 | ||||
| import Hledger | ||||
| import Hledger.Cli.CliOptions | ||||
| import Hledger.Data | ||||
| import Hledger.Query | ||||
| import Hledger.Reports | ||||
| import Hledger.Utils | ||||
| import Hledger.Web.WebOptions | ||||
| import Widget.AddForm (addForm) | ||||
| import Widget.Common (accountQuery, mixedAmountAsHtml) | ||||
| 
 | ||||
| -- | The formatted journal view, with sidebar. | ||||
| -- XXX like registerReportAsHtml | ||||
| getJournalR :: Handler Html | ||||
| getJournalR = do | ||||
|   VD{j, m, opts, qopts} <- getViewData | ||||
|   -- XXX like registerReportAsHtml | ||||
| 
 | ||||
|   VD{j, m, opts, qopts, today} <- getViewData | ||||
|   let title = case inAccount qopts of | ||||
|         Nothing -> "General Journal" | ||||
|         Just (a, inclsubs) -> "Transactions in " <> a <> if inclsubs then "" else " (excluding subaccounts)" | ||||
| @ -31,6 +27,7 @@ getJournalR = do | ||||
|       acctlink a = (RegisterR, [("q", accountQuery a)]) | ||||
|       (_, items) = journalTransactionsReport (reportopts_ $ cliopts_ opts) j m | ||||
| 
 | ||||
|   (addView, addEnctype) <- generateFormPost (addForm j today) | ||||
|   defaultLayout $ do | ||||
|     setTitle "journal - hledger-web" | ||||
|     $(widgetFile "journal") | ||||
|  | ||||
| @ -10,22 +10,20 @@ module Handler.RegisterR where | ||||
| 
 | ||||
| import Import | ||||
| 
 | ||||
| import Data.Time | ||||
| import Data.List (intersperse) | ||||
| import qualified Data.Text as T | ||||
| import Safe (headMay) | ||||
| import Text.Hamlet (hamletFile) | ||||
| 
 | ||||
| import Handler.Common (mixedAmountAsHtml, numberTransactionsReportItems) | ||||
| 
 | ||||
| import Hledger | ||||
| import Hledger.Cli.CliOptions | ||||
| import Hledger.Web.WebOptions | ||||
| import Widget.AddForm (addForm) | ||||
| import Widget.Common (mixedAmountAsHtml, numberTransactionsReportItems) | ||||
| 
 | ||||
| -- | The main journal/account register view, with accounts sidebar. | ||||
| getRegisterR :: Handler Html | ||||
| getRegisterR = do | ||||
|   VD{j, m, opts, qopts} <- getViewData | ||||
|   VD{j, m, opts, qopts, today} <- getViewData | ||||
|   let (a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts | ||||
|       s1 = if inclsubs then "" else " (excluding subaccounts)" | ||||
|       s2 = if m /= Any then ", filtered" else "" | ||||
| @ -39,6 +37,7 @@ getRegisterR = do | ||||
|         | newd = "newday" | ||||
|         | otherwise = "" :: Text | ||||
| 
 | ||||
|   (addView, addEnctype) <- generateFormPost (addForm j today) | ||||
|   defaultLayout $ do | ||||
|     setTitle "register - hledger-web" | ||||
|     $(widgetFile "register") | ||||
| @ -50,12 +49,12 @@ registerChartHtml percommoditytxnreports = $(hamletFile "templates/chart.hamlet" | ||||
|  -- have to make sure plot is not called when our container (maincontent) | ||||
|  -- is hidden, eg with add form toggled | ||||
|  where | ||||
|    charttitle = case maybe "" (fst.snd) $ headMay percommoditytxnreports of | ||||
|    charttitle = case maybe "" (fst . snd) $ listToMaybe percommoditytxnreports of | ||||
|      "" -> "" | ||||
|      s  -> s <> ":" | ||||
|    colorForCommodity = fromMaybe 0 . flip lookup commoditiesIndex | ||||
|    commoditiesIndex = zip (map fst percommoditytxnreports) [0..] :: [(CommoditySymbol,Int)] | ||||
|    simpleMixedAmountQuantity = maybe 0 aquantity . headMay . amounts | ||||
|    simpleMixedAmountQuantity = maybe 0 aquantity . listToMaybe . amounts | ||||
|    shownull c = if null c then " " else c | ||||
| 
 | ||||
| dayToJsTimestamp :: Day -> Integer | ||||
|  | ||||
| @ -1,8 +0,0 @@ | ||||
| -- | Site root and misc. handlers. | ||||
| 
 | ||||
| module Handler.RootR where | ||||
| 
 | ||||
| import Import | ||||
| 
 | ||||
| getRootR :: Handler Html | ||||
| getRootR = redirect JournalR | ||||
| @ -7,12 +7,20 @@ import           Prelude              as Import hiding (head, init, last, | ||||
|                                                  readFile, tail, writeFile) | ||||
| 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           Control.Arrow        as Import ((&&&)) | ||||
| import           Control.Monad        as Import | ||||
| import           Data.Bifunctor       as Import | ||||
| import           Data.Default         as Import | ||||
| import           Data.Either          as Import | ||||
| import           Data.Foldable        as Import | ||||
| import           Data.List            as Import (foldl', unfoldr) | ||||
| import           Data.Maybe           as Import | ||||
| import           Data.Text            as Import (Text) | ||||
| 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 | ||||
|  | ||||
							
								
								
									
										115
									
								
								hledger-web/src/Widget/AddForm.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										115
									
								
								hledger-web/src/Widget/AddForm.hs
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,115 @@ | ||||
| {-# LANGUAGE FlexibleContexts #-} | ||||
| {-# LANGUAGE GADTs #-} | ||||
| {-# LANGUAGE OverloadedStrings #-} | ||||
| {-# LANGUAGE QuasiQuotes #-} | ||||
| {-# LANGUAGE TemplateHaskell #-} | ||||
| 
 | ||||
| module Widget.AddForm | ||||
|   ( addForm | ||||
|   ) where | ||||
| 
 | ||||
| import Control.Monad.State.Strict (evalStateT) | ||||
| import Data.Bifunctor (first) | ||||
| import Data.List (dropWhileEnd, nub, sort, unfoldr) | ||||
| import Data.Maybe (isJust) | ||||
| import Data.Semigroup ((<>)) | ||||
| import Data.Text (Text) | ||||
| import qualified Data.Text as T | ||||
| import Data.Time (Day) | ||||
| import Text.Blaze.Internal (Markup, preEscapedString) | ||||
| import Text.JSON | ||||
| import Text.Megaparsec (eof, parseErrorPretty, runParser) | ||||
| import Yesod | ||||
| 
 | ||||
| import Hledger | ||||
| import Settings (widgetFile) | ||||
| 
 | ||||
| -- XXX <select> which journal to add to | ||||
| 
 | ||||
| addForm :: | ||||
|      (site ~ HandlerSite m, RenderMessage site FormMessage, MonadHandler m) | ||||
|   => Journal | ||||
|   -> Day | ||||
|   -> Markup | ||||
|   -> MForm m (FormResult Transaction, WidgetFor site ()) | ||||
| addForm j today = identifyForm "add" $ \extra -> do | ||||
|   (dateRes, dateView) <- mreq dateField dateFS Nothing | ||||
|   (descRes, descView) <- mreq textField descFS Nothing | ||||
|   (acctRes, _) <- mreq listField acctFS Nothing | ||||
|   (amtRes, _) <- mreq listField amtFS Nothing | ||||
| 
 | ||||
|   let (msgs', postRes) = case validatePostings <$> acctRes <*> amtRes of | ||||
|         FormSuccess (Left es) -> (es, FormFailure ["Postings validation failed"]) | ||||
|         FormSuccess (Right xs) -> ([], FormSuccess xs) | ||||
|         FormMissing -> ([], FormMissing) | ||||
|         FormFailure es -> ([], FormFailure es) | ||||
|       msgs = zip [(1 :: Int)..] $ msgs' ++ replicate (4 - length msgs') ("", "", Nothing, Nothing) | ||||
| 
 | ||||
|   let descriptions = sort $ nub $ tdescription <$> jtxns j | ||||
|       escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>" -- #236 | ||||
|       listToJsonValueObjArrayStr = preEscapedString . escapeJSSpecialChars . | ||||
|         encode . JSArray . fmap (\a -> JSObject $ toJSObject [("value", showJSON a)]) | ||||
|       journals = fst <$> jfiles j | ||||
| 
 | ||||
|   pure (makeTransaction <$> dateRes <*> descRes <*> postRes, $(widgetFile "add-form")) | ||||
|   where | ||||
| 
 | ||||
|     makeTransaction date desc postings = | ||||
|       nulltransaction {tdate = date, tdescription = desc, tpostings = postings} | ||||
| 
 | ||||
|     dateFS = FieldSettings "date" Nothing Nothing (Just "date") | ||||
|       [("class", "form-control input-lg"), ("placeholder", "Date")] | ||||
|     descFS = FieldSettings "desc" Nothing Nothing (Just "description") | ||||
|       [("class", "form-control input-lg typeahead"), ("placeholder", "Description"), ("size", "40")] | ||||
|     acctFS = FieldSettings "amount" Nothing Nothing (Just "account") [] | ||||
|     amtFS = FieldSettings "amount" Nothing Nothing (Just "amount") [] | ||||
|     dateField = checkMMap (pure . validateDate) (T.pack . show) textField | ||||
|     validateDate s = | ||||
|       first (const ("Invalid date format" :: Text)) $ | ||||
|       fixSmartDateStrEither' today (T.strip s) | ||||
| 
 | ||||
|     listField = Field | ||||
|       { fieldParse = const . pure . Right . Just . dropWhileEnd T.null | ||||
|       , fieldView = error "Don't render using this!" | ||||
|       , fieldEnctype = UrlEncoded | ||||
|       } | ||||
| 
 | ||||
| validatePostings :: [Text] -> [Text] -> Either [(Text, Text, Maybe Text, Maybe Text)] [Posting] | ||||
| validatePostings a b = | ||||
|   case traverse id $ (\(_, _, x) -> x) <$> postings of | ||||
|     Left _ -> Left $ foldr catPostings [] postings | ||||
|     Right [] -> Left | ||||
|       [ ("", "", Just "Missing account", Just "Missing amount") | ||||
|       , ("", "", Just "Missing account", Nothing) | ||||
|       ] | ||||
|     Right [p] -> Left | ||||
|       [ (paccount p, T.pack . showMixedAmountWithoutPrice $ pamount p, Nothing, Nothing) | ||||
|       , ("", "", Just "Missing account", Nothing) | ||||
|       ] | ||||
|     Right xs -> Right xs | ||||
|   where | ||||
|     postings = unfoldr go (True, a, b) | ||||
| 
 | ||||
|     go (_, x:xs, y:ys) = Just ((x, y, zipPosting (validateAccount x) (validateAmount y)), (True, xs, ys)) | ||||
|     go (True, x:y:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Left "Missing amount")), (True, y:xs, [])) | ||||
|     go (True, x:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Right missingamt)), (False, xs, [])) | ||||
|     go (False, x:xs, []) = Just ((x, "", zipPosting (validateAccount x) (Left "Missing amount")), (False, xs, [])) | ||||
|     go (_, [], y:ys) = Just (("", y, zipPosting (Left "Missing account") (validateAmount y)), (False, [], ys)) | ||||
|     go (_, [], []) = Nothing | ||||
| 
 | ||||
|     zipPosting = zipEither (\acc amt -> nullposting {paccount = acc, pamount = Mixed [amt]}) | ||||
| 
 | ||||
|     catPostings (t, t', Left (e, e')) xs = (t, t', e, e') : xs | ||||
|     catPostings (t, t', Right _) xs = (t, t', Nothing, Nothing) : xs | ||||
| 
 | ||||
|     errorToFormMsg = first (("Invalid value: " <>) . T.pack . parseErrorPretty) | ||||
|     validateAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip | ||||
|     validateAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip | ||||
| 
 | ||||
| -- Modification of Align, from the `these` package | ||||
| zipEither :: (a -> a' -> r) -> Either e a -> Either e' a' -> Either (Maybe e, Maybe e') r | ||||
| zipEither f a b = case (a, b) of | ||||
|   (Right a', Right b') -> Right (f a' b') | ||||
|   (Left a', Right _) -> Left (Just a', Nothing) | ||||
|   (Right _, Left b') -> Left (Nothing, Just b') | ||||
|   (Left a', Left b') -> Left (Just a', Just b') | ||||
							
								
								
									
										92
									
								
								hledger-web/src/Widget/Common.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										92
									
								
								hledger-web/src/Widget/Common.hs
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,92 @@ | ||||
| {-# LANGUAGE BangPatterns #-} | ||||
| {-# LANGUAGE NamedFieldPuns #-} | ||||
| {-# LANGUAGE OverloadedStrings #-} | ||||
| {-# LANGUAGE QuasiQuotes #-} | ||||
| 
 | ||||
| module Widget.Common | ||||
|   ( accountQuery | ||||
|   , accountOnlyQuery | ||||
|   , balanceReportAsHtml | ||||
|   , helplink | ||||
|   , mixedAmountAsHtml | ||||
|   , numberTransactionsReportItems | ||||
|   ) where | ||||
| 
 | ||||
| import Data.Foldable (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 qualified Text.Blaze.Html5 as H | ||||
| import qualified Text.Blaze.Html5.Attributes as A | ||||
| import Text.Blaze.Internal (preEscapedString) | ||||
| import Yesod | ||||
| 
 | ||||
| import Hledger | ||||
| import Settings (manualurl) | ||||
| 
 | ||||
| -- | 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| | ||||
| $forall (acct, adisplay, aindent, abal) <- items | ||||
|   <tr .#{inacctClass acct}> | ||||
|     <td .acct> | ||||
|       <div .ff-wrapper> | ||||
|         \#{indent aindent} | ||||
|         <a href="@?{acctLink acct}" .#{inacctClass acct} | ||||
|            title="Show transactions affecting this account and subaccounts"> | ||||
|           #{adisplay} | ||||
|         $if hasSubs acct | ||||
|           <a href="@?{acctOnlyLink acct}" .only .hidden-sm .hidden-xs | ||||
|              title="Show transactions affecting this account but not subaccounts">only | ||||
|     <td> | ||||
|       ^{mixedAmountAsHtml abal} | ||||
| <tr .total> | ||||
|   <td> | ||||
|   <td> | ||||
|     ^{mixedAmountAsHtml total} | ||||
| |] where | ||||
|   l = ledgerFromJournal Any j | ||||
|   inacctClass acct = case inAccountQuery qopts of | ||||
|     Just m' -> if m' `matchesAccount` acct then "inacct" else "" | ||||
|     Nothing -> "" :: Text | ||||
|   hasSubs acct = maybe True (not . null . asubs) (ledgerAccount l acct) | ||||
|   indent a = preEscapedString $ concat $ replicate (2 + 2 * a) " " | ||||
|   acctLink acct = (registerR, [("q", accountQuery acct)]) | ||||
|   acctOnlyLink acct = (registerR, [("q", accountOnlyQuery acct)]) | ||||
| 
 | ||||
| accountQuery :: AccountName -> Text | ||||
| accountQuery = ("inacct:" <>) .  quoteIfSpaced | ||||
| 
 | ||||
| accountOnlyQuery :: AccountName -> Text | ||||
| accountOnlyQuery = ("inacctonly:" <>) . quoteIfSpaced | ||||
| 
 | ||||
| numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int, Bool, Bool, TransactionsReportItem)] | ||||
| numberTransactionsReportItems = snd . mapAccumL number (0, nulldate) | ||||
|   where | ||||
|     number :: (Int, Day) -> TransactionsReportItem -> ((Int, Day), (Int, Bool, Bool, TransactionsReportItem)) | ||||
|     number (!n, !prevd) i@(t, _, _, _, _, _) = ((n', d), (n', newday, newmonth, i)) | ||||
|       where | ||||
|         n' = n + 1 | ||||
|         d = tdate t | ||||
|         newday = d /= prevd | ||||
|         newmonth = dm /= prevdm || dy /= prevdy | ||||
|         (dy, dm, _) = toGregorian d | ||||
|         (prevdy, prevdm, _) = toGregorian prevd | ||||
| 
 | ||||
| mixedAmountAsHtml :: MixedAmount -> HtmlUrl a | ||||
| mixedAmountAsHtml b _ = | ||||
|   for_ (lines (showMixedAmountWithoutPrice b)) $ \t -> do | ||||
|     H.span ! A.class_ c $ toHtml t | ||||
|     H.br | ||||
|   where | ||||
|     c = case isNegativeMixedAmount b of | ||||
|       Just True -> "negative amount" | ||||
|       _ -> "positive amount" | ||||
| @ -78,10 +78,9 @@ function registerChart($container, series) { | ||||
|         position: 'sw' | ||||
|       }, | ||||
|       grid: { | ||||
|         markings: | ||||
|          function (axes) { | ||||
|         markings: function () { | ||||
|           var now = Date.now(); | ||||
|           var markings = [ | ||||
|           return [ | ||||
|             { | ||||
|               xaxis: { to: now }, // past
 | ||||
|               yaxis: { to: 0 },   // <0
 | ||||
| @ -103,7 +102,6 @@ function registerChart($container, series) { | ||||
|               lineWidth:1 | ||||
|             }, | ||||
|           ]; | ||||
|           return markings; | ||||
|         }, | ||||
|         hoverable: true, | ||||
|         autoHighlight: true, | ||||
| @ -127,9 +125,11 @@ function registerChart($container, series) { | ||||
| } | ||||
| 
 | ||||
| function registerChartClick(ev, pos, item) { | ||||
|   if (item) { | ||||
|     targetselector = '#'+item.series.data[item.dataIndex][5]; | ||||
|     $target = $(targetselector); | ||||
|   if (!item) { | ||||
|     return; | ||||
|   } | ||||
|   var targetselector = '#' + item.series.data[item.dataIndex][5]; | ||||
|   var $target = $(targetselector); | ||||
|   if ($target.length) { | ||||
|     window.location.hash = targetselector; | ||||
|     $('html, body').animate({ | ||||
| @ -137,7 +137,6 @@ function registerChartClick(ev, pos, item) { | ||||
|     }, 1000); | ||||
|   } | ||||
| } | ||||
| } | ||||
| 
 | ||||
| //----------------------------------------------------------------------
 | ||||
| // ADD FORM
 | ||||
| @ -192,8 +191,7 @@ function addformAddPosting() { | ||||
|   // clear and renumber the field, add keybindings
 | ||||
|   $acctinput | ||||
|     .val('') | ||||
|     .prop('id','account'+(num+1)) | ||||
|     .prop('name','account'+(num+1)) | ||||
|     .prop('name', 'account') | ||||
|     .prop('placeholder', 'Account ' + (num + 1)); | ||||
|   //lastrow.find('input') // not :last this time
 | ||||
|   $acctinput | ||||
| @ -203,8 +201,7 @@ function addformAddPosting() { | ||||
| 
 | ||||
|   $amntinput | ||||
|     .val('') | ||||
|     .prop('id','amount'+(num+1)) | ||||
|     .prop('name','amount'+(num+1)) | ||||
|     .prop('name','amount') | ||||
|     .prop('placeholder','Amount ' + (num + 1)) | ||||
|     .keypress(addformAddPosting); | ||||
| 
 | ||||
| @ -241,47 +238,3 @@ function sidebarToggle() { | ||||
|   $('#spacer').toggleClass('col-md-4 col-sm-4 col-any-0'); | ||||
|   $.cookie('showsidebar', $('#sidebar-menu').hasClass('col-any-0') ? '0' : '1'); | ||||
| } | ||||
| 
 | ||||
| //----------------------------------------------------------------------
 | ||||
| // MISC
 | ||||
| 
 | ||||
| function enableTypeahead($el, suggester) { | ||||
|   return $el.typeahead( | ||||
|     { | ||||
|       highlight: true | ||||
|     }, | ||||
|     { | ||||
|       source: suggester.ttAdapter() | ||||
|     } | ||||
|   ); | ||||
| } | ||||
| 
 | ||||
| // function journalSelect(ev) {
 | ||||
| //   var textareas = $('textarea', $('form#editform'));
 | ||||
| //   for (i=0; i<textareas.length; i++) {
 | ||||
| //     textareas[i].style.display = 'none';
 | ||||
| //     textareas[i].disabled = true;
 | ||||
| //   }
 | ||||
| //   var targ = getTarget(ev);
 | ||||
| //   if (targ.value) {
 | ||||
| //     var journalid = targ.value+'_textarea';
 | ||||
| //     var textarea = document.getElementById(journalid);
 | ||||
| //   }
 | ||||
| //   else {
 | ||||
| //     var textarea = textareas[0];
 | ||||
| //   }
 | ||||
| //   textarea.style.display = 'block';
 | ||||
| //   textarea.disabled = false;
 | ||||
| //   return true;
 | ||||
| // }
 | ||||
| 
 | ||||
| // // Get the current event's target in a robust way.
 | ||||
| // // http://www.quirksmode.org/js/events_properties.html
 | ||||
| // function getTarget(ev) {
 | ||||
| //   var targ;
 | ||||
| //   if (!ev) var ev = window.event;
 | ||||
| //   if (ev.target) targ = ev.target;
 | ||||
| //   else if (ev.srcElement) targ = ev.srcElement;
 | ||||
| //   if (targ.nodeType == 3) targ = targ.parentNode;
 | ||||
| //   return targ;
 | ||||
| // }
 | ||||
|  | ||||
| @ -1,6 +1,5 @@ | ||||
| <script> | ||||
|   jQuery(document).ready(function() { | ||||
|     /* set up typeahead fields */ | ||||
|     descriptionsSuggester = new Bloodhound({ | ||||
|       local:#{listToJsonValueObjArrayStr descriptions}, | ||||
|       limit:100, | ||||
| @ -10,53 +9,62 @@ | ||||
|     descriptionsSuggester.initialize(); | ||||
| 
 | ||||
|     accountsSuggester = new Bloodhound({ | ||||
|       local:#{listToJsonValueObjArrayStr accts}, | ||||
|       local:#{listToJsonValueObjArrayStr (journalAccountNamesDeclaredOrImplied j)}, | ||||
|       limit:100, | ||||
|       datumTokenizer: function(d) { return [d.value]; }, | ||||
|       queryTokenizer: function(q) { return [q]; } | ||||
|       /* | ||||
|         datumTokenizer: Bloodhound.tokenizers.obj.whitespace('value'), | ||||
|         datumTokenizer: Bloodhound.tokenizers.whitespace(d.value) | ||||
|         queryTokenizer: Bloodhound.tokenizers.whitespace | ||||
|       */ | ||||
|     }); | ||||
|     accountsSuggester.initialize(); | ||||
| 
 | ||||
|     enableTypeahead(jQuery('input#description'), descriptionsSuggester); | ||||
|     enableTypeahead(jQuery('input#account1, input#account2, input#account3, input#account4'), accountsSuggester); | ||||
|     jQuery('input[name=description]').typeahead({ highlight: true }, { source: descriptionsSuggester.ttAdapter() }); | ||||
|     jQuery('input[name=account]').typeahead({ highlight: true }, { source: accountsSuggester.ttAdapter() }); | ||||
|   }); | ||||
| ^{extra} | ||||
| 
 | ||||
| <form#addform action=@{r} method=POST .form> | ||||
| <div .form-group> | ||||
|   <div .row> | ||||
|    <div .col-md-3 .col-xs-6 .col-sm-6> | ||||
|     <div #dateWrap .input-group .date> | ||||
|      <input #date required lang=en name=date .form-control .input-lg placeholder="Date" > | ||||
|     <div .col-md-3 .col-xs-6 .col-sm-6 :isJust (fvErrors dateView):.has-error> | ||||
|       <div #dateWrap .form-group.input-group.date> | ||||
|         ^{fvInput dateView} | ||||
|         <div .input-group-addon> | ||||
|           <span .glyphicon .glyphicon-th> | ||||
|       $maybe err <- fvErrors dateView | ||||
|         <span .help-block .error-block>#{err} | ||||
|     <div .col-md-9 .col-xs-6 .col-sm-6 :isJust (fvErrors descView):.has-error> | ||||
|       <div .form-group> | ||||
|         ^{fvInput descView} | ||||
|       $maybe err <- fvErrors descView | ||||
|         <span .help-block .error-block>#{err} | ||||
|   <div .row> | ||||
|     <div .col-md-3 .col-xs-6 .col-sm-6> | ||||
|     <div .col-md-9 .col-xs-6 .col-sm-6> | ||||
|     <input #description required .typeahead .form-control .input-lg type=text size=40 name=description placeholder="Description"> | ||||
| 
 | ||||
| <div .account-postings> | ||||
|   $forall n <- postingnums | ||||
|   $forall (n, (acc, amt, accE, amtE)) <- msgs | ||||
|     <div .form-group .row .account-group #grp#{n}> | ||||
|     <div .col-md-8 .col-xs-8 .col-sm-8> | ||||
|      <input #account#{n} .account-input.form-control.input-lg.typeahead type=text name=account#{n} placeholder="Account #{n}"> | ||||
|     <div .col-md-4 .col-xs-4 .col-sm-4> | ||||
|      <input #amount#{n} .amount-input.form-control.input-lg type=text name=amount#{n} placeholder="Amount#{n}"> | ||||
|       <div .col-md-8 .col-xs-8 .col-sm-8 :isJust accE:.has-error> | ||||
|         <input .account-input.form-control.input-lg.typeahead type=text | ||||
|           name=account placeholder="Account #{n}" value="#{acc}"> | ||||
|         $maybe err <- accE | ||||
|           <span .help-block .error-block>_{err} | ||||
|       <div .col-md-4 .col-xs-4 .col-sm-4 :isJust amtE:.has-error> | ||||
|         <input .amount-input.form-control.input-lg type=text | ||||
|           name=amount placeholder="Amount #{n}" value="#{amt}"> | ||||
|         $maybe err <- amtE | ||||
|           <span .help-block .error-block>_{err} | ||||
| 
 | ||||
| <div .row> | ||||
|   <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 | ||||
|  $if length filepaths > 1 | ||||
| 
 | ||||
| $if length journals > 1 | ||||
|   <br> | ||||
|   <span .input-lg>to: | ||||
|    <select #journalselect .form-control.input-lg name=journal onchange="/*journalSelect(event)*/"  style="width:auto; display:inline-block;"> | ||||
|     $forall p <- filepaths | ||||
|     <select #journalselect .form-control.input-lg name=journal style="width:auto; display:inline-block;"> | ||||
|       $forall p <- journals | ||||
|         <option value=#{p}>#{p} | ||||
| 
 | ||||
|  <span style="padding-left:2em;"> | ||||
|   <span .small> | ||||
| <span .small style="padding-left:2em;"> | ||||
|   Enter a value in the last field for | ||||
|     <a href="#" onclick="addformAddPosting(); return false;">more | ||||
|     (or ctrl +, ctrl -) | ||||
|  | ||||
| @ -47,61 +47,3 @@ $newline never | ||||
|             <script> | ||||
|                 window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})}) | ||||
|         \<![endif]--> | ||||
| 
 | ||||
|         <div .modal.fade #helpmodal tabindex="-1" role="dialog" aria-labelledby="helpLabel" aria-hidden="true"> | ||||
|           <div .modal-dialog .modal-lg> | ||||
|             <div .modal-content> | ||||
|               <div .modal-header> | ||||
|                 <button type="button" .close data-dismiss="modal" aria-hidden="true">× | ||||
|                 <h3 .modal-title #helpLabel>Help | ||||
|               <div .modal-body> | ||||
|                 <div .row> | ||||
|                   <div .col-xs-6> | ||||
|                     <p> | ||||
|                       <b>Keyboard shortcuts | ||||
|                       <ul> | ||||
|                         <li> <code>h</code> or maybe <code>?</code> - view this help (escape or click to exit) | ||||
|                         <li> <code>j</code> - go to the Journal view (home) | ||||
|                         <li> <code>a</code> - add a transaction (escape to cancel) | ||||
|                         <li> <code>s</code> - toggle sidebar | ||||
|                         <li> <code>f</code> - focus search form ("find") | ||||
|                     <p> | ||||
|                       <b>General | ||||
|                       <ul> | ||||
|                         <li> The Journal view shows general journal entries, representing zero-sum movements of money (or other commodity) between hierarchical accounts | ||||
|                         <li> The sidebar shows the resulting accounts and their final balances | ||||
|                         <li> Parent account balances include subaccount balances | ||||
|                         <li> Multiple currencies in balances are displayed one above the other | ||||
|                         <li> Click account name links to see transactions affecting that account, with running balance | ||||
|                         <li> Click date links to see journal entries on that date | ||||
|                   <div .col-xs-6> | ||||
|                     <p> | ||||
|                       <b>Search | ||||
|                       <ul> | ||||
|                         <li> <code>acct:REGEXP</code> - filter on to/from account | ||||
|                         <li> <code>desc:REGEXP</code> - filter on description | ||||
|                         <li> <code>date:PERIODEXP</code>, <code>date2:PERIODEXP</code> - filter on date or secondary date | ||||
|                         <li> <code>code:REGEXP</code> - filter on transaction's code (eg check number) | ||||
|                         <li> <code>status:*</code>, <code>status:!</code>, <code>status:</code> - filter on transaction's cleared status (cleared, pending, uncleared) | ||||
|                         <!-- <li> <code>empty:BOOL</code> - filter on whether amount is zero --> | ||||
|                         <li> <code>amt:N</code>, <code>amt:<N</code>, <code>amt:>N</code> - filter on the unsigned amount magnitude. Or with a sign before N, filter on the signed value. (Single-commodity amounts only.) | ||||
|                         <li> <code>cur:REGEXP</code> - filter on the currency/commodity symbol (must match all of it). Dollar sign must be written as <code>\$</code> | ||||
|                         <li> <code>tag:NAME</code>, <code>tag:NAME=REGEX</code> - filter on tag name, or tag name and value | ||||
|                         <!-- <li> <code>depth:N</code> - filter out accounts below this depth --> | ||||
|                         <li> <code>real:BOOL</code> - filter on postings' real/virtual-ness | ||||
|                         <li> Enclose search patterns containing spaces in single or double quotes | ||||
|                         <li> Prepend <code>not:</code> to negate a search term | ||||
|                         <li> Multiple search terms on different fields are AND'ed, multiple search terms on the same field are OR'ed | ||||
|                         <li> These search terms also work with command-line hledger | ||||
| 
 | ||||
|         <div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true"> | ||||
|           <div .modal-dialog .modal-lg> | ||||
|             <div .modal-content> | ||||
|               <div .modal-header> | ||||
|                 <button type="button" .close data-dismiss="modal" aria-hidden="true">× | ||||
|                 <h3 .modal-title #addLabel>Add a transaction | ||||
|               <div .modal-body> | ||||
|                 $maybe m <- msg | ||||
|                   $if isPrefixOf "Errors" (renderHtml m) | ||||
|                     <div #message>#{m} | ||||
|                 ^{addFormHamlet j AddR} | ||||
|  | ||||
| @ -1,6 +1,5 @@ | ||||
| $maybe m <- msg | ||||
|   $if not (isPrefixOf "Errors" (renderHtml m)) | ||||
|     <div #message>#{m} | ||||
|   <div #message .alert-primary>#{m} | ||||
| 
 | ||||
| <div#spacer .col-xs-2.#{topShowsm}.#{topShowmd}> | ||||
|   <h1> | ||||
| @ -21,7 +20,7 @@ $maybe m <- msg | ||||
|     ^{accounts} | ||||
| 
 | ||||
| <div #main-content .col-xs-12.#{mainShowmd}.#{mainShowsm}> | ||||
|   <div#searchformdiv .row> | ||||
|   <div .row> | ||||
|     <form#searchform .form-inline method=GET> | ||||
|       <div .form-group .col-md-12 .col-sm-12 .col-xs-12> | ||||
|         <div #searchbar .input-group> | ||||
| @ -36,3 +35,49 @@ $maybe m <- msg | ||||
|             <button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal" | ||||
|                title="Show search and general help">? | ||||
|   ^{widget} | ||||
| 
 | ||||
| <div .modal.fade #helpmodal tabindex="-1" role="dialog" aria-labelledby="helpLabel" aria-hidden="true"> | ||||
|   <div .modal-dialog .modal-lg> | ||||
|     <div .modal-content> | ||||
|       <div .modal-header> | ||||
|         <button type="button" .close data-dismiss="modal" aria-hidden="true">× | ||||
|         <h3 .modal-title #helpLabel>Help | ||||
|       <div .modal-body> | ||||
|         <div .row> | ||||
|           <div .col-xs-6> | ||||
|             <p> | ||||
|               <b>Keyboard shortcuts | ||||
|               <ul> | ||||
|                 <li> <code>h</code> or maybe <code>?</code> - view this help (escape or click to exit) | ||||
|                 <li> <code>j</code> - go to the Journal view (home) | ||||
|                 <li> <code>a</code> - add a transaction (escape to cancel) | ||||
|                 <li> <code>s</code> - toggle sidebar | ||||
|                 <li> <code>f</code> - focus search form ("find") | ||||
|             <p> | ||||
|               <b>General | ||||
|               <ul> | ||||
|                 <li> The Journal view shows general journal entries, representing zero-sum movements of money (or other commodity) between hierarchical accounts | ||||
|                 <li> The sidebar shows the resulting accounts and their final balances | ||||
|                 <li> Parent account balances include subaccount balances | ||||
|                 <li> Multiple currencies in balances are displayed one above the other | ||||
|                 <li> Click account name links to see transactions affecting that account, with running balance | ||||
|                 <li> Click date links to see journal entries on that date | ||||
|           <div .col-xs-6> | ||||
|             <p> | ||||
|               <b>Search | ||||
|               <ul> | ||||
|                 <li> <code>acct:REGEXP</code> - filter on to/from account | ||||
|                 <li> <code>desc:REGEXP</code> - filter on description | ||||
|                 <li> <code>date:PERIODEXP</code>, <code>date2:PERIODEXP</code> - filter on date or secondary date | ||||
|                 <li> <code>code:REGEXP</code> - filter on transaction's code (eg check number) | ||||
|                 <li> <code>status:*</code>, <code>status:!</code>, <code>status:</code> - filter on transaction's cleared status (cleared, pending, uncleared) | ||||
|                 <!-- <li> <code>empty:BOOL</code> - filter on whether amount is zero --> | ||||
|                 <li> <code>amt:N</code>, <code>amt:<N</code>, <code>amt:>N</code> - filter on the unsigned amount magnitude. Or with a sign before N, filter on the signed value. (Single-commodity amounts only.) | ||||
|                 <li> <code>cur:REGEXP</code> - filter on the currency/commodity symbol (must match all of it). Dollar sign must be written as <code>\$</code> | ||||
|                 <li> <code>tag:NAME</code>, <code>tag:NAME=REGEX</code> - filter on tag name, or tag name and value | ||||
|                 <!-- <li> <code>depth:N</code> - filter out accounts below this depth --> | ||||
|                 <li> <code>real:BOOL</code> - filter on postings' real/virtual-ness | ||||
|                 <li> Enclose search patterns containing spaces in single or double quotes | ||||
|                 <li> Prepend <code>not:</code> to negate a search term | ||||
|                 <li> Multiple search terms on different fields are AND'ed, multiple search terms on the same field are OR'ed | ||||
|                 <li> These search terms also work with command-line hledger | ||||
|  | ||||
| @ -18,7 +18,5 @@ | ||||
|       <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 # | ||||
|         <input type=submit name=submit value="save"> | ||||
|         <a href="#" onclick="return editformToggle(event)">cancel | ||||
|  | ||||
| @ -3,7 +3,5 @@ | ||||
|   <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 | ||||
|  | ||||
| @ -30,3 +30,13 @@ | ||||
|               #{elideAccountName 40 acc} | ||||
|           <td .amount .nonhead style="text-align:right;"> | ||||
|             ^{mixedAmountAsHtml amt} | ||||
| 
 | ||||
| <div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true"> | ||||
|   <div .modal-dialog .modal-lg> | ||||
|     <div .modal-content> | ||||
|       <div .modal-header> | ||||
|         <button type="button" .close data-dismiss="modal" aria-hidden="true">× | ||||
|         <h3 .modal-title #addLabel>Add a transaction | ||||
|       <div .modal-body> | ||||
|         <form#addform.form action=@{AddR} method=POST enctype=#{addEnctype}> | ||||
|           ^{addView} | ||||
|  | ||||
| @ -30,3 +30,13 @@ | ||||
|             $if not split || not (isZeroMixedAmount amt) | ||||
|               \^{mixedAmountAsHtml amt} | ||||
|           <td .balance style="text-align:right;">^{mixedAmountAsHtml bal} | ||||
| 
 | ||||
| <div .modal #addmodal tabindex="-1" role="dialog" aria-labelledby="addLabel" aria-hidden="true"> | ||||
|   <div .modal-dialog .modal-lg> | ||||
|     <div .modal-content> | ||||
|       <div .modal-header> | ||||
|         <button type="button" .close data-dismiss="modal" aria-hidden="true">× | ||||
|         <h3 .modal-title #addLabel>Add a transaction | ||||
|       <div .modal-body> | ||||
|         <form#addform.form action=@{AddR} method=POST enctype=#{addEnctype}> | ||||
|           ^{addView} | ||||
|  | ||||
		Loading…
	
		Reference in New Issue
	
	Block a user