installing: drop -fweb610 flag
This commit is contained in:
Simon Michael
parent
c42496b134
commit
03ca434cdb
@ -23,8 +23,6 @@ module Hledger.Cli.Commands.All (
|
||||
#endif
|
||||
#if defined(WEB)
|
||||
module Hledger.Cli.Commands.Web,
|
||||
#elif defined(WEB610)
|
||||
module Hledger.Cli.Commands.Web610,
|
||||
#endif
|
||||
tests_Hledger_Commands
|
||||
)
|
||||
@ -44,8 +42,6 @@ import Hledger.Cli.Commands.Vty
|
||||
#endif
|
||||
#if defined(WEB)
|
||||
import Hledger.Cli.Commands.Web
|
||||
#elif defined(WEB610)
|
||||
import Hledger.Cli.Commands.Web610
|
||||
#endif
|
||||
import Test.HUnit (Test(TestList))
|
||||
|
||||
@ -68,6 +64,4 @@ tests_Hledger_Commands = TestList
|
||||
-- #endif
|
||||
-- #if defined(WEB)
|
||||
-- ,Hledger.Cli.Commands.Web.tests_Web
|
||||
-- #elif defined(WEB610)
|
||||
-- ,Hledger.Cli.Commands.Web610.tests_Web
|
||||
-- #endif
|
||||
|
||||
@ -1,316 +0,0 @@
|
||||
{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
|
||||
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
|
||||
{-|
|
||||
A web-based UI.
|
||||
-}
|
||||
|
||||
module Hledger.Cli.Commands.Web610
|
||||
where
|
||||
import Codec.Binary.UTF8.String (decodeString)
|
||||
import Control.Applicative.Error (Failing(Success,Failure))
|
||||
import Control.Concurrent
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.IORef (newIORef, atomicModifyIORef)
|
||||
import System.IO.Storage (withStore, putValue, getValue)
|
||||
import Text.ParserCombinators.Parsec (parse)
|
||||
|
||||
import Hack.Contrib.Constants (_TextHtmlUTF8)
|
||||
import Hack.Contrib.Response (set_content_type)
|
||||
import qualified Hack (Env, http)
|
||||
import qualified Hack.Contrib.Request (inputs, params, path)
|
||||
import qualified Hack.Contrib.Response (redirect)
|
||||
import Hack.Handler.SimpleServer (run)
|
||||
|
||||
import Network.Loli (loli, io, get, post, html, text, public)
|
||||
import Network.Loli.Type (AppUnit)
|
||||
import Network.Loli.Utils (update)
|
||||
|
||||
import HSP hiding (Request,catch)
|
||||
import qualified HSP (Request(..))
|
||||
|
||||
import Hledger.Cli.Commands.Add (journalAddTransaction)
|
||||
import Hledger.Cli.Commands.Balance
|
||||
import Hledger.Cli.Commands.Histogram
|
||||
import Hledger.Cli.Commands.Print
|
||||
import Hledger.Cli.Commands.Register
|
||||
import Hledger.Data
|
||||
import Hledger.Read.Journal (someamount)
|
||||
import Hledger.Cli.Options hiding (value)
|
||||
#ifdef MAKE
|
||||
import Paths_hledger_make (getDataFileName)
|
||||
#else
|
||||
import Paths_hledger (getDataFileName)
|
||||
#endif
|
||||
import Hledger.Cli.Utils
|
||||
|
||||
|
||||
tcpport = 5000 :: Int
|
||||
homeurl = printf "http://localhost:%d/" tcpport
|
||||
browserdelay = 100000 -- microseconds
|
||||
|
||||
web :: [Opt] -> [String] -> Journal -> IO ()
|
||||
web opts args j = do
|
||||
unless (Debug `elem` opts) $ forkIO browser >> return ()
|
||||
server opts args j
|
||||
|
||||
browser :: IO ()
|
||||
browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()
|
||||
|
||||
server :: [Opt] -> [String] -> Journal -> IO ()
|
||||
server opts args j =
|
||||
-- server initialisation
|
||||
withStore "hledger" $ do -- IO ()
|
||||
printf "starting web server on port %d\n" tcpport
|
||||
t <- getCurrentLocalTime
|
||||
webfiles <- getDataFileName "web"
|
||||
putValue "hledger" "journal" j
|
||||
run tcpport $ -- (Env -> IO Response) -> IO ()
|
||||
\env -> do -- IO Response
|
||||
-- general request handler
|
||||
let opts' = opts ++ [Period $ unwords $ map decodeString $ reqParamUtf8 env "p"]
|
||||
args' = args ++ map decodeString (reqParamUtf8 env "a")
|
||||
j' <- fromJust `fmap` getValue "hledger" "journal"
|
||||
(jE, changed) <- io $ journalReloadIfChanged opts j'
|
||||
let (j''', err) = either (\e -> (j',e)) (\j'' -> (j'',"")) jE
|
||||
when (changed && null err) $ putValue "hledger" "journal" j'''
|
||||
when (changed && not (null err)) $ printf "error while reading %s\n" (filepath j')
|
||||
-- declare path-specific request handlers
|
||||
let command :: [String] -> ([Opt] -> FilterSpec -> Journal -> String) -> AppUnit
|
||||
command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) j'''
|
||||
(loli $ -- State Loli () -> (Env -> IO Response)
|
||||
do
|
||||
get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()
|
||||
get "/register" $ command [] showRegisterReport
|
||||
get "/histogram" $ command [] showHistogram
|
||||
get "/transactions" $ journalpage [] j''' (showTransactions (optsToFilterSpec opts' args' t))
|
||||
post "/transactions" $ handleAddform j'''
|
||||
get "/env" $ getenv >>= (text . show)
|
||||
get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params)
|
||||
get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs)
|
||||
public (Just webfiles) ["/style.css"]
|
||||
get "/" $ redirect ("transactions") Nothing
|
||||
) env
|
||||
|
||||
getenv = ask
|
||||
response = update
|
||||
redirect u c = response $ Hack.Contrib.Response.redirect u c
|
||||
|
||||
reqParamUtf8 :: Hack.Env -> String -> [String]
|
||||
reqParamUtf8 env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
|
||||
|
||||
journalpage :: [String] -> Journal -> (Journal -> String) -> AppUnit
|
||||
journalpage msgs j f = do
|
||||
env <- getenv
|
||||
(jE, _) <- io $ journalReloadIfChanged [] j
|
||||
let (j'', _) = either (\e -> (j,e)) (\j' -> (j',"")) jE
|
||||
hsp msgs $ const <div><% addform env %><pre><% f j'' %></pre></div>
|
||||
|
||||
-- | A loli directive to serve a string in pre tags within the hledger web
|
||||
-- layout.
|
||||
string :: [String] -> String -> AppUnit
|
||||
string msgs s = hsp msgs $ const <pre><% s %></pre>
|
||||
|
||||
-- | A loli directive to serve a hsp template wrapped in the hledger web
|
||||
-- layout. The hack environment is passed in to every hsp template as an
|
||||
-- argument, since I don't see how to get it within the hsp monad.
|
||||
-- A list of messages is also passed, eg for form errors.
|
||||
hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
|
||||
hsp msgs f = do
|
||||
env <- getenv
|
||||
let contenthsp = f env
|
||||
pagehsp = hledgerpage env msgs title contenthsp
|
||||
html =<< (io $ do
|
||||
hspenv <- hackEnvToHspEnv env
|
||||
(_,xml) <- runHSP html4Strict pagehsp hspenv
|
||||
return $ addDoctype $ renderAsHTML xml)
|
||||
response $ set_content_type _TextHtmlUTF8
|
||||
where
|
||||
title = ""
|
||||
addDoctype = ("<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n" ++)
|
||||
hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
|
||||
hackEnvToHspEnv env = do
|
||||
x <- newIORef 0
|
||||
let req = HSP.Request (reqParamUtf8 env) (Hack.http env)
|
||||
num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
|
||||
return $ HSPEnv req num
|
||||
|
||||
-- htmlToHsp :: Html -> HSP XML
|
||||
-- htmlToHsp h = return $ cdata $ showHtml h
|
||||
|
||||
-- views
|
||||
|
||||
hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
|
||||
hledgerpage env msgs title content =
|
||||
<html>
|
||||
<head>
|
||||
<meta http-equiv = "Content-Type" content = "text/html; charset=utf-8" />
|
||||
<link rel="stylesheet" type="text/css" href="/style.css" media="all" />
|
||||
<title><% title %></title>
|
||||
</head>
|
||||
<body>
|
||||
<% navbar env %>
|
||||
<div id="messages"><% intercalate ", " msgs %></div>
|
||||
<div id="content"><% content %></div>
|
||||
</body>
|
||||
</html>
|
||||
|
||||
navbar :: Hack.Env -> HSP XML
|
||||
navbar env =
|
||||
<div id="navbar">
|
||||
<a href="http://hledger.org" id="hledgerorglink">hledger.org</a>
|
||||
<% navlinks env %>
|
||||
<% searchform env %>
|
||||
<a href="http://hledger.org/MANUAL.html" id="helplink">help</a>
|
||||
</div>
|
||||
|
||||
getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p
|
||||
|
||||
navlinks :: Hack.Env -> HSP XML
|
||||
navlinks _ = do
|
||||
a <- getParamOrNull "a"
|
||||
p <- getParamOrNull "p"
|
||||
let addparams=(++(printf "?a=%s&p=%s" a p))
|
||||
link s = <a href=(addparams s) class="navlink"><% s %></a>
|
||||
<div id="navlinks">
|
||||
<% link "transactions" %> |
|
||||
<% link "register" %> |
|
||||
<% link "balance" %>
|
||||
</div>
|
||||
|
||||
searchform :: Hack.Env -> HSP XML
|
||||
searchform env = do
|
||||
a <- getParamOrNull "a"
|
||||
p <- getParamOrNull "p"
|
||||
let resetlink | null a && null p = <span></span>
|
||||
| otherwise = <span id="resetlink"><% nbsp %><a href=u>reset</a></span>
|
||||
where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
|
||||
<form action="" id="searchform">
|
||||
<% nbsp %>search for:<% nbsp %><input name="a" size="20" value=a
|
||||
/><% help "filter-patterns"
|
||||
%><% nbsp %><% nbsp %>in reporting period:<% nbsp %><input name="p" size="20" value=p
|
||||
/><% help "period-expressions"
|
||||
%><input type="submit" name="submit" value="filter" style="display:none" />
|
||||
<% resetlink %>
|
||||
</form>
|
||||
|
||||
addform :: Hack.Env -> HSP XML
|
||||
addform env = do
|
||||
today <- io $ liftM showDate $ getCurrentDay
|
||||
let inputs = Hack.Contrib.Request.inputs env
|
||||
date = decodeString $ fromMaybe today $ lookup "date" inputs
|
||||
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
|
||||
<div>
|
||||
<div id="addform">
|
||||
<form action="" method="POST">
|
||||
<table border="0">
|
||||
<tr>
|
||||
<td>
|
||||
Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %>
|
||||
Description: <input size="35" name="desc" value=desc /><% nbsp %>
|
||||
</td>
|
||||
</tr>
|
||||
<% transactionfields 1 env %>
|
||||
<% transactionfields 2 env %>
|
||||
<tr id="addbuttonrow"><td><input type="submit" value="add transaction"
|
||||
/><% help "file-format" %></td></tr>
|
||||
</table>
|
||||
</form>
|
||||
</div>
|
||||
<br clear="all" />
|
||||
</div>
|
||||
|
||||
help :: String -> HSP XML
|
||||
help topic = <a href=u>?</a>
|
||||
where u = printf "http://hledger.org/MANUAL.html%s" l :: String
|
||||
l | null topic = ""
|
||||
| otherwise = '#':topic
|
||||
|
||||
transactionfields :: Int -> Hack.Env -> HSP XML
|
||||
transactionfields n env = do
|
||||
let inputs = Hack.Contrib.Request.inputs env
|
||||
acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
|
||||
amt = decodeString $ fromMaybe "" $ lookup amtvar inputs
|
||||
<tr>
|
||||
<td>
|
||||
<% nbsp %><% nbsp %>
|
||||
Account: <input size="35" name=acctvar value=acct /><% nbsp %>
|
||||
Amount: <input size="15" name=amtvar value=amt /><% nbsp %>
|
||||
</td>
|
||||
</tr>
|
||||
where
|
||||
numbered = (++ show n)
|
||||
acctvar = numbered "acct"
|
||||
amtvar = numbered "amt"
|
||||
|
||||
handleAddform :: Journal -> AppUnit
|
||||
handleAddform j = do
|
||||
env <- getenv
|
||||
d <- io getCurrentDay
|
||||
t <- io getCurrentLocalTime
|
||||
handle t $ validate env d
|
||||
where
|
||||
validate :: Hack.Env -> Day -> Failing Transaction
|
||||
validate env today =
|
||||
let inputs = Hack.Contrib.Request.inputs env
|
||||
date = decodeString $ fromMaybe "today" $ lookup "date" inputs
|
||||
desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
|
||||
acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
|
||||
amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
|
||||
acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
|
||||
amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
|
||||
validateDate "" = ["missing date"]
|
||||
validateDate _ = []
|
||||
validateDesc "" = ["missing description"]
|
||||
validateDesc _ = []
|
||||
validateAcct1 "" = ["missing account 1"]
|
||||
validateAcct1 _ = []
|
||||
validateAmt1 "" = ["missing amount 1"]
|
||||
validateAmt1 _ = []
|
||||
validateAcct2 "" = ["missing account 2"]
|
||||
validateAcct2 _ = []
|
||||
validateAmt2 _ = []
|
||||
amt1' = either (const missingamt) id $ parse someamount "" amt1
|
||||
amt2' = either (const missingamt) id $ parse someamount "" amt2
|
||||
(date', dateparseerr) = case fixSmartDateStrEither today date of
|
||||
Right d -> (d, [])
|
||||
Left e -> ("1900/01/01", [showDateParseError e])
|
||||
t = Transaction {
|
||||
tdate = parsedate date' -- date' must be parseable
|
||||
,teffectivedate=Nothing
|
||||
,tstatus=False
|
||||
,tcode=""
|
||||
,tdescription=desc
|
||||
,tcomment=""
|
||||
,tpostings=[
|
||||
Posting False acct1 amt1' "" RegularPosting (Just t')
|
||||
,Posting False acct2 amt2' "" RegularPosting (Just t')
|
||||
]
|
||||
,tpreceding_comment_lines=""
|
||||
}
|
||||
(t', balanceerr) = case balanceTransaction t of
|
||||
Right t'' -> (t'', [])
|
||||
Left e -> (t, [head $ lines e]) -- show just the error not the transaction
|
||||
errs = concat [
|
||||
validateDate date
|
||||
,dateparseerr
|
||||
,validateDesc desc
|
||||
,validateAcct1 acct1
|
||||
,validateAmt1 amt1
|
||||
,validateAcct2 acct2
|
||||
,validateAmt2 amt2
|
||||
,balanceerr
|
||||
]
|
||||
in
|
||||
case null errs of
|
||||
False -> Failure errs
|
||||
True -> Success t'
|
||||
|
||||
handle :: LocalTime -> Failing Transaction -> AppUnit
|
||||
handle _ (Failure errs) = hsp errs addform
|
||||
handle ti (Success t) = do
|
||||
io $ journalAddTransaction j t >>= journalReload
|
||||
journalpage [msg] j (showTransactions (optsToFilterSpec [] [] ti))
|
||||
where msg = printf "Added transaction:\n%s" (show t)
|
||||
|
||||
nbsp :: XML
|
||||
nbsp = cdata " "
|
||||
@ -39,7 +39,7 @@ See "Hledger.Data.Ledger" for more examples.
|
||||
-}
|
||||
|
||||
module Hledger.Cli.Main where
|
||||
#if defined(WEB) || defined(WEB610)
|
||||
#if defined(WEB)
|
||||
import System.Info (os)
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ <= 610
|
||||
@ -76,7 +76,7 @@ main = do
|
||||
#ifdef VTY
|
||||
| cmd `isPrefixOf` "vty" = withJournalDo opts args cmd vty
|
||||
#endif
|
||||
#if defined(WEB) || defined(WEB610)
|
||||
#if defined(WEB)
|
||||
| cmd `isPrefixOf` "web" = withJournalDo opts args cmd web
|
||||
#endif
|
||||
#ifdef CHART
|
||||
@ -86,7 +86,7 @@ main = do
|
||||
| otherwise = putStr help1
|
||||
|
||||
-- in a web-enabled build on windows, run the web ui by default
|
||||
#if defined(WEB) || defined(WEB610)
|
||||
#if defined(WEB)
|
||||
defaultcmd | os=="mingw32" = Just web
|
||||
| otherwise = Nothing
|
||||
#else
|
||||
|
||||
@ -42,10 +42,10 @@ help1 =
|
||||
" (DISABLED, install with -fvty)\n" ++
|
||||
#endif
|
||||
" web - run a simple web-based UI" ++
|
||||
#if defined(WEB) || defined(WEB610)
|
||||
#if defined(WEB)
|
||||
"\n" ++
|
||||
#else
|
||||
" (DISABLED, install with -fweb or -fweb610)\n" ++
|
||||
" (DISABLED, install with -fweb)\n" ++
|
||||
#endif
|
||||
" chart - generate balances pie charts" ++
|
||||
#ifdef CHART
|
||||
|
||||
@ -70,8 +70,6 @@ configflags = tail [""
|
||||
,"vty"
|
||||
#endif
|
||||
#if defined(WEB)
|
||||
,"web (using yesod/hamlet/simpleserver)"
|
||||
#elif defined(WEB610)
|
||||
,"web (using loli/hsp/simpleserver)"
|
||||
,"web"
|
||||
#endif
|
||||
]
|
||||
|
||||
1
Makefile
1
Makefile
@ -535,7 +535,6 @@ setversion: $(VERSIONSENSITIVEFILES)
|
||||
|
||||
Hledger/Cli/Version.hs: $(VERSIONFILE)
|
||||
perl -p -e "s/(^version *= *)\".*?\"/\1\"$(VERSION3)\"/" -i $@
|
||||
# XXX also touch manually when switching between cabal install -fweb and -fweb610
|
||||
|
||||
hledger.cabal: $(VERSIONFILE)
|
||||
perl -p -e "s/(^ *version:) *.*/\1 $(VERSION)/" -i $@
|
||||
|
||||
@ -53,10 +53,6 @@ flag web
|
||||
description: enable the web ui (using yesod/hamlet/simpleserver, requires ghc 6.12)
|
||||
default: False
|
||||
|
||||
flag web610
|
||||
description: enable the web ui (using loli/hsp/simpleserver, works with ghc 6.10)
|
||||
default: False
|
||||
|
||||
executable hledger
|
||||
main-is: hledger.hs
|
||||
-- should set patchlevel here as in Makefile
|
||||
@ -118,21 +114,6 @@ executable hledger
|
||||
,data-object >= 0.3.1.2 && < 0.4
|
||||
,failure >= 0.1 && < 0.2
|
||||
|
||||
if flag(web610)
|
||||
cpp-options: -DWEB610
|
||||
other-modules:Hledger.Cli.Commands.Web610
|
||||
build-depends:
|
||||
hsp
|
||||
,hsx
|
||||
,xhtml >= 3000.2
|
||||
,loli
|
||||
,io-storage
|
||||
,hack-contrib
|
||||
,hack
|
||||
,hack-handler-simpleserver
|
||||
,HTTP >= 4000.0
|
||||
,applicative-extras
|
||||
|
||||
-- modules and dependencies below should be as above, except
|
||||
-- chart, vty, web etc. are not presently exposed as library functions
|
||||
library
|
||||
|
||||
Loading…
Reference in New Issue
Block a user