convert from HAppS to happstack

HappsCommand.hs

@@ -4,6 +4,8 @@ A happs-based web UI for hledger.
 
 module WebCommand
 where
+import Control.Monad.Trans (liftIO)
+import Data.ByteString.Lazy.UTF8 (toString)
 import qualified Data.Map as M
 import Data.Map ((!))
 import Data.Time.Clock
@@ -11,10 +13,10 @@ import Data.Time.Format
 import System.Locale
 import Control.Concurrent
 import qualified Data.ByteString.Lazy.Char8 as B
--- import qualified Text.StringTemplate as T
+import Happstack.Data (defaultValue)
--- import Codec.Compression.GZip (compress)
+import Happstack.Server
--- import Data.ByteString.UTF8 (fromString)
+import Happstack.Server.HTTP.FileServe (fileServe)
-import HAppS.Server
+import Happstack.State.Control (waitForTermination)
 import System.Cmd (system)
 import System.Info (os)
 import System.Exit
@@ -41,45 +43,54 @@ data AppState = AppState {
 tcpport = 5000
 
 web :: [Opt] -> [String] -> Ledger -> IO ()
-web opts args l = do
+web opts args l =
-  putStrLn $ printf "starting web server on port %d" tcpport
+  if Debug `elem` opts
-  tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ handlers opts args l
+     then do
-  putStrLn "starting web browser"
+       putStrLn $ printf "starting web server on port %d in debug mode" tcpport
-  browseUrl $ printf "http://localhost:%s/print" (show tcpport)
+       simpleHTTP nullConf{port=tcpport} handlers
-  waitForTermination
+     else do
-  putStrLn "shutting down..."
+       putStrLn $ printf "starting web server on port %d" tcpport
-  killThread tid
+       tid <- forkIO $ simpleHTTP nullConf{port=tcpport} handlers
-  putStrLn "shutdown complete"
+       putStrLn "starting web browser"
+       openBrowserOn $ printf "http://localhost:%s/print" (show tcpport)
+       waitForTermination
+       putStrLn "shutting down web server..."
+       killThread tid
+       putStrLn "shutdown complete"
 
-template r = printf (
-             "<div style=float:right>" ++
-             "<form action=%s>search:&nbsp;<input name=a value=%s></form>" ++
-             "</div>" ++
-             "<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>")
-             (dropWhile (=='/') $ rqUri r)
-             (fromMaybe "" $ queryValue "a" r)
-
-type Handler = ServerPart Response
-
-handlers :: [Opt] -> [String] -> Ledger -> [Handler]
-handlers opts args l = 
-        [
-          dir "print" [withRequest $ \r -> respond r $ printreport r]
-        , dir "register" [withRequest $ \r -> respond r $ registerreport r]
-        , dir "balance" [withRequest $ \r -> respond r $ balancereport r]
-        ]
     where
-      respond r = ok . setContentType "text/html" . toResponse . (printf (template r) :: String -> String)
+      handlers :: ServerPartT IO Response
-      printreport r = showEntries opts (pats r ++ args) l
+      handlers = msum
-      registerreport r = showRegisterReport opts (pats r ++ args) l
+       [dir "print" $ withDataFn (look "a") $ \a -> templatise $ printreport [a]
-      balancereport r = showBalanceReport (opts++[SubTotal]) (pats r ++ args) l
+       ,dir "print" $ templatise $ printreport []
-      pats r = as -- ++ if null ds then [] else ("--":ds)
+       ,dir "register" $ withDataFn (look "a") $ \a -> templatise $ registerreport [a]
-               where (as,ds) = (queryValues "a" r, queryValues "d" r)
+       ,dir "register" $ templatise $ registerreport []
+       ,dir "balance" $ withDataFn (look "a") $ \a -> templatise $ balancereport [a]
+       ,dir "balance" $ templatise $ balancereport []
+       ]
+      printreport apats    = showEntries opts (apats ++ args) l
+      registerreport apats = showRegisterReport opts (apats ++ args) l
+      balancereport apats  = showBalanceReport opts (apats ++ args) l
+
+templatise :: String -> ServerPartT IO Response
+templatise s = do
+  r <- askRq
+  return $ setHeader "Content-Type" "text/html" $ toResponse $ maintemplate r s
+
+maintemplate :: Request -> String -> String
+maintemplate r = printf (unlines
+  ["<div style=float:right>"
+  ,"<form action=%s>search:&nbsp;<input name=a value=%s></form>"
+  ,"</div>"
+  ,"<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>"
+  ])
+  (dropWhile (=='/') $ rqUri r)
+  (fromMaybe "" $ queryValue "a" r)
 
 queryValues :: String -> Request -> [String]
 queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r
@@ -90,8 +101,8 @@ queryValue q r = case filter ((==q).fst) $ rqInputs r of
                    is -> Just $ B.unpack $ inputValue $ snd $ head is
 
 -- | Attempt to open a web browser on the given url, all platforms.
-browseUrl :: String -> IO ExitCode
+openBrowserOn :: String -> IO ExitCode
-browseUrl u = trybrowsers browsers u
+openBrowserOn u = trybrowsers browsers u
     where
       trybrowsers (b:bs) u = do
         e <- system $ printf "%s %s" b u
@@ -112,27 +123,3 @@ browseUrl u = trybrowsers browsers u
     -- ::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)
-

hledger.cabal

@@ -68,7 +68,7 @@ Executable hledger
     Other-Modules:ANSICommand
     cpp-options: -DANSI
   if flag(happs)
-    Build-Depends:HAppS-Server>=0.9.3.1
+    Build-Depends:happstack-server>=0.2, happstack-state>=0.2
     Other-Modules:HappsCommand
     cpp-options: -DHAPPS