From 4c3613b473ca3d87d331727557a48f6f3e2cb97a Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Tue, 17 Mar 2009 19:52:44 +0000 Subject: [PATCH] convert from HAppS to happstack --- HappsCommand.hs | 121 +++++++++++++++++++++--------------------------- hledger.cabal | 2 +- 2 files changed, 55 insertions(+), 68 deletions(-) diff --git a/HappsCommand.hs b/HappsCommand.hs index 6ef34ecd5..3cb930fef 100644 --- a/HappsCommand.hs +++ b/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 Codec.Compression.GZip (compress) --- import Data.ByteString.UTF8 (fromString) -import HAppS.Server +import Happstack.Data (defaultValue) +import Happstack.Server +import Happstack.Server.HTTP.FileServe (fileServe) +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 - putStrLn $ printf "starting web server on port %d" tcpport - tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ handlers opts args l - putStrLn "starting web browser" - browseUrl $ printf "http://localhost:%s/print" (show tcpport) - waitForTermination - putStrLn "shutting down..." - killThread tid - putStrLn "shutdown complete" +web opts args l = + if Debug `elem` opts + then do + putStrLn $ printf "starting web server on port %d in debug mode" tcpport + simpleHTTP nullConf{port=tcpport} handlers + else do + putStrLn $ printf "starting web server on port %d" tcpport + tid <- forkIO $ simpleHTTP nullConf{port=tcpport} handlers + 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 ( - "
" ++ - "
search: 
" ++ - "
" ++ - "
" ++ - " ledger" ++ - " | register" ++ - " | balance" ++ - "
" ++ - "
%%s
") - (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) - 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) + handlers :: ServerPartT IO Response + handlers = msum + [dir "print" $ withDataFn (look "a") $ \a -> templatise $ printreport [a] + ,dir "print" $ templatise $ printreport [] + ,dir "register" $ withDataFn (look "a") $ \a -> templatise $ registerreport [a] + ,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 + ["
" + ,"
search: 
" + ,"
" + ,"
" + ," ledger" + ," | register" + ," | balance" + ,"
" + ,"
%s
" + ]) + (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 -browseUrl u = trybrowsers browsers u +openBrowserOn :: String -> IO ExitCode +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) - diff --git a/hledger.cabal b/hledger.cabal index d5c35836d..08c39c332 100644 --- a/hledger.cabal +++ b/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