diff --git a/Hledger/Cli/Commands/All.hs b/Hledger/Cli/Commands/All.hs index cc9f4f720..fe7090e7d 100644 --- a/Hledger/Cli/Commands/All.hs +++ b/Hledger/Cli/Commands/All.hs @@ -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 diff --git a/Hledger/Cli/Commands/Web610.hs b/Hledger/Cli/Commands/Web610.hs deleted file mode 100644 index 5491fe419..000000000 --- a/Hledger/Cli/Commands/Web610.hs +++ /dev/null @@ -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
<% addform env %>
<% f j'' %>
- --- | 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 
<% s %>
- --- | 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 = ("\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 = - - - - - <% title %> - - - <% navbar env %> -
<% intercalate ", " msgs %>
-
<% content %>
- - - -navbar :: Hack.Env -> HSP XML -navbar env = - - -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 = <% s %> - - -searchform :: Hack.Env -> HSP XML -searchform env = do - a <- getParamOrNull "a" - p <- getParamOrNull "p" - let resetlink | null a && null p = - | otherwise = <% nbsp %>reset - where u = dropWhile (=='/') $ Hack.Contrib.Request.path env -
- <% nbsp %>search for:<% nbsp %><% help "filter-patterns" - %><% nbsp %><% nbsp %>in reporting period:<% nbsp %><% help "period-expressions" - %> - <% resetlink %> -
- -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 -
-
-
- - - - - <% transactionfields 1 env %> - <% transactionfields 2 env %> - -
- Date: <% help "dates" %><% nbsp %> - Description: <% nbsp %> -
<% help "file-format" %>
-
-
-
-
- -help :: String -> HSP XML -help topic = ? - 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 - - - <% nbsp %><% nbsp %> - Account: <% nbsp %> - Amount: <% nbsp %> - - - 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 " " diff --git a/Hledger/Cli/Main.hs b/Hledger/Cli/Main.hs index 80661b76c..e51cb8f84 100644 --- a/Hledger/Cli/Main.hs +++ b/Hledger/Cli/Main.hs @@ -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 diff --git a/Hledger/Cli/Options.hs b/Hledger/Cli/Options.hs index f1050eafa..640ea81f7 100644 --- a/Hledger/Cli/Options.hs +++ b/Hledger/Cli/Options.hs @@ -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 diff --git a/Hledger/Cli/Version.hs b/Hledger/Cli/Version.hs index 420565471..7dbc1fb42 100644 --- a/Hledger/Cli/Version.hs +++ b/Hledger/Cli/Version.hs @@ -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 ] diff --git a/Makefile b/Makefile index 66749d8ad..4e1ab6b94 100644 --- a/Makefile +++ b/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 $@ diff --git a/hledger.cabal b/hledger.cabal index 011d4870f..82689218d 100644 --- a/hledger.cabal +++ b/hledger.cabal @@ -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