+mkYesod "HledgerWebApp" [$parseRoutes|
+/ IndexPage GET
+/transactions TransactionsPage GET POST
+/register RegisterPage GET
+/balance BalancePage GET
+/style.css StyleCss GET
+/params ParamsDebug GET
+|]
--- | A loli directive to serve a string in pre tags within the hledger web
--- layout.
-string :: [String] -> String -> AppUnit
-string msgs s = hsp msgs $ const
<% s %>
+getParamsDebug = do
+ r <- getRequest
+ return $ RepHtml $ toContent $ show $ reqGetParams r
--- | A loli directive to serve a hsp template wrapped in the hledger web
--- layout. The hack environment is passed in to every hsp template as an
--- argument, since I don't see how to get it within the hsp monad.
--- A list of messages is also passed, eg for form errors.
-hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
-hsp msgs f = do
- env <- getenv
- let contenthsp = f env
- pagehsp = hledgerpage env msgs title contenthsp
- html =<< (io $ do
- hspenv <- hackEnvToHspEnv env
- (_,xml) <- runHSP html4Strict pagehsp hspenv
- return $ addDoctype $ renderAsHTML xml)
- response $ set_content_type _TextHtmlUTF8
- where
- title = ""
- addDoctype = ("\n" ++)
- hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
- hackEnvToHspEnv env = do
- x <- newIORef 0
- let req = HSP.Request (reqParamUtf8 env) (Hack.http env)
- num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
- return $ HSPEnv req num
+getIndexPage :: Handler HledgerWebApp ()
+getIndexPage = redirect RedirectTemporary TransactionsPage
--- htmlToHsp :: Html -> HSP XML
--- htmlToHsp h = return $ cdata $ showHtml h
+getStyleCss :: Handler HledgerWebApp RepPlain
+getStyleCss = do
+ app <- getYesod
+ let dir = appWebdir app
+ s <- liftIO $ readFile $ dir "style.css"
+ header "Content-Type" "text/css"
+ return $ RepPlain $ toContent s
--- views
+getTransactionsPage :: Handler HledgerWebApp RepHtml
+getTransactionsPage = withLatestJournalRender (const showTransactions)
-hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
-hledgerpage env msgs title content =
-
-
-
-
- <% title %>
-
-
- <% navbar env %>
-
- where
- numbered = (++ show n)
- acctvar = numbered "acct"
- amtvar = numbered "amt"
+helplink topic = [$hamlet|%a!href=$string.u$ ?|]
+ where u = manualurl ++ if null topic then "" else '#':topic
-handleAddform :: Journal -> AppUnit
-handleAddform j = do
- env <- getenv
- d <- io getCurrentDay
- t <- io getCurrentLocalTime
- handle t $ validate env d
- where
- validate :: Hack.Env -> Day -> Failing Transaction
- validate env today =
- let inputs = Hack.Contrib.Request.inputs env
- date = decodeString $ fromMaybe "today" $ lookup "date" inputs
- desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
- acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
- amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
- acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
- amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
- validateDate "" = ["missing date"]
- validateDate _ = []
- validateDesc "" = ["missing description"]
- validateDesc _ = []
- validateAcct1 "" = ["missing account 1"]
- validateAcct1 _ = []
- validateAmt1 "" = ["missing amount 1"]
- validateAmt1 _ = []
- validateAcct2 "" = ["missing account 2"]
- validateAcct2 _ = []
- validateAmt2 _ = []
- amt1' = either (const missingamt) id $ parse someamount "" amt1
- amt2' = either (const missingamt) id $ parse someamount "" amt2
- (date', dateparseerr) = case fixSmartDateStrEither today date of
- Right d -> (d, [])
- Left e -> ("1900/01/01", [showDateParseError e])
- t = Transaction {
- tdate = parsedate date' -- date' must be parseable
- ,teffectivedate=Nothing
- ,tstatus=False
- ,tcode=""
- ,tdescription=desc
- ,tcomment=""
- ,tpostings=[
- Posting False acct1 amt1' "" RegularPosting (Just t')
- ,Posting False acct2 amt2' "" RegularPosting (Just t')
- ]
- ,tpreceding_comment_lines=""
- }
- (t', balanceerr) = case balanceTransaction t of
- Right t'' -> (t'', [])
- Left e -> (t, [head $ lines e]) -- show just the error not the transaction
- errs = concat [
- validateDate date
- ,dateparseerr
- ,validateDesc desc
- ,validateAcct1 acct1
- ,validateAmt1 amt1
- ,validateAcct2 acct2
- ,validateAmt2 amt2
- ,balanceerr
- ]
- in
- case null errs of
- False -> Failure errs
- True -> Success t'
+addform :: Request -> String -> String -> Hamlet HledgerWebAppRoutes
+addform _ _ _ = [$hamlet|
+ %form#addform!action=$string.action$!method=POST
+ %table!border=0
+ %tr
+ %td
+ Date:
+ %input!size=15!name=date!value=$string.date$
+ ^datehelp^ $
+ Description:
+ %input!size=35!name=desc!value=$string.desc$ $
+ ^transactionfields1^
+ ^transactionfields2^
+ %tr#addbuttonrow
+ %td
+ %input!type=submit!value=$string.addlabel$
+ ^addhelp^
+
+|]
+ where
+ datehelp = helplink "dates"
+ addlabel = "add transaction"
+ addhelp = helplink "file-format"
+ action=""
+ date = ""
+ desc = ""
+ transactionfields1 = transactionfields 1
+ transactionfields2 = transactionfields 2
- handle :: LocalTime -> Failing Transaction -> AppUnit
- handle _ (Failure errs) = hsp errs addform
- handle ti (Success t) = do
- io $ journalAddTransaction j t >>= journalReload
- ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
- where msg = printf "Added transaction:\n%s" (show t)
+-- transactionfields :: Int -> Hamlet String
+transactionfields n = [$hamlet|
+ %tr
+ %td
+
+ Account:
+ %input!size=35!name=$string.acctvar$!value=$string.acct$
+
+ Amount:
+ %input!size=15!name=$string.amtvar$!value=$string.amt$ $
+|]
+ where
+ acct = ""
+ amt = ""
+ numbered = (++ show n)
+ acctvar = numbered "acct"
+ amtvar = numbered "amt"
+
+postTransactionsPage :: Handler HledgerWebApp RepPlain
+postTransactionsPage = do
+ today <- liftIO getCurrentDay
+ -- get form input values, or basic validation errors. E means an Either value.
+ dateE <- runFormPost $ catchFormError $ notEmpty $ required $ input "date"
+ descE <- runFormPost $ catchFormError $ required $ input "desc"
+ acct1E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct1"
+ amt1E <- runFormPost $ catchFormError $ required $ input "amt1"
+ acct2E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct2"
+ amt2E <- runFormPost $ catchFormError $ required $ input "amt2"
+ -- supply defaults and parse date and amounts, or get errors.
+ let dateE' = either Left (either (\e -> Left [("date", showDateParseError e)]) Right . fixSmartDateStrEither today) dateE
+ amt1E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt1E -- XXX missingamt only when missing/empty
+ amt2E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt2E
+ strEs = [dateE', descE, acct1E, acct2E]
+ amtEs = [amt1E', amt2E']
+ errs = lefts strEs ++ lefts amtEs
+ [date,desc,acct1,acct2] = rights strEs
+ [amt1,amt2] = rights amtEs
+ -- if no errors so far, generate a transaction and balance it or get the error.
+ tE | not $ null errs = Left errs
+ | otherwise = either (\e -> Left [[("unbalanced postings", head $ lines e)]]) Right
+ (balanceTransaction $ nulltransaction {
+ tdate=parsedate date
+ ,teffectivedate=Nothing
+ ,tstatus=False
+ ,tcode=""
+ ,tdescription=desc
+ ,tcomment=""
+ ,tpostings=[
+ Posting False acct1 amt1 "" RegularPosting Nothing
+ ,Posting False acct2 amt2 "" RegularPosting Nothing
+ ]
+ ,tpreceding_comment_lines=""
+ })
+ -- display errors or add transaction
+ case tE of
+ Left errs -> do
+ -- save current form values in session
+ setMessage $ string $ intercalate ", " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) errs
+ redirect RedirectTemporary TransactionsPage
+
+ Right t -> do
+ let t' = txnTieKnot t -- XXX move into balanceTransaction
+ j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
+ -- j' <- liftIO $ journalAddTransaction j t' >>= journalReload
+ -- liftIO $ putValue "hledger" "journal" j'
+ liftIO $ journalAddTransaction j t'
+ setMessage $ string $ printf "Added transaction:\n%s" (show t')
+ redirect RedirectTemporary TransactionsPage
-nbsp :: XML
-nbsp = cdata " "
diff --git a/Hledger/Cli/Commands/Web610.hs b/Hledger/Cli/Commands/Web610.hs
new file mode 100644
index 000000000..04473d668
--- /dev/null
+++ b/Hledger/Cli/Commands/Web610.hs
@@ -0,0 +1,313 @@
+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -F -pgmFtrhsx #-}
+{-|
+A web-based UI.
+-}
+
+module Hledger.Cli.Commands.Web610
+where
+import Codec.Binary.UTF8.String (decodeString)
+import Control.Applicative.Error (Failing(Success,Failure))
+import Control.Concurrent
+import Control.Monad.Reader (ask)
+import Data.IORef (newIORef, atomicModifyIORef)
+import System.IO.Storage (withStore, putValue, getValue)
+import Text.ParserCombinators.Parsec (parse)
+
+import Hack.Contrib.Constants (_TextHtmlUTF8)
+import Hack.Contrib.Response (set_content_type)
+import qualified Hack (Env, http)
+import qualified Hack.Contrib.Request (inputs, params, path)
+import qualified Hack.Contrib.Response (redirect)
+import Hack.Handler.SimpleServer (run)
+
+import Network.Loli (loli, io, get, post, html, text, public)
+import Network.Loli.Type (AppUnit)
+import Network.Loli.Utils (update)
+
+import HSP hiding (Request,catch)
+import qualified HSP (Request(..))
+
+import Hledger.Cli.Commands.Add (journalAddTransaction)
+import Hledger.Cli.Commands.Balance
+import Hledger.Cli.Commands.Histogram
+import Hledger.Cli.Commands.Print
+import Hledger.Cli.Commands.Register
+import Hledger.Data
+import Hledger.Read.Journal (someamount)
+import Hledger.Cli.Options hiding (value)
+#ifdef MAKE
+import Paths_hledger_make (getDataFileName)
+#else
+import Paths_hledger (getDataFileName)
+#endif
+import Hledger.Cli.Utils
+
+
+tcpport = 5000 :: Int
+homeurl = printf "http://localhost:%d/" tcpport
+browserdelay = 100000 -- microseconds
+
+web :: [Opt] -> [String] -> Journal -> IO ()
+web opts args j = do
+ unless (Debug `elem` opts) $ forkIO browser >> return ()
+ server opts args j
+
+browser :: IO ()
+browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()
+
+server :: [Opt] -> [String] -> Journal -> IO ()
+server opts args j =
+ -- server initialisation
+ withStore "hledger" $ do -- IO ()
+ printf "starting web server on port %d\n" tcpport
+ t <- getCurrentLocalTime
+ webfiles <- getDataFileName "web"
+ putValue "hledger" "journal" j
+ run tcpport $ -- (Env -> IO Response) -> IO ()
+ \env -> do -- IO Response
+ -- general request handler
+ let opts' = opts ++ [Period $ unwords $ map decodeString $ reqParamUtf8 env "p"]
+ args' = args ++ map decodeString (reqParamUtf8 env "a")
+ j' <- fromJust `fmap` getValue "hledger" "journal"
+ (changed, j'') <- io $ journalReloadIfChanged opts j'
+ when changed $ putValue "hledger" "journal" j''
+ -- declare path-specific request handlers
+ let command :: [String] -> ([Opt] -> FilterSpec -> Journal -> String) -> AppUnit
+ command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) j''
+ (loli $ -- State Loli () -> (Env -> IO Response)
+ do
+ get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()
+ get "/register" $ command [] showRegisterReport
+ get "/histogram" $ command [] showHistogram
+ get "/transactions" $ ledgerpage [] j'' (showTransactions (optsToFilterSpec opts' args' t))
+ post "/transactions" $ handleAddform j''
+ get "/env" $ getenv >>= (text . show)
+ get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params)
+ get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs)
+ public (Just webfiles) ["/style.css"]
+ get "/" $ redirect ("transactions") Nothing
+ ) env
+
+getenv = ask
+response = update
+redirect u c = response $ Hack.Contrib.Response.redirect u c
+
+reqParamUtf8 :: Hack.Env -> String -> [String]
+reqParamUtf8 env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
+
+ledgerpage :: [String] -> Journal -> (Journal -> String) -> AppUnit
+ledgerpage msgs j f = do
+ env <- getenv
+ (_, j') <- io $ journalReloadIfChanged [] j
+ hsp msgs $ const
<% addform env %>
<% f j' %>
+
+-- | A loli directive to serve a string in pre tags within the hledger web
+-- layout.
+string :: [String] -> String -> AppUnit
+string msgs s = hsp msgs $ const
<% s %>
+
+-- | A loli directive to serve a hsp template wrapped in the hledger web
+-- layout. The hack environment is passed in to every hsp template as an
+-- argument, since I don't see how to get it within the hsp monad.
+-- A list of messages is also passed, eg for form errors.
+hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
+hsp msgs f = do
+ env <- getenv
+ let contenthsp = f env
+ pagehsp = hledgerpage env msgs title contenthsp
+ html =<< (io $ do
+ hspenv <- hackEnvToHspEnv env
+ (_,xml) <- runHSP html4Strict pagehsp hspenv
+ return $ addDoctype $ renderAsHTML xml)
+ response $ set_content_type _TextHtmlUTF8
+ where
+ title = ""
+ addDoctype = ("\n" ++)
+ hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
+ hackEnvToHspEnv env = do
+ x <- newIORef 0
+ let req = HSP.Request (reqParamUtf8 env) (Hack.http env)
+ num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
+ return $ HSPEnv req num
+
+-- htmlToHsp :: Html -> HSP XML
+-- htmlToHsp h = return $ cdata $ showHtml h
+
+-- views
+
+hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
+hledgerpage env msgs title content =
+
+
+
+
+ <% title %>
+
+
+ <% navbar env %>
+
+
+getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p
+
+navlinks :: Hack.Env -> HSP XML
+navlinks _ = do
+ a <- getParamOrNull "a"
+ p <- getParamOrNull "p"
+ let addparams=(++(printf "?a=%s&p=%s" a p))
+ link s = <% s %>
+
+ <% link "transactions" %> |
+ <% link "register" %> |
+ <% link "balance" %>
+
+
+searchform :: Hack.Env -> HSP XML
+searchform env = do
+ a <- getParamOrNull "a"
+ p <- getParamOrNull "p"
+ let resetlink | null a && null p =
+ | otherwise = <% nbsp %>reset
+ where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
+
+
+addform :: Hack.Env -> HSP XML
+addform env = do
+ today <- io $ liftM showDate $ getCurrentDay
+ let inputs = Hack.Contrib.Request.inputs env
+ date = decodeString $ fromMaybe today $ lookup "date" inputs
+ desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
+
+
+
+
+
+
+
+help :: String -> HSP XML
+help topic = ?
+ where u = printf "http://hledger.org/MANUAL.html%s" l :: String
+ l | null topic = ""
+ | otherwise = '#':topic
+
+transactionfields :: Int -> Hack.Env -> HSP XML
+transactionfields n env = do
+ let inputs = Hack.Contrib.Request.inputs env
+ acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
+ amt = decodeString $ fromMaybe "" $ lookup amtvar inputs
+
+ where
+ numbered = (++ show n)
+ acctvar = numbered "acct"
+ amtvar = numbered "amt"
+
+handleAddform :: Journal -> AppUnit
+handleAddform j = do
+ env <- getenv
+ d <- io getCurrentDay
+ t <- io getCurrentLocalTime
+ handle t $ validate env d
+ where
+ validate :: Hack.Env -> Day -> Failing Transaction
+ validate env today =
+ let inputs = Hack.Contrib.Request.inputs env
+ date = decodeString $ fromMaybe "today" $ lookup "date" inputs
+ desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
+ acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
+ amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
+ acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
+ amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
+ validateDate "" = ["missing date"]
+ validateDate _ = []
+ validateDesc "" = ["missing description"]
+ validateDesc _ = []
+ validateAcct1 "" = ["missing account 1"]
+ validateAcct1 _ = []
+ validateAmt1 "" = ["missing amount 1"]
+ validateAmt1 _ = []
+ validateAcct2 "" = ["missing account 2"]
+ validateAcct2 _ = []
+ validateAmt2 _ = []
+ amt1' = either (const missingamt) id $ parse someamount "" amt1
+ amt2' = either (const missingamt) id $ parse someamount "" amt2
+ (date', dateparseerr) = case fixSmartDateStrEither today date of
+ Right d -> (d, [])
+ Left e -> ("1900/01/01", [showDateParseError e])
+ t = Transaction {
+ tdate = parsedate date' -- date' must be parseable
+ ,teffectivedate=Nothing
+ ,tstatus=False
+ ,tcode=""
+ ,tdescription=desc
+ ,tcomment=""
+ ,tpostings=[
+ Posting False acct1 amt1' "" RegularPosting (Just t')
+ ,Posting False acct2 amt2' "" RegularPosting (Just t')
+ ]
+ ,tpreceding_comment_lines=""
+ }
+ (t', balanceerr) = case balanceTransaction t of
+ Right t'' -> (t'', [])
+ Left e -> (t, [head $ lines e]) -- show just the error not the transaction
+ errs = concat [
+ validateDate date
+ ,dateparseerr
+ ,validateDesc desc
+ ,validateAcct1 acct1
+ ,validateAmt1 amt1
+ ,validateAcct2 acct2
+ ,validateAmt2 amt2
+ ,balanceerr
+ ]
+ in
+ case null errs of
+ False -> Failure errs
+ True -> Success t'
+
+ handle :: LocalTime -> Failing Transaction -> AppUnit
+ handle _ (Failure errs) = hsp errs addform
+ handle ti (Success t) = do
+ io $ journalAddTransaction j t >>= journalReload
+ ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
+ where msg = printf "Added transaction:\n%s" (show t)
+
+nbsp :: XML
+nbsp = cdata " "
diff --git a/Hledger/Cli/Commands/WebYesod.hs b/Hledger/Cli/Commands/WebYesod.hs
deleted file mode 100644
index b14bae729..000000000
--- a/Hledger/Cli/Commands/WebYesod.hs
+++ /dev/null
@@ -1,299 +0,0 @@
-{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, TemplateHaskell #-}
-{-|
-A web-based UI.
--}
-
-module Hledger.Cli.Commands.WebYesod
-where
-import Control.Concurrent -- (forkIO)
-import Data.Either
-import Network.Wai.Handler.SimpleServer (run)
-import System.FilePath (())
-import System.IO.Storage (withStore, putValue, getValue)
-import Text.Hamlet
-import Text.ParserCombinators.Parsec (parse)
-import Yesod
-
-import Hledger.Cli.Commands.Add (journalAddTransaction)
-import Hledger.Cli.Commands.Balance
-import Hledger.Cli.Commands.Print
-import Hledger.Cli.Commands.Register
-import Hledger.Cli.Options hiding (value)
-import Hledger.Cli.Utils
-import Hledger.Data
-import Hledger.Read.Journal (someamount)
-#ifdef MAKE
-import Paths_hledger_make (getDataFileName)
-#else
-import Paths_hledger (getDataFileName)
-#endif
-
-
-defhost = "localhost"
-defport = 5000
-browserstartdelay = 100000 -- microseconds
-hledgerurl = "http://hledger.org"
-manualurl = hledgerurl++"/MANUAL.html"
-
-web :: [Opt] -> [String] -> Journal -> IO ()
-web opts args j = do
- let host = fromMaybe defhost $ hostFromOpts opts
- port = fromMaybe defport $ portFromOpts opts
- url = printf "http://%s:%d" host port :: String
- unless (Debug `elem` opts) $ forkIO (browser url) >> return ()
- server url port opts args j
-
-browser :: String -> IO ()
-browser url = putStrLn "starting web browser" >> threadDelay browserstartdelay >> openBrowserOn url >> return ()
-
-server :: String -> Int -> [Opt] -> [String] -> Journal -> IO ()
-server url port opts args j = do
- printf "starting web server at %s\n" url
- fp <- getDataFileName "web"
- let app = HledgerWebApp{
- appOpts=opts
- ,appArgs=args
- ,appJournal=j
- ,appWebdir=fp
- ,appRoot=url
- }
- withStore "hledger" $ do -- IO ()
- putValue "hledger" "journal" j
- toWaiApp app >>= run port
-
-data HledgerWebApp = HledgerWebApp {
- appOpts::[Opt]
- ,appArgs::[String]
- ,appJournal::Journal
- ,appWebdir::FilePath
- ,appRoot::String
- }
-
-instance Yesod HledgerWebApp where approot = appRoot
-
-mkYesod "HledgerWebApp" [$parseRoutes|
-/ IndexPage GET
-/transactions TransactionsPage GET POST
-/register RegisterPage GET
-/balance BalancePage GET
-/style.css StyleCss GET
-/params ParamsDebug GET
-|]
-
-getParamsDebug = do
- r <- getRequest
- return $ RepHtml $ toContent $ show $ reqGetParams r
-
-getIndexPage :: Handler HledgerWebApp ()
-getIndexPage = redirect RedirectTemporary TransactionsPage
-
-getStyleCss :: Handler HledgerWebApp RepPlain
-getStyleCss = do
- app <- getYesod
- let dir = appWebdir app
- s <- liftIO $ readFile $ dir "style.css"
- header "Content-Type" "text/css"
- return $ RepPlain $ toContent s
-
-getTransactionsPage :: Handler HledgerWebApp RepHtml
-getTransactionsPage = withLatestJournalRender (const showTransactions)
-
-getRegisterPage :: Handler HledgerWebApp RepHtml
-getRegisterPage = withLatestJournalRender showRegisterReport
-
-getBalancePage :: Handler HledgerWebApp RepHtml
-getBalancePage = withLatestJournalRender showBalanceReport
-
-withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
-withLatestJournalRender reportfn = do
- app <- getYesod
- params <- getParams
- t <- liftIO $ getCurrentLocalTime
- let head' x = if null x then "" else head x
- as = head' $ params "a"
- ps = head' $ params "p"
- opts = appOpts app ++ [Period ps]
- args = appArgs app ++ [as]
- fspec = optsToFilterSpec opts args t
- -- reload journal if changed
- j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
- (changed, j') <- liftIO $ journalReloadIfChanged opts j
- when changed $ liftIO $ putValue "hledger" "journal" j'
- -- run the specified report using this request's params
- let s = reportfn opts fspec j'
- -- render the standard template
- req <- getRequest
- msg <- getMessage
- Just here <- getRoute
- hamletToRepHtml $ template here req msg as ps "hledger" s
-
-template :: HledgerWebAppRoutes
- -> Request -> Maybe (Html ()) -> String -> String
- -> String -> String -> Hamlet HledgerWebAppRoutes
-template here req msg as ps title content = [$hamlet|
-!!!
-%html
- %head
- %title $string.title$
- %meta!http-equiv=Content-Type!content=$string.metacontent$
- %link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
- %body
- ^navbar'^
- #messages $m$
- ^addform'^
- #content
- %pre $string.content$
-|]
- where m = fromMaybe (string "") msg
- navbar' = navbar here req as ps
- addform' = addform req as ps
- stylesheet = StyleCss
- metacontent = "text/html; charset=utf-8"
-
-navbar :: HledgerWebAppRoutes -> Request -> String -> String -> Hamlet HledgerWebAppRoutes
-navbar here req as ps = [$hamlet|
- #navbar
- %a#hledgerorglink!href=$string.hledgerurl$ hledger.org
- ^navlinks'^
- ^searchform'^
- %a#helplink!href=$string.manualurl$ help
-|]
- where navlinks' = navlinks req as ps
- searchform' = searchform here as ps
-
-navlinks :: Request -> String -> String -> Hamlet HledgerWebAppRoutes
-navlinks _ as ps = [$hamlet|
- #navlinks
- ^transactionslink^ | $
- ^registerlink^ | $
- ^balancelink^
-|]
- where
- transactionslink = navlink "transactions" TransactionsPage
- registerlink = navlink "register" RegisterPage
- balancelink = navlink "balance" BalancePage
- navlink s dest = [$hamlet|%a.navlink!href=@?u@ $string.s$|]
- where u = (dest, [("a", as), ("p", ps)])
-
-searchform :: HledgerWebAppRoutes -> String -> String -> Hamlet HledgerWebAppRoutes
-searchform here a p = [$hamlet|
- %form#searchform!action=$string.action$
- search for: $
- %input!name=a!size=20!value=$string.a$
- ^ahelp^ $
- in reporting period: $
- %input!name=p!size=20!value=$string.p$
- ^phelp^ $
- %input!name=submit!type=submit!value=filter!style=display:none;
- ^resetlink^
-|]
- where
- action=""
- ahelp = helplink "filter-patterns"
- phelp = helplink "period-expressions"
- resetlink
- | null a && null p = [$hamlet||]
- | otherwise = [$hamlet|%span#resetlink $
- %a!href=@here@ reset|]
-
-helplink topic = [$hamlet|%a!href=$string.u$ ?|]
- where u = manualurl ++ if null topic then "" else '#':topic
-
-addform :: Request -> String -> String -> Hamlet HledgerWebAppRoutes
-addform _ _ _ = [$hamlet|
- %form#addform!action=$string.action$!method=POST
- %table!border=0
- %tr
- %td
- Date:
- %input!size=15!name=date!value=$string.date$
- ^datehelp^ $
- Description:
- %input!size=35!name=desc!value=$string.desc$ $
- ^transactionfields1^
- ^transactionfields2^
- %tr#addbuttonrow
- %td
- %input!type=submit!value=$string.addlabel$
- ^addhelp^
-
-|]
- where
- datehelp = helplink "dates"
- addlabel = "add transaction"
- addhelp = helplink "file-format"
- action=""
- date = ""
- desc = ""
- transactionfields1 = transactionfields 1
- transactionfields2 = transactionfields 2
-
--- transactionfields :: Int -> Hamlet String
-transactionfields n = [$hamlet|
- %tr
- %td
-
- Account:
- %input!size=35!name=$string.acctvar$!value=$string.acct$
-
- Amount:
- %input!size=15!name=$string.amtvar$!value=$string.amt$ $
-|]
- where
- acct = ""
- amt = ""
- numbered = (++ show n)
- acctvar = numbered "acct"
- amtvar = numbered "amt"
-
-postTransactionsPage :: Handler HledgerWebApp RepPlain
-postTransactionsPage = do
- today <- liftIO getCurrentDay
- -- get form input values, or basic validation errors. E means an Either value.
- dateE <- runFormPost $ catchFormError $ notEmpty $ required $ input "date"
- descE <- runFormPost $ catchFormError $ required $ input "desc"
- acct1E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct1"
- amt1E <- runFormPost $ catchFormError $ required $ input "amt1"
- acct2E <- runFormPost $ catchFormError $ notEmpty $ required $ input "acct2"
- amt2E <- runFormPost $ catchFormError $ required $ input "amt2"
- -- supply defaults and parse date and amounts, or get errors.
- let dateE' = either Left (either (\e -> Left [("date", showDateParseError e)]) Right . fixSmartDateStrEither today) dateE
- amt1E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt1E -- XXX missingamt only when missing/empty
- amt2E' = either Left (either (const (Right missingamt)) Right . parse someamount "") amt2E
- strEs = [dateE', descE, acct1E, acct2E]
- amtEs = [amt1E', amt2E']
- errs = lefts strEs ++ lefts amtEs
- [date,desc,acct1,acct2] = rights strEs
- [amt1,amt2] = rights amtEs
- -- if no errors so far, generate a transaction and balance it or get the error.
- tE | not $ null errs = Left errs
- | otherwise = either (\e -> Left [[("unbalanced postings", head $ lines e)]]) Right
- (balanceTransaction $ nulltransaction {
- tdate=parsedate date
- ,teffectivedate=Nothing
- ,tstatus=False
- ,tcode=""
- ,tdescription=desc
- ,tcomment=""
- ,tpostings=[
- Posting False acct1 amt1 "" RegularPosting Nothing
- ,Posting False acct2 amt2 "" RegularPosting Nothing
- ]
- ,tpreceding_comment_lines=""
- })
- -- display errors or add transaction
- case tE of
- Left errs -> do
- -- save current form values in session
- setMessage $ string $ intercalate ", " $ map (intercalate ", " . map (\(a,b) -> a++": "++b)) errs
- redirect RedirectTemporary TransactionsPage
-
- Right t -> do
- let t' = txnTieKnot t -- XXX move into balanceTransaction
- j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
- -- j' <- liftIO $ journalAddTransaction j t' >>= journalReload
- -- liftIO $ putValue "hledger" "journal" j'
- liftIO $ journalAddTransaction j t'
- setMessage $ string $ printf "Added transaction:\n%s" (show t')
- redirect RedirectTemporary TransactionsPage
-
diff --git a/Hledger/Cli/Main.hs b/Hledger/Cli/Main.hs
index 166d5931b..56afae2ea 100644
--- a/Hledger/Cli/Main.hs
+++ b/Hledger/Cli/Main.hs
@@ -70,7 +70,7 @@ main = do
#ifdef VTY
| cmd `isPrefixOf` "vty" = withJournalDo opts args cmd vty
#endif
-#if defined(WEB) || defined(WEBYESOD)
+#if defined(WEB) || defined(WEB610)
| cmd `isPrefixOf` "web" = withJournalDo opts args cmd web
#endif
#ifdef CHART
diff --git a/Hledger/Cli/Options.hs b/Hledger/Cli/Options.hs
index 77788466e..062552f70 100644
--- a/Hledger/Cli/Options.hs
+++ b/Hledger/Cli/Options.hs
@@ -38,7 +38,7 @@ usagehdr =
#ifdef VTY
" vty - run a simple curses-style UI\n" ++
#endif
-#if defined(WEB) || defined(WEBYESOD)
+#if defined(WEB) || defined(WEB610)
" web - run a simple web-based UI\n" ++
#endif
#ifdef CHART
@@ -81,7 +81,7 @@ options = [
,Option "M" ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary"
,Option "Q" ["quarterly"] (NoArg QuarterlyOpt) "register report: show quarterly summary"
,Option "Y" ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary"
-#if defined(WEB) || defined(WEBYESOD)
+#ifdef WEB
,Option "" ["host"] (ReqArg Host "HOST") "web: use hostname HOST rather than localhost"
,Option "" ["port"] (ReqArg Port "N") "web: use tcp port N rather than 5000"
#endif
@@ -119,7 +119,7 @@ data Opt =
MonthlyOpt |
QuarterlyOpt |
YearlyOpt |
-#if defined(WEB) || defined(WEBYESOD)
+#ifdef WEB
Host {value::String} |
Port {value::String} |
#endif
@@ -224,7 +224,7 @@ displayExprFromOpts opts = listtomaybe $ optValuesForConstructor Display opts
listtomaybe [] = Nothing
listtomaybe vs = Just $ last vs
-#if defined(WEB) || defined(WEBYESOD)
+#ifdef WEB
-- | Get the value of the (last) host option, if any.
hostFromOpts :: [Opt] -> Maybe String
hostFromOpts opts = listtomaybe $ optValuesForConstructor Host opts
diff --git a/Hledger/Cli/Version.hs b/Hledger/Cli/Version.hs
index 13582b08b..e8277eee9 100644
--- a/Hledger/Cli/Version.hs
+++ b/Hledger/Cli/Version.hs
@@ -70,8 +70,8 @@ configflags = tail [""
,"vty"
#endif
#if defined(WEB)
- ,"web (using loli/hsp/simpleserver)"
-#elif defined(WEBYESOD)
,"web (using yesod/hamlet/simpleserver)"
+#elif defined(WEB610)
+ ,"web (using loli/hsp/simpleserver)"
#endif
]
diff --git a/MANUAL.markdown b/MANUAL.markdown
index 88b06ce10..d215d33ec 100644
--- a/MANUAL.markdown
+++ b/MANUAL.markdown
@@ -68,17 +68,21 @@ with the cabal-install tool:
extra features (if you're new to cabal, I recommend you get the basic
install working first, then add these one at a time):
- - `-fvty` - builds the [vty](#vty) command. (Not available on microsoft
- windows.)
-
- - `-fweb` - builds the [web](#web) command (works with ghc 6.10).
-
- - `-fwebyesod` - builds a newer version of the [web](#web) command (requires ghc 6.12).
-
- - `-fchart` builds the [chart](#chart) command. This requires
- additional GTK/GHC integration libraries (on ubuntu: `apt-get
- install libghc6-gtk-dev`) and possibly other things - see the
+ - `-fchart` builds the [chart](#chart) command, enabling simple
+ balance pie chart generation. This requires additional GTK/GHC
+ integration libraries (on ubuntu: `apt-get install libghc6-gtk-dev`)
+ and possibly other things - see the
[gtk2hs install docs](http://code.haskell.org/gtk2hs/INSTALL).
+ At present this add a lot of build complexity for not much gain.
+
+ - `-fvty` - builds the [vty](#vty) command, enabling a basic
+ curses-style user interface. This does not work on microsoft
+ windows, unless possibly with cygwin.
+
+ - `-fweb` - builds the [web](#web) command, enabling a web-based user
+ interface (requires ghc 6.12). If you are stuck with ghc 6.10, you
+ can use `-fweb610` instead, to build an older version of the
+ [web](#web) command.
If you have any trouble, proceed at once to [Troubleshooting](#troubleshooting) for help!
@@ -115,7 +119,7 @@ on:
hledger histogram # transactions per day, or other interval
hledger add # add some new transactions to the ledger file
hledger vty # curses ui, if installed with -fvty
- hledger web # web ui, if installed with -fweb or -fwebyesod
+ hledger web # web ui, if installed with -fweb or -fweb610
hledger chart # make a balance chart, if installed with -fchart
You'll find more examples below.
@@ -280,8 +284,6 @@ Examples:
##### chart
-(optional feature)
-
The chart command saves a pie chart of your top account balances to an
image file (usually "hledger.png", or use -o/--output FILE). You can
adjust the image resolution with --size=WIDTHxHEIGHT, and the number of
@@ -303,6 +305,8 @@ Examples:
$ hledger chart ^expenses -o balance.png --size 1000x600 --items 20
$ for m in 01 02 03 04 05 06 07 08 09 10 11 12; do hledger -p 2009/$m chart ^expenses --depth 2 -o expenses-2009$m.png --size 400x300; done
+This is an optional feature; see [installing](#installing).
+
##### histogram
The histogram command displays a quick bar chart showing transaction
@@ -323,8 +327,6 @@ Examples:
##### vty
-(optional feature)
-
The vty command starts hledger's curses (full-screen, text) user interface,
which allows interactive navigation of the print/register/balance
reports. This lets you browse around your numbers and get quick insights
@@ -335,6 +337,8 @@ Examples:
$ hledger vty
$ hledger vty -BE food
+This is an optional feature; see [installing](#installing).
+
#### Modifying commands
The following commands can alter your ledger file.
@@ -350,32 +354,25 @@ $ hledger add $ hledger add accounts:personal:bob
##### web
-(optional feature)
-
The web command starts hledger's web interface, and tries to open a web
-browser to view it (if this fails, you'll have to visit the indicated url
-yourself.) The web ui combines the features of the print, register,
-balance and add commands.
+browser to view it. (If this fails, you'll have to manually visit the url
+it displays.) The web interface combines the features of the print,
+register, balance and add commands, and adds a general edit command.
-Note there are two alternate implementations of the web command - the old
-one, built with `-fweb`:
+This is an optional feature. Note there is also an older implementation of
+the web command which does not provide edit. See [installing](#installing).
+
+Examples:
$ hledger web
-
-and the new one, built with `-fwebyesod`, which you run in the same way:
-
- $ hledger web
-
-We will assume the latter in the rest of these docs. Some more examples:
-
$ hledger web -E -B p 'this year'
$ hledger web --base-url http://this.vhost.com --port 5010 --debug -f my.journal
-The new web ui adds an edit command. Warning: this is the first hledger
-feature which can alter your existing journal data. You can edit, or
-ERASE, the (top-level) journal file through the web ui. There is no access
-control. A numbered backup of the file will be saved at each edit, in
-normal circumstances (eg if file permissions allow, disk is not full, etc.)
+About the edit command: warning, this is the first hledger feature which
+can alter your existing journal data. You can edit, or erase, the journal
+file through the web ui. There is no access control. A numbered backup of
+the file will be saved at each edit, in normal circumstances (eg if file
+permissions allow, disk is not full, etc.)
#### Other commands
@@ -884,8 +881,8 @@ sailing. Here are some known issues and things to try:
- **Did you cabal update ?** If you didn't already, ``cabal update`` and try again.
-- **Do you have a new enough version of GHC ?** As of 2010, 6.10 and 6.12
- are supported, 6.8 might or might not work.
+- **Do you have a new enough version of GHC ?** hledger supports GHC 6.10
+ and 6.12. Building with the `-fweb` flag requires 6.12 or greater.
- **Do you have a new enough version of cabal-install ?**
Recent versions tend to be better at resolving dependencies. The error
@@ -894,11 +891,12 @@ sailing. Here are some known issues and things to try:
$ cabal update
$ cabal install cabal-install
+ $ cabal clean
then try installing hledger again.
- **Could not run trhsx.**
- You are installing with `-fweb`, which needs to run the ``trhsx`` executable.
+ You are installing with `-fweb610`, which needs to run the ``trhsx`` executable.
It is installed by the hsx package in ~/.cabal/bin, which needs to be in
your path.
@@ -921,10 +919,14 @@ sailing. Here are some known issues and things to try:
you are probably on a mac with macports libraries installed, causing
[this issue](http://hackage.haskell.org/trac/ghc/ticket/4068).
- To work around, add this --extra-lib-dirs flag:
+ To work around temporarily, add this --extra-lib-dirs flag:
$ cabal install hledger --extra-lib-dirs=/usr/lib
+ or permanently, add this to ~/.cabal/config:
+
+ extra-lib-dirs: /usr/lib
+
- **A ghc: panic! (the 'impossible' happened)** might be
[this issue](http://hackage.haskell.org/trac/ghc/ticket/3862)
@@ -949,16 +951,13 @@ sailing. Here are some known issues and things to try:
Look for the cause of the failure near the end of the output. If it's
not apparent, try again with `-v2` or `-v3` for more verbose output.
-- **cabal fails to reconcile dependencies.**
- This could be related to your GHC version: hledger requires at least GHC
- 6.10 and `-fwebyesod` requires 6.12 or greater.
-
- Also, it's possible for cabal to get confused, eg if you have
- installed/updated many cabal package versions or GHC itself. You can
- sometimes work around this by using cabal install's `--constraint`
- option. Another (drastic) way is to purge all unnecessary package
- versions by removing (or renaming) ~/.ghc, then trying cabal install
- again.
+- **cabal fails to resolve dependencies.**
+ It's possible for cabal to get confused, eg if you have
+ installed/updated many cabal package versions or GHC itself. You can
+ sometimes work around this by using cabal install's `--constraint`
+ option. Another (drastic) way is to purge all unnecessary package
+ versions by removing (or renaming) ~/.ghc, then trying cabal install
+ again.
#### Usage issues
diff --git a/Makefile b/Makefile
index 6087d5eeb..0f9699eca 100644
--- a/Makefile
+++ b/Makefile
@@ -1,8 +1,8 @@
# hledger project makefile
# optional features described in MANUAL, comment out if you don't have the libs
-#OPTFLAGS=-DCHART -DVTY -DWEBHAPPSTACK
-OPTFLAGS=-DVTY -DWEB
+#OPTFLAGS=-DCHART -DVTY -DWEB
+OPTFLAGS=-DWEB
#OPTFLAGS=
# command to run during "make ci"
diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal
index 5987a3a34..5070b7ef3 100644
--- a/hledger-lib/hledger-lib.cabal
+++ b/hledger-lib/hledger-lib.cabal
@@ -25,6 +25,8 @@ build-type: Simple
-- sample.timelog
library
+ -- should set patchlevel here as in Makefile
+ cpp-options: -DPATCHLEVEL=0
exposed-modules:
Hledger.Data
Hledger.Data.Account
@@ -58,9 +60,6 @@ library
,utf8-string >= 0.3
,HUnit
- -- should set patchlevel here as in Makefile
- cpp-options: -DPATCHLEVEL=0
-
-- source-repository head
-- type: darcs
-- location: http://joyful.com/repos/hledger
diff --git a/hledger.cabal b/hledger.cabal
index e60f5a6b8..0caef1874 100644
--- a/hledger.cabal
+++ b/hledger.cabal
@@ -18,7 +18,7 @@ maintainer: Simon Michael
homepage: http://hledger.org
bug-reports: http://code.google.com/p/hledger/issues
stability: experimental
-tested-with: GHC==6.10
+tested-with: GHC==6.10, GHC==6.12
cabal-version: >= 1.2
build-type: Custom
data-dir: data
@@ -35,24 +35,26 @@ extra-source-files:
data/sample.timelog
data/sample.rules
+flag chart
+ description: enable simple balance pie chart generation
+ default: False
+
flag vty
- description: enable the curses ui
+ description: enable the curses-style ui
default: False
flag web
- description: enable the web ui (using loli/hsp/simpleserver, works with ghc 6.10)
- default: False
-
-flag webyesod
description: enable the web ui (using yesod/hamlet/simpleserver, requires ghc 6.12)
default: False
-flag chart
- description: enable the pie chart generation
+flag web610
+ description: enable the web ui (using loli/hsp/simpleserver, works with ghc 6.10)
default: False
executable hledger
main-is: hledger.hs
+ -- should set patchlevel here as in Makefile
+ cpp-options: -DPATCHLEVEL=0
other-modules:
Paths_hledger
Hledger.Cli.Main
@@ -87,8 +89,12 @@ executable hledger
,time
,utf8-string >= 0.3
- -- should set patchlevel here as in Makefile
- cpp-options: -DPATCHLEVEL=0
+ if flag(chart)
+ cpp-options: -DCHART
+ other-modules:Hledger.Cli.Commands.Chart
+ build-depends:
+ Chart >= 0.11
+ ,colour
if flag(vty)
cpp-options: -DVTY
@@ -99,6 +105,18 @@ executable hledger
if flag(web)
cpp-options: -DWEB
other-modules:Hledger.Cli.Commands.Web
+ build-depends:
+ bytestring >= 0.9.1 && < 0.9.2
+ ,blaze-html >= 0.1.1 && < 0.2
+ ,hamlet >= 0.3.1 && < 0.4
+ ,io-storage >= 0.3 && < 0.4
+ ,wai >= 0.1 && < 0.2
+ ,wai-extra >= 0.1 && < 0.2
+ ,yesod >= 0.3.1 && < 0.4
+
+ if flag(web610)
+ cpp-options: -DWEB610
+ other-modules:Hledger.Cli.Commands.Web610
build-depends:
hsp
,hsx
@@ -111,27 +129,13 @@ executable hledger
,HTTP >= 4000.0
,applicative-extras
- if flag(webyesod)
- cpp-options: -DWEBYESOD
- other-modules:Hledger.Cli.Commands.WebYesod
- build-depends:
- bytestring >= 0.9.1 && < 0.9.2
- ,blaze-html >= 0.1.1 && < 0.2
- ,hamlet >= 0.3.1 && < 0.4
- ,io-storage >= 0.3 && < 0.4
- ,wai >= 0.1 && < 0.2
- ,wai-extra >= 0.1 && < 0.2
- ,yesod >= 0.3.1 && < 0.4
-
- if flag(chart)
- cpp-options: -DCHART
- other-modules:Hledger.Cli.Commands.Chart
- build-depends:
- Chart >= 0.11
- ,colour
-
+-- modules and dependencies below should be as above, except
+-- chart, vty, web etc. are not presently exposed as library functions
library
+ -- should set patchlevel here as in Makefile
+ cpp-options: -DPATCHLEVEL=0
exposed-modules:
+ Paths_hledger
Hledger.Cli.Main
Hledger.Cli.Options
Hledger.Cli.Tests
@@ -164,37 +168,6 @@ library
,time
,utf8-string >= 0.3
- -- should set patchlevel here as in Makefile
- cpp-options: -DPATCHLEVEL=0
-
- if flag(vty)
- cpp-options: -DVTY
- exposed-modules:Hledger.Cli.Commands.Vty
- build-depends:
- vty >= 4.0.0.1
-
- if flag(web)
- cpp-options: -DWEB
- exposed-modules:Hledger.Cli.Commands.Web
- build-depends:
- hsp
- ,hsx
- ,xhtml >= 3000.2
- ,loli
- ,io-storage
- ,hack-contrib
- ,hack
- ,hack-handler-simpleserver
- ,HTTP >= 4000.0
- ,applicative-extras
-
- if flag(chart)
- cpp-options: -DCHART
- exposed-modules:Hledger.Cli.Commands.Chart
- build-depends:
- Chart >= 0.11
- ,colour
-
-- source-repository head
-- type: darcs
-- location: http://joyful.com/repos/hledger