web: new -fwebyesod flag builds an alternate yesod-based web ui

This requires ghc >= 6.12.

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

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"]

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
+  <div>
+   <div id="addform">
+   <form action="" method="POST">
+    <table border="0">
+      <tr>
+        <td>
+          Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %>
+          Description: <input size="35" name="desc" value=desc /><% nbsp %>
+        </td>
+      </tr>
+      <% transactionfields 1 env %>
+      <% transactionfields 2 env %>
+      <tr id="addbuttonrow"><td><input type="submit" value="add transaction" 
+      /><% help "file-format" %></td></tr>
+    </table>
+   </form>
+   </div>
+   <br clear="all" />
+   </div>
+
+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
+  <tr>
+    <td>
+    <% nbsp %><% nbsp %>
+      Account: <input size="35" name=acctvar value=acct /><% nbsp %>
+      Amount: <input size="15" name=amtvar value=amt /><% nbsp %>
+    </td>
+   </tr>
+    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)
+
+-}

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

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