convert from HAppS to happstack
This commit is contained in:
Simon Michael
parent
08a3d43c39
commit
4c3613b473
121
HappsCommand.hs
121
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 (
|
||||
"<div style=float:right>" ++
|
||||
"<form action=%s>search: <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)
|
||||
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
|
||||
["<div style=float:right>"
|
||||
,"<form action=%s>search: <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
|
||||
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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user