1 {-| 2 A happs-based web UI for hledger. 3 -} 4 5 module Commands.Web 6 where 7 import Control.Monad.Trans (liftIO) 8 import Data.ByteString.Lazy.UTF8 (toString) 9 import qualified Data.Map as M 10 -- import Data.Map ((!)) 11 import Data.Time.Clock 12 import Data.Time.Format 13 import Locale 14 import Control.Concurrent 15 import qualified Data.ByteString.Lazy.Char8 as B 16 import Happstack.Data (defaultValue) 17 import Happstack.Server 18 import Happstack.Server.HTTP.FileServe (fileServe) 19 import Happstack.State.Control (waitForTermination) 20 import System.Cmd (system) 21 import System.Info (os) 22 import System.Exit 23 import Network.HTTP (urlEncode, urlDecode, urlEncodeVars) 24 import Text.XHtml hiding (dir) 25 26 import Ledger 27 import Options hiding (value) 28 import Commands.Balance 29 import Commands.Register 30 import Commands.Print 31 import Commands.Histogram 32 import Utils (filterAndCacheLedgerWithOpts) 33 34 35 tcpport = 5000 36 37 web :: [Opt] -> [String] -> Ledger -> IO () 38 web opts args l = do 39 t <- getCurrentLocalTime -- how to get this per request ? 40 if Debug `elem` opts 41 then do 42 -- just run the server in the foreground 43 putStrLn $ printf "starting web server on port %d in debug mode" tcpport 44 simpleHTTP nullConf{port=tcpport} $ webHandlers opts args l t 45 else do 46 -- start the server (in background, so we can..) then start the web browser 47 putStrLn $ printf "starting web server on port %d" tcpport 48 tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ webHandlers opts args l t 49 putStrLn "starting web browser" 50 openBrowserOn $ printf "http://localhost:%d/" tcpport 51 waitForTermination 52 putStrLn "shutting down web server..." 53 killThread tid 54 putStrLn "shutdown complete" 55 56 webHandlers :: [Opt] -> [String] -> Ledger -> LocalTime -> ServerPartT IO Response 57 webHandlers opts args l t = msum 58 [ 59 methodSP GET $ view showBalanceReport 60 ,dir "balance" $ view showBalanceReport 61 ,dir "register" $ view showRegisterReport 62 ,dir "print" $ view showLedgerTransactions 63 ,dir "histogram" $ view showHistogram 64 ] 65 where 66 view f = withDataFn rqdata $ render f 67 render f (a,p) = renderPage (a,p) $ f opts' args' l' 68 where 69 opts' = opts ++ [Period p] 70 args' = args ++ (map urlDecode $ words a) 71 -- re-filter the full ledger with the new opts 72 l' = filterAndCacheLedgerWithOpts opts' args' t (rawledgertext l) (rawledger l) 73 rqdata = do 74 a <- look "a" `mplus` return "" -- filter patterns 75 p <- look "p" `mplus` return "" -- reporting period 76 return (a,p) 77 renderPage :: (String, String) -> String -> ServerPartT IO Response 78 renderPage (a,p) s = do 79 r <- askRq 80 return $ setHeader "Content-Type" "text/html" $ toResponse $ renderHtml $ hledgerview r a p s 81 82 {- 83 <div style=\"float:right;text-align:right;\"> 84 <form action=%s> 85 filter by: <input name=a size=30 value=\"%s\"> 86 reporting period: <input name=p size=30 value=\"%s\"> 87 %s 88 </form> 89 </div> 90 <div style=\"width:100%%; font-weight:bold;\"> 91 <a href=balance%s>balance</a> 92 | <a href=register%s>register</a> 93 | <a href=print%s>print</a> 94 | <a href=histogram%s>histogram</a> 95 </div> 96 <pre>%s</pre> 97 -} 98 hledgerview :: Request -> String -> String -> String -> Html 99 hledgerview r a p' s = body << topbar r a p' +++ pre << s 100 101 topbar :: Request -> String -> String -> Html 102 topbar r a p' = concatHtml 103 [thediv ! [thestyle "float:right; text-align:right;"] << searchform r a p' 104 ,thediv ! [thestyle "width:100%; font-weight:bold;"] << navlinks r a p'] 105 106 searchform :: Request -> String -> String -> Html 107 searchform r a p' = 108 form ! [action u] << concatHtml 109 [spaceHtml +++ stringToHtml "filter by:" +++ spaceHtml 110 ,textfield "a" ! [size s, value a] 111 ,spaceHtml 112 ,spaceHtml +++ stringToHtml "reporting period:" +++ spaceHtml 113 ,textfield "p" ! [size s, value p'] 114 ,resetlink] 115 where 116 -- another way to get them 117 -- a = fromMaybe "" $ queryValue "a" r 118 -- p = fromMaybe "" $ queryValue "p" r 119 u = dropWhile (=='/') $ rqUri r 120 s = "20" 121 resetlink | null a && null p' = noHtml 122 | otherwise = spaceHtml +++ anchor ! [href u] << stringToHtml "reset" 123 124 navlinks :: Request -> String -> String -> Html 125 navlinks r a p' = 126 concatHtml $ intersperse sep $ map linkto ["balance", "register", "print", "histogram"] 127 where 128 sep = stringToHtml " | " 129 linkto s = anchor ! [href (s++q)] << s 130 q' = intercalate "&" $ 131 (if null a then [] else [(("a="++).urlEncode) a]) ++ 132 (if null p' then [] else [(("p="++).urlEncode) p']) 133 q = if null q' then "" else '?':q' 134 135 -- queryValues :: String -> Request -> [String] 136 -- queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r 137 138 -- queryValue :: String -> Request -> Maybe String 139 -- queryValue q r = case filter ((==q).fst) $ rqInputs r of 140 -- [] -> Nothing 141 -- is -> Just $ B.unpack $ inputValue $ snd $ head is 142 143 -- | Attempt to open a web browser on the given url, all platforms. 144 openBrowserOn :: String -> IO ExitCode 145 openBrowserOn u = trybrowsers browsers u 146 where 147 trybrowsers (b:bs) u = do 148 e <- system $ printf "%s %s" b u 149 case e of 150 ExitSuccess -> return ExitSuccess 151 ExitFailure _ -> trybrowsers bs u 152 trybrowsers [] u = do 153 putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers 154 putStrLn $ printf "Please open your browser and visit %s" u 155 return $ ExitFailure 127 156 browsers | os=="darwin" = ["open"] 157 | os=="mingw32" = ["firefox","safari","opera","iexplore"] 158 | otherwise = ["sensible-browser","firefox"] 159 -- jeffz: write a ffi binding for it using the Win32 package as a basis 160 -- start by adding System/Win32/Shell.hsc and follow the style of any 161 -- other module in that directory for types, headers, error handling and 162 -- what not. 163 -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL); 164 -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL); 165