From dc6c3dec76b95a497a609fdbed1babb7f693ce71 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Tue, 24 May 2011 04:27:37 +0000 Subject: [PATCH] web: more yesod 0.8 migration; adopt the scaffolding app's layout, slightly simplified --- hledger-web/.hledger/unused/addform.hamlet | 47 - .../unused/addformpostingfields.hamlet | 15 - .../.hledger/unused/default-layout.hamlet | 9 - hledger-web/.hledger/unused/homepage.cassius | 6 - hledger-web/.hledger/unused/homepage.hamlet | 12 - hledger-web/.hledger/unused/homepage.julius | 3 - hledger-web/.hledger/web/favicon.ico | Bin 1150 -> 0 bytes .../web/{ => static}/combo_select.gif | Bin .../.hledger/web/{ => static}/dhtmlxcombo.js | 0 .../.hledger/web/{ => static}/dhtmlxcommon.js | 0 hledger-web/.hledger/web/static/favicon.ico | Bin 0 -> 1150 bytes .../.hledger/web/{ => static}/hledger.js | 0 .../.hledger/web/{ => static}/jquery.js | 0 .../.hledger/web/{ => static}/jquery.url.js | 0 .../.hledger/web/{ => static}/style.css | 7 + .../templates}/default-layout.cassius | 0 .../web/templates/default-layout.hamlet | 9 + .../.hledger/web/templates/homepage.cassius | 4 + .../.hledger/web/templates/homepage.hamlet | 2 + .../.hledger/web/templates/homepage.julius | 3 + hledger-web/App.hs | 100 ++ hledger-web/Controller.hs | 56 ++ .../Web/Files.hs => EmbeddedFiles.hs} | 20 +- .../{Hledger/Web/App.hs => Handlers.hs} | 867 ++++++------------ hledger-web/Hledger/Web/Main.hs | 100 -- hledger-web/Hledger/Web/Settings.hs | 128 --- hledger-web/Settings.hs | 147 +++ hledger-web/StaticFiles.hs | 18 + hledger-web/hledger-web.cabal | 89 +- hledger-web/hledger-web.hs | 111 ++- hledger-web/models | 0 hledger-web/routes | 7 + 32 files changed, 803 insertions(+), 957 deletions(-) delete mode 100644 hledger-web/.hledger/unused/addform.hamlet delete mode 100644 hledger-web/.hledger/unused/addformpostingfields.hamlet delete mode 100644 hledger-web/.hledger/unused/default-layout.hamlet delete mode 100644 hledger-web/.hledger/unused/homepage.cassius delete mode 100644 hledger-web/.hledger/unused/homepage.hamlet delete mode 100644 hledger-web/.hledger/unused/homepage.julius delete mode 100644 hledger-web/.hledger/web/favicon.ico rename hledger-web/.hledger/web/{ => static}/combo_select.gif (100%) rename hledger-web/.hledger/web/{ => static}/dhtmlxcombo.js (100%) rename hledger-web/.hledger/web/{ => static}/dhtmlxcommon.js (100%) create mode 100644 hledger-web/.hledger/web/static/favicon.ico rename hledger-web/.hledger/web/{ => static}/hledger.js (100%) rename hledger-web/.hledger/web/{ => static}/jquery.js (100%) rename hledger-web/.hledger/web/{ => static}/jquery.url.js (100%) rename hledger-web/.hledger/web/{ => static}/style.css (98%) rename hledger-web/.hledger/{unused => web/templates}/default-layout.cassius (100%) create mode 100644 hledger-web/.hledger/web/templates/default-layout.hamlet create mode 100644 hledger-web/.hledger/web/templates/homepage.cassius create mode 100644 hledger-web/.hledger/web/templates/homepage.hamlet create mode 100644 hledger-web/.hledger/web/templates/homepage.julius create mode 100644 hledger-web/App.hs create mode 100644 hledger-web/Controller.hs rename hledger-web/{Hledger/Web/Files.hs => EmbeddedFiles.hs} (62%) rename hledger-web/{Hledger/Web/App.hs => Handlers.hs} (58%) delete mode 100644 hledger-web/Hledger/Web/Main.hs delete mode 100644 hledger-web/Hledger/Web/Settings.hs create mode 100644 hledger-web/Settings.hs create mode 100644 hledger-web/StaticFiles.hs create mode 100644 hledger-web/models create mode 100644 hledger-web/routes diff --git a/hledger-web/.hledger/unused/addform.hamlet b/hledger-web/.hledger/unused/addform.hamlet deleted file mode 100644 index 89c9478a1..000000000 --- a/hledger-web/.hledger/unused/addform.hamlet +++ /dev/null @@ -1,47 +0,0 @@ -%script!type=text/javascript - $$(document).ready(function() { - /* dhtmlxcombo setup */ - window.dhx_globalImgPath="../static/"; - var desccombo = new dhtmlXCombo("description"); - var acct1combo = new dhtmlXCombo("account1"); - var acct2combo = new dhtmlXCombo("account2"); - desccombo.enableFilteringMode(true); - acct1combo.enableFilteringMode(true); - acct2combo.enableFilteringMode(true); - desccombo.setSize(300); - acct1combo.setSize(300); - acct2combo.setSize(300); - }); - -%form#addform!method=POST; - %table.form - %tr - %td!colspan=4 - %table - %tr#descriptionrow - %td - Date: - %td - %input.textinput!size=15!name=date!value=$date$ - %td!style=padding-left:1em; - Description: - %td - %select!id=description!name=description - %option - $forall descriptions d - %option!value=$d$ $d$ - %tr.helprow - %td - %td - .help $datehelp$ $ - %td - %td - .help $deschelp$ - $postingfields1$ - $postingfields2$ - %tr#addbuttonrow - %td!colspan=4 - %input!type=hidden!name=action!value=add - %input!type=submit!name=submit!value="add transaction" - $if manyfiles - \ to: ^journalselect.files^ diff --git a/hledger-web/.hledger/unused/addformpostingfields.hamlet b/hledger-web/.hledger/unused/addformpostingfields.hamlet deleted file mode 100644 index ff44e1088..000000000 --- a/hledger-web/.hledger/unused/addformpostingfields.hamlet +++ /dev/null @@ -1,15 +0,0 @@ - %tr#postingrow - %td!align=right $acctlabel$: - %td - %select!id=$acctvar$!name=$acctvar$ - %option - $forall acctnames a - %option!value=$a$ $a$ - $amtfield$ - %tr.helprow - %td - %td - .help $accthelp$ - %td - %td - .help $amthelp$ diff --git a/hledger-web/.hledger/unused/default-layout.hamlet b/hledger-web/.hledger/unused/default-layout.hamlet deleted file mode 100644 index 4b8ce5070..000000000 --- a/hledger-web/.hledger/unused/default-layout.hamlet +++ /dev/null @@ -1,9 +0,0 @@ -!!! -%html - %head - %title $pageTitle.pc$ - ^pageHead.pc^ - %body - $maybe mmsg msg - #message $msg$ - ^pageBody.pc^ diff --git a/hledger-web/.hledger/unused/homepage.cassius b/hledger-web/.hledger/unused/homepage.cassius deleted file mode 100644 index f14022e41..000000000 --- a/hledger-web/.hledger/unused/homepage.cassius +++ /dev/null @@ -1,6 +0,0 @@ -body - font-family: sans-serif -h1 - text-align: center -h2#$h2id$ - color: red diff --git a/hledger-web/.hledger/unused/homepage.hamlet b/hledger-web/.hledger/unused/homepage.hamlet deleted file mode 100644 index bd73ffca1..000000000 --- a/hledger-web/.hledger/unused/homepage.hamlet +++ /dev/null @@ -1,12 +0,0 @@ -%h1 Hello -%h2#$h2id$ You do not have Javascript enabled. -$maybe mu u - %p - You are logged in as $userIdent.snd.u$. $ - %a!href=@AuthR.LogoutR@ Logout - \. -$nothing - %p - You are not logged in. $ - %a!href=@AuthR.LoginR@ Login now - \. diff --git a/hledger-web/.hledger/unused/homepage.julius b/hledger-web/.hledger/unused/homepage.julius deleted file mode 100644 index 9bc2f68d2..000000000 --- a/hledger-web/.hledger/unused/homepage.julius +++ /dev/null @@ -1,3 +0,0 @@ -window.onload = function(){ - document.getElementById("%h2id%").innerHTML = "Added from JavaScript."; -} diff --git a/hledger-web/.hledger/web/favicon.ico b/hledger-web/.hledger/web/favicon.ico deleted file mode 100644 index 4613ed03a65f518e28cd421beb06f346bedf0e1e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1150 zcmai!--{Aa6vuBE1--NoL@%*DMlV4SK@YvvbI>1A&%MMFkx;b$VAM=knRM14tGhdn zKgLy=5mzPMY}H+Vu&V{pO1TjD=7Wf6r+Z!QAk#oIeCOPI=6udMocV#!IeacHA$+}o zo}EYNDnjTc7ItCJnI9X3@ICbb07$KV|JU`z1{-_7V*QpAa;xoT`|fl){U=V%jmKkM zUP?ZfL-t`y4ghcTK{L>TeNS~3Wum?8R@Qb{lUXuR5r9uw(Z zGsh>fWFUNI)74OObbpxffv_6U5s`ecrsqt5O6m+})Dt7SRk8z{T?G;>sPm8acq=Tdb;L;6h= z3dKjxV7&NYJ3n2lpvYhz#zuJz@P!dKp~(AL>x#lFaYJy!TS&&*#8U}>}C_TXR z-o5)#7sf`Wf$231TbO5L967&l-_tOV+DDH*tFB#pzW`Yuhz&|-ad8Lkf%F5@t}(Lw ziWPS%K=DymcV>N5)c(g;uDr8AmItwcY2O}XPiyOWjQ9rm3n;!E7^ZK5anp^g_w#=S hhKE4>7Ks0$;Xm~Z3?TdyhW9fte1_uZ#~Bzv7y!I9`)dFI literal 0 HcmV?d00001 diff --git a/hledger-web/.hledger/web/hledger.js b/hledger-web/.hledger/web/static/hledger.js similarity index 100% rename from hledger-web/.hledger/web/hledger.js rename to hledger-web/.hledger/web/static/hledger.js diff --git a/hledger-web/.hledger/web/jquery.js b/hledger-web/.hledger/web/static/jquery.js similarity index 100% rename from hledger-web/.hledger/web/jquery.js rename to hledger-web/.hledger/web/static/jquery.js diff --git a/hledger-web/.hledger/web/jquery.url.js b/hledger-web/.hledger/web/static/jquery.url.js similarity index 100% rename from hledger-web/.hledger/web/jquery.url.js rename to hledger-web/.hledger/web/static/jquery.url.js diff --git a/hledger-web/.hledger/web/style.css b/hledger-web/.hledger/web/static/style.css similarity index 98% rename from hledger-web/.hledger/web/style.css rename to hledger-web/.hledger/web/static/style.css index fde7ba490..adcef832f 100644 --- a/hledger-web/.hledger/web/style.css +++ b/hledger-web/.hledger/web/static/style.css @@ -1,3 +1,10 @@ +/* LOCAL: +hledger-web executables built in this repo will include these local styles +when generating the web support files +*/ +body { border-top: thin solid red; } +/* END LOCAL */ + /* hledger web ui styles */ /*------------------------------------------------------------------------------------------*/ diff --git a/hledger-web/.hledger/unused/default-layout.cassius b/hledger-web/.hledger/web/templates/default-layout.cassius similarity index 100% rename from hledger-web/.hledger/unused/default-layout.cassius rename to hledger-web/.hledger/web/templates/default-layout.cassius diff --git a/hledger-web/.hledger/web/templates/default-layout.hamlet b/hledger-web/.hledger/web/templates/default-layout.hamlet new file mode 100644 index 000000000..d07318684 --- /dev/null +++ b/hledger-web/.hledger/web/templates/default-layout.hamlet @@ -0,0 +1,9 @@ +!!! +#{pageTitle pc} + ^{pageHead pc} + #{msg} + ^{pageBody pc} diff --git a/hledger-web/.hledger/web/templates/homepage.cassius b/hledger-web/.hledger/web/templates/homepage.cassius new file mode 100644 index 000000000..d6eee1b56 --- /dev/null +++ b/hledger-web/.hledger/web/templates/homepage.cassius @@ -0,0 +1,4 @@ +h1 + text-align: center +h2##{h2id} + color: #990 diff --git a/hledger-web/.hledger/web/templates/homepage.hamlet b/hledger-web/.hledger/web/templates/homepage.hamlet new file mode 100644 index 000000000..ccab6463c --- /dev/null +++ b/hledger-web/.hledger/web/templates/homepage.hamlet @@ -0,0 +1,2 @@ +

