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 4613ed03a..000000000
Binary files a/hledger-web/.hledger/web/favicon.ico and /dev/null differ
diff --git a/hledger-web/.hledger/web/combo_select.gif b/hledger-web/.hledger/web/static/combo_select.gif
similarity index 100%
rename from hledger-web/.hledger/web/combo_select.gif
rename to hledger-web/.hledger/web/static/combo_select.gif
diff --git a/hledger-web/.hledger/web/dhtmlxcombo.js b/hledger-web/.hledger/web/static/dhtmlxcombo.js
similarity index 100%
rename from hledger-web/.hledger/web/dhtmlxcombo.js
rename to hledger-web/.hledger/web/static/dhtmlxcombo.js
diff --git a/hledger-web/.hledger/web/dhtmlxcommon.js b/hledger-web/.hledger/web/static/dhtmlxcommon.js
similarity index 100%
rename from hledger-web/.hledger/web/dhtmlxcommon.js
rename to hledger-web/.hledger/web/static/dhtmlxcommon.js
diff --git a/hledger-web/.hledger/web/static/favicon.ico b/hledger-web/.hledger/web/static/favicon.ico
new file mode 100644
index 000000000..9888b98f9
Binary files /dev/null and b/hledger-web/.hledger/web/static/favicon.ico differ
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}
-