web: -fweb now builds with simpleserver; the alternate -fwebhappstack builds with happstack

hack-handler-simpleserver is presumably quite a bit easier to install than
happstack, and so far fits hledger's needs just as well, so it is now the
default when installing with -fweb. To build with happstack, use
-fwebhappstack instead.  hledger --version shows which webserver was
built. Also webserver thread management has been simplified so should be
more consistent across platforms.

Commands/All.hs

@@ -18,7 +18,7 @@ module Commands.All (
 #ifdef VTY
                      module Commands.UI,
 #endif
-#ifdef WEB
+#if defined(WEB) || defined(WEBHAPPSTACK)
                      module Commands.Web,
 #endif
 #ifdef CHART
@@ -37,7 +37,7 @@ import Commands.Stats
 #ifdef VTY
 import Commands.UI
 #endif
-#ifdef WEB
+#if defined(WEB) || defined(WEBHAPPSTACK)
 import Commands.Web
 #endif
 #ifdef CHART

Commands/Web.hs

@@ -13,36 +13,31 @@ import Control.Applicative.Error (Failing(Success,Failure))
 import Control.Concurrent
 import Control.Monad.Reader (ask)
 import Data.IORef (newIORef, atomicModifyIORef)
-import HSP hiding (Request,catch)
-import HSP.HTML (renderAsHTML)
---import qualified HSX.XMLGenerator (XML)
-import Hack.Contrib.Constants (_TextHtmlUTF8)
-import Hack.Contrib.Response (set_content_type)
-import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))
-import Happstack.State.Control (waitForTermination)
 import Network.HTTP (urlEncode, urlDecode)
-import Network.Loli (loli, io, get, post, html, text, public)
---import Network.Loli.Middleware.IOConfig (ioconfig)
-import Network.Loli.Type (AppUnit)
-import Network.Loli.Utils (update)
-import Options hiding (value)
-#ifdef MAKE
-import Paths_hledger_make (getDataFileName)
-#else
-import Paths_hledger (getDataFileName)
-#endif
 import System.Directory (getModificationTime)
 import System.IO.Storage (withStore, putValue, getValue)
-import System.Process (readProcess)
 import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
 import Text.ParserCombinators.Parsec (parse)
--- import Text.XHtml hiding (dir, text, param, label)
+
--- import Text.XHtml.Strict ((<<),(+++),(!))
+import Hack.Contrib.Constants (_TextHtmlUTF8)
-import qualified HSP (Request(..))
+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 qualified Text.XHtml.Strict as H
+#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)
+import Network.Loli.Utils (update)
+
+import HSP hiding (Request,catch)
+import qualified HSP (Request(..))
+import HSP.HTML (renderAsHTML)
 
 import Commands.Add (ledgerAddTransaction)
 import Commands.Balance
@@ -50,33 +45,69 @@ import Commands.Histogram
 import Commands.Print
 import Commands.Register
 import Ledger
-import Utils (openBrowserOn)
 import Ledger.IO (readLedger)
-# 
+import Options hiding (value)
+#ifdef MAKE
+import Paths_hledger_make (getDataFileName)
+#else
+import Paths_hledger (getDataFileName)
+#endif
+import Utils (openBrowserOn)
+
 -- import Debug.Trace
 -- strace :: Show a => a -> a
 -- strace a = trace (show a) a
 
 tcpport = 5000 :: Int
 homeurl = printf "http://localhost:%d/" tcpport
+browserdelay = 100000 -- microseconds
 
 web :: [Opt] -> [String] -> Ledger -> IO ()
 web opts args l = do
