diff --git a/Hledger/Cli/Commands/All.hs b/Hledger/Cli/Commands/All.hs
index 95d5ebd3c..edb46d141 100644
--- a/Hledger/Cli/Commands/All.hs
+++ b/Hledger/Cli/Commands/All.hs
@@ -18,9 +18,12 @@ module Hledger.Cli.Commands.All (
#ifdef VTY
module Hledger.Cli.Commands.Vty,
#endif
-#if defined(WEB) || defined(WEBHAPPSTACK)
+#if defined(WEB)
module Hledger.Cli.Commands.Web,
#endif
+#if defined(WEBYESOD)
+ module Hledger.Cli.Commands.WebYesod,
+#endif
#ifdef CHART
module Hledger.Cli.Commands.Chart,
#endif
@@ -37,9 +40,12 @@ import Hledger.Cli.Commands.Stats
#ifdef VTY
import Hledger.Cli.Commands.Vty
#endif
-#if defined(WEB) || defined(WEBHAPPSTACK)
+#if defined(WEB)
import Hledger.Cli.Commands.Web
#endif
+#if defined(WEBYESOD)
+import Hledger.Cli.Commands.WebYesod
+#endif
#ifdef CHART
import Hledger.Cli.Commands.Chart
#endif
@@ -59,9 +65,12 @@ tests_Hledger_Commands = TestList
-- #ifdef VTY
-- ,Hledger.Cli.Commands.Vty.tests_Vty
-- #endif
--- #if defined(WEB) || defined(WEBHAPPSTACK)
+-- #if defined(WEB)
-- ,Hledger.Cli.Commands.Web.tests_Web
-- #endif
+-- #if defined(WEBYESOD)
+-- ,Hledger.Cli.Commands.WebYesod.tests_Web
+-- #endif
-- #ifdef CHART
-- ,Hledger.Cli.Commands.Chart.tests_Chart
-- #endif
diff --git a/Hledger/Cli/Commands/Web.hs b/Hledger/Cli/Commands/Web.hs
index e87e5dc0a..518c68332 100644
--- a/Hledger/Cli/Commands/Web.hs
+++ b/Hledger/Cli/Commands/Web.hs
@@ -21,12 +21,7 @@ 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)
-#ifdef WEBHAPPSTACK
-import System.Process (readProcess)
-import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))
-#else
import Hack.Handler.SimpleServer (run)
-#endif
import Network.Loli (loli, io, get, post, html, text, public)
import Network.Loli.Type (AppUnit)
@@ -70,12 +65,7 @@ server opts args j =
t <- getCurrentLocalTime
webfiles <- getDataFileName "web"
putValue "hledger" "journal" j
-#ifdef WEBHAPPSTACK
- hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"
- runWithConfig (ServerConf tcpport hostname) $ -- (Env -> IO Response) -> IO ()
-#else
run tcpport $ -- (Env -> IO Response) -> IO ()
-#endif
\env -> do -- IO Response
-- general request handler
let opts' = opts ++ [Period $ unwords $ map decodeString $ reqParamUtf8 env "p"]
diff --git a/Hledger/Cli/Commands/WebYesod.hs b/Hledger/Cli/Commands/WebYesod.hs
new file mode 100644
index 000000000..de979dd99
--- /dev/null
+++ b/Hledger/Cli/Commands/WebYesod.hs
@@ -0,0 +1,339 @@
+{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, TemplateHaskell #-}
+{-|
+A web-based UI.
+-}
+
+module Hledger.Cli.Commands.WebYesod
+where
+
+-- import Codec.Binary.UTF8.String (decodeString)
+import Control.Concurrent -- (forkIO)
+import qualified Network.Wai (Request(pathInfo))
+import System.Directory (getModificationTime)
+import System.FilePath (())
+import System.IO.Storage (withStore, putValue, getValue)
+import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
+import Text.Hamlet
+-- import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Char8 as B
+import Yesod
+-- import Yesod.Helpers.Static
+
+-- 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.Cli.Options hiding (value)
+import Hledger.Cli.Utils (openBrowserOn)
+import Hledger.Data
+import Hledger.Read
+#ifdef MAKE
+import Paths_hledger_make (getDataFileName)
+#else
+import Paths_hledger (getDataFileName)
+#endif
+
+
+tcpport = 5000 :: Int
+browserdelay = 100000 -- microseconds
+homeurl = printf "http://localhost:%d" tcpport
+hledgerurl = "http://hledger.org"
+manualurl = hledgerurl++"/MANUAL.html"
+
+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 = do
+ printf "starting web server on port %d\n" tcpport
+ fp <- getDataFileName "web"
+ let app = HledgerWebApp{
+ appOpts=opts
+ ,appArgs=args
+ ,appJournal=j
+ ,appWebdir=fp
+ }
+ withStore "hledger" $ do -- IO ()
+ putValue "hledger" "journal" j
+ toWaiApp app >>= basicHandler tcpport
+
+data HledgerWebApp = HledgerWebApp {
+ appOpts::[Opt]
+ ,appArgs::[String]
+ ,appJournal::Journal
+ ,appWebdir::FilePath
+ }
+
+instance Yesod HledgerWebApp where approot _ = homeurl
+
+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
+
+getTransactionsPage :: Handler HledgerWebApp RepHtml
+getTransactionsPage = withLatestJournalRender (const showTransactions)
+
+postTransactionsPage :: Handler HledgerWebApp RepHtml
+postTransactionsPage = withLatestJournalRender (const showTransactions)
+
+getRegisterPage :: Handler HledgerWebApp RepHtml
+getRegisterPage = withLatestJournalRender showRegisterReport
+
+getBalancePage :: Handler HledgerWebApp RepHtml
+getBalancePage = withLatestJournalRender showBalanceReport
+
+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
+
+withLatestJournalRender :: ([Opt] -> FilterSpec -> Journal -> String) -> Handler HledgerWebApp RepHtml
+withLatestJournalRender f = do
+ app <- getYesod
+ req <- getRequest
+ params <- getParams
+ t <- liftIO $ getCurrentLocalTime
+ let as = params "a"
+ ps = params "p"
+ opts = appOpts app ++ [Period $ unwords ps]
+ args = appArgs app ++ as
+ fs = optsToFilterSpec opts args t
+ j <- liftIO $ fromJust `fmap` getValue "hledger" "journal"
+ j' <- liftIO $ journalReloadIfChanged opts args j
+ let content = f opts fs j'
+ return $ RepHtml $ toContent $ renderHamlet id $ template req as ps "" content
+ -- hamletToRepHtml $ template "" s
+
+journalReloadIfChanged :: [Opt] -> [String] -> Journal -> IO Journal
+journalReloadIfChanged opts _ j@Journal{filepath=f,filereadtime=tread} = do
+ tmod <- journalFileModifiedTime j
+ let newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
+ -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)
+ if newer
+ then do
+ when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" f
+ reload j
+ else return j
+
+journalFileModifiedTime :: Journal -> IO ClockTime
+journalFileModifiedTime Journal{filepath=f}
+ | null f = getClockTime
+ | otherwise = getModificationTime f `Prelude.catch` \_ -> getClockTime
+
+reload :: Journal -> IO Journal
+reload Journal{filepath=f} = do
+ j' <- readJournalFile Nothing f
+ putValue "hledger" "journal" j'
+ return j'
+
+stylesheet = "/style.css"
+-- stylesheet = StaticR "/style.css"
+metacontent = "text/html; charset=utf-8"
+
+template :: Request -> [String] -> [String] -> String -> String -> Hamlet String
+template req as ps t s = [$hamlet|
+!!!
+%html
+ %head
+ %meta!http-equiv=Content-Type!content=$string.metacontent$
+ %link!rel=stylesheet!type=text/css!href=@stylesheet@!media=all
+ %title $string.t$
+ %body
+ ^navbar'^
+ #messages $string.msgs$
+ #content
+ %pre $string.s$
+|]
+ where msgs = intercalate ", " []
+ navbar' = navbar req as ps
+
+navbar :: Request -> [String] -> [String] -> Hamlet String
+navbar req as ps = [$hamlet|
+ #navbar
+ %a#hledgerorglink!href=@hledgerurl@ hledger.org
+ ^navlinks'^
+ ^searchform'^
+ %a#helplink!href=@manualurl@ help
+|]
+ where navlinks' = navlinks req as ps
+ searchform' = searchform req as ps
+
+navlinks :: Request -> [String] -> [String] -> Hamlet String
+navlinks _ as ps = [$hamlet|
+ #navlinks
+ ^transactionslink^ | $
+ ^registerlink^ | $
+ ^balancelink^
+|]
+ where
+ transactionslink = navlink "transactions"
+ registerlink = navlink "register"
+ balancelink = navlink "balance"
+ navlink s = [$hamlet|%a.navlink!href=@u@ $string.s$|]
+ where u = printf "../%s?a=%s&p=%s" s (intercalate "+" as) (intercalate "+" ps)
+
+searchform :: Request -> [String] -> [String] -> Hamlet String
+searchform req as ps = [$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=""
+ a = intercalate "+" as
+ p = intercalate "+" ps
+ ahelp = helplink "filter-patterns"
+ phelp = helplink "period-expressions"
+ resetlink
+ | null a && null p = [$hamlet||]
+ | otherwise = [$hamlet|%span#resetlink $
+ %a!href=@u@ reset|]
+ where u = B.unpack $ Network.Wai.pathInfo $ waiRequest req
+
+helplink topic = [$hamlet|%a!href=@u@ ?|]
+ where u = manualurl ++ if null topic then "" else '#':topic
+
+{-
+
+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
+
+
+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
+
+ |
+ <% nbsp %><% nbsp %>
+ Account: <% nbsp %>
+ Amount: <% nbsp %>
+ |
+
+ 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 >> reload j
+ ledgerpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
+ where msg = printf "Added transaction:\n%s" (show t)
+
+-}
diff --git a/Hledger/Cli/Main.hs b/Hledger/Cli/Main.hs
index 342a2d9b2..10240a7f5 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(WEBHAPPSTACK)
+#if defined(WEB) || defined(WEBYESOD)
| cmd `isPrefixOf` "web" = withJournalDo opts args cmd web
#endif
#ifdef CHART
diff --git a/hledger.cabal b/hledger.cabal
index 33878637c..cc2378b7e 100644
--- a/hledger.cabal
+++ b/hledger.cabal
@@ -40,7 +40,11 @@ flag vty
default: False
flag web
- description: enable the web ui (using simpleserver)
+ description: enable the web ui (using loli, hack, simpleserver)
+ default: False
+
+flag webyesod
+ description: enable the web ui (using yesod, wai, simpleserver)
default: False
flag chart
@@ -107,6 +111,16 @@ 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
+ ,hamlet >= 0.3.1 && < 0.4
+ ,io-storage >= 0.3 && < 0.4
+ ,wai >= 0.1 && < 0.2
+ ,yesod >= 0.3.1 && < 0.4
+
if flag(chart)
cpp-options: -DCHART
other-modules:Hledger.Cli.Commands.Chart