From 63531f8adc976774e1aed4163d579a281ac9d6bb Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Sat, 11 Sep 2010 01:47:46 +0000 Subject: [PATCH] web: update for cassius, julius, template reloading, authentication, persistence --- hledger-web/Hledger/{Web.hs => Web/App.hs} | 676 +++++++++++++-------- hledger-web/Hledger/Web/Settings.hs | 133 ++++ hledger-web/Main.hs | 51 +- hledger-web/data/static/style.css | 2 +- hledger-web/hledger-web.cabal | 27 +- 5 files changed, 620 insertions(+), 269 deletions(-) rename hledger-web/Hledger/{Web.hs => Web/App.hs} (69%) create mode 100644 hledger-web/Hledger/Web/Settings.hs diff --git a/hledger-web/Hledger/Web.hs b/hledger-web/Hledger/Web/App.hs similarity index 69% rename from hledger-web/Hledger/Web.hs rename to hledger-web/Hledger/Web/App.hs index 811b09b8d..bc90e9368 100644 --- a/hledger-web/Hledger/Web.hs +++ b/hledger-web/Hledger/Web/App.hs @@ -1,21 +1,30 @@ -{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} {-| -A web-based UI. +The web app providing a richer interface to hledger's data, along with +authentication, registration and persistent storage of user accounts. -} - -module Hledger.Web +module Hledger.Web.App + ( App (..) + , withApp + ) where -import Control.Concurrent (forkIO, threadDelay) import Control.Applicative ((<$>), (<*>)) import Control.Failure +-- import qualified Data.ByteString.Lazy as L import Data.Either +-- import System.Directory import System.FilePath ((), takeFileName) -import System.IO.Storage (withStore, putValue, getValue) +import System.IO.Storage (putValue, getValue) import Text.ParserCombinators.Parsec (parse) + +import Database.Persist.GenericSql (ConnectionPool, SqlPersist, runMigration, migrate) import Yesod +import Yesod.Mail import Yesod.Helpers.Static -import Text.Hamlet +import Yesod.Helpers.Auth +-- import Yesod.WebRoutes +import Text.Hamlet (defaultHamletSettings) import Text.Hamlet.RT import Hledger.Cli.Commands.Add (journalAddTransaction) @@ -25,34 +34,66 @@ import Hledger.Cli.Commands.Register import Hledger.Cli.Options hiding (value) import Hledger.Cli.Utils import Hledger.Cli.Version (version) -import Hledger.Data hiding (today) +import Hledger.Data hiding (insert, today) import Hledger.Read (journalFromPathAndString) import Hledger.Read.Journal (someamount) -#ifdef MAKE -import Paths_hledger_web_make (getDataFileName) -#else -import Paths_hledger_web (getDataFileName) -#endif +import Hledger.Web.Settings ( + withConnectionPool + , runConnectionPool + -- , staticroot + , staticdir + , hamletFile + , cassiusFile + , juliusFile + , hledgerorgurl + , manualurl + , style_css + , hledger_js + , jquery_js + , jquery_url_js + , dhtmlxcommon_js + , dhtmlxcombo_js + , robots_txt + ) -defhost = "localhost" -defport = 5000 -browserstartdelay = 100000 -- microseconds -hledgerorgurl = "http://hledger.org" -manualurl = hledgerorgurl++"/MANUAL.html" +---------------------------------------------------------------------- +-- define the web app +---------------------------------------------------------------------- -data HledgerWebApp = HledgerWebApp { - appRoot :: String - ,appDir :: FilePath - ,appOpts :: [Opt] - ,appArgs :: [String] - ,appJournal :: Journal - ,appStatic :: Static - } +-- persistent data schema for the web app. User account info is stored here, +-- hledger's main data is stored in the usual places (journal files etc.) +-- persist (quasi-quoter from persistent) defines a list of data entities. +-- mkPersist (template haskell from persistent) defines persistence-capable data types based on these. +mkPersist [$persist| +User + ident String + password String null update + UniqueUser ident +Email + email String + user UserId null update + verkey String null update + UniqueEmail email +|] -type Handler = GHandler HledgerWebApp HledgerWebApp +-- run-time data kept by the web app. +data App = App + {appConnPool :: Maybe ConnectionPool + ,appRoot :: String + ,appDataDir :: FilePath + ,appOpts :: [Opt] + ,appArgs :: [String] + ,appJournal :: Journal + ,appStatic :: Static + } -mkYesod "HledgerWebApp" [$parseRoutes| +-- parseRoutes (quasi-quoter from web-routes) defines a list of route patterns for the web app. +-- mkYesod (template haskell from yesod) defines types for the web app based on the routes. +mkYesod "App" [$parseRoutes| +/auth AuthR Auth getAuth +/favicon.ico FaviconR GET +/robots.txt RobotsR GET /static StaticR Static appStatic / IndexR GET /journalonly JournalOnlyR GET POST @@ -63,20 +104,132 @@ mkYesod "HledgerWebApp" [$parseRoutes| /addformrt AddformRTR GET |] -style_css = StaticRoute ["style.css"] [] -hledger_js = StaticRoute ["hledger.js"] [] -jquery_js = StaticRoute ["jquery.js"] [] -jquery_url_js = StaticRoute ["jquery.url.js"] [] -dhtmlxcommon_js = StaticRoute ["dhtmlxcommon.js"] [] -dhtmlxcombo_js = StaticRoute ["dhtmlxcombo.js"] [] +type Handler = GHandler App App -instance Yesod HledgerWebApp where approot = appRoot +instance Yesod App where + approot = appRoot + defaultLayout widget = do + mmsg <- getMessage + pc <- widgetToPageContent $ do + widget + addStyle $(cassiusFile "default-layout") + hamletToRepHtml $(hamletFile "default-layout") + authRoute _ = Just $ AuthR LoginR + -- static file-serving optimisations, disable for the moment + -- urlRenderOverride a (StaticR s) = + -- Just $ uncurry (joinPath a staticroot) $ format s + -- where + -- format = formatPathSegments ss + -- ss :: Site StaticRoute (String -> Maybe (GHandler Static App ChooseRep)) + -- ss = getSubSite + urlRenderOverride _ _ = Nothing + -- addStaticContent ext' _ content = do + -- let fn = base64md5 content ++ '.' : ext' + -- let statictmp = staticdir ++ "/tmp/" + -- liftIO $ createDirectoryIfMissing True statictmp + -- liftIO $ L.writeFile (statictmp ++ fn) content + -- return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) -defaultroute = JournalR +instance YesodPersist App where + type YesodDB App = SqlPersist + runDB db = do + y <- getYesod + let p = appConnPool y + case p of Just p' -> runConnectionPool db p' + Nothing -> error "no connection pool, programmer error" -- XXX + +instance YesodAuth App where + type AuthEntity App = User + type AuthEmailEntity App = Email + + defaultDest _ = IndexR + + getAuthId creds _extra = runDB $ do + x <- getBy $ UniqueUser $ credsIdent creds + case x of + Just (uid, _) -> return $ Just uid + Nothing -> do + fmap Just $ insert $ User (credsIdent creds) Nothing + + openIdEnabled _ = True + + emailSettings _ = Just EmailSettings { + addUnverified = \email verkey -> runDB $ insert $ Email email Nothing (Just verkey) + , sendVerifyEmail = sendVerifyEmail' + , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get + , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key] + , verifyAccount = \eid -> runDB $ do + me <- get eid + case me of + Nothing -> return Nothing + Just e -> do + let email = emailEmail e + case emailUser e of + Just uid -> return $ Just uid + Nothing -> do + uid <- insert $ User email Nothing + update eid [EmailUser $ Just uid] + return $ Just uid + , getPassword = runDB . fmap (join . fmap userPassword) . get + , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass] + , getEmailCreds = \email -> runDB $ do + me <- getBy $ UniqueEmail email + case me of + Nothing -> return Nothing + Just (eid, e) -> return $ Just EmailCreds + { emailCredsId = eid + , emailCredsAuthId = emailUser e + , emailCredsStatus = isJust $ emailUser e + , emailCredsVerkey = emailVerkey e + } + , getEmail = runDB . fmap (fmap emailEmail) . get + } + +sendVerifyEmail' :: String -> String -> String -> GHandler Auth m () +sendVerifyEmail' email _ verurl = + liftIO $ renderSendMail Mail + { mailHeaders = + [ ("From", "noreply") + , ("To", email) + , ("Subject", "Verify your email address") + ] + , mailPlain = verurl + , mailParts = return Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partDisposition = Inline + , partContent = renderHamlet id [$hamlet| +%p Please confirm your email address by clicking on the link below. +%p + %a!href=$verurl$ $verurl$ +%p Thank you +|] + } + } + +-- | Migrate the app's persistent data and run the given yesod/persistent/wai-ish IO action on it. +withApp :: App -> (Yesod.Application -> IO a) -> IO a +withApp app f = toPersistentApp app >>= toWaiApp >>= f + +-- | Obtain a persistent db connection pool to the app, and run any necessary data migrations. +toPersistentApp :: App -> IO App +toPersistentApp app = withConnectionPool $ \p -> do + flip runConnectionPool p $ runMigration $ do + migrate (undefined :: User) + migrate (undefined :: Email) + return () + return app{appConnPool=Just p} + + +---------------------------------------------------------------------- +-- handler utilities, common templates +---------------------------------------------------------------------- + +nulltemplate = [$hamlet||] -- | A bundle of useful data passed to templates. data TemplateData = TD { - here :: HledgerWebAppRoute -- ^ the current page's route + here :: AppRoute -- ^ the current page's route ,title :: String -- ^ page's title ,msg :: Maybe Html -- ^ transient message ,a :: String -- ^ a (acct/desc filter pattern) parameter @@ -95,42 +248,13 @@ mktd = TD { ,today = ModifiedJulianDay 0 } --- | The web command. -web :: [Opt] -> [String] -> Journal -> IO () -web opts args j = do - let host = defhost - port = fromMaybe defport $ portFromOpts opts - baseurl = fromMaybe (printf "http://%s:%d" host port) $ baseUrlFromOpts opts - unless (Debug `elem` opts) $ forkIO (browser baseurl) >> return () - server baseurl port opts args j - -browser :: String -> IO () -browser baseurl = do - putStrLn "starting web browser" - threadDelay browserstartdelay - openBrowserOn baseurl - return () - -server :: String -> Int -> [Opt] -> [String] -> Journal -> IO () -server baseurl port opts args j = do - printf "starting web server on port %d with base url %s\n" port baseurl - dir <- getDataFileName "" - let app = HledgerWebApp{ - appRoot=baseurl - ,appDir=dir - ,appStatic=fileLookupDir (dir "static") $ typeByExt -- ++[("hamlet","text/plain")] - ,appOpts=opts - ,appArgs=args - ,appJournal=j - } - withStore "hledger" $ do - putValue "hledger" "journal" j - basicHandler' port Nothing app - --- | Gather all the stuff we want for a typical hledger web request handler. -getHandlerParameters :: Handler - (String, String, [Opt], FilterSpec, Journal, Maybe Html, HledgerWebAppRoute) -getHandlerParameters = do +-- | Gather the data useful for a hledger web request handler, including: +-- initial command-line options, current a and p query string values, a +-- journal filter specification based on the above and the current time, +-- an up-to-date parsed journal, the current route, and the current ui +-- message if any. +getHandlerData :: Handler (String, String, [Opt], FilterSpec, Journal, Maybe Html, AppRoute) +getHandlerData = do Just here <- getCurrentRoute (a, p, opts, fspec) <- getReportParameters (j, err) <- getLatestJournal opts @@ -170,18 +294,207 @@ getHandlerParameters = do oldmsg <- getMessage return $ maybe oldmsg (Just . string) newmsgstr +-- | Wrap a template with the standard hledger web ui page layout. +pageLayout :: TemplateData -> Hamlet AppRoute -> Hamlet AppRoute +pageLayout td@TD{title=basetitle, msg=msg, p=p, j=j, today=today} content = [$hamlet| +!!! +%html + %head + %title $title'$ + %meta!http-equiv=Content-Type!content=$metacontent$ + %script!type=text/javascript!src=@StaticR.jquery_js@ + %script!type=text/javascript!src=@StaticR.jquery_url_js@ + %script!type=text/javascript!src=@StaticR.dhtmlxcommon_js@ + %script!type=text/javascript!src=@StaticR.dhtmlxcombo_js@ + %script!type=text/javascript!src=@StaticR.hledger_js@ + %link!rel=stylesheet!type=text/css!media=all!href=@StaticR.style_css@ + %body + ^navbar.td^ + #messages $m$ + #content + ^content^ +|] + where title' = basetitle ++ " - " ++ journaltitle + (journaltitle, _) = journalTitleDesc j p today + metacontent = "text/html; charset=utf-8" + m = fromMaybe (string "") msg + +-- | Global toolbar/heading area. +navbar :: TemplateData -> Hamlet AppRoute +navbar TD{p=p,j=j,today=today} = [$hamlet| + #navbar + %a.topleftlink!href=$hledgerorgurl$ + hledger +
+ $version$ + %a.toprightlink!href=$manualurl$!target=hledgerhelp manual + %h1 $title$ + \ $ + %span#journaldesc $desc$ +|] + where (title, desc) = journalTitleDesc j p today + +-- | Generate a title and description for the given journal, period +-- expression, and date. +journalTitleDesc :: Journal -> String -> Day -> (String, String) +journalTitleDesc j p today = (title, desc) + where + title = printf "%s" (takeFileName $ filepath j) :: String + desc = printf "%s" (showspan span) :: String + span = either (const $ DateSpan Nothing Nothing) snd (parsePeriodExpr today p) + showspan (DateSpan Nothing Nothing) = "" + showspan s = " (" ++ dateSpanAsText s ++ ")" + +-- | Links to the main views. +navlinks :: TemplateData -> Hamlet AppRoute +navlinks td = [$hamlet| + #navlinks + ^accountsjournallink^ + \ | $ + ^accountsregisterlink^ + \ | $ + %a#addformlink!href!onclick="return addformToggle()" add transaction + %a#importformlink!href!onclick="return importformToggle()"!style=display:none; import transactions + \ | $ + %a#editformlink!href!onclick="return editformToggle()" edit journal +|] +-- \ | $ + where + accountsjournallink = navlink td "journal" JournalR + accountsregisterlink = navlink td "register" RegisterR + +navlink :: TemplateData -> String -> AppRoute -> Hamlet AppRoute +navlink TD{here=here,a=a,p=p} s dest = [$hamlet|%a#$s$link.$style$!href=@?u@ $s$|] + where u = (dest, concat [(if null a then [] else [("a", a)]) + ,(if null p then [] else [("p", p)])]) + style | dest == here = "navlinkcurrent" + | otherwise = "navlink" + +-- | Form controlling journal filtering parameters. +filterform :: TemplateData -> Hamlet AppRoute +filterform TD{here=here,a=a,p=p} = [$hamlet| + #filterformdiv + %form#filterform.form!method=GET!style=display:$visible$; + %table.form + %tr.$filteringperiodclass$ + %td + filter by period: + \ $ + %td + %input!name=p!size=60!value=$p$ + ^phelp^ + \ $ + %td!align=right + ^stopfilteringperiod^ + %tr.$filteringclass$ + %td + filter by account/description: + \ $ + %td + %input!name=a!size=60!value=$a$ + ^ahelp^ + \ $ + %input!type=submit!value=filter $ + \ $ + %td!align=right + ^stopfiltering^ +|] + where + ahelp = helplink "filter-patterns" "?" + phelp = helplink "period-expressions" "?" + filtering = not $ null a + filteringperiod = not $ null p + visible = "block" + filteringclass = if filtering then "filtering" else "" + filteringperiodclass = if filteringperiod then "filtering" else "" + stopfiltering = if filtering then [$hamlet|%a#stopfilterlink!href=@?u@ stop filtering acct/desc|] else nulltemplate + where u = (here, if filteringperiod then [("p", p)] else []) + stopfilteringperiod = if filteringperiod then [$hamlet|%a#stopfilterlink!href=@?u@ stop filtering period|] else nulltemplate + where u = (here, if filtering then [("a", a)] else []) + +-- | Link to a topic in the manual. +helplink :: String -> String -> Hamlet AppRoute +helplink topic label = [$hamlet|%a!href=$u$!target=hledgerhelp $label$|] + where u = manualurl ++ if null topic then "" else '#':topic + +-- | Render a runtime template with the provided runtime data as html. +renderHamletFileRT :: FilePath -> HamletMap AppRoute -> Handler Html +renderHamletFileRT hfile hmap = do + hrt <- readTemplateFile hfile >>= parseHamletRT defaultHamletSettings + renderHamletRT hrt hmap urlParamsToString + +-- | Read a file from the app's templates directory. +readTemplateFile :: FilePath -> Handler String +readTemplateFile hfile = do + dir <- (( "templates") . appDataDir) `fmap` getYesod + liftIO $ readFile $ dir hfile + +-- what to do if rendering a runtime template fails. +instance Failure HamletException Handler + where failure = error' . show + +renderHamletAsHtml :: Hamlet AppRoute -> Html +renderHamletAsHtml h = h urlParamsToString + +htmlAsHamlet :: Html -> Hamlet AppRoute +htmlAsHamlet h = [$hamlet|$h$|] + +urlParamsToString :: AppRoute -> [(String,String)] -> String +urlParamsToString u [] = show u +urlParamsToString u ps = show u ++ "?" ++ intercalate "&" [k++"="++v | (k,v) <- ps] + +-- | Convert a string to a hamlet HDHtml data item. +hdstring :: String -> HamletData AppRoute +hdstring = HDHtml . string + +-- | Convert a simple list of strings to hamlet's complicated HDList type. +hdstringlist :: [String] -> HamletData AppRoute +hdstringlist ss = HDList [ [([], hdstring s)] | s <- ss ] + +-- renderHamletRT' :: Failure HamletException m => HamletMap AppRoute -> HamletRT -> m Html +-- renderHamletRT' m h = renderHamletRT h m urlParamsToString + +-- parseHamletRT' :: Failure HamletException m => String -> m HamletRT +-- parseHamletRT' s = parseHamletRT defaultHamletSettings s + +-- hamletToHamletRT :: Failure HamletException m => Hamlet AppRoute -> m HamletRT +-- hamletToHamletRT h = stringToHamletRT $ show $ unsafeByteString $ renderHamlet show h + +---------------------------------------------------------------------- +-- handlers/views +---------------------------------------------------------------------- + +getFaviconR :: Handler () +getFaviconR = sendFile "image/x-icon" $ staticdir "favicon.ico" + +---------------------------------------------------------------------- + +getRobotsR :: Handler RepPlain +getRobotsR = return $ RepPlain $ toContent robots_txt + ---------------------------------------------------------------------- --- handlers & templates getIndexR :: Handler () -getIndexR = redirect RedirectTemporary defaultroute +getIndexR = redirect RedirectTemporary defaultroute where defaultroute = JournalR + +---------------------------------------------------------------------- + +getDemoR :: Handler RepHtml +getDemoR = do + mu <- maybeAuth + defaultLayout $ do + h2id <- newIdent + setTitle $ string "hledger front page" + addBody $(hamletFile "homepage") + addStyle $(cassiusFile "homepage") + addJavascript $(juliusFile "homepage") ---------------------------------------------------------------------- -- | A combined accounts and journal view. getJournalR :: Handler RepHtml getJournalR = do - (a, p, opts, fspec, j, msg, here) <- getHandlerParameters + (a, p, opts, fspec, j, msg, here) <- getHandlerData today <- liftIO getCurrentDay -- app <- getYesod -- t <- liftIO $ getCurrentLocalTime @@ -211,7 +524,7 @@ postJournalR = postJournalOnlyR -- | A combined accounts and register view. getRegisterR :: Handler RepHtml getRegisterR = do - (a, p, opts, fspec, j, msg, here) <- getHandlerParameters + (a, p, opts, fspec, j, msg, here) <- getHandlerData today <- liftIO getCurrentDay -- app <- getYesod -- t <- liftIO $ getCurrentLocalTime @@ -242,13 +555,13 @@ postRegisterR = postJournalOnlyR -- | A simple accounts and balances view like hledger balance. getAccountsOnlyR :: Handler RepHtml getAccountsOnlyR = do - (a, p, opts, fspec, j, msg, here) <- getHandlerParameters + (a, p, opts, fspec, j, msg, here) <- getHandlerData today <- liftIO getCurrentDay let td = mktd{here=here, title="hledger accounts", msg=msg, a=a, p=p, j=j, today=today} hamletToRepHtml $ pageLayout td $ balanceReportAsHtml opts td $ balanceReport opts fspec j -- | Render a balance report as HTML. -balanceReportAsHtml :: [Opt] -> TemplateData -> BalanceReport -> Hamlet HledgerWebAppRoute +balanceReportAsHtml :: [Opt] -> TemplateData -> BalanceReport -> Hamlet AppRoute balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [$hamlet| %table.balancereport %tr @@ -291,7 +604,7 @@ balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [$hamlet| else nulltemplate where allurl = (here, [("p",p)]) itemAsHtml' = itemAsHtml td - itemAsHtml :: TemplateData -> BalanceReportItem -> Hamlet HledgerWebAppRoute + itemAsHtml :: TemplateData -> BalanceReportItem -> Hamlet AppRoute itemAsHtml TD{p=p} (acct, adisplay, adepth, abal) = [$hamlet| %tr.item.$current$ %td.account @@ -319,7 +632,7 @@ isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:(" -- | A basic journal view, like hledger print, with editing. getJournalOnlyR :: Handler RepHtml getJournalOnlyR = do - (a, p, opts, fspec, j, msg, here) <- getHandlerParameters + (a, p, opts, fspec, j, msg, here) <- getHandlerData today <- liftIO getCurrentDay let td = mktd{here=here, title="hledger journal", msg=msg, a=a, p=p, j=j, today=today} editform' = editform td $ jtext j @@ -336,7 +649,7 @@ getJournalOnlyR = do |] -- | Render a journal report as HTML. -journalReportAsHtml :: [Opt] -> TemplateData -> JournalReport -> Hamlet HledgerWebAppRoute +journalReportAsHtml :: [Opt] -> TemplateData -> JournalReport -> Hamlet AppRoute journalReportAsHtml _ td items = [$hamlet| %table.journalreport $forall number.items i @@ -345,7 +658,7 @@ journalReportAsHtml _ td items = [$hamlet| where number = zip [1..] itemAsHtml' = itemAsHtml td - itemAsHtml :: TemplateData -> (Int, JournalReportItem) -> Hamlet HledgerWebAppRoute + itemAsHtml :: TemplateData -> (Int, JournalReportItem) -> Hamlet AppRoute itemAsHtml _ (n, t) = [$hamlet| %tr.item.$evenodd$ %td.transaction @@ -354,7 +667,7 @@ journalReportAsHtml _ td items = [$hamlet| evenodd = if even n then "even" else "odd" txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse -addform :: TemplateData -> Hamlet HledgerWebAppRoute +addform :: TemplateData -> Hamlet AppRoute addform td = [$hamlet| %script!type=text/javascript $$(document).ready(function() { @@ -409,7 +722,7 @@ addform td = [$hamlet| date = "today" descriptions = sort $ nub $ map tdescription $ jtxns $ j td -postingsfields :: TemplateData -> Hamlet HledgerWebAppRoute +postingsfields :: TemplateData -> Hamlet AppRoute postingsfields td = [$hamlet| ^p1^ ^p2^ @@ -418,7 +731,7 @@ postingsfields td = [$hamlet| p1 = postingfields td 1 p2 = postingfields td 2 -postingfields :: TemplateData -> Int -> Hamlet HledgerWebAppRoute +postingfields :: TemplateData -> Int -> Hamlet AppRoute postingfields td n = [$hamlet| %tr#postingrow %td!align=right $acctlabel$: @@ -458,7 +771,7 @@ postingfields td n = [$hamlet| ,"" ) -editform :: TemplateData -> String -> Hamlet HledgerWebAppRoute +editform :: TemplateData -> String -> Hamlet AppRoute editform _ content = [$hamlet| %form#editform!method=POST!style=display:none; %table.form#editform @@ -479,7 +792,7 @@ editform _ content = [$hamlet| where formathelp = helplink "file-format" "file format help" -importform :: Hamlet HledgerWebAppRoute +importform :: Hamlet AppRoute importform = [$hamlet| %form#importform!method=POST!style=display:none; %table.form @@ -502,7 +815,7 @@ postJournalOnlyR = do -- | Handle a journal add form post. postAddForm :: Handler RepPlain postAddForm = do - (_, _, opts, _, _, _, _) <- getHandlerParameters + (_, _, opts, _, _, _, _) <- getHandlerData today <- liftIO getCurrentDay -- get form input values. M means a Maybe value. (dateM, descM, acct1M, amt1M, acct2M, amt2M) <- runFormPost' @@ -616,13 +929,13 @@ postImportForm = do -- | A simple postings view like hledger register. getRegisterOnlyR :: Handler RepHtml getRegisterOnlyR = do - (a, p, opts, fspec, j, msg, here) <- getHandlerParameters + (a, p, opts, fspec, j, msg, here) <- getHandlerData today <- liftIO getCurrentDay let td = mktd{here=here, title="hledger register", msg=msg, a=a, p=p, j=j, today=today} hamletToRepHtml $ pageLayout td $ registerReportAsHtml opts td $ registerReport opts fspec j -- | Render a register report as HTML. -registerReportAsHtml :: [Opt] -> TemplateData -> RegisterReport -> Hamlet HledgerWebAppRoute +registerReportAsHtml :: [Opt] -> TemplateData -> RegisterReport -> Hamlet AppRoute registerReportAsHtml _ td items = [$hamlet| %table.registerreport %tr.headings @@ -640,7 +953,7 @@ registerReportAsHtml _ td items = [$hamlet| %th.balance!align=right Balance |] itemAsHtml' = itemAsHtml td - itemAsHtml :: TemplateData -> (Int, RegisterReportItem) -> Hamlet HledgerWebAppRoute + itemAsHtml :: TemplateData -> (Int, RegisterReportItem) -> Hamlet AppRoute itemAsHtml TD{p=p} (n, (ds, posting, b)) = [$hamlet| %tr.item.$evenodd$.$firstposting$ %td.date $date$ @@ -667,7 +980,7 @@ mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "
" $ lines $ -- | A standalone journal edit form page. getEditR :: Handler RepHtml getEditR = do - (a, p, _, _, _, msg, here) <- getHandlerParameters + (a, p, _, _, _, msg, here) <- getHandlerData today <- liftIO getCurrentDay -- reload journal's text without parsing, if changed -- XXX are we doing this right ? j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" @@ -678,10 +991,10 @@ getEditR = do ---------------------------------------------------------------------- --- | Get the add form from template files reloaded at run-time. +-- | An add form with template files reloaded at runtime. getAddformRTR :: Handler RepHtml getAddformRTR = do - (a, p, _, _, j, msg, here) <- getHandlerParameters + (a, p, _, _, j, msg, here) <- getHandlerData today <- liftIO getCurrentDay let td = mktd{here=here, title="hledger add transaction", msg=msg, a=a, p=p, j=j, today=today} descriptions = sort $ nub $ map tdescription $ jtxns j @@ -690,10 +1003,10 @@ getAddformRTR = do (["acctlabel"], hdstring acctlabel) ,(["acctvar"], hdstring acctvar) ,(["acctnames"], hdstringlist acctnames) - ,(["amtfield"], HDHtml $ renderHamlet' amtfield) + ,(["amtfield"], HDHtml $ renderHamletAsHtml amtfield) ,(["accthelp"], hdstring accthelp) ,(["amthelp"], hdstring amthelp) - ] :: HamletMap HledgerWebAppRoute + ] :: HamletMap AppRoute where numbered = (++ show n) acctvar = numbered "account" @@ -714,9 +1027,9 @@ getAddformRTR = do ,nulltemplate ,"" ) - pfields1 <- renderHamletFile "addformpostingfields.hamlet" (postingData 1) - pfields2 <- renderHamletFile "addformpostingfields.hamlet" (postingData 2) - addform <- renderHamletFile "addform.hamlet" ([ + pfields1 <- renderHamletFileRT "addformpostingfields.hamlet" (postingData 1) + pfields2 <- renderHamletFileRT "addformpostingfields.hamlet" (postingData 2) + addform <- renderHamletFileRT "addform.hamlet" ([ (["date"], hdstring "today") ,(["desc"], hdstring "") ,(["descriptions"], hdstringlist descriptions) @@ -724,167 +1037,6 @@ getAddformRTR = do ,(["deschelp"], hdstring "eg: supermarket (optional)") ,(["postingfields1"], HDHtml pfields1) ,(["postingfields2"], HDHtml pfields2) - ] :: HamletMap HledgerWebAppRoute) + ] :: HamletMap AppRoute) hamletToRepHtml $ pageLayout td $ htmlAsHamlet addform --- | Convert a string to a hamlet HDHtml data item. -hdstring :: String -> HamletData HledgerWebAppRoute -hdstring = HDHtml . string - --- | Convert a simple list of strings to hamlet's complicated HDList type. -hdstringlist :: [String] -> HamletData HledgerWebAppRoute -hdstringlist ss = HDList [ [([], hdstring s)] | s <- ss ] - -instance Failure HamletException Handler - where failure = error' . show - -renderHamletFile :: FilePath -> HamletMap HledgerWebAppRoute -> Handler Html -renderHamletFile hfile hmap = do - hrt <- readHamletFile hfile >>= parseHamletRT defaultHamletSettings - renderHamletRT hrt hmap renderurlwithparams - -renderurlwithparams u [] = show u -renderurlwithparams u ps = show u ++ "?" ++ intercalate "&" [k++"="++v | (k,v) <- ps] - -readHamletFile :: FilePath -> Handler String -readHamletFile hfile = do - dir <- (( "templates") . appDir) `fmap` getYesod - liftIO $ readFile $ dir hfile - -htmlAsHamlet :: Html -> Hamlet HledgerWebAppRoute -htmlAsHamlet h = [$hamlet|$h$|] - -parseHamletRT' :: Failure HamletException m => String -> m HamletRT -parseHamletRT' s = parseHamletRT defaultHamletSettings s - -renderHamletRT' :: Failure HamletException m => HamletMap HledgerWebAppRoute -> HamletRT -> m Html -renderHamletRT' m h = renderHamletRT h m renderurlwithparams - -renderHamlet' :: Hamlet HledgerWebAppRoute -> Html -renderHamlet' h = h renderurlwithparams - --- hamletToHamletRT :: Failure HamletException m => Hamlet HledgerWebAppRoute -> m HamletRT --- hamletToHamletRT h = stringToHamletRT $ show $ unsafeByteString $ renderHamlet show h - ----------------------------------------------------------------------- - --- | Wrap a template with the standard hledger web ui page layout. -pageLayout :: TemplateData -> Hamlet HledgerWebAppRoute -> Hamlet HledgerWebAppRoute -pageLayout td@TD{title=basetitle, msg=msg, p=p, j=j, today=today} content = [$hamlet| -!!! -%html - %head - %title $title'$ - %meta!http-equiv=Content-Type!content=$metacontent$ - %script!type=text/javascript!src=@StaticR.jquery_js@ - %script!type=text/javascript!src=@StaticR.jquery_url_js@ - %script!type=text/javascript!src=@StaticR.dhtmlxcommon_js@ - %script!type=text/javascript!src=@StaticR.dhtmlxcombo_js@ - %script!type=text/javascript!src=@StaticR.hledger_js@ - %link!rel=stylesheet!type=text/css!media=all!href=@StaticR.style_css@ - %body - ^navbar.td^ - #messages $m$ - #content - ^content^ -|] - where m = fromMaybe (string "") msg - metacontent = "text/html; charset=utf-8" - (journaltitle, _) = journalTitleInfo j p today - title' = basetitle ++ " - " ++ journaltitle - -navbar :: TemplateData -> Hamlet HledgerWebAppRoute -navbar TD{p=p,j=j,today=today} = [$hamlet| - #navbar - %a.topleftlink!href=$hledgerorgurl$ - hledger -
- $version$ - %a.toprightlink!href=$manualurl$!target=hledgerhelp manual - %h1 $journaltitle$ - \ $ - %span#journalinfo $journalinfo$ -|] - where (journaltitle, journalinfo) = journalTitleInfo j p today - --- | Generate journal- and context-specific title and info strings for display. -journalTitleInfo :: Journal -> String -> Day -> (String, String) -journalTitleInfo j p today = (journaltitle, journalinfo) - where - journaltitle = printf "%s" (takeFileName $ filepath j) :: String - journalinfo = printf "%s" (showspan span) :: String - span = either (const $ DateSpan Nothing Nothing) snd (parsePeriodExpr today p) - showspan (DateSpan Nothing Nothing) = "" - showspan s = " (" ++ dateSpanAsText s ++ ")" - -navlinks :: TemplateData -> Hamlet HledgerWebAppRoute -navlinks td = [$hamlet| - #navlinks - ^accountsjournallink^ - \ | $ - ^accountsregisterlink^ - \ | $ - %a#addformlink!href!onclick="return addformToggle()" add transaction - %a#importformlink!href!onclick="return importformToggle()"!style=display:none; import transactions - \ | $ - %a#editformlink!href!onclick="return editformToggle()" edit journal -|] --- \ | $ - where - accountsjournallink = navlink td "journal" JournalR - accountsregisterlink = navlink td "register" RegisterR - -navlink :: TemplateData -> String -> HledgerWebAppRoute -> Hamlet HledgerWebAppRoute -navlink TD{here=here,a=a,p=p} s dest = [$hamlet|%a#$s$link.$style$!href=@?u@ $s$|] - where u = (dest, concat [(if null a then [] else [("a", a)]) - ,(if null p then [] else [("p", p)])]) - style | dest == here = "navlinkcurrent" - | otherwise = "navlink" - -filterform :: TemplateData -> Hamlet HledgerWebAppRoute -filterform TD{here=here,a=a,p=p} = [$hamlet| - #filterformdiv - %form#filterform.form!method=GET!style=display:$visible$; - %table.form - %tr.$filteringperiodclass$ - %td - filter by period: - \ $ - %td - %input!name=p!size=60!value=$p$ - ^phelp^ - \ $ - %td!align=right - ^stopfilteringperiod^ - %tr.$filteringclass$ - %td - filter by account/description: - \ $ - %td - %input!name=a!size=60!value=$a$ - ^ahelp^ - \ $ - %input!type=submit!value=filter $ - \ $ - %td!align=right - ^stopfiltering^ -|] - where - ahelp = helplink "filter-patterns" "?" - phelp = helplink "period-expressions" "?" - filtering = not $ null a - filteringperiod = not $ null p - visible = "block" - filteringclass = if filtering then "filtering" else "" - filteringperiodclass = if filteringperiod then "filtering" else "" - stopfiltering = if filtering then [$hamlet|%a#stopfilterlink!href=@?u@ stop filtering acct/desc|] else nulltemplate - where u = (here, if filteringperiod then [("p", p)] else []) - stopfilteringperiod = if filteringperiod then [$hamlet|%a#stopfilterlink!href=@?u@ stop filtering period|] else nulltemplate - where u = (here, if filtering then [("a", a)] else []) - -helplink :: String -> String -> Hamlet HledgerWebAppRoute -helplink topic label = [$hamlet|%a!href=$u$!target=hledgerhelp $label$|] - where u = manualurl ++ if null topic then "" else '#':topic - -nulltemplate = [$hamlet||] - diff --git a/hledger-web/Hledger/Web/Settings.hs b/hledger-web/Hledger/Web/Settings.hs new file mode 100644 index 000000000..4b0a4af09 --- /dev/null +++ b/hledger-web/Hledger/Web/Settings.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP #-} +module Hledger.Web.Settings + ( hamletFile + , cassiusFile + , juliusFile + , connStr + , ConnectionPool + , withConnectionPool + , runConnectionPool + , approot + , staticroot + , datadir + , staticdir + , templatesdir + + , defhost + , defport + , browserstartdelay + , hledgerorgurl + , manualurl + , style_css + , hledger_js + , jquery_js + , jquery_url_js + , dhtmlxcommon_js + , dhtmlxcombo_js + , robots_txt + ) where + +import System.FilePath (()) +import Text.Printf (printf) +import qualified Text.Hamlet as H +import qualified Text.Cassius as H +import qualified Text.Julius as H +import Language.Haskell.TH.Syntax +import Database.Persist.Sqlite +import Yesod (MonadCatchIO) +import Yesod.Helpers.Static + + +browserstartdelay = 100000 -- microseconds + +---------------------------------------------------------------------- +-- urls +---------------------------------------------------------------------- + +hledgerorgurl = "http://hledger.org" +manualurl = hledgerorgurl++"/MANUAL.html" + +defhost = "localhost" +defport = 5000 + +approot :: String +#ifdef PRODUCTION +approot = printf "http://%s:%d" defhost (defport :: Int) +#else +approot = printf "http://%s:%d" defhost (defport :: Int) +#endif + +staticroot :: String +staticroot = approot ++ "/static" + +-- Some static routes we can refer to by name, without hard-coded filesystem location. +style_css = StaticRoute ["style.css"] [] +hledger_js = StaticRoute ["hledger.js"] [] +jquery_js = StaticRoute ["jquery.js"] [] +jquery_url_js = StaticRoute ["jquery.url.js"] [] +dhtmlxcommon_js = StaticRoute ["dhtmlxcommon.js"] [] +dhtmlxcombo_js = StaticRoute ["dhtmlxcombo.js"] [] + +-- Content for /robots.txt +robots_txt = "User-agent: *" + + +---------------------------------------------------------------------- +-- filesystem +---------------------------------------------------------------------- + +-- XXX hard-coded data directory path. This must be in your current dir +-- when you run or compile hledger-web. +datadir :: FilePath +datadir = "data" + +staticdir :: FilePath +staticdir = datadir ++ "/static" + +templatesdir :: FilePath +templatesdir = datadir ++ "/templates" + +-- The following are compile-time macros. In production mode, the template +-- is read only once at startup, otherwise every time. + +hamletFile :: FilePath -> Q Exp +#ifdef PRODUCTION +hamletFile x = H.hamletFile $ templatesdir (x ++ ".hamlet") +#else +hamletFile x = H.hamletFileDebug $ templatesdir (x ++ ".hamlet") +#endif + +cassiusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +cassiusFile x = H.cassiusFile $ templatesdir (x ++ ".cassius") +#else +cassiusFile x = H.cassiusFileDebug $ templatesdir (x ++ ".cassius") +#endif + +juliusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +juliusFile x = H.juliusFile $ templatesdir (x ++ ".julius") +#else +juliusFile x = H.juliusFileDebug $ templatesdir (x ++ ".julius") +#endif + +---------------------------------------------------------------------- +-- database +---------------------------------------------------------------------- + +connStr :: String +#ifdef PRODUCTION +connStr = "production.db3" +#else +connStr = "debug.db3" +#endif + +connectionCount :: Int +connectionCount = 10 + +withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a +withConnectionPool = withSqlitePool connStr connectionCount + +runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool = runSqlPool + diff --git a/hledger-web/Main.hs b/hledger-web/Main.hs index d2363b777..c188e9427 100644 --- a/hledger-web/Main.hs +++ b/hledger-web/Main.hs @@ -11,13 +11,27 @@ module Main where import Prelude hiding (putStr, putStrLn) import System.IO.UTF8 (putStr, putStrLn) #endif +import Control.Concurrent (forkIO, threadDelay) +-- import System.FilePath (()) +import System.IO.Storage (withStore, putValue,) + +import Network.Wai.Handler.SimpleServer (run) +import Yesod.Content (typeByExt) +import Yesod.Helpers.Static (fileLookupDir) import Hledger.Cli.Options -- import Hledger.Cli.Tests -import Hledger.Cli.Utils (withJournalDo) +import Hledger.Cli.Utils (withJournalDo, openBrowserOn) import Hledger.Cli.Version (versionmsg) --, binaryfilename) import Hledger.Data -import Hledger.Web +import Hledger.Web.App (App(..), withApp) +import Hledger.Web.Settings (browserstartdelay, defhost, defport, datadir, staticdir) +-- #ifdef MAKE +-- import Paths_hledger_web_make (getDataFileName) +-- #else +-- import Paths_hledger_web (getDataFileName) +-- #endif + main :: IO () main = do @@ -36,3 +50,36 @@ main = do | otherwise = putStr help1 defaultcmd = Just web + +-- | The web command. +web :: [Opt] -> [String] -> Journal -> IO () +web opts args j = do + let host = defhost + port = fromMaybe defport $ portFromOpts opts + baseurl = fromMaybe (printf "http://%s:%d" host port) $ baseUrlFromOpts opts + unless (Debug `elem` opts) $ forkIO (browser baseurl) >> return () + server baseurl port opts args j + +browser :: String -> IO () +browser baseurl = do + putStrLn "starting web browser" + threadDelay $ fromIntegral browserstartdelay + openBrowserOn baseurl >> return () + +server :: String -> Int -> [Opt] -> [String] -> Journal -> IO () +server baseurl port opts args j = do + printf "starting web server on port %d with base url %s\n" port baseurl + withStore "hledger" $ do + putValue "hledger" "journal" j + -- dir <- getDataFileName "" + -- let staticdir = dir "static" + withApp App{ + appConnPool=Nothing + ,appRoot=baseurl + ,appDataDir=datadir + ,appStatic=fileLookupDir staticdir $ typeByExt -- ++[("hamlet","text/plain")] + ,appOpts=opts + ,appArgs=args + ,appJournal=j + } $ run port + diff --git a/hledger-web/data/static/style.css b/hledger-web/data/static/style.css index 4272c5c45..36b778483 100644 --- a/hledger-web/data/static/style.css +++ b/hledger-web/data/static/style.css @@ -10,7 +10,7 @@ input.textinput, .dhx_combo_input, .dhx_combo_list { font-size:small; } #filterform { font-size:small; } .topleftlink { font-size:small; } .toprightlink { font-size:small; } -#journalinfo { font-size:small; } +#journaldesc { font-size:small; } .help { font-size:smaller; } .form { font-size:small; } .journalreport { font-size:small; } diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 29c4ee3f8..78c6cabfa 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -7,11 +7,11 @@ description: license: GPL license-file: LICENSE author: Simon Michael -maintainer: +maintainer: Simon Michael homepage: http://hledger.org bug-reports: http://code.google.com/p/hledger/issues -stability: experimental -tested-with: GHC==6.10, GHC==6.12 +stability: alpha +tested-with: GHC==6.12 cabal-version: >= 1.6 build-type: Simple data-dir: data @@ -22,7 +22,15 @@ data-files: static/jquery.url.js static/dhtmlxcommon.js static/dhtmlxcombo.js + static/favicon.ico static/images/combo_select.gif + templates/addform.hamlet + templates/addformpostingfields.hamlet + templates/default-layout.cassius + templates/default-layout.hamlet + templates/homepage.cassius + templates/homepage.hamlet + templates/homepage.julius extra-tmp-files: extra-source-files: @@ -30,11 +38,18 @@ source-repository head type: darcs location: http://joyful.com/repos/hledger +Flag production + Description: Build in production mode, which reads templates only once at startup. + Default: False + executable hledger-web main-is: Main.hs ghc-options: -threaded -W + if flag(production) + cpp-options: -DPRODUCTION other-modules: - Hledger.Web + Hledger.Web.App + Hledger.Web.Settings build-depends: hledger == 0.12.98 ,hledger-lib == 0.12.98 @@ -60,3 +75,7 @@ executable hledger-web ,convertible-text >= 0.3.0.1 && < 0.4 ,data-object >= 0.3.1.2 && < 0.4 ,failure >= 0.1 && < 0.2 + ,persistent == 0.2.* + ,persistent-sqlite == 0.2.* + ,template-haskell == 2.4.* + ,wai-extra == 0.2.*