Hello +

You could have Javascript enabled. \ No newline at end of file diff --git a/hledger-web/.hledger/web/templates/homepage.julius b/hledger-web/.hledger/web/templates/homepage.julius new file mode 100644 index 000000000..0589b9153 --- /dev/null +++ b/hledger-web/.hledger/web/templates/homepage.julius @@ -0,0 +1,3 @@ +window.onload = function(){ + document.getElementById("#{h2id}").innerHTML = "Added from JavaScript."; +} diff --git a/hledger-web/App.hs b/hledger-web/App.hs new file mode 100644 index 000000000..c7537250a --- /dev/null +++ b/hledger-web/App.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module App + ( App (..) + , AppRoute (..) + , resourcesApp + , Handler + , Widget + , module Yesod.Core + , module Settings + , StaticRoute (..) + , lift + , liftIO + ) where + +import Yesod.Core +import Yesod.Helpers.Static +import qualified Settings +import System.Directory +import qualified Data.ByteString.Lazy as L +import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) +import Control.Monad (unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T + +import Hledger.Cli.Options (Opt) +import Hledger.Data (Journal) + +-- | The site argument for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. +data App = App + {getStatic :: Static -- ^ Settings for static file serving. + ,appRoot :: T.Text + ,appOpts :: [Opt] + ,appArgs :: [String] + ,appJournal :: Journal + } + +-- | A useful synonym; most of the handler functions in your application +-- will need to be of this type. +type Handler = GHandler App App + +-- | A useful synonym; most of the widgets functions in your application +-- will need to be of this type. +type Widget = GWidget App App + +-- This is where we define all of the routes in our application. For a full +-- explanation of the syntax, please see: +-- http://docs.yesodweb.com/book/web-routes-quasi/ +-- +-- This function does three things: +-- +-- * Creates the route datatype AppRoute. Every valid URL in your +-- application can be represented as a value of this type. +-- * Creates the associated type: +-- type instance Route App = AppRoute +-- * Creates the value resourcesApp which contains information on the +-- resources declared below. This is used in Controller.hs by the call to +-- mkYesodDispatch +-- +-- What this function does *not* do is create a YesodSite instance for +-- App. Creating that instance requires all of the handler functions +-- for our application to be in scope. However, the handler functions +-- usually require access to the AppRoute datatype. Therefore, we +-- split these actions into two functions and place them in separate files. +mkYesodData "App" $(parseRoutesFile "routes") + +-- Please see the documentation for the Yesod typeclass. There are a number +-- of settings which can be configured by overriding methods here. +instance Yesod App where + approot = appRoot + + defaultLayout widget = do + mmsg <- getMessage + pc <- widgetToPageContent $ do + widget + addCassius $(Settings.cassiusFile "default-layout") + hamletToRepHtml $(Settings.hamletFile "default-layout") + + -- This is done to provide an optimization for serving static files from + -- a separate domain. Please see the staticroot setting in Settings.hs + -- urlRenderOverride a (StaticR s) = + -- Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s + -- urlRenderOverride _ _ = Nothing + + -- This function creates static content files in the static folder + -- and names them based on a hash of their content. This allows + -- expiration dates to be set far in the future without worry of + -- users receiving stale content. + addStaticContent ext' _ content = do + let fn = base64md5 content ++ '.' : T.unpack ext' + let statictmp = Settings.staticdir ++ "/tmp/" + liftIO $ createDirectoryIfMissing True statictmp + let fn' = statictmp ++ fn + exists <- liftIO $ doesFileExist fn' + unless exists $ liftIO $ L.writeFile fn' content + return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], []) \ No newline at end of file diff --git a/hledger-web/Controller.hs b/hledger-web/Controller.hs new file mode 100644 index 000000000..0726f540c --- /dev/null +++ b/hledger-web/Controller.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Controller + ( withApp + , withDevelApp + ) where + +import App +import Settings +import Yesod.Helpers.Static +import Data.ByteString (ByteString) +import Network.Wai (Application) +import Data.Dynamic (Dynamic, toDyn) +import System.FilePath (()) + +-- Import all relevant handler modules here. +import Handlers + +import Hledger.Data (nulljournal) + +-- This line actually creates our YesodSite instance. It is the second half +-- of the call to mkYesodData which occurs in App.hs. Please see +-- the comments there for more details. +mkYesodDispatch "App" resourcesApp + +-- Some default handlers that ship with the Yesod site template. You will +-- very rarely need to modify this. +getFaviconR :: Handler () +getFaviconR = sendFile "image/x-icon" $ Settings.staticdir "favicon.ico" + +getRobotsR :: Handler RepPlain +getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) + +-- This function allocates resources (such as a database connection pool), +-- performs initialization and creates a WAI application. This is also the +-- place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +withApp :: App -> (Application -> IO a) -> IO a +withApp a f = do + toWaiApp a >>= f + -- where + -- s = static Settings.staticdir + +withDevelApp :: Dynamic +-- withDevelApp = undefined +withDevelApp = toDyn (withApp a :: (Application -> IO ()) -> IO ()) + where a = App{ + getStatic=static Settings.staticdir + ,appRoot=Settings.defapproot + ,appOpts=[] + ,appArgs=[] + ,appJournal=nulljournal + } + diff --git a/hledger-web/Hledger/Web/Files.hs b/hledger-web/EmbeddedFiles.hs similarity index 62% rename from hledger-web/Hledger/Web/Files.hs rename to hledger-web/EmbeddedFiles.hs index 72d671d37..8cbbeb6e0 100644 --- a/hledger-web/Hledger/Web/Files.hs +++ b/hledger-web/EmbeddedFiles.hs @@ -1,14 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} {-| -Support files used by the web app are embedded here at compile time via -template haskell magic. This allows us minimise deployment hassle by -recreating them on the filesystem when needed (since hamlet can not use -the embedded files directly.) Installing on the filesystem has the added -benefit of making them easily customisable. +Support files (static files and templates) used by the web app are +embedded in this module at compile time. Since hamlet can not use the +embedded files directly, we also provide a way to write them out to the +filesystem at startup, when needed. This simplifies installation for +end-users, and customisation too. -} -module Hledger.Web.Files +module EmbeddedFiles ( files ,createFilesIfMissing @@ -18,9 +18,9 @@ import Control.Monad import qualified Data.ByteString as B import Data.FileEmbed (embedDir) import System.Directory +import System.FilePath -import Hledger.Web.Settings (datadir) - +import Settings (datadir) -- | An embedded copy of all files below the the hledger-web data -- directory (@.hledger/web/@) at compile time, as (FilePath,ByteString) @@ -40,5 +40,7 @@ createFilesIfMissing = do else do createDirectoryIfMissing True datadir setCurrentDirectory datadir - forM_ files $ \(f,d) -> B.writeFile f d + forM_ files $ \(f,d) -> do + createDirectoryIfMissing True $ takeDirectory f + B.writeFile f d return True diff --git a/hledger-web/Hledger/Web/App.hs b/hledger-web/Handlers.hs similarity index 58% rename from hledger-web/Hledger/Web/App.hs rename to hledger-web/Handlers.hs index 84393e42e..49c8de626 100644 --- a/hledger-web/Hledger/Web/App.hs +++ b/hledger-web/Handlers.hs @@ -1,36 +1,13 @@ -{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, GeneralizedNewtypeDeriving, OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} -{-| -The web app providing a richer interface to hledger's data. --} --- with authentication, registration and persistent storage of user accounts (not yet) -module Hledger.Web.App - ( App (..) - , withApp - ) -where -import Control.Applicative ((<$>), (<*>)) --- import Control.Failure -import qualified Data.ByteString.Lazy as L -import Data.Either --- import qualified Data.Text as T +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +module Handlers where + +import Control.Applicative ((<$>)) --, (<*>)) import Data.Text(Text,pack,unpack) -import System.Directory -import System.FilePath ((), takeFileName) +import System.FilePath (takeFileName) --()) import System.IO.Storage (putValue, getValue) -import Text.Jasmine (minifym) +import Text.Hamlet import Text.ParserCombinators.Parsec hiding (string) --- import Database.Persist.GenericSql (ConnectionPool, SqlPersist, runMigration, migrate) -import Yesod -import Yesod.Helpers.Static --- import Yesod.Helpers.Auth --- import Yesod.Mail --- import Yesod.WebRoutes --- import Text.Hamlet (defaultHamletSettings) --- import Text.Hamlet.RT - -import Hledger.Cli.Add (appendToJournalFile) import Hledger.Cli.Balance import Hledger.Cli.Print import Hledger.Cli.Register @@ -38,496 +15,22 @@ import Hledger.Cli.Options hiding (value) import Hledger.Cli.Utils import Hledger.Cli.Version (version) import Hledger.Data hiding (insert, today) -import Hledger.Read (journalFromPathAndString) -import Hledger.Read.JournalReader (someamount) -import Hledger.Web.Settings - -- -- withConnectionPool - -- -- , runConnectionPool - -- -- , staticroot - -- datadir - -- -- , hamletFile - -- -- , cassiusFile - -- -- , juliusFile - -- -- , hledgerorgurl - -- , manualurl - -- -- , style_css - -- -- , hledger_js - -- -- , jquery_js - -- -- , jquery_url_js - -- -- , dhtmlxcommon_js - -- -- , dhtmlxcombo_js - -- , robots_txt - -- ) +import App +import Settings +import StaticFiles ----------------------------------------------------------------------- --- define the web app ----------------------------------------------------------------------- - --- 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 --- |] - --- run-time data kept by the web app. -data App = App - { -- appConnPool :: Maybe ConnectionPool - appRoot :: Text - ,appDataDir :: FilePath - ,appOpts :: [Opt] - ,appArgs :: [String] - ,appStaticSettings :: Static - ,appJournal :: Journal - } - --- 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. --- /auth AuthR Auth getAuth -mkYesod "App" [$parseRoutes| -/ IndexR GET -/static StaticR Static appStaticSettings -/favicon.ico FaviconR GET -/robots.txt RobotsR GET -/journalonly JournalOnlyR GET POST -/registeronly RegisterOnlyR GET -/accounts AccountsOnlyR GET -/journal JournalR GET POST -/register RegisterR GET POST -|] --- /addformrt AddformRTR GET - -type Handler = GHandler App App - -instance Yesod App where - approot = appRoot - -- This function creates static content files in the static folder - -- and names them based on a hash of their content. This allows - -- expiration dates to be set far in the future without worry of - -- users receiving stale content. - addStaticContent ext' _ content = do - let fn = base64md5 content ++ '.' : unpack ext' - let content' = - if ext' == "js" - then case minifym content of - Left _ -> content - Right y -> y - else content - let statictmp = Hledger.Web.Settings.datadir ++ "/tmp/" - liftIO $ createDirectoryIfMissing True statictmp - let fn' = statictmp ++ fn - exists <- liftIO $ doesFileExist fn' - unless exists $ liftIO $ L.writeFile fn' content' - return $ Just $ Right (StaticR $ StaticRoute ["tmp", pack fn] [], []) - - -- defaultLayout widget = do - -- mmsg <- getMessage - -- pc <- widgetToPageContent $ do - -- widget - -- addCassius $(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 = datadir ++ "/tmp/" - -- liftIO $ createDirectoryIfMissing True statictmp - -- liftIO $ L.writeFile (statictmp ++ fn) content - -- return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) - --- 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 -withApp :: App -> (Yesod.Application -> IO a) -> IO a -withApp app f = toWaiApp app >>= 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 AppRoute -nulltemplate = [$hamlet||] - --- | A bundle of useful data passed to templates. -data TemplateData = TD { - 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 - ,p :: String -- ^ p (period expression) parameter - ,j :: Journal -- ^ the current journal - ,today :: Day -- ^ the current day - } - -mktd :: TemplateData -mktd = TD { - here = IndexR - ,title = "hledger" - ,msg = Nothing - ,a = "" - ,p = "" - ,j = nulljournal - ,today = ModifiedJulianDay 0 - } - --- | 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 - msg <- getMessage' err - return (a, p, opts, fspec, j, msg, here') - where - -- | Get current report parameters for this request. - getReportParameters :: Handler (String, String, [Opt], FilterSpec) - getReportParameters = do - app <- getYesod - t <- liftIO $ getCurrentLocalTime - a <- fromMaybe "" <$> lookupGetParam "a" - p <- fromMaybe "" <$> lookupGetParam "p" - let (a',p') = (unpack a, unpack p) - opts = appOpts app ++ [Period p'] - args = appArgs app ++ words' a' - fspec = optsToFilterSpec opts args t - return (a', p', opts, fspec) - - -- | Quote-sensitive words, ie don't split on spaces which are inside quotes. - words' :: String -> [String] - words' = fromparse . parsewith ((quotedPattern <|> pattern) `sepBy` many1 spacenonewline) - where - pattern = many (noneOf " \n\r\"") - quotedPattern = between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\"" - - -- | Update our copy of the journal if the file changed. If there is an - -- error while reloading, keep the old one and return the error, and set a - -- ui message. - getLatestJournal :: [Opt] -> Handler (Journal, Maybe String) - getLatestJournal opts = do - j <- liftIO $ fromJust `fmap` getValue "hledger" "journal" - (jE, changed) <- liftIO $ journalReloadIfChanged opts j - if not changed - then return (j,Nothing) - else case jE of - Right j' -> do liftIO $ putValue "hledger" "journal" j' - return (j',Nothing) - Left e -> do setMessage $ "error while reading" {- ++ ": " ++ e-} - return (j, Just e) - - -- | Helper to work around a yesod feature (can't set and get a message in the same request.) - getMessage' :: Maybe String -> Handler (Maybe Html) - getMessage' newmsgstr = do - oldmsg <- getMessage - return $ maybe oldmsg (Just . toHtml) 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| -!!! -#{title'} - #{m} - Hamlet AppRoute -navbar TD{p=p,j=j,today=today} = [$hamlet| - - #{version} - #{title} - \ # - #{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 $ journalFilePath 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| - add transaction - import transactions - \ | # - 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|#{s}|] - where u = (dest, concat [(if null a then [] else [("a", pack a)]) - ,(if null p then [] else [("p", pack p)])]) - style | dest == here = "navlinkcurrent" - | otherwise = "navlink" :: Text - --- | Form controlling journal filtering parameters. -filterform :: TemplateData -> Hamlet AppRoute -filterform TD{here=here,a=a,p=p} = [$hamlet| - String -> Hamlet AppRoute -helplink topic label = [$hamlet|#{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 <- 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" $ datadir "favicon.ico" - ----------------------------------------------------------------------- - -getRobotsR :: Handler RepPlain -getRobotsR = return $ RepPlain $ toContent robots_txt - ----------------------------------------------------------------------- - -getIndexR :: Handler () -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") +getRootR :: Handler RepHtml +getRootR = redirect RedirectTemporary defaultroute where defaultroute = JournalR + -- defaultLayout $ do + -- h2id <- lift newIdent + -- setTitle "hledger-web homepage" + -- addWidget $(widgetFile "homepage") ---------------------------------------------------------------------- @@ -544,7 +47,7 @@ getJournalR = do maincontent = journalReportAsHtml opts td $ journalReport opts fspec j td = mktd{here=here, title="hledger journal", msg=msg, a=a, p=p, j=j, today=today} editform' = editform td - hamletToRepHtml $ pageLayout td [$hamlet| + hamletToRepHtml $ pageLayout td [hamlet| TemplateData -> BalanceReport -> Hamlet AppRoute -balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [$hamlet| +balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [hamlet| ^{accountsheading} $forall i <- items @@ -615,49 +118,48 @@ balanceReportAsHtml _ td@TD{here=here,a=a,p=p} (items,total) = [$hamlet| - #{mixedAmountAsHtml total} > + #{mixedAmountAsHtml total} |] where - accountsheading = [$hamlet| - ^{showmore} ^{showall}|] :: Hamlet AppRoute showmore = case (filteringaccts, items) of -- cunning parent account logic (True, ((acct, _, _, _):_)) -> let a' = if isAccountRegex a then a else acct a'' = accountNameToAccountRegex $ parentAccountName $ accountRegexToAccountName a' parenturl = (here, [("a",pack a''), ("p",pack p)]) - in [$hamlet| + in [hamlet| \ | # - show more ↑ |] _ -> nulltemplate showall = if filteringaccts - then [$hamlet| + then [hamlet| \ | # - show all |] else nulltemplate where allurl = (here, [("p",pack p)]) itemAsHtml' = itemAsHtml td itemAsHtml :: TemplateData -> BalanceReportItem -> Hamlet AppRoute - itemAsHtml TD{p=p} (acct, adisplay, adepth, abal) = [$hamlet| + itemAsHtml TD{p=p} (acct, adisplay, adepth, abal) = [hamlet| #{adisplay} + #{adisplay} #{mixedAmountAsHtml abal} |] where - -- current = if not (null a) && containsRegex a acct then "current" else "" indent = preEscapedString $ concat $ replicate (2 * adepth) " " - aurl = printf ".?a=%s%s" (accountNameToAccountRegex acct) p' :: String - p' = if null p then "" else printf "&p=%s" p :: String + acctpat = accountNameToAccountRegex acct + pparam = if null p then "" else "&p="++p accountNameToAccountRegex :: String -> String accountNameToAccountRegex "" = "" @@ -679,7 +181,7 @@ getJournalOnlyR = do let td = mktd{here=here, title="hledger journal", msg=msg, a=a, p=p, j=j, today=today} editform' = editform td txns = journalReportAsHtml opts td $ journalReport opts fspec j - hamletToRepHtml $ pageLayout td [$hamlet| + hamletToRepHtml $ pageLayout td [hamlet| TemplateData -> JournalReport -> Hamlet AppRoute -journalReportAsHtml _ td items = [$hamlet| +journalReportAsHtml _ td items = [hamlet| $forall i <- number items ^{itemAsHtml' i} @@ -701,7 +203,7 @@ journalReportAsHtml _ td items = [$hamlet| number = zip [1..] itemAsHtml' = itemAsHtml td itemAsHtml :: TemplateData -> (Int, JournalReportItem) -> Hamlet AppRoute - itemAsHtml _ (n, t) = [$hamlet| + itemAsHtml _ (n, t) = [hamlet| 
 #{txn}
@@ -710,7 +212,7 @@ journalReportAsHtml _ td items = [$hamlet|
        txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse
 
 addform :: TemplateData -> Hamlet AppRoute
-addform td = [$hamlet|
+addform td = [hamlet|