web: update for yesod 0.9
This commit is contained in:
Simon Michael
parent
2f313663af
commit
7bc67a7f00
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Hledger.Web.App
|
||||
( App (..)
|
||||
, AppRoute (..)
|
||||
@ -6,46 +7,44 @@ module Hledger.Web.App
|
||||
, Handler
|
||||
, Widget
|
||||
, module Yesod.Core
|
||||
-- , module Settings
|
||||
, StaticRoute (..)
|
||||
, lift
|
||||
, liftIO
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import System.Directory
|
||||
import Text.Hamlet hiding (hamletFile)
|
||||
import Web.ClientSession (getKey)
|
||||
import Yesod.Core
|
||||
import Yesod.Helpers.Static
|
||||
import Yesod.Logger (Logger, logLazyText)
|
||||
import Yesod.Static (Static, base64md5, StaticRoute(..))
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Hledger.Data
|
||||
import Hledger.Web.Options
|
||||
import Hledger.Web.Settings
|
||||
import Hledger.Web.StaticFiles
|
||||
|
||||
|
||||
-- | 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
|
||||
{ settings :: Hledger.Web.Settings.AppConfig
|
||||
, getLogger :: Logger
|
||||
, getStatic :: Static -- ^ Settings for static file serving.
|
||||
|
||||
,appOpts :: WebOpts
|
||||
,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/
|
||||
@ -57,7 +56,7 @@ type Widget = GWidget App App
|
||||
-- * 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
|
||||
-- resources declared below. This is used in Handler.hs by the call to
|
||||
-- mkYesodDispatch
|
||||
--
|
||||
-- What this function does *not* do is create a YesodSite instance for
|
||||
@ -70,13 +69,17 @@ 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
|
||||
approot = Hledger.Web.Settings.appRoot . settings
|
||||
|
||||
-- Place the session key file in the config folder
|
||||
encryptKey _ = fmap Just $ getKey "client_session_key.aes"
|
||||
|
||||
defaultLayout widget = do
|
||||
-- mmsg <- getMessage
|
||||
pc <- widgetToPageContent $ do
|
||||
widget
|
||||
-- addCassius $(Settings.cassiusFile "default-layout")
|
||||
-- addCassius $(cassiusFile "default-layout")
|
||||
-- hamletToRepHtml $(hamletFile "default-layout")
|
||||
hamletToRepHtml [$hamlet|
|
||||
!!!
|
||||
<html
|
||||
@ -96,22 +99,24 @@ instance Yesod App where
|
||||
^{pageBody pc}
|
||||
|]
|
||||
|
||||
-- -- 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
|
||||
-- This is done to provide an optimization for serving static files from
|
||||
-- a separate domain. Please see the staticroot setting in Settings.hs
|
||||
-- urlRenderOverride y (StaticR s) =
|
||||
-- Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
|
||||
-- urlRenderOverride _ _ = Nothing
|
||||
|
||||
messageLogger y loc level msg =
|
||||
formatLogMessage loc level msg >>= logLazyText (getLogger y)
|
||||
|
||||
-- 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 = Hledger.Web.Settings.staticdir ++ "/tmp/"
|
||||
let statictmp = Hledger.Web.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] [], [])
|
||||
|
||||
|
||||
@ -1,18 +1,20 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Hledger.Web.AppRun (
|
||||
withApp
|
||||
,withDevelApp
|
||||
,withWaiHandlerDevelApp
|
||||
,withDevelAppPort
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Dynamic (Dynamic, toDyn)
|
||||
import Network.Wai (Application)
|
||||
import Network.Wai.Middleware.Debug (debugHandle)
|
||||
import System.IO.Storage (withStore, putValue)
|
||||
import Yesod.Helpers.Static
|
||||
import Yesod.Logger (makeLogger, flushLogger, Logger, logLazyText, logString)
|
||||
import Yesod.Static
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli
|
||||
@ -26,38 +28,71 @@ import Hledger.Web.Settings
|
||||
-- the comments there for more details.
|
||||
mkYesodDispatch "App" resourcesApp
|
||||
|
||||
-- withApp :: App -> (Application -> IO a) -> IO a
|
||||
-- withApp a f = toWaiApp a >>= f
|
||||
|
||||
-- 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 = toWaiApp a >>= f
|
||||
withApp :: AppConfig -> Logger -> (Application -> IO a) -> IO a
|
||||
withApp conf logger f = do
|
||||
#ifdef PRODUCTION
|
||||
s <- static Hledger.Web.Settings.staticDir
|
||||
#else
|
||||
s <- staticDevel Hledger.Web.Settings.staticDir
|
||||
#endif
|
||||
let h = App {settings=conf
|
||||
,getLogger=logger
|
||||
,getStatic=s
|
||||
,appOpts=defwebopts
|
||||
,appArgs=[]
|
||||
,appJournal=nulljournal
|
||||
}
|
||||
toWaiApp h >>= f
|
||||
|
||||
-- Called by yesod devel.
|
||||
withDevelApp :: Dynamic
|
||||
withDevelApp = toDyn (withApp a :: (Application -> IO ()) -> IO ())
|
||||
where a = App{
|
||||
getStatic=static Hledger.Web.Settings.staticdir
|
||||
,appRoot=Hledger.Web.Settings.defapproot
|
||||
,appOpts=defwebopts
|
||||
,appArgs=[]
|
||||
,appJournal=nulljournal
|
||||
}
|
||||
-- withDevelApp :: Dynamic
|
||||
-- withDevelApp = do
|
||||
-- s <- static Hledger.Web.Settings.staticdir
|
||||
-- let a = App{
|
||||
-- getStatic=s
|
||||
-- ,appRoot=Hledger.Web.Settings.defapproot
|
||||
-- ,appOpts=defwebopts
|
||||
-- ,appArgs=[]
|
||||
-- ,appJournal=nulljournal
|
||||
-- }
|
||||
-- return $ toDyn (withApp a :: (Application -> IO ()) -> IO ())
|
||||
|
||||
-- Called by wai-handler-devel.
|
||||
-- Eg: cabal-dev/bin/wai-handler-devel 5001 AppRun withWaiHandlerDevelApp
|
||||
withWaiHandlerDevelApp :: (Application -> IO ()) -> IO ()
|
||||
withWaiHandlerDevelApp func = do
|
||||
let f = "./test.journal"
|
||||
ej <- readJournalFile Nothing f
|
||||
let Right j = ej
|
||||
let a = App{
|
||||
getStatic=static Hledger.Web.Settings.staticdir
|
||||
,appRoot="http://localhost:5002"
|
||||
,appOpts=defwebopts{cliopts_=defcliopts{file_=Just f}}
|
||||
,appArgs=[]
|
||||
,appJournal=j
|
||||
}
|
||||
withStore "hledger" $ do
|
||||
putValue "hledger" "journal" j
|
||||
withApp a func
|
||||
-- for yesod devel
|
||||
withDevelAppPort :: Dynamic
|
||||
withDevelAppPort =
|
||||
toDyn go
|
||||
where
|
||||
go :: ((Int, Application) -> IO ()) -> IO ()
|
||||
go f = do
|
||||
conf <- Hledger.Web.Settings.loadConfig Hledger.Web.Settings.Development
|
||||
let port = appPort conf
|
||||
logger <- makeLogger
|
||||
logString logger $ "Devel application launched, listening on port " ++ show port
|
||||
withApp conf logger $ \app -> f (port, debugHandle (logHandle logger) app)
|
||||
flushLogger logger
|
||||
where
|
||||
logHandle logger msg = logLazyText logger msg >> flushLogger logger
|
||||
|
||||
-- -- Called by wai-handler-devel.
|
||||
-- -- Eg: cabal-dev/bin/wai-handler-devel 5001 AppRun withWaiHandlerDevelApp
|
||||
-- withWaiHandlerDevelApp :: (Application -> IO ()) -> IO ()
|
||||
-- withWaiHandlerDevelApp func = do
|
||||
-- let f = "./test.journal"
|
||||
-- ej <- readJournalFile Nothing f
|
||||
-- let Right j = ej
|
||||
-- let a = App{
|
||||
-- getStatic=static Hledger.Web.Settings.staticdir
|
||||
-- ,appRoot="http://localhost:5002"
|
||||
-- ,appOpts=defwebopts{cliopts_=defcliopts{file_=Just f}}
|
||||
-- ,appArgs=[]
|
||||
-- ,appJournal=j
|
||||
-- }
|
||||
-- withStore "hledger" $ do
|
||||
-- putValue "hledger" "journal" j
|
||||
-- withApp a func
|
||||
|
||||
@ -17,10 +17,10 @@ import Data.Text(Text,pack,unpack)
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Format
|
||||
-- import Safe
|
||||
import System.FilePath (takeFileName, (</>))
|
||||
import System.IO.Storage (putValue, getValue)
|
||||
import System.Locale (defaultTimeLocale)
|
||||
import Text.Blaze (preEscapedString, toHtml)
|
||||
import Text.Hamlet hiding (hamletFile)
|
||||
import Text.Printf
|
||||
import Yesod.Form
|
||||
@ -34,7 +34,7 @@ import Hledger.Web.Settings
|
||||
|
||||
|
||||
getFaviconR :: Handler ()
|
||||
getFaviconR = sendFile "image/x-icon" $ Hledger.Web.Settings.staticdir </> "favicon.ico"
|
||||
getFaviconR = sendFile "image/x-icon" $ Hledger.Web.Settings.staticDir </> "favicon.ico"
|
||||
|
||||
getRobotsR :: Handler RepPlain
|
||||
getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
|
||||
@ -187,11 +187,11 @@ getAccountsJsonR = do
|
||||
-- view helpers
|
||||
|
||||
-- | Render the sidebar used on most views.
|
||||
sidebar :: ViewData -> Hamlet AppRoute
|
||||
sidebar :: ViewData -> HtmlUrl AppRoute
|
||||
sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport2 (reportopts_ $ cliopts_ opts) am j
|
||||
|
||||
-- | Render a "AccountsReport" as HTML.
|
||||
accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> Hamlet AppRoute
|
||||
accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute
|
||||
accountsReportAsHtml _ vd@VD{..} (items',total) =
|
||||
[$hamlet|
|
||||
<div#accountsheading
|
||||
@ -234,7 +234,7 @@ accountsReportAsHtml _ vd@VD{..} (items',total) =
|
||||
inacctmatcher = inAccountMatcher qopts
|
||||
allaccts = isNothing inacctmatcher
|
||||
items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher
|
||||
itemAsHtml :: ViewData -> AccountsReportItem -> Hamlet AppRoute
|
||||
itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute
|
||||
itemAsHtml _ (acct, adisplay, aindent, abal) = [$hamlet|
|
||||
<tr.item.#{inacctclass}
|
||||
<td.account.#{depthclass}
|
||||
@ -272,14 +272,14 @@ accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRe
|
||||
accountUrl r a = (r, [("q",pack $ accountQuery a)])
|
||||
|
||||
-- | Render a "EntriesReport" as HTML for the journal entries view.
|
||||
entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> Hamlet AppRoute
|
||||
entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute
|
||||
entriesReportAsHtml _ vd items = [$hamlet|
|
||||
<table.journalreport>
|
||||
$forall i <- numbered items
|
||||
^{itemAsHtml vd i}
|
||||
|]
|
||||
where
|
||||
itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> Hamlet AppRoute
|
||||
itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute
|
||||
itemAsHtml _ (n, t) = [$hamlet|
|
||||
<tr.item.#{evenodd}>
|
||||
<td.transaction>
|
||||
@ -290,7 +290,7 @@ entriesReportAsHtml _ vd items = [$hamlet|
|
||||
txn = trimnl $ showTransaction t where trimnl = reverse . dropWhile (=='\n') . reverse
|
||||
|
||||
-- | Render an "TransactionsReport" as HTML for the formatted journal view.
|
||||
journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute
|
||||
journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
|
||||
journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|
|
||||
<table.journalreport
|
||||
<tr.headings
|
||||
@ -303,7 +303,7 @@ journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|
|
||||
|]
|
||||
where
|
||||
-- .#{datetransition}
|
||||
itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> Hamlet AppRoute
|
||||
itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute
|
||||
itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [$hamlet|
|
||||
<tr.item.#{evenodd}.#{firstposting}
|
||||
<td.date>#{date}
|
||||
@ -328,14 +328,14 @@ $forall p <- tpostings t
|
||||
showamt = not split || not (isZeroMixedAmount amt)
|
||||
|
||||
-- Generate html for an account register, including a balance chart and transaction list.
|
||||
registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute
|
||||
registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
|
||||
registerReportHtml opts vd r@(_,items) = [$hamlet|
|
||||
^{registerChartHtml items}
|
||||
^{registerItemsHtml opts vd r}
|
||||
|]
|
||||
|
||||
-- Generate html for a transaction list from an "TransactionsReport".
|
||||
registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> Hamlet AppRoute
|
||||
registerItemsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
|
||||
registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
|
||||
<table.registerreport
|
||||
<tr.headings
|
||||
@ -353,7 +353,7 @@ registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
|
||||
where
|
||||
-- inacct = inAccount qopts
|
||||
-- filtering = m /= MatchAny
|
||||
itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> Hamlet AppRoute
|
||||
itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute
|
||||
itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [$hamlet|
|
||||
<tr.item.#{evenodd}.#{firstposting}.#{datetransition}
|
||||
<td.date>#{date}
|
||||
@ -451,7 +451,7 @@ postRegisterR = handlePost
|
||||
-- | Handle a post from any of the edit forms.
|
||||
handlePost :: Handler RepPlain
|
||||
handlePost = do
|
||||
action <- runFormPost' $ maybeStringInput "action"
|
||||
action <- lookupPostParam "action"
|
||||
case action of Just "add" -> handleAdd
|
||||
Just "edit" -> handleEdit
|
||||
Just "import" -> handleImport
|
||||
@ -462,15 +462,13 @@ handleAdd :: Handler RepPlain
|
||||
handleAdd = do
|
||||
VD{..} <- getViewData
|
||||
-- get form input values. M means a Maybe value.
|
||||
(dateM, descM, acct1M, amt1M, acct2M, amt2M, journalM) <- runFormPost'
|
||||
$ (,,,,,,)
|
||||
<$> maybeStringInput "date"
|
||||
<*> maybeStringInput "description"
|
||||
<*> maybeStringInput "account1"
|
||||
<*> maybeStringInput "amount1"
|
||||
<*> maybeStringInput "account2"
|
||||
<*> maybeStringInput "amount2"
|
||||
<*> maybeStringInput "journal"
|
||||
dateM <- lookupPostParam "date"
|
||||
descM <- lookupPostParam "description"
|
||||
acct1M <- lookupPostParam "account1"
|
||||
amt1M <- lookupPostParam "amount1"
|
||||
acct2M <- lookupPostParam "account2"
|
||||
amt2M <- lookupPostParam "amount2"
|
||||
journalM <- lookupPostParam "journal"
|
||||
-- supply defaults and parse date and amounts, or get errors.
|
||||
let dateE = maybe (Left "date required") (either (\e -> Left $ showDateParseError e) Right . fixSmartDateStrEither today . unpack) dateM
|
||||
descE = Right $ maybe "" unpack descM
|
||||
@ -506,7 +504,7 @@ handleAdd = do
|
||||
Left errs -> do
|
||||
-- save current form values in session
|
||||
-- setMessage $ toHtml $ intercalate "; " errs
|
||||
setMessage [$hamlet|
|
||||
setMessage [$shamlet|
|
||||
Errors:<br>
|
||||
$forall e<-errs
|
||||
#{e}<br>
|
||||
@ -518,7 +516,7 @@ handleAdd = do
|
||||
liftIO $ do ensureJournalFile journalpath
|
||||
appendToJournalFileOrStdout journalpath $ showTransaction t'
|
||||
-- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String)
|
||||
setMessage [$hamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]
|
||||
setMessage [$shamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]
|
||||
redirectParams RedirectTemporary RegisterR [("add","1")]
|
||||
|
||||
chomp :: String -> String
|
||||
@ -530,10 +528,8 @@ handleEdit = do
|
||||
VD{..} <- getViewData
|
||||
-- get form input values, or validation errors.
|
||||
-- getRequest >>= liftIO (reqRequestBody req) >>= mtrace
|
||||
(textM, journalM) <- runFormPost'
|
||||
$ (,)
|
||||
<$> maybeStringInput "text"
|
||||
<*> maybeStringInput "journal"
|
||||
textM <- lookupPostParam "text"
|
||||
journalM <- lookupPostParam "journal"
|
||||
let textE = maybe (Left "No value provided") (Right . unpack) textM
|
||||
journalE = maybe (Right $ journalFilePath j)
|
||||
(\f -> let f' = unpack f in
|
||||
@ -578,7 +574,7 @@ handleImport = do
|
||||
setMessage "can't handle file upload yet"
|
||||
redirect RedirectTemporary JournalR
|
||||
-- -- get form input values, or basic validation errors. E means an Either value.
|
||||
-- fileM <- runFormPost' $ maybeFileInput "file"
|
||||
-- fileM <- runFormPost $ maybeFileInput "file"
|
||||
-- let fileE = maybe (Left "No file provided") Right fileM
|
||||
-- -- display errors or import transactions
|
||||
-- case fileE of
|
||||
@ -594,7 +590,7 @@ handleImport = do
|
||||
-- | Other view components.
|
||||
|
||||
-- | Global toolbar/heading area.
|
||||
topbar :: ViewData -> Hamlet AppRoute
|
||||
topbar :: ViewData -> HtmlUrl AppRoute
|
||||
topbar VD{..} = [$hamlet|
|
||||
<div#topbar
|
||||
<a.topleftlink href=#{hledgerorgurl} title="More about hledger"
|
||||
@ -610,7 +606,7 @@ $maybe m <- msg
|
||||
title = takeFileName $ journalFilePath j
|
||||
|
||||
-- | Navigation link, preserving parameters and possibly highlighted.
|
||||
navlink :: ViewData -> String -> AppRoute -> String -> Hamlet AppRoute
|
||||
navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute
|
||||
navlink VD{..} s dest title = [$hamlet|
|
||||
<a##{s}link.#{style} href=@?{u} title="#{title}">#{s}
|
||||
|]
|
||||
@ -619,7 +615,7 @@ navlink VD{..} s dest title = [$hamlet|
|
||||
| otherwise = "navlink" :: Text
|
||||
|
||||
-- | Links to the various journal editing forms.
|
||||
editlinks :: Hamlet AppRoute
|
||||
editlinks :: HtmlUrl AppRoute
|
||||
editlinks = [$hamlet|
|
||||
<a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit
|
||||
\ | #
|
||||
@ -628,14 +624,14 @@ editlinks = [$hamlet|
|
||||
|]
|
||||
|
||||
-- | Link to a topic in the manual.
|
||||
helplink :: String -> String -> Hamlet AppRoute
|
||||
helplink :: String -> String -> HtmlUrl AppRoute
|
||||
helplink topic label = [$hamlet|
|
||||
<a href=#{u} target=hledgerhelp>#{label}
|
||||
|]
|
||||
where u = manualurl ++ if null topic then "" else '#':topic
|
||||
|
||||
-- | Search form for entering custom queries to filter journal data.
|
||||
searchform :: ViewData -> Hamlet AppRoute
|
||||
searchform :: ViewData -> HtmlUrl AppRoute
|
||||
searchform VD{..} = [$hamlet|
|
||||
<div#searchformdiv
|
||||
<form#searchform.form method=GET
|
||||
@ -676,7 +672,7 @@ searchform VD{..} = [$hamlet|
|
||||
filtering = not $ null q
|
||||
|
||||
-- | Add transaction form.
|
||||
addform :: ViewData -> Hamlet AppRoute
|
||||
addform :: ViewData -> HtmlUrl AppRoute
|
||||
addform vd@VD{..} = [$hamlet|
|
||||
<script type=text/javascript>
|
||||
$(document).ready(function() {
|
||||
@ -779,7 +775,7 @@ addform vd@VD{..} = [$hamlet|
|
||||
)
|
||||
|
||||
-- | Edit journal form.
|
||||
editform :: ViewData -> Hamlet AppRoute
|
||||
editform :: ViewData -> HtmlUrl AppRoute
|
||||
editform VD{..} = [$hamlet|
|
||||
<form#editform method=POST style=display:none;
|
||||
<table.form
|
||||
@ -809,7 +805,7 @@ editform VD{..} = [$hamlet|
|
||||
formathelp = helplink "file-format" "file format help"
|
||||
|
||||
-- | Import journal form.
|
||||
importform :: Hamlet AppRoute
|
||||
importform :: HtmlUrl AppRoute
|
||||
importform = [$hamlet|
|
||||
<form#importform method=POST style=display:none;
|
||||
<table.form
|
||||
@ -822,14 +818,14 @@ importform = [$hamlet|
|
||||
<a href="#" onclick="return importformToggle(event)" cancel
|
||||
|]
|
||||
|
||||
journalselect :: [(FilePath,String)] -> Hamlet AppRoute
|
||||
journalselect :: [(FilePath,String)] -> HtmlUrl AppRoute
|
||||
journalselect journalfiles = [$hamlet|
|
||||
<select id=journalselect name=journal onchange="editformJournalSelect(event)"
|
||||
$forall f <- journalfiles
|
||||
<option value=#{fst f}>#{fst f}
|
||||
|]
|
||||
|
||||
nulltemplate :: Hamlet AppRoute
|
||||
nulltemplate :: HtmlUrl AppRoute
|
||||
nulltemplate = [$hamlet||]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
@ -1,8 +1,6 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- | Settings are centralized, as much as possible, into this file. This
|
||||
-- includes database connection settings, static file locations, etc.
|
||||
-- In addition, you can configure a number of different aspects of Yesod
|
||||
@ -14,30 +12,36 @@ module Hledger.Web.Settings
|
||||
, juliusFile
|
||||
, luciusFile
|
||||
, widgetFile
|
||||
, datadir
|
||||
, staticdir
|
||||
-- , staticroot
|
||||
, staticRoot
|
||||
, staticDir
|
||||
, loadConfig
|
||||
, AppEnvironment(..)
|
||||
, AppConfig(..)
|
||||
|
||||
, defhost
|
||||
, defport
|
||||
, defapproot
|
||||
-- , browserstartdelay
|
||||
, hledgerorgurl
|
||||
, manualurl
|
||||
, datadir
|
||||
|
||||
) where
|
||||
|
||||
import Data.Monoid (mempty) --, mappend)
|
||||
import Data.Text (Text,pack)
|
||||
import qualified Text.Hamlet as S
|
||||
import qualified Text.Cassius as S
|
||||
import qualified Text.Julius as S
|
||||
import qualified Text.Lucius as S
|
||||
import Text.Printf
|
||||
import qualified Text.Shakespeare.Text as S
|
||||
import Text.Shakespeare.Text (st)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile)
|
||||
import Data.Monoid (mempty)
|
||||
import System.Directory (doesFileExist)
|
||||
import Text.Printf (printf)
|
||||
import qualified Text.Hamlet as H
|
||||
import qualified Text.Cassius as H
|
||||
import qualified Text.Julius as H
|
||||
import qualified Text.Lucius as H
|
||||
import Yesod.Widget (addWidget, addCassius, addJulius, addLucius)
|
||||
|
||||
|
||||
-- browserstartdelay = 100000 -- microseconds
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Object
|
||||
import qualified Data.Object.Yaml as YAML
|
||||
import Control.Monad (join)
|
||||
|
||||
hledgerorgurl, manualurl :: String
|
||||
hledgerorgurl = "http://hledger.org"
|
||||
@ -50,49 +54,88 @@ defport = 5000
|
||||
defhost :: String
|
||||
defhost = "localhost"
|
||||
|
||||
-- | The default base URL for your application. This will usually be different for
|
||||
-- development and production. Yesod automatically constructs URLs for you,
|
||||
-- so this value must be accurate to create valid links.
|
||||
-- For hledger-web this is usually overridden with --base-url.
|
||||
defapproot :: Text
|
||||
defapproot = pack $ printf "http://%s:%d" defhost defport
|
||||
-- #ifdef PRODUCTION
|
||||
-- #else
|
||||
-- #endif
|
||||
|
||||
-- | Hard-coded data directory path. This must be in your current dir when
|
||||
-- you compile. At run time it's also required but we'll auto-create it.
|
||||
datadir :: FilePath
|
||||
datadir = "./.hledger/web/"
|
||||
|
||||
-- -- | The base URL for your static files. As you can see by the default
|
||||
-- -- value, this can simply be "static" appended to your application root.
|
||||
-- -- A powerful optimization can be serving static files from a separate
|
||||
-- -- domain name. This allows you to use a web server optimized for static
|
||||
-- -- files, more easily set expires and cache values, and avoid possibly
|
||||
-- -- costly transference of cookies on static files. For more information,
|
||||
-- -- please see:
|
||||
-- -- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain
|
||||
-- --
|
||||
-- -- If you change the resource pattern for StaticR in hledger-web.hs, you will
|
||||
-- -- have to make a corresponding change here.
|
||||
-- --
|
||||
-- -- To see how this value is used, see urlRenderOverride in hledger-web.hs
|
||||
-- staticroot :: Text
|
||||
-- staticroot = defapproot `mappend` "/static"
|
||||
data AppEnvironment = Test
|
||||
| Development
|
||||
| Staging
|
||||
| Production
|
||||
deriving (Eq, Show, Read, Enum, Bounded)
|
||||
|
||||
-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml.
|
||||
-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).
|
||||
--
|
||||
-- By convention these settings should be overwritten by any command line arguments.
|
||||
-- See config/App.hs for command line arguments
|
||||
-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku).
|
||||
--
|
||||
data AppConfig = AppConfig {
|
||||
appEnv :: AppEnvironment
|
||||
|
||||
, appPort :: Int
|
||||
|
||||
-- | The base URL for your application. This will usually be different for
|
||||
-- development and production. Yesod automatically constructs URLs for you,
|
||||
-- so this value must be accurate to create valid links.
|
||||
-- Please note that there is no trailing slash.
|
||||
--
|
||||
-- You probably want to change this! If your domain name was "yesod.com",
|
||||
-- you would probably want it to be:
|
||||
-- > "http://yesod.com"
|
||||
, appRoot :: Text
|
||||
} deriving (Show)
|
||||
|
||||
loadConfig :: AppEnvironment -> IO AppConfig
|
||||
loadConfig env = do
|
||||
allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping
|
||||
settings <- lookupMapping (show env) allSettings
|
||||
hostS <- lookupScalar "host" settings
|
||||
port <- fmap read $ lookupScalar "port" settings
|
||||
return $ AppConfig {
|
||||
appEnv = env
|
||||
, appPort = port
|
||||
, appRoot = pack $ hostS ++ addPort port
|
||||
}
|
||||
where
|
||||
addPort :: Int -> String
|
||||
#ifdef PRODUCTION
|
||||
addPort _ = ""
|
||||
#else
|
||||
addPort p = ":" ++ (show p)
|
||||
#endif
|
||||
|
||||
-- | The location of static files on your system. This is a file system
|
||||
-- path. The default value works properly with your scaffolded site.
|
||||
staticdir :: FilePath
|
||||
staticdir = datadir++"static"
|
||||
staticDir :: FilePath
|
||||
--staticDir = "static"
|
||||
staticDir = datadir++"static"
|
||||
|
||||
datadir :: FilePath
|
||||
datadir = "./.hledger/web/"
|
||||
|
||||
-- | The base URL for your static files. As you can see by the default
|
||||
-- value, this can simply be "static" appended to your application root.
|
||||
-- A powerful optimization can be serving static files from a separate
|
||||
-- domain name. This allows you to use a web server optimized for static
|
||||
-- files, more easily set expires and cache values, and avoid possibly
|
||||
-- costly transference of cookies on static files. For more information,
|
||||
-- please see:
|
||||
-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain
|
||||
--
|
||||
-- If you change the resource pattern for StaticR in hledger-web.hs, you will
|
||||
-- have to make a corresponding change here.
|
||||
--
|
||||
-- To see how this value is used, see urlRenderOverride in hledger-web.hs
|
||||
staticRoot :: AppConfig -> Text
|
||||
staticRoot conf = [st|#{appRoot conf}/static|]
|
||||
|
||||
-- The rest of this file contains settings which rarely need changing by a
|
||||
-- user.
|
||||
|
||||
-- The following three functions are used for calling HTML, CSS and
|
||||
-- Javascript templates from your Haskell code. During development,
|
||||
-- The following functions are used for calling HTML, CSS,
|
||||
-- Javascript, and plain text templates from your Haskell code. During development,
|
||||
-- the "Debug" versions of these functions are used so that changes to
|
||||
-- the templates are immediately reflected in an already running
|
||||
-- application. When making a production compile, the non-debug version
|
||||
@ -104,44 +147,54 @@ staticdir = datadir++"static"
|
||||
-- used; to get the same auto-loading effect, it is recommended that you
|
||||
-- use the devel server.
|
||||
|
||||
toHamletFile, toCassiusFile, toJuliusFile, toLuciusFile :: String -> FilePath
|
||||
toHamletFile x = datadir++"templates/" ++ x ++ ".hamlet"
|
||||
toCassiusFile x = datadir++"templates/" ++ x ++ ".cassius"
|
||||
toJuliusFile x = datadir++"templates/" ++ x ++ ".julius"
|
||||
toLuciusFile x = datadir++"templates/" ++ x ++ ".lucius"
|
||||
-- | expects a root folder for each type, e.g: hamlet/ lucius/ julius/
|
||||
globFile :: String -> String -> FilePath
|
||||
-- globFile kind x = kind ++ "/" ++ x ++ "." ++ kind
|
||||
globFile kind x = datadir ++ "templates/" ++ x ++ "." ++ kind
|
||||
|
||||
hamletFile :: FilePath -> Q Exp
|
||||
hamletFile = H.hamletFile . toHamletFile
|
||||
hamletFile = S.hamletFile . globFile "hamlet"
|
||||
|
||||
cassiusFile :: FilePath -> Q Exp
|
||||
cassiusFile =
|
||||
#ifdef PRODUCTION
|
||||
cassiusFile = H.cassiusFile . toCassiusFile
|
||||
S.cassiusFile . globFile "cassius"
|
||||
#else
|
||||
cassiusFile = H.cassiusFileDebug . toCassiusFile
|
||||
S.cassiusFileDebug . globFile "cassius"
|
||||
#endif
|
||||
|
||||
luciusFile :: FilePath -> Q Exp
|
||||
luciusFile =
|
||||
#ifdef PRODUCTION
|
||||
luciusFile = H.luciusFile . toLuciusFile
|
||||
S.luciusFile . globFile "lucius"
|
||||
#else
|
||||
luciusFile = H.luciusFileDebug . toLuciusFile
|
||||
S.luciusFileDebug . globFile "lucius"
|
||||
#endif
|
||||
|
||||
juliusFile :: FilePath -> Q Exp
|
||||
juliusFile =
|
||||
#ifdef PRODUCTION
|
||||
juliusFile = H.juliusFile . toJuliusFile
|
||||
S.juliusFile . globFile "julius"
|
||||
#else
|
||||
juliusFile = H.juliusFileDebug . toJuliusFile
|
||||
S.juliusFileDebug . globFile "julius"
|
||||
#endif
|
||||
|
||||
textFile :: FilePath -> Q Exp
|
||||
textFile =
|
||||
#ifdef PRODUCTION
|
||||
S.textFile . globFile "text"
|
||||
#else
|
||||
S.textFileDebug . globFile "text"
|
||||
#endif
|
||||
|
||||
widgetFile :: FilePath -> Q Exp
|
||||
widgetFile x = do
|
||||
let h = unlessExists toHamletFile hamletFile
|
||||
let c = unlessExists toCassiusFile cassiusFile
|
||||
let j = unlessExists toJuliusFile juliusFile
|
||||
let l = unlessExists toLuciusFile luciusFile
|
||||
let h = whenExists (globFile "hamlet") (whamletFile . globFile "hamlet")
|
||||
let c = whenExists (globFile "cassius") cassiusFile
|
||||
let j = whenExists (globFile "julius") juliusFile
|
||||
let l = whenExists (globFile "lucius") luciusFile
|
||||
[|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|]
|
||||
where
|
||||
unlessExists tofn f = do
|
||||
whenExists tofn f = do
|
||||
e <- qRunIO $ doesFileExist $ tofn x
|
||||
if e then f x else [|mempty|]
|
||||
|
||||
@ -11,8 +11,8 @@ This is a separate module to satisfy template haskell requirements.
|
||||
-}
|
||||
module Hledger.Web.StaticFiles where
|
||||
|
||||
import Yesod.Helpers.Static
|
||||
import Yesod.Static
|
||||
|
||||
import Hledger.Web.Settings (staticdir)
|
||||
import Hledger.Web.Settings (staticDir)
|
||||
|
||||
$(staticFiles staticdir)
|
||||
$(staticFiles staticDir)
|
||||
|
||||
@ -63,40 +63,37 @@ executable hledger-web
|
||||
,base >= 4 && < 5
|
||||
,bytestring
|
||||
,cmdargs >= 0.8 && < 0.9
|
||||
-- ,containers
|
||||
-- ,csv
|
||||
,directory
|
||||
,filepath
|
||||
-- ,mtl
|
||||
,old-locale
|
||||
-- ,old-time
|
||||
,parsec
|
||||
-- ,process
|
||||
,regexpr >= 0.5.1
|
||||
,safe >= 0.2
|
||||
-- ,split == 0.1.*
|
||||
,text
|
||||
,time
|
||||
-- ,utf8-string >= 0.3.5 && < 0.4
|
||||
,io-storage >= 0.3 && < 0.4
|
||||
-- ,convertible-text >= 0.3.0.1 && < 0.4
|
||||
-- ,data-object >= 0.3.1.2 && < 0.4
|
||||
,failure >= 0.1 && < 0.2
|
||||
,file-embed == 0.0.*
|
||||
,template-haskell >= 2.4 && < 2.6
|
||||
-- ,yesod >= 0.8 && < 0.9
|
||||
,yesod-core >= 0.8 && < 0.9
|
||||
,yesod-form == 0.1.*
|
||||
,yesod-json == 0.1.*
|
||||
,yesod-static == 0.1.*
|
||||
,aeson == 0.3.*
|
||||
,hamlet == 0.8.*
|
||||
|
||||
,yesod >= 0.9.2.1 && < 0.10
|
||||
,yesod-core
|
||||
,yesod-form
|
||||
,yesod-json
|
||||
,yesod-static >= 0.3
|
||||
,aeson-native
|
||||
,blaze-html
|
||||
,clientsession
|
||||
,data-object
|
||||
,data-object-yaml
|
||||
,hamlet
|
||||
,shakespeare-css
|
||||
,shakespeare-js
|
||||
,shakespeare-text
|
||||
,transformers
|
||||
,wai < 0.5
|
||||
,wai-extra < 0.5
|
||||
,warp < 0.5
|
||||
-- , blaze-builder
|
||||
-- , web-routes
|
||||
,wai
|
||||
,wai-extra
|
||||
,warp
|
||||
|
||||
library
|
||||
if flag(devel)
|
||||
|
||||
@ -13,14 +13,15 @@ import Control.Monad
|
||||
import Data.Maybe
|
||||
import Data.Text(pack)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
#if PRODUCTION
|
||||
#else
|
||||
import Network.Wai.Middleware.Debug (debug)
|
||||
#endif
|
||||
import System.Exit
|
||||
import System.IO.Storage (withStore, putValue)
|
||||
import Text.Printf
|
||||
import Yesod.Helpers.Static
|
||||
#ifndef PRODUCTION
|
||||
import Network.Wai.Middleware.Debug (debugHandle)
|
||||
import Yesod.Logger (logString, logLazyText, flushLogger, makeLogger)
|
||||
#else
|
||||
import Yesod.Logger (makeLogger)
|
||||
#endif
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli hiding (progname,progversion)
|
||||
@ -74,17 +75,71 @@ web opts j = do
|
||||
server :: String -> Int -> WebOpts -> Journal -> IO ()
|
||||
server baseurl port opts j = do
|
||||
printf "Starting http server on port %d with base url %s\n" port baseurl
|
||||
let a = App{getStatic=static staticdir
|
||||
,appRoot=pack baseurl
|
||||
,appOpts=opts
|
||||
,appArgs=patterns_ $ reportopts_ $ cliopts_ opts
|
||||
,appJournal=j
|
||||
}
|
||||
-- let a = App{getStatic=static staticdir
|
||||
-- ,appRoot=pack baseurl
|
||||
-- ,appOpts=opts
|
||||
-- ,appArgs=patterns_ $ reportopts_ $ cliopts_ opts
|
||||
-- ,appJournal=j
|
||||
-- }
|
||||
withStore "hledger" $ do
|
||||
putValue "hledger" "journal" j
|
||||
return ()
|
||||
|
||||
-- yesod main
|
||||
logger <- makeLogger
|
||||
-- args <- cmdArgs argConfig
|
||||
-- env <- getAppEnv args
|
||||
let env = Development
|
||||
-- c <- loadConfig env
|
||||
-- let c' = if port_ opts /= 0
|
||||
-- then c{ appPort = port args }
|
||||
-- else c
|
||||
let c = AppConfig {
|
||||
appEnv = env
|
||||
, appPort = port_ opts
|
||||
, appRoot = pack baseurl
|
||||
}
|
||||
|
||||
#if PRODUCTION
|
||||
withApp a (run port)
|
||||
withApp c logger $ run (appPort c)
|
||||
#else
|
||||
withApp a (run port . debug)
|
||||
logString logger $ (show env) ++ " application launched, listening on port " ++ show (appPort c)
|
||||
withApp c logger $ run (appPort c) . debugHandle (logHandle logger)
|
||||
flushLogger logger
|
||||
|
||||
where
|
||||
logHandle logger msg = logLazyText logger msg >> flushLogger logger
|
||||
#endif
|
||||
|
||||
-- data ArgConfig = ArgConfig
|
||||
-- { environment :: String
|
||||
-- , port :: Int
|
||||
-- } deriving (Show, Data, Typeable)
|
||||
|
||||
-- argConfig :: ArgConfig
|
||||
-- argConfig = ArgConfig
|
||||
-- { environment = def
|
||||
-- &= help ("application environment, one of: " ++ (foldl1 (\a b -> a ++ ", " ++ b) environments))
|
||||
-- &= typ "ENVIRONMENT"
|
||||
-- , port = def
|
||||
-- &= typ "PORT"
|
||||
-- }
|
||||
|
||||
-- environments :: [String]
|
||||
-- environments = map ((map toLower) . show) ([minBound..maxBound] :: [AppEnvironment])
|
||||
|
||||
-- | retrieve the -e environment option
|
||||
-- getAppEnv :: ArgConfig -> IO AppEnvironment
|
||||
-- getAppEnv cfg = do
|
||||
-- let e = if environment cfg /= ""
|
||||
-- then environment cfg
|
||||
-- else
|
||||
-- #if PRODUCTION
|
||||
-- "production"
|
||||
-- #else
|
||||
-- "development"
|
||||
-- #endif
|
||||
-- return $ read $ capitalize e
|
||||
|
||||
-- where
|
||||
-- capitalize [] = []
|
||||
-- capitalize (x:xs) = toUpper x : map toLower xs
|
||||
|
||||
Loading…
Reference in New Issue
Block a user