-  if Debug `elem` opts
+  unless (Debug `elem` opts) $ forkIO browser >> return ()
-   then do
+  server opts args l
-    -- just run the server in the foreground
+
-    putStrLn $ printf "starting web server on port %d in debug mode" tcpport
+browser :: IO ()
-    server opts args l
+browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()
-   else do
+
-    -- start the server (in background, so we can..) then start the web browser
+server :: [Opt] -> [String] -> Ledger -> IO ()
-    printf "starting web interface on port %d\n" tcpport
+server opts args l =
-    tid <- forkIO $ server opts args l
+  -- server initialisation
-    putStrLn "starting web browser"
+  withStore "hledger" $ do -- IO ()
-    openBrowserOn homeurl
+    printf "starting web server on port %d\n" tcpport
-    waitForTermination
+    t <- getCurrentLocalTime
-    putStrLn "shutting down web server..."
+    webfiles <- getDataFileName "web"
-    killThread tid
+    putValue "hledger" "ledger" l
-    putStrLn "shutdown complete"
+#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 a = intercalate "+" $ reqparam env "a"
+           p = intercalate "+" $ reqparam env "p"
+           opts' = opts ++ [Period p]
+           args' = args ++ (map urlDecode $ words a)
+       l' <- fromJust `fmap` getValue "hledger" "ledger"
+       l'' <- reloadIfChanged opts' args' l'
+       -- declare path-specific request handlers
+       let command :: [String] -> ([Opt] -> FilterSpec -> Ledger -> String) -> AppUnit
+           command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) l''
+       (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 [] l'' (showTransactions (optsToFilterSpec opts' args' t))
+          post "/transactions"   $ handleAddform l''
+          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
@@ -115,41 +146,6 @@ reloadIfChanged opts _ l = do
 -- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger
 -- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (jtext $ journal l) (journal l)
 
-server :: [Opt] -> [String] -> Ledger -> IO ()
-server opts args l =
-  -- server initialisation
-  withStore "hledger" $ do -- IO ()
-    t <- getCurrentLocalTime
-    webfiles <- getDataFileName "web"
-    putValue "hledger" "ledger" l
-    -- XXX hack-happstack abstraction leak
-    hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"
-    runWithConfig (ServerConf tcpport hostname) $            -- (Env -> IO Response) -> IO ()
-      \env -> do -- IO Response
-       -- general request handler
-       let a = intercalate "+" $ reqparam env "a"
-           p = intercalate "+" $ reqparam env "p"
-           opts' = opts ++ [Period p]
-           args' = args ++ (map urlDecode $ words a)
-       l' <- fromJust `fmap` getValue "hledger" "ledger"
-       l'' <- reloadIfChanged opts' args' l'
-       -- declare path-specific request handlers
-       let command :: [String] -> ([Opt] -> FilterSpec -> Ledger -> String) -> AppUnit
-           command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) l''
-       (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 [] l'' (showTransactions (optsToFilterSpec opts' args' t))
-          post "/transactions"   $ handleAddform l''
-          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
-
 ledgerpage :: [String] -> Ledger -> (Ledger -> String) -> AppUnit
 ledgerpage msgs l f = do
   env <- getenv

HledgerMain.hs

@@ -37,7 +37,7 @@ main = do
 #ifdef VTY
        | cmd `isPrefixOf` "ui"        = withLedgerDo opts args cmd ui
 #endif
-#ifdef WEB
+#if defined(WEB) || defined(WEBHAPPSTACK)
        | cmd `isPrefixOf` "web"       = withLedgerDo opts args cmd web
 #endif
 #ifdef CHART

Makefile

@@ -1,7 +1,8 @@
 # hledger project makefile
 
 # optional features described in MANUAL, comment out if you don't have the libs
-OPTFLAGS=-DWEB -DVTY
+OPTFLAGS=-DCHART -DVTY -DWEB
+#OPTFLAGS=-DCHART -DVTY -DWEBHAPPSTACK
 
 # command to run during "make ci"
 CICMD=test

Version.hs

@@ -61,13 +61,15 @@ versionmsg    = progname ++ "-" ++ versionstr ++ configmsg :: String
               | otherwise = " with " ++ intercalate ", " configflags
 
 configflags   = tail [""
-#ifdef VTY
-  ,"vty"
-#endif
-#ifdef WEB
-  ,"web"
-#endif
 #ifdef CHART
   ,"chart"
+#endif
+#ifdef VTY
+  ,"vty"
+#endif
+#if defined(WEB)
+  ,"web (using simpleserver)"
+#else if defined(WEBHAPPSTACK)
+  ,"web (using happstack)"
 #endif
  ]

hledger.cabal

@@ -35,7 +35,11 @@ flag vty
   default:     False
 
 flag web
-  description: enable the web ui
+  description: enable the web ui (using simpleserver)
+  default:     False
+
+flag webhappstack
+  description: enable the web ui (using happstack)
   default:     False
 
 flag chart
@@ -105,6 +109,21 @@ executable hledger
   if flag(web)
     cpp-options: -DWEB
     other-modules: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(webhappstack)
+    cpp-options: -DWEBHAPPSTACK
+    other-modules:Commands.Web
     build-depends:
                   hsp
                  ,hsx