web command now shows ledger/register/balance, starts browser

HappsCommand.hs

@@ -1,14 +1,24 @@
 {-| 
-
 A happs-based web UI for hledger.
-
 -}
 
 module WebCommand
 where
-import qualified Data.Map as Map
+import qualified Data.Map as M
 import Data.Map ((!))
+import Data.Time.Clock
+import Data.Time.Format
+import System.Locale
+import Control.Concurrent
+import qualified Text.StringTemplate as T
+import Codec.Compression.GZip (compress)
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.UTF8 (fromString, toString)
 import HAppS.Server
+import System.Cmd (system)
+import System.Info (os)
+import System.Exit
+
 import Ledger
 import Options
 import BalanceCommand
@@ -32,8 +42,91 @@ tcpport = 5000
 
 web :: [Opt] -> [String] -> Ledger -> IO ()
 web opts args l = do
-  putStrLn $ printf "starting hledger web server on port %d" tcpport
+  putStrLn $ printf "starting web server on port %d" tcpport
-  simpleHTTP nullConf{port=tcpport} [
+  tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ handlers opts args l
-                     method GET $ ok $ toResponse $ output
+  putStrLn "starting web browser"
-                    ]
+  browseUrl $ printf "http://localhost:%s/print" (show tcpport)
-      where output = showBalanceReport (opts++[SubTotal]) [] l
+  waitForTermination
+  putStrLn "shutting down..."
+  killThread tid
+  putStrLn "shutdown complete"
+
+template  = "<div align=center style=width:100%%>" ++
+            " <a href=print>ledger</a>" ++
+            " | <a href=register>register</a>" ++
+            " | <a href=balance>balance</a>" ++
+            "</div>" ++
+            "<pre>%s</pre>"
+
+type Handler = ServerPart Response
+
+handlers :: [Opt] -> [String] -> Ledger -> [Handler]
+handlers opts args l = 
+        [
+          dir "print" [withRequest $ \r -> respond $ printreport r]
+        , dir "register" [withRequest $ \r -> respond $ registerreport r]
+        , dir "balance" [withRequest $ \r -> respond $ balancereport r]
+        ]
+    where
+      respond = ok . setContentType "text/html" . toResponse . (printf template :: String -> String)
+      printreport r = showEntries opts (pats r ++ args) l
+      registerreport r = showRegisterReport opts (pats r ++ args) l
+      balancereport r = showBalanceReport (opts++[SubTotal]) (pats r ++ args) l
+      pats r = as -- ++ if null ds then [] else ("--":ds)
+               where (as,ds) = (queryValues "a" r, queryValues "d" r)
+
+queryValues :: String -> Request -> [String]
+queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r
+
+queryValue :: String -> Request -> Maybe String
+queryValue q r = case filter ((==q).fst) $ rqInputs r of
+                   [] -> Nothing
+                   is -> Just $ B.unpack $ inputValue $ snd $ head is
+
+-- | Attempt to open a web browser on the given url, all platforms.
+browseUrl :: String -> IO ExitCode
+browseUrl u = trybrowsers browsers u
+    where
+      trybrowsers (b:bs) u = do
+        e <- system $ printf "%s %s" b u
+        case e of
+          ExitSuccess -> return ExitSuccess
+          ExitFailure _ -> trybrowsers bs u
+      trybrowsers [] u = do
+        putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers
+        putStrLn $ printf "Please open your browser and visit %s" u
+        return $ ExitFailure 127
+      browsers | os=="darwin"  = ["open -a firefox", "open"]
+               | os=="mingw32" = ["firefox","safari","opera","iexplore"]
+               | otherwise     = ["firefox","sensible-browser"]
+    -- jeffz: write a ffi binding for it using the Win32 package as a basis
+    -- start by adding System/Win32/Shell.hsc and follow the style of any
+    -- other module in that directory for types, headers, error handling and
+    -- what not.
+    -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL);
+    -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL);
+
+withExpiresHeaders :: ServerPart Response -> ServerPart Response
+withExpiresHeaders sp = require getCacheTime $ \t -> [liftM (setHeader "Expires" $ formatDateTime "%a, %d %b %Y %T GMT" t) sp]
+
+getCacheTime :: IO (Maybe UTCTime)
+getCacheTime = getCurrentTime >>= (return . Just . addMinutes 360)
+
+addMinutes :: Int -> UTCTime -> UTCTime
+addMinutes n = addUTCTime (fromIntegral n) 
+
+formatDateTime :: String -> UTCTime -> String
+formatDateTime = formatTime defaultTimeLocale
+
+setContentType :: String -> Response -> Response
+setContentType = setHeader "Content-Type"
+
+setFilename :: String -> Response -> Response
+setFilename = setHeader "Content-Disposition" . \fname -> "attachment: filename=\"" ++ fname ++ "\""
+
+gzipBinary :: Response -> Response
+gzipBinary r@(Response {rsBody = b}) =  setHeader "Content-Encoding" "gzip" $ r {rsBody = compress b}
+
+acceptsZip :: Request -> Bool
+acceptsZip req = isJust $ M.lookup (fromString "accept-encoding") (rqHeaders req)
+