module Foundation where
import Prelude
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Data.IORef
import Yesod
import Yesod.Static
import Yesod.Default.Config
#ifndef DEVELOPMENT
import Yesod.Default.Util (addStaticContentExternal)
#endif
import Network.HTTP.Conduit (Manager)
import Settings.Development (development)
import Settings.StaticFiles
import Settings (staticRoot, widgetFile, Extra (..))
#ifndef DEVELOPMENT
import Settings (staticDir)
import Text.Jasmine (minifym)
#endif
import Text.Blaze.Html.Renderer.String (renderHtml)
import Text.Hamlet (hamletFile)
import Hledger.Web.Options
import Hledger.Data.Types
import Data.List
import Data.Maybe
import Data.Text as Text (Text,pack,unpack)
import Data.Time.Calendar
#if BLAZE_HTML_0_4
import Text.Blaze (preEscapedString)
#else
import Text.Blaze.Internal (preEscapedString)
#endif
import Text.JSON
import Hledger.Data.Journal
import Hledger.Query
import Hledger hiding (is)
import Hledger.Cli hiding (version)
data App = App
{ settings :: AppConfig DefaultEnv Extra
, getStatic :: Static
, httpManager :: Manager
, appOpts :: WebOpts
, appJournal :: IORef Journal
}
mkMessage "App" "messages" "en"
mkYesodData "App" $(parseRoutesFile "config/routes")
type AppRoute = Route App
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
instance Yesod App where
approot = ApprootMaster $ appRoot . settings
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
(120 * 60)
".hledger-web_client_session_key.aes"
defaultLayout widget = do
master <- getYesod
lastmsg <- getMessage
vd@VD{..} <- getViewData
pc <- widgetToPageContent $ do
$(widgetFile "normalize")
addStylesheet $ StaticR css_bootstrap_min_css
toWidgetHead [hamlet|
<script type="text/javascript" src="@{StaticR js_jquery_min_js}"></script>
<script type="text/javascript" src="@{StaticR js_typeahead_bundle_min_js}"></script>
|]
addScript $ StaticR js_bootstrap_min_js
addScript $ StaticR js_jquery_url_js
addScript $ StaticR js_jquery_cookie_js
addScript $ StaticR js_jquery_hotkeys_js
addScript $ StaticR js_jquery_flot_min_js
addScript $ StaticR js_jquery_flot_time_min_js
addScript $ StaticR js_jquery_flot_tooltip_min_js
toWidget [hamlet| \<!--[if lte IE 8]> <script type="text/javascript" src="@{StaticR js_excanvas_min_js}"></script> <![endif]--> |]
addStylesheet $ StaticR hledger_css
addScript $ StaticR hledger_js
$(widgetFile "default-layout")
staticRootUrl <- (staticRoot . settings) <$> getYesod
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
urlRenderOverride y (StaticR s) =
Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
urlRenderOverride _ _ = Nothing
#ifndef DEVELOPMENT
addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
#endif
jsLoader _ = BottomOfBody
shouldLog _ _source level =
development || level == LevelWarn || level == LevelError
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
getExtra :: Handler Extra
getExtra = fmap (appExtra . settings) getYesod
data ViewData = VD {
opts :: WebOpts
,here :: AppRoute
,msg :: Maybe Html
,today :: Day
,j :: Journal
,q :: String
,m :: Query
,qopts :: [QueryOpt]
,am :: Query
,aopts :: [QueryOpt]
,showpostings :: Bool
,showsidebar :: Bool
}
nullviewdata :: ViewData
nullviewdata = viewdataWithDateAndParams nulldate "" "" ""
viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData
viewdataWithDateAndParams d q a p =
let (querymatcher,queryopts) = parseQuery d q
(acctsmatcher,acctsopts) = parseQuery d a
in VD {
opts = defwebopts
,j = nulljournal
,here = RootR
,msg = Nothing
,today = d
,q = q
,m = querymatcher
,qopts = queryopts
,am = acctsmatcher
,aopts = acctsopts
,showpostings = p == "1"
,showsidebar = False
}
getViewData :: Handler ViewData
getViewData = do
app <- getYesod
let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app
(j, merr) <- getCurrentJournal app copts{reportopts_=ropts{no_elide_=True}}
lastmsg <- getLastMessage
let msg = maybe lastmsg (Just . toHtml) merr
Just here <- getCurrentRoute
today <- liftIO getCurrentDay
q <- getParameterOrNull "q"
a <- getParameterOrNull "a"
p <- getParameterOrNull "p"
sidebarparam <- lookupGetParam (pack "sidebar")
cookies <- reqCookies <$> getRequest
let sidebarcookie = lookup "showsidebar" cookies
let showsidebar = maybe (sidebarcookie == Just "1") (=="1") sidebarparam
return (viewdataWithDateAndParams today q a p){
opts=opts
,msg=msg
,here=here
,today=today
,j=j
,showsidebar=showsidebar
}
where
getCurrentJournal :: App -> CliOpts -> Handler (Journal, Maybe String)
getCurrentJournal app opts = do
j <- liftIO $ readIORef $ appJournal app
(jE, changed) <- liftIO $ journalReloadIfChanged opts j
if not changed
then return (j,Nothing)
else case jE of
Right j' -> do liftIO $ writeIORef (appJournal app) j'
return (j',Nothing)
Left e -> do setMessage $ "error while reading"
return (j, Just e)
getParameterOrNull :: String -> Handler String
getParameterOrNull p = unpack `fmap` fromMaybe "" <$> lookupGetParam (pack p)
getLastMessage :: Handler (Maybe Html)
getLastMessage = cached getMessage
addform :: Text -> ViewData -> HtmlUrl AppRoute
addform _ vd@VD{..} = [hamlet|
<script language="javascript">
jQuery(document).ready(function() {
/* set up typeahead fields */
datesSuggester = new Bloodhound({
local:#{listToJsonValueObjArrayStr dates},
limit:100,
datumTokenizer: function(d) { return [d.value]; },
queryTokenizer: function(q) { return [q]; }
});
datesSuggester.initialize();
descriptionsSuggester = new Bloodhound({
local:#{listToJsonValueObjArrayStr descriptions},
limit:100,
datumTokenizer: function(d) { return [d.value]; },
queryTokenizer: function(q) { return [q]; }
});
descriptionsSuggester.initialize();
accountsSuggester = new Bloodhound({
local:#{listToJsonValueObjArrayStr accts},
limit:100,
datumTokenizer: function(d) { return [d.value]; },
queryTokenizer: function(q) { return [q]; }
/*
datumTokenizer: Bloodhound.tokenizers.obj.whitespace('value'),
datumTokenizer: Bloodhound.tokenizers.whitespace(d.value)
queryTokenizer: Bloodhound.tokenizers.whitespace
*/
});
accountsSuggester.initialize();
enableTypeahead(jQuery('input#date'), datesSuggester);
enableTypeahead(jQuery('input#description'), descriptionsSuggester);
enableTypeahead(jQuery('input#account1, input#account2, input#account3, input#account4'), accountsSuggester);
});
<form#addform method=POST style="position:relative;">
<table.form style="width:100%; white-space:nowrap;">
<tr>
<td colspan=4>
<table style="width:100%;">
<tr#descriptionrow>
<td>
<input #date .typeahead .formcontrol .inputlg type=text size=15 name=date placeholder="Date" value=#{defdate}>
<td>
<input #description .typeahead .formcontrol .inputlg type=text size=40 name=description placeholder="Description">
$forall n <- postingnums
^{postingfields vd n}
<span style="padding-left:2em;">
<span .small>
Tab in last field for <a .small href="#" onclick="addformAddPosting(); return false;">more</a> (or ctrl +, ctrl )
|]
where
defdate = "today" :: String
dates = ["today","yesterday","tomorrow"] :: [String]
descriptions = sort $ nub $ map tdescription $ jtxns j
accts = sort $ journalAccountNamesUsed j
escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>"
listToJsonValueObjArrayStr as = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as
numpostings = 4
postingnums = [1..numpostings]
postingfields :: ViewData -> Int -> HtmlUrl AppRoute
postingfields _ n = [hamlet|
<tr .posting>
<td style="padding-left:2em;">
<input ##{acctvar} .accountinput .typeahead .formcontrol .inputlg style="width:100%;" type=text name=#{acctvar} placeholder="#{acctph}">
^{amtfieldorsubmitbtn}
|]
where
islast = n == numpostings
acctvar = "account" ++ show n
acctph = "Account " ++ show n
amtfieldorsubmitbtn
| not islast = [hamlet|
<td>
<input ##{amtvar} .amountinput .formcontrol .inputlg type=text size=10 name=#{amtvar} placeholder="#{amtph}">
|]
| otherwise = [hamlet|
<td #addbtncell style="text-align:right;">
<button type=submit .btn .btnlg name=submit>add
$if length filepaths > 1
<br>
<span class="input-lg">to:
^{journalselect filepaths}
|]
where
amtvar = "amount" ++ show n
amtph = "Amount " ++ show n
filepaths = map fst $ files j
journalselect :: [FilePath] -> HtmlUrl AppRoute
journalselect journalfilepaths = [hamlet|
<select id=journalselect name=journal onchange="/*journalSelect(event)*/" class="form-control input-lg" style="width:auto; display:inline-block;">
$forall p <- journalfilepaths
<option value=#{p}>#{p}
|]
journalradio :: [FilePath] -> HtmlUrl AppRoute
journalradio journalfilepaths = [hamlet|
$forall p <- journalfilepaths
<div style="white-space:nowrap;">
<span class="input-lg" style="position:relative; top:-8px; left:8px;">#{p}
<input name=journal type=radio value=#{p} class="form-control" style="width:auto; display:inline;">
|]