web: officially drop GHC 6.12 support, fix build warnings with 7.0, 7.2, 7.4
This commit is contained in:
Simon Michael
parent
7f3b990394
commit
2912a11929
@ -24,7 +24,7 @@ import Network.Wai (Application)
|
||||
import Hledger.Web.Foundation
|
||||
import Hledger.Web.Handlers
|
||||
import Hledger.Web.Options
|
||||
import Hledger.Web.Settings (parseExtra)
|
||||
import Hledger.Web.Settings (Extra(..), parseExtra)
|
||||
import Hledger.Web.Settings.StaticFiles (staticSite)
|
||||
|
||||
-- This line actually creates our YesodSite instance. It is the second half
|
||||
|
||||
@ -8,7 +8,6 @@ module Hledger.Web.Foundation
|
||||
, Handler
|
||||
, Widget
|
||||
, module Yesod.Core
|
||||
, module Hledger.Web.Settings
|
||||
, liftIO
|
||||
) where
|
||||
|
||||
@ -24,7 +23,7 @@ import Text.Hamlet
|
||||
|
||||
import Hledger.Web.Options
|
||||
import qualified Hledger.Web.Settings
|
||||
import Hledger.Web.Settings (Extra (..), widgetFile)
|
||||
import Hledger.Web.Settings (Extra (..))
|
||||
import Hledger.Web.Settings.StaticFiles
|
||||
|
||||
|
||||
@ -75,8 +74,8 @@ instance Yesod App where
|
||||
encryptKey _ = fmap Just $ getKey "client_session_key.aes"
|
||||
|
||||
defaultLayout widget = do
|
||||
master <- getYesod
|
||||
mmsg <- getMessage
|
||||
-- master <- getYesod
|
||||
-- mmsg <- getMessage
|
||||
-- We break up the default layout into two components:
|
||||
-- default-layout is the contents of the body tag, and
|
||||
-- default-layout-wrapper is the entire page. Since the final
|
||||
@ -88,7 +87,7 @@ instance Yesod App where
|
||||
-- hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
pc <- widgetToPageContent $ do
|
||||
widget
|
||||
hamletToRepHtml [$hamlet|
|
||||
hamletToRepHtml [hamlet|
|
||||
!!!
|
||||
<html
|
||||
<head
|
||||
|
||||
@ -9,8 +9,6 @@ module Hledger.Web.Handlers where
|
||||
|
||||
import Prelude
|
||||
import Control.Applicative ((<$>))
|
||||
-- import Data.Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either (lefts,rights)
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
@ -19,7 +17,7 @@ import qualified Data.Text (null)
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Format
|
||||
import System.FilePath (takeFileName, (</>))
|
||||
import System.FilePath (takeFileName)
|
||||
import System.IO.Storage (putValue, getValue)
|
||||
import System.Locale (defaultTimeLocale)
|
||||
import Text.Blaze (preEscapedString, toHtml)
|
||||
@ -28,7 +26,7 @@ import Text.Printf
|
||||
import Yesod.Core
|
||||
-- import Yesod.Json
|
||||
|
||||
import Hledger hiding (today)
|
||||
import Hledger hiding (today,subs,is,d)
|
||||
import Hledger.Cli hiding (version)
|
||||
import Hledger.Web.Foundation
|
||||
import Hledger.Web.Options
|
||||
@ -60,15 +58,15 @@ getJournalR = do
|
||||
filtering = m /= Any
|
||||
-- showlastcolumn = if injournal && not filtering then False else True
|
||||
title = case inacct of
|
||||
Nothing -> "Journal"++filter
|
||||
Just (a,subs) -> "Transactions in "++a++andsubs++filter
|
||||
where andsubs = if subs then " (and subaccounts)" else ""
|
||||
Nothing -> "Journal"++s2
|
||||
Just (a,subs) -> "Transactions in "++a++s1++s2
|
||||
where s1 = if subs then " (and subaccounts)" else ""
|
||||
where
|
||||
filter = if filtering then ", filtered" else ""
|
||||
s2 = if filtering then ", filtered" else ""
|
||||
maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
|
||||
defaultLayout $ do
|
||||
setTitle "hledger-web journal"
|
||||
addHamlet [$hamlet|
|
||||
addHamlet [hamlet|
|
||||
^{topbar vd}
|
||||
<div#content
|
||||
<div#sidebar
|
||||
@ -101,7 +99,7 @@ getJournalEntriesR = do
|
||||
maincontent = entriesReportAsHtml opts vd $ entriesReport (reportopts_ $ cliopts_ opts) nullfilterspec $ filterJournalTransactions2 m j
|
||||
defaultLayout $ do
|
||||
setTitle "hledger-web journal"
|
||||
addHamlet [$hamlet|
|
||||
addHamlet [hamlet|
|
||||
^{topbar vd}
|
||||
<div#content
|
||||
<div#sidebar
|
||||
@ -133,15 +131,15 @@ getRegisterR = do
|
||||
let sidecontent = sidebar vd
|
||||
-- injournal = isNothing inacct
|
||||
filtering = m /= Any
|
||||
title = "Transactions in "++a++andsubs++filter
|
||||
title = "Transactions in "++a++s1++s2
|
||||
where
|
||||
(a,subs) = fromMaybe ("all accounts",False) $ inAccount qopts
|
||||
andsubs = if subs then " (and subaccounts)" else ""
|
||||
filter = if filtering then ", filtered" else ""
|
||||
s1 = if subs then " (and subaccounts)" else ""
|
||||
s2 = if filtering then ", filtered" else ""
|
||||
maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts
|
||||
defaultLayout $ do
|
||||
setTitle "hledger-web register"
|
||||
addHamlet [$hamlet|
|
||||
addHamlet [hamlet|
|
||||
^{topbar vd}
|
||||
<div#content
|
||||
<div#sidebar
|
||||
@ -199,7 +197,7 @@ sidebar vd@VD{..} = accountsReportAsHtml opts vd $ accountsReport2 (reportopts_
|
||||
-- | Render a "AccountsReport" as HTML.
|
||||
accountsReportAsHtml :: WebOpts -> ViewData -> AccountsReport -> HtmlUrl AppRoute
|
||||
accountsReportAsHtml _ vd@VD{..} (items',total) =
|
||||
[$hamlet|
|
||||
[hamlet|
|
||||
<div#accountsheading
|
||||
<a#accounts-toggle-link.togglelink href="#" title="Toggle sidebar">[+]
|
||||
<div#accounts
|
||||
@ -241,7 +239,7 @@ accountsReportAsHtml _ vd@VD{..} (items',total) =
|
||||
allaccts = isNothing inacctmatcher
|
||||
items = items' -- maybe items' (\m -> filter (matchesAccount m . \(a,_,_,_)->a) items') showacctmatcher
|
||||
itemAsHtml :: ViewData -> AccountsReportItem -> HtmlUrl AppRoute
|
||||
itemAsHtml _ (acct, adisplay, aindent, abal) = [$hamlet|
|
||||
itemAsHtml _ (acct, adisplay, aindent, abal) = [hamlet|
|
||||
<tr.item.#{inacctclass}
|
||||
<td.account.#{depthclass}
|
||||
#{indent}
|
||||
@ -262,7 +260,7 @@ accountsReportAsHtml _ vd@VD{..} (items',total) =
|
||||
numpostings = length $ apostings $ ledgerAccount l acct
|
||||
depthclass = "depth"++show aindent
|
||||
inacctclass = case inacctmatcher of
|
||||
Just m -> if m `matchesAccount` acct then "inacct" else "notinacct"
|
||||
Just m' -> if m' `matchesAccount` acct then "inacct" else "notinacct"
|
||||
Nothing -> "" :: String
|
||||
indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) " "
|
||||
acctquery = (RegisterR, [("q", pack $ accountQuery acct)])
|
||||
@ -274,19 +272,19 @@ accountQuery a = "inacct:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)
|
||||
accountOnlyQuery :: AccountName -> String
|
||||
accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)
|
||||
|
||||
-- accountUrl :: AppRoute -> AccountName -> (AppRoute,[(String,ByteString)])
|
||||
accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
|
||||
accountUrl r a = (r, [("q", pack $ accountQuery a)])
|
||||
|
||||
-- | Render a "EntriesReport" as HTML for the journal entries view.
|
||||
entriesReportAsHtml :: WebOpts -> ViewData -> EntriesReport -> HtmlUrl AppRoute
|
||||
entriesReportAsHtml _ vd items = [$hamlet|
|
||||
entriesReportAsHtml _ vd items = [hamlet|
|
||||
<table.journalreport>
|
||||
$forall i <- numbered items
|
||||
^{itemAsHtml vd i}
|
||||
|]
|
||||
where
|
||||
itemAsHtml :: ViewData -> (Int, EntriesReportItem) -> HtmlUrl AppRoute
|
||||
itemAsHtml _ (n, t) = [$hamlet|
|
||||
itemAsHtml _ (n, t) = [hamlet|
|
||||
<tr.item.#{evenodd}>
|
||||
<td.transaction>
|
||||
<pre>#{txn}
|
||||
@ -297,7 +295,7 @@ entriesReportAsHtml _ vd items = [$hamlet|
|
||||
|
||||
-- | Render an "TransactionsReport" as HTML for the formatted journal view.
|
||||
journalTransactionsReportAsHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
|
||||
journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|
|
||||
journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|
|
||||
<table.journalreport
|
||||
<tr.headings
|
||||
<th.date align=left>Date
|
||||
@ -310,19 +308,19 @@ journalTransactionsReportAsHtml _ vd (_,items) = [$hamlet|
|
||||
where
|
||||
-- .#{datetransition}
|
||||
itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute
|
||||
itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [$hamlet|
|
||||
itemAsHtml VD{..} (n, _, _, _, (t, _, split, _, amt, _)) = [hamlet|
|
||||
<tr.item.#{evenodd}.#{firstposting}
|
||||
<td.date>#{date}
|
||||
<td.description colspan=2 title="#{show t}">#{elideRight 60 desc}
|
||||
<td.amount align=right>
|
||||
$if showamt
|
||||
#{mixedAmountAsHtml amt}
|
||||
$forall p <- tpostings t
|
||||
$forall p' <- tpostings t
|
||||
<tr.item.#{evenodd}.posting
|
||||
<td.date
|
||||
<td.description
|
||||
<td.account> <a href="@?{accountUrl here $ paccount p}" title="Show transactions in #{paccount p}">#{elideRight 40 $ paccount p}
|
||||
<td.amount align=right>#{mixedAmountAsHtml $ pamount p}
|
||||
<td.account> <a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}
|
||||
<td.amount align=right>#{mixedAmountAsHtml $ pamount p'}
|
||||
|]
|
||||
where
|
||||
evenodd = if even n then "even" else "odd" :: String
|
||||
@ -335,14 +333,14 @@ $forall p <- tpostings t
|
||||
|
||||
-- Generate html for an account register, including a balance chart and transaction list.
|
||||
registerReportHtml :: WebOpts -> ViewData -> TransactionsReport -> HtmlUrl AppRoute
|
||||
registerReportHtml opts vd r@(_,items) = [$hamlet|
|
||||
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 -> HtmlUrl AppRoute
|
||||
registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
|
||||
registerItemsHtml _ vd (balancelabel,items) = [hamlet|
|
||||
<table.registerreport
|
||||
<tr.headings
|
||||
<th.date align=left>Date
|
||||
@ -360,7 +358,7 @@ registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
|
||||
-- inacct = inAccount qopts
|
||||
-- filtering = m /= Any
|
||||
itemAsHtml :: ViewData -> (Int, Bool, Bool, Bool, TransactionsReportItem) -> HtmlUrl AppRoute
|
||||
itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [$hamlet|
|
||||
itemAsHtml VD{..} (n, newd, newm, _, (t, _, split, acct, amt, bal)) = [hamlet|
|
||||
<tr.item.#{evenodd}.#{firstposting}.#{datetransition}
|
||||
<td.date>#{date}
|
||||
<td.description title="#{show t}">#{elideRight 30 desc}
|
||||
@ -374,12 +372,12 @@ registerItemsHtml _ vd (balancelabel,items) = [$hamlet|
|
||||
$if showamt
|
||||
#{mixedAmountAsHtml amt}
|
||||
<td.balance align=right>#{mixedAmountAsHtml bal}
|
||||
$forall p <- tpostings t
|
||||
$forall p' <- tpostings t
|
||||
<tr.item.#{evenodd}.posting style=#{postingsdisplaystyle}
|
||||
<td.date
|
||||
<td.description
|
||||
<td.account> <a href="@?{accountUrl here $ paccount p}" title="Show transactions in #{paccount p}">#{elideRight 40 $ paccount p}
|
||||
<td.amount align=right>#{mixedAmountAsHtml $ pamount p}
|
||||
<td.account> <a href="@?{accountUrl here $ paccount p'}" title="Show transactions in #{paccount p'}">#{elideRight 40 $ paccount p'}
|
||||
<td.amount align=right>#{mixedAmountAsHtml $ pamount p'}
|
||||
<td.balance align=right>
|
||||
|]
|
||||
where
|
||||
@ -394,10 +392,15 @@ $forall p <- tpostings t
|
||||
|
||||
-- | Generate javascript/html for a register balance line chart based on
|
||||
-- the provided "TransactionsReportItem"s.
|
||||
-- registerChartHtml :: forall t (t1 :: * -> *) t2 t3 t4 t5.
|
||||
-- Data.Foldable.Foldable t1 =>
|
||||
-- t1 (Transaction, t2, t3, t4, t5, MixedAmount)
|
||||
-- -> t -> Text.Blaze.Internal.HtmlM ()
|
||||
registerChartHtml :: [TransactionsReportItem] -> HtmlUrl AppRoute
|
||||
registerChartHtml items =
|
||||
-- have to make sure plot is not called when our container (maincontent)
|
||||
-- is hidden, eg with add form toggled
|
||||
[$hamlet|
|
||||
[hamlet|
|
||||
<script type=text/javascript>
|
||||
if (document.getElementById('maincontent').style.display != 'none')
|
||||
\$(document).ready(function() {
|
||||
@ -425,7 +428,7 @@ stringIfLongerThan n s = if length s > n then s else ""
|
||||
|
||||
numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]
|
||||
numberTransactionsReportItems [] = []
|
||||
numberTransactionsReportItems is = number 0 nulldate is
|
||||
numberTransactionsReportItems items = number 0 nulldate items
|
||||
where
|
||||
number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]
|
||||
number _ _ [] = []
|
||||
@ -437,6 +440,7 @@ numberTransactionsReportItems is = number 0 nulldate is
|
||||
(dy,dm,_) = toGregorian d
|
||||
(prevdy,prevdm,_) = toGregorian prevd
|
||||
|
||||
mixedAmountAsHtml :: MixedAmount -> Html
|
||||
mixedAmountAsHtml b = preEscapedString $ addclass $ intercalate "<br>" $ lines $ show b
|
||||
where addclass = printf "<span class=\"%s\">%s</span>" (c :: String)
|
||||
c = case isNegativeMixedAmount b of Just True -> "negative amount"
|
||||
@ -511,12 +515,12 @@ handleAdd = do
|
||||
})
|
||||
-- display errors or add transaction
|
||||
case tE of
|
||||
Left errs -> do
|
||||
Left errs' -> do
|
||||
-- save current form values in session
|
||||
-- setMessage $ toHtml $ intercalate "; " errs
|
||||
setMessage [$shamlet|
|
||||
setMessage [shamlet|
|
||||
Errors:<br>
|
||||
$forall e<-errs
|
||||
$forall e<-errs'
|
||||
#{e}<br>
|
||||
|]
|
||||
Right t -> do
|
||||
@ -524,7 +528,7 @@ handleAdd = do
|
||||
liftIO $ do ensureJournalFileExists journalpath
|
||||
appendToJournalFileOrStdout journalpath $ showTransaction t'
|
||||
-- setMessage $ toHtml $ (printf "Added transaction:\n%s" (show t') :: String)
|
||||
setMessage [$shamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]
|
||||
setMessage [shamlet|<span>Added transaction:<small><pre>#{chomp $ show t'}</pre></small>|]
|
||||
|
||||
redirect (RegisterR, [("add","1")])
|
||||
|
||||
@ -600,7 +604,7 @@ handleImport = do
|
||||
|
||||
-- | Global toolbar/heading area.
|
||||
topbar :: ViewData -> HtmlUrl AppRoute
|
||||
topbar VD{..} = [$hamlet|
|
||||
topbar VD{..} = [hamlet|
|
||||
<div#topbar
|
||||
<a.topleftlink href=#{hledgerorgurl} title="More about hledger"
|
||||
hledger-web
|
||||
@ -608,24 +612,24 @@ topbar VD{..} = [$hamlet|
|
||||
#{version}
|
||||
<a.toprightlink href=#{manualurl} target=hledgerhelp title="User manual">manual
|
||||
<h1>#{title}
|
||||
$maybe m <- msg
|
||||
<div#message>#{m}
|
||||
$maybe m' <- msg
|
||||
<div#message>#{m'}
|
||||
|]
|
||||
where
|
||||
title = takeFileName $ journalFilePath j
|
||||
|
||||
-- | Navigation link, preserving parameters and possibly highlighted.
|
||||
navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute
|
||||
navlink VD{..} s dest title = [$hamlet|
|
||||
<a##{s}link.#{style} href=@?{u} title="#{title}">#{s}
|
||||
navlink VD{..} s dest title = [hamlet|
|
||||
<a##{s}link.#{style} href=@?{u'} title="#{title}">#{s}
|
||||
|]
|
||||
where u = (dest, if null q then [] else [("q", pack q)])
|
||||
where u' = (dest, if null q then [] else [("q", pack q)])
|
||||
style | dest == here = "navlinkcurrent"
|
||||
| otherwise = "navlink" :: Text
|
||||
|
||||
-- | Links to the various journal editing forms.
|
||||
editlinks :: HtmlUrl AppRoute
|
||||
editlinks = [$hamlet|
|
||||
editlinks = [hamlet|
|
||||
<a#editformlink href="#" onclick="return editformToggle(event)" title="Toggle journal edit form">edit
|
||||
\ | #
|
||||
<a#addformlink href="#" onclick="return addformToggle(event)" title="Toggle transaction add form">add
|
||||
@ -634,14 +638,14 @@ editlinks = [$hamlet|
|
||||
|
||||
-- | Link to a topic in the manual.
|
||||
helplink :: String -> String -> HtmlUrl AppRoute
|
||||
helplink topic label = [$hamlet|
|
||||
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 -> HtmlUrl AppRoute
|
||||
searchform VD{..} = [$hamlet|
|
||||
searchform VD{..} = [hamlet|
|
||||
<div#searchformdiv
|
||||
<form#searchform.form method=GET
|
||||
<table
|
||||
@ -682,7 +686,7 @@ searchform VD{..} = [$hamlet|
|
||||
|
||||
-- | Add transaction form.
|
||||
addform :: ViewData -> HtmlUrl AppRoute
|
||||
addform vd@VD{..} = [$hamlet|
|
||||
addform vd@VD{..} = [hamlet|
|
||||
<script type=text/javascript>
|
||||
\$(document).ready(function() {
|
||||
/* dhtmlxcombo setup */
|
||||
@ -743,7 +747,8 @@ addform vd@VD{..} = [$hamlet|
|
||||
date = "today" :: String
|
||||
descriptions = sort $ nub $ map tdescription $ jtxns j
|
||||
manyfiles = (length $ files j) > 1
|
||||
postingfields VD{..} n = [$hamlet|
|
||||
postingfields :: ViewData -> Int -> HtmlUrl AppRoute
|
||||
postingfields _ n = [hamlet|
|
||||
<tr#postingrow
|
||||
<td align=right>#{acctlabel}:
|
||||
<td
|
||||
@ -762,14 +767,14 @@ addform vd@VD{..} = [$hamlet|
|
||||
|]
|
||||
where
|
||||
shouldselect a = n == 2 && maybe False ((a==).fst) (inAccount qopts)
|
||||
numbered = (++ show n)
|
||||
acctvar = numbered "account"
|
||||
amtvar = numbered "amount"
|
||||
withnumber = (++ show n)
|
||||
acctvar = withnumber "account"
|
||||
amtvar = withnumber "amount"
|
||||
acctnames = sort $ journalAccountNamesUsed j
|
||||
(acctlabel, accthelp, amtfield, amthelp)
|
||||
| n == 1 = ("To account"
|
||||
,"eg: expenses:food"
|
||||
,[$hamlet|
|
||||
,[hamlet|
|
||||
<td style=padding-left:1em;
|
||||
Amount:
|
||||
<td
|
||||
@ -785,7 +790,7 @@ addform vd@VD{..} = [$hamlet|
|
||||
|
||||
-- | Edit journal form.
|
||||
editform :: ViewData -> HtmlUrl AppRoute
|
||||
editform VD{..} = [$hamlet|
|
||||
editform VD{..} = [hamlet|
|
||||
<form#editform method=POST style=display:none;
|
||||
<h2#contenttitle>#{title}
|
||||
<table.form
|
||||
@ -817,7 +822,7 @@ editform VD{..} = [$hamlet|
|
||||
|
||||
-- | Import journal form.
|
||||
importform :: HtmlUrl AppRoute
|
||||
importform = [$hamlet|
|
||||
importform = [hamlet|
|
||||
<form#importform method=POST style=display:none;
|
||||
<table.form
|
||||
<tr
|
||||
@ -830,14 +835,14 @@ importform = [$hamlet|
|
||||
|]
|
||||
|
||||
journalselect :: [(FilePath,String)] -> HtmlUrl AppRoute
|
||||
journalselect journalfiles = [$hamlet|
|
||||
journalselect journalfiles = [hamlet|
|
||||
<select id=journalselect name=journal onchange="editformJournalSelect(event)"
|
||||
$forall f <- journalfiles
|
||||
<option value=#{fst f}>#{fst f}
|
||||
|]
|
||||
|
||||
nulltemplate :: HtmlUrl AppRoute
|
||||
nulltemplate = [$hamlet||]
|
||||
nulltemplate = [hamlet||]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- utilities
|
||||
@ -925,6 +930,7 @@ getMessageOr mnewmsg = do
|
||||
oldmsg <- getMessage
|
||||
return $ maybe oldmsg (Just . toHtml) mnewmsg
|
||||
|
||||
numbered :: [a] -> [(Int,a)]
|
||||
numbered = zip [1..]
|
||||
|
||||
dayToJsTimestamp :: Day -> Integer
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
module Hledger.Web.Import
|
||||
( module Prelude
|
||||
, module Hledger.Web.Foundation
|
||||
, (<>)
|
||||
, Text
|
||||
, module Data.Monoid
|
||||
@ -12,8 +11,6 @@ import Data.Monoid (Monoid (mappend, mempty, mconcat))
|
||||
import Control.Applicative ((<$>), (<*>), pure)
|
||||
import Data.Text (Text)
|
||||
|
||||
import Hledger.Web.Foundation
|
||||
|
||||
infixr 5 <>
|
||||
(<>) :: Monoid m => m -> m -> m
|
||||
(<>) = mappend
|
||||
|
||||
@ -22,15 +22,19 @@ version = ""
|
||||
progname = $(packageVariable (pkgName . package))
|
||||
version = $(packageVariable (pkgVersion . package))
|
||||
#endif
|
||||
prognameandversion :: String
|
||||
prognameandversion = progname ++ " " ++ version :: String
|
||||
|
||||
defbaseurlexample :: String
|
||||
defbaseurlexample = (reverse $ drop 4 $ reverse $ defbaseurl defport) ++ "PORT"
|
||||
|
||||
webflags :: [Flag [([Char], [Char])]]
|
||||
webflags = [
|
||||
flagReq ["base-url"] (\s opts -> Right $ setopt "base-url" s opts) "URL" ("set the base url (default: "++defbaseurlexample++")")
|
||||
,flagReq ["port"] (\s opts -> Right $ setopt "port" s opts) "PORT" ("listen on this tcp port (default: "++show defport++")")
|
||||
]
|
||||
|
||||
webmode :: Mode [([Char], [Char])]
|
||||
webmode = (mode "hledger-web" [("command","web")]
|
||||
"start serving the hledger web interface"
|
||||
mainargsflag []){
|
||||
@ -51,6 +55,7 @@ data WebOpts = WebOpts {
|
||||
,cliopts_ :: CliOpts
|
||||
} deriving (Show)
|
||||
|
||||
defwebopts :: WebOpts
|
||||
defwebopts = WebOpts
|
||||
def
|
||||
def
|
||||
|
||||
@ -1,6 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP, TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
|
||||
-- | 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
|
||||
@ -12,41 +10,21 @@ module Hledger.Web.Settings
|
||||
, staticDir
|
||||
, Extra (..)
|
||||
, parseExtra
|
||||
|
||||
-- , hamletFile
|
||||
-- , cassiusFile
|
||||
-- , juliusFile
|
||||
-- , luciusFile
|
||||
-- , AppEnvironment(..)
|
||||
-- , AppConfig(..)
|
||||
, defport
|
||||
, defbaseurl
|
||||
, hledgerorgurl
|
||||
, manualurl
|
||||
|
||||
) where
|
||||
|
||||
import Prelude
|
||||
import Text.Shakespeare.Text (st)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Yesod.Default.Config
|
||||
import qualified Yesod.Default.Util
|
||||
import Control.Applicative
|
||||
import Data.Text (Text)
|
||||
import Data.Yaml
|
||||
import Control.Applicative
|
||||
|
||||
-- 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 Language.Haskell.TH.Syntax
|
||||
import Prelude
|
||||
import Text.Printf
|
||||
import qualified Text.Shakespeare.Text as S
|
||||
import Text.Shakespeare.Text (st)
|
||||
import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile)
|
||||
import Data.Monoid (mempty)
|
||||
import System.Directory (doesFileExist)
|
||||
import Data.Text (pack)
|
||||
import Control.Monad (join)
|
||||
import Yesod.Default.Config
|
||||
import qualified Yesod.Default.Util
|
||||
|
||||
|
||||
hledgerorgurl, manualurl :: String
|
||||
@ -100,73 +78,3 @@ parseExtra :: DefaultEnv -> Object -> Parser Extra
|
||||
parseExtra _ o = Extra
|
||||
<$> o .: "copyright"
|
||||
<*> o .:? "analytics"
|
||||
|
||||
{-
|
||||
-- The rest of this file contains settings which rarely need changing by a
|
||||
-- user.
|
||||
|
||||
-- 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
|
||||
-- is used for increased performance.
|
||||
--
|
||||
-- You can see an example of how to call these functions in Handler/Root.hs
|
||||
--
|
||||
-- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer
|
||||
-- used; to get the same auto-loading effect, it is recommended that you
|
||||
-- use the devel server.
|
||||
|
||||
-- | 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 = "templates/" ++ x ++ "." ++ kind
|
||||
|
||||
hamletFile :: FilePath -> Q Exp
|
||||
hamletFile = S.hamletFile . globFile "hamlet"
|
||||
|
||||
cassiusFile :: FilePath -> Q Exp
|
||||
cassiusFile =
|
||||
#ifdef PRODUCTION
|
||||
S.cassiusFile . globFile "cassius"
|
||||
#else
|
||||
S.cassiusFileDebug . globFile "cassius"
|
||||
#endif
|
||||
|
||||
luciusFile :: FilePath -> Q Exp
|
||||
luciusFile =
|
||||
#ifdef PRODUCTION
|
||||
S.luciusFile . globFile "lucius"
|
||||
#else
|
||||
S.luciusFileDebug . globFile "lucius"
|
||||
#endif
|
||||
|
||||
juliusFile :: FilePath -> Q Exp
|
||||
juliusFile =
|
||||
#ifdef PRODUCTION
|
||||
S.juliusFile . globFile "julius"
|
||||
#else
|
||||
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 = 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
|
||||
whenExists tofn f = do
|
||||
e <- qRunIO $ doesFileExist $ tofn x
|
||||
if e then f x else [|mempty|]
|
||||
-}
|
||||
@ -11,7 +11,6 @@ This is a separate module to satisfy template haskell requirements.
|
||||
-}
|
||||
module Hledger.Web.Settings.StaticFiles where
|
||||
|
||||
import Prelude (IO)
|
||||
import System.IO
|
||||
import Yesod.Static
|
||||
import qualified Yesod.Static as Static
|
||||
|
||||
@ -12,8 +12,8 @@ where
|
||||
|
||||
import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort)
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Yesod.Logger (Logger, defaultDevelopmentLogger) --, logString)
|
||||
-- import Yesod.Default.Main (defaultMain)
|
||||
import Yesod.Logger ({- Logger,-} defaultDevelopmentLogger) --, logString)
|
||||
|
||||
import Prelude hiding (putStrLn)
|
||||
-- -- import Control.Concurrent (forkIO, threadDelay)
|
||||
@ -26,9 +26,8 @@ import Text.Printf
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli hiding (progname,prognameandversion)
|
||||
import Hledger.Web.Settings (parseExtra)
|
||||
import Hledger.Utils.UTF8IOCompat (putStrLn)
|
||||
import Hledger.Web
|
||||
import Hledger.Web hiding (opts,j)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
@ -38,9 +37,7 @@ main = do
|
||||
runWith opts
|
||||
|
||||
runWith :: WebOpts -> IO ()
|
||||
runWith opts = run opts
|
||||
where
|
||||
run opts
|
||||
runWith opts
|
||||
| "help" `in_` (rawopts_ $ cliopts_ opts) = putStr (showModeHelp webmode) >> exitSuccess
|
||||
| "version" `in_` (rawopts_ $ cliopts_ opts) = putStrLn prognameandversion >> exitSuccess
|
||||
| "binary-filename" `in_` (rawopts_ $ cliopts_ opts) = putStrLn (binaryfilename progname)
|
||||
@ -85,6 +82,7 @@ server baseurl port opts j = do
|
||||
appEnv = Development
|
||||
, appPort = port_ opts
|
||||
, appRoot = pack baseurl
|
||||
, appExtra = Extra "" Nothing
|
||||
}
|
||||
logger <- defaultDevelopmentLogger
|
||||
app <- getApplication config logger
|
||||
|
||||
Loading…
Reference in New Issue
Block a user