{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
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.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.WebOptions
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, Markup)
#else
import Text.Blaze (Markup)
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
#if MIN_VERSION_yesod(1,6,0)
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
#else
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
#endif
instance Yesod App where
approot = ApprootMaster $ appRoot . settings
makeSessionBackend _ = return Nothing
defaultLayout widget = do
master <- getYesod
lastmsg <- getMessage
vd@VD{..} <- getViewData
pc <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_min_css
addStylesheet $ StaticR css_bootstrap_datepicker_standalone_min_css
toWidgetHead [hamlet|
<script type="text/javascript" src="@{StaticR js_jquery_min_js}">
<script type="text/javascript" src="@{StaticR js_typeahead_bundle_min_js}">
|]
addScript $ StaticR js_bootstrap_min_js
addScript $ StaticR js_bootstrap_datepicker_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")
urlParamRenderOverride _ _ _ = Nothing
#ifndef DEVELOPMENT
addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
#endif
jsLoader _ = BottomOfBody
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
} deriving (Show)
instance Show Text.Blaze.Markup where show _ = "<blaze markup>"
nullviewdata :: ViewData
nullviewdata = viewdataWithDateAndParams nulldate "" "" ""
viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData
viewdataWithDateAndParams d q a p =
let (querymatcher,queryopts) = parseQuery d (pack q)
(acctsmatcher,acctsopts) = parseQuery d (pack 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 = True
}
getViewData :: Handler ViewData
getViewData = do
mhere <- getCurrentRoute
case mhere of
Nothing -> return nullviewdata
Just here -> do
app <- getYesod
let opts@WebOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} = appOpts app
today <- liftIO getCurrentDay
(j, merr) <- getCurrentJournal app copts{reportopts_=ropts{no_elide_=True}} today
lastmsg <- getLastMessage
let msg = maybe lastmsg (Just . toHtml) merr
q <- getParameterOrNull "q"
a <- getParameterOrNull "a"
p <- getParameterOrNull "p"
msidebarparam <- lookupGetParam "sidebar"
msidebarcookie <- reqCookies <$> getRequest >>= return . lookup "showsidebar"
let showsidebar = maybe (msidebarcookie /= Just "0") (/="0") msidebarparam
return (viewdataWithDateAndParams today q a p){
opts=opts
,msg=msg
,here=here
,today=today
,j=j
,showsidebar=showsidebar
}
where
getCurrentJournal :: App -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal app opts d = do
j <- liftIO $ readIORef $ appJournal app
(ej, changed) <- liftIO $ journalReloadIfChanged opts d j
let initq = queryFromOpts d $ reportopts_ opts
ej' = filterJournalTransactions initq <$> ej
if not changed
then return (j,Nothing)
else case ej' 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>
jQuery(document).ready(function() {
/* set up typeahead fields */
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#description'), descriptionsSuggester);
enableTypeahead(jQuery('input#account1, input#account2, input#account3, input#account4'), accountsSuggester);
});
<form#addform method=POST .form>
<div .form-group>
<div .row>
<div .col-md-3 .col-xs-6 .col-sm-6>
<div #dateWrap .input-group .date>
<input #date required lang=en name=date .form-control .input-lg placeholder="Date" >
<div .input-group-addon>
<span .glyphicon .glyphicon-th>
<div .col-md-9 .col-xs-6 .col-sm-6>
<input #description required .typeahead .form-control .input-lg type=text size=40 name=description placeholder="Description">
<div .account-postings>
$forall n <- postingnums
^{postingfields vd n}
<div .col-md-8 .col-xs-8 .col-sm-8>
<div .col-md-4 .col-xs-4 .col-sm-4>
<button type=submit .btn .btn-default .btn-lg name=submit>add
$if length filepaths > 1
<br>
<span class="input-lg">to:
^{journalselect filepaths}
<span style="padding-left:2em;">
<span .small>
Enter a value in the last field for
<a href="#" onclick="addformAddPosting(); return false;">more
(or ctrl +, ctrl -)
|]
where
descriptions = sort $ nub $ map tdescription $ jtxns j
accts = journalAccountNamesDeclaredOrImplied j
escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>"
listToJsonValueObjArrayStr as = preEscapedString $ escapeJSSpecialChars $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("value", showJSON a)]) as
numpostings = 4
postingnums = [1..numpostings]
filepaths = map fst $ jfiles j
postingfields :: ViewData -> Int -> HtmlUrl AppRoute
postingfields _ n = [hamlet|
<div .form-group .row .account-group ##{grpvar}>
<div .col-md-8 .col-xs-8 .col-sm-8>
<input ##{acctvar} .account-input .typeahead .form-control .input-lg type=text name=#{acctvar} placeholder="#{acctph}">
<div .col-md-4 .col-xs-4 .col-sm-4>
<input ##{amtvar} .amount-input .form-control .input-lg type=text name=#{amtvar} placeholder="#{amtph}">
|]
where
acctvar = "account" ++ show n
acctph = "Account " ++ show n
amtvar = "amount" ++ show n
amtph = "Amount " ++ show n
grpvar = "grp" ++ show n
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;">
|]