{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Hledger.Web.Foundation where
import Control.Applicative ((<|>))
import Control.Monad (join, when)
import qualified Data.ByteString.Char8 as BC
import Data.Traversable (for)
import Data.IORef (IORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Network.HTTP.Conduit (Manager)
import Network.HTTP.Types (status403)
import Network.Wai (requestHeaders)
import System.Directory (XdgDirectory (..), createDirectoryIfMissing,
getXdgDirectory)
import System.FilePath (takeFileName, (</>))
import Text.Blaze (Markup)
import Text.Hamlet (hamletFile)
import Yesod
import Yesod.Static
import Yesod.Default.Config
#ifndef DEVELOPMENT
import Hledger.Web.Settings (staticDir)
import Text.Jasmine (minifym)
import Yesod.Default.Util (addStaticContentExternal)
#endif
import Hledger
import Hledger.Cli (CliOpts(..), journalReloadIfChanged)
import Hledger.Web.Settings (Extra(..), widgetFile)
import Hledger.Web.Settings.StaticFiles
import Hledger.Web.WebOptions
import Hledger.Web.Widget.Common (balanceReportAsHtml)
data App = App
{ App -> AppConfig DefaultEnv Extra
settings :: AppConfig DefaultEnv Extra
, App -> Static
getStatic :: Static
, App -> Manager
httpManager :: Manager
, App -> WebOpts
appOpts :: WebOpts
, App -> IORef Journal
appJournal :: IORef Journal
}
mkYesodData "App" $(parseRoutesFile "config/routes")
type AppRoute = Route App
type Form a = Html -> MForm Handler (FormResult a, Widget)
instance Yesod App where
approot :: Approot App
approot = forall master. (master -> Text) -> Approot master
ApprootMaster forall a b. (a -> b) -> a -> b
$ forall environment extra. AppConfig environment extra -> Text
appRoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. App -> AppConfig DefaultEnv Extra
settings
makeSessionBackend :: App -> IO (Maybe SessionBackend)
makeSessionBackend App
_ = do
String
hledgerdata <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgCache String
"hledger"
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
hledgerdata
let sessionexpirysecs :: Int
sessionexpirysecs = Int
120
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> String -> IO SessionBackend
defaultClientSessionBackend Int
sessionexpirysecs (String
hledgerdata String -> ShowS
</> String
"hledger-web_client_session_key.aes")
defaultLayout :: WidgetFor App () -> HandlerFor App Markup
defaultLayout WidgetFor App ()
widget = do
Handler ()
checkServerSideUiEnabled
App
master <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
Route App
here <- forall a. a -> Maybe a -> a
fromMaybe Route App
RootR forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
VD {[Capability]
caps :: ViewData -> [Capability]
caps :: [Capability]
caps, Journal
j :: ViewData -> Journal
j :: Journal
j, Query
m :: ViewData -> Query
m :: Query
m, WebOpts
opts :: ViewData -> WebOpts
opts :: WebOpts
opts, Text
q :: ViewData -> Text
q :: Text
q, [QueryOpt]
qopts :: ViewData -> [QueryOpt]
qopts :: [QueryOpt]
qopts} <- Handler ViewData
getViewData
Maybe Markup
msg <- forall (m :: * -> *). MonadHandler m => m (Maybe Markup)
getMessage
Bool
showSidebar <- HandlerFor App Bool
shouldShowSidebar
let rspec :: ReportSpec
rspec = CliOpts -> ReportSpec
reportspec_ (WebOpts -> CliOpts
cliopts_ WebOpts
opts)
ropts :: ReportOpts
ropts = ReportSpec -> ReportOpts
_rsReportOpts ReportSpec
rspec
ropts' :: ReportOpts
ropts' = (ReportSpec -> ReportOpts
_rsReportOpts ReportSpec
rspec)
{accountlistmode_ :: AccountListMode
accountlistmode_ = AccountListMode
ALTree
,empty_ :: Bool
empty_ = Bool
True
}
rspec' :: ReportSpec
rspec' = ReportSpec
rspec{_rsQuery :: Query
_rsQuery=Query
m,_rsReportOpts :: ReportOpts
_rsReportOpts=ReportOpts
ropts'}
Bool
hideEmptyAccts <- if ReportOpts -> Bool
empty_ ReportOpts
ropts
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"1") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"hideemptyaccts" forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodRequest -> [(Text, Text)]
reqCookies forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
let accounts :: HtmlUrl (Route App)
accounts =
forall r.
Eq r =>
(r, r)
-> r
-> Bool
-> Journal
-> Text
-> [QueryOpt]
-> BalanceReport
-> HtmlUrl r
balanceReportAsHtml (Route App
JournalR, Route App
RegisterR) Route App
here Bool
hideEmptyAccts Journal
j Text
q [QueryOpt]
qopts forall a b. (a -> b) -> a -> b
$
ReportSpec -> Journal -> BalanceReport
balanceReport ReportSpec
rspec' Journal
j
topShowmd :: Text
topShowmd = if Bool
showSidebar then Text
"col-md-4" else Text
"col-any-0" :: Text
topShowsm :: Text
topShowsm = if Bool
showSidebar then Text
"col-sm-4" else Text
"" :: Text
sideShowmd :: Text
sideShowmd = if Bool
showSidebar then Text
"col-md-4" else Text
"col-any-0" :: Text
sideShowsm :: Text
sideShowsm = if Bool
showSidebar then Text
"col-sm-4" else Text
"" :: Text
mainShowmd :: Text
mainShowmd = if Bool
showSidebar then Text
"col-md-8" else Text
"col-md-12" :: Text
mainShowsm :: Text
mainShowsm = if Bool
showSidebar then Text
"col-sm-8" else Text
"col-sm-12" :: Text
PageContent (Route App)
pc <- forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
css_bootstrap_min_css
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
css_bootstrap_datepicker_standalone_min_css
forall site a (m :: * -> *).
(ToWidgetHead site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidgetHead [hamlet|
<script type="text/javascript" src="@{StaticR js_jquery_min_js}">
<script type="text/javascript" src="@{StaticR js_typeahead_bundle_min_js}">
|]
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_bootstrap_min_js
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_bootstrap_datepicker_min_js
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_url_js
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_cookie_js
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_hotkeys_js
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_flot_min_js
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_flot_selection_min_js
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_flot_time_min_js
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_flot_tooltip_min_js
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet| \<!--[if lte IE 8]> <script type="text/javascript" src="@{StaticR js_excanvas_min_js}"></script> <![endif]--> |]
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
hledger_css
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
hledger_js
$(widgetFile "default-layout")
forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
#ifndef DEVELOPMENT
addStaticContent :: Text
-> Text
-> ByteString
-> HandlerFor App (Maybe (Either Text (Route App, [(Text, Text)])))
addStaticContent = forall a master.
(ByteString -> Either a ByteString)
-> (ByteString -> String)
-> String
-> ([Text] -> Route master)
-> Text
-> Text
-> ByteString
-> HandlerFor
master (Maybe (Either Text (Route master, [(Text, Text)])))
addStaticContentExternal ByteString -> Either String ByteString
minifym ByteString -> String
base64md5 String
staticDir (Route Static -> Route App
StaticR forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip [Text] -> [(Text, Text)] -> Route Static
StaticRoute [])
#endif
instance RenderMessage App FormMessage where
renderMessage :: App -> [Text] -> FormMessage -> Text
renderMessage App
_ [Text]
_ = FormMessage -> Text
defaultFormMessage
data ViewData = VD
{ ViewData -> WebOpts
opts :: WebOpts
, ViewData -> Day
today :: Day
, ViewData -> Journal
j :: Journal
, ViewData -> Text
q :: Text
, ViewData -> Query
m :: Query
, ViewData -> [QueryOpt]
qopts :: [QueryOpt]
, ViewData -> [Capability]
caps :: [Capability]
} deriving (Int -> ViewData -> ShowS
[ViewData] -> ShowS
ViewData -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ViewData] -> ShowS
$cshowList :: [ViewData] -> ShowS
show :: ViewData -> String
$cshow :: ViewData -> String
showsPrec :: Int -> ViewData -> ShowS
$cshowsPrec :: Int -> ViewData -> ShowS
Show)
instance Show Text.Blaze.Markup where show :: Markup -> String
show Markup
_ = String
"<blaze markup>"
getViewData :: Handler ViewData
getViewData :: Handler ViewData
getViewData = do
App{appOpts :: App -> WebOpts
appOpts=opts :: WebOpts
opts@WebOpts{cliopts_ :: WebOpts -> CliOpts
cliopts_=copts :: CliOpts
copts@CliOpts{reportspec_ :: CliOpts -> ReportSpec
reportspec_=rspec :: ReportSpec
rspec@ReportSpec{ReportOpts
_rsReportOpts :: ReportOpts
_rsReportOpts :: ReportSpec -> ReportOpts
_rsReportOpts}}}, IORef Journal
appJournal :: IORef Journal
appJournal :: App -> IORef Journal
appJournal} <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
let today :: Day
today = ReportSpec -> Day
_rsDay ReportSpec
rspec
(Journal
j, Maybe String
mjerr) <- IORef Journal -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal
IORef Journal
appJournal
CliOpts
copts{reportspec_ :: ReportSpec
reportspec_=ReportSpec
rspec{_rsReportOpts :: ReportOpts
_rsReportOpts=ReportOpts
_rsReportOpts{no_elide_ :: Bool
no_elide_=Bool
True}}}
Day
today
Text
q <- forall a. a -> Maybe a -> a
fromMaybe Text
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"q"
(Query
m, [QueryOpt]
qopts, Maybe String
mqerr) <- do
case Day -> Text -> Either String (Query, [QueryOpt])
parseQuery Day
today Text
q of
Right (Query
m, [QueryOpt]
qopts) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Query
m, [QueryOpt]
qopts, forall a. Maybe a
Nothing)
Left String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (Query
Any, [], forall a. a -> Maybe a
Just String
err)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall (m :: * -> *). MonadHandler m => Markup -> m ()
setMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMarkup a => a -> Markup
toHtml) forall a b. (a -> b) -> a -> b
$ Maybe String
mjerr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
mqerr
[Capability]
caps <- case WebOpts -> Maybe (CI ByteString)
capabilitiesHeader_ WebOpts
opts of
Maybe (CI ByteString)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (WebOpts -> [Capability]
capabilities_ WebOpts
opts)
Just CI ByteString
h -> do
[[ByteString]]
hs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> ByteString -> [ByteString]
BC.split Char
',' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== CI ByteString
h) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(CI ByteString, ByteString)]
requestHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m Request
waiRequest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[ByteString]]
hs) forall a b. (a -> b) -> a -> b
$ \ByteString
x -> case ByteString -> Either ByteString Capability
capabilityFromBS ByteString
x of
Left ByteString
e -> [] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). MonadHandler m => Text -> Markup -> m ()
addMessage Text
"" (Markup
"Unknown permission: " forall a. Semigroup a => a -> a -> a
<> forall a. ToMarkup a => a -> Markup
toHtml (ByteString -> String
BC.unpack ByteString
e))
Right Capability
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Capability
c]
forall (m :: * -> *) a. Monad m => a -> m a
return VD{WebOpts
opts :: WebOpts
opts :: WebOpts
opts, Day
today :: Day
today :: Day
today, Journal
j :: Journal
j :: Journal
j, Text
q :: Text
q :: Text
q, Query
m :: Query
m :: Query
m, [QueryOpt]
qopts :: [QueryOpt]
qopts :: [QueryOpt]
qopts, [Capability]
caps :: [Capability]
caps :: [Capability]
caps}
checkServerSideUiEnabled :: Handler ()
checkServerSideUiEnabled :: Handler ()
checkServerSideUiEnabled = do
VD{opts :: ViewData -> WebOpts
opts=WebOpts{Bool
serve_api_ :: WebOpts -> Bool
serve_api_ :: Bool
serve_api_}} <- Handler ViewData
getViewData
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
serve_api_ forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
status403 (Text
"server-side UI is disabled due to --serve-api" :: Text)
shouldShowSidebar :: Handler Bool
= do
Maybe Text
msidebarparam <- forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"sidebar"
Maybe Text
msidebarcookie <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"showsidebar" forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodRequest -> [(Text, Text)]
reqCookies forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
let disablevalues :: [Text]
disablevalues = [Text
"",Text
"0"]
in forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
disablevalues) forall a b. (a -> b) -> a -> b
$ Maybe Text
msidebarparam forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
msidebarcookie
getCurrentJournal :: IORef Journal -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal :: IORef Journal -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal IORef Journal
jref CliOpts
opts Day
d = do
let initq :: Query
initq = ReportSpec -> Query
_rsQuery forall a b. (a -> b) -> a -> b
$ CliOpts -> ReportSpec
reportspec_ CliOpts
opts
Journal
j <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef Journal
jref)
Either String (Journal, Bool)
ej <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ CliOpts -> Day -> Journal -> ExceptT String IO (Journal, Bool)
journalReloadIfChanged CliOpts
opts Day
d Journal
j
case Either String (Journal, Bool)
ej of
Left String
e -> do
forall (m :: * -> *). MonadHandler m => Markup -> m ()
setMessage Markup
"error while reading journal"
forall (m :: * -> *) a. Monad m => a -> m a
return (Journal
j, forall a. a -> Maybe a
Just String
e)
Right (Journal
j', Bool
True) -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> a -> IO ()
writeIORef IORef Journal
jref forall a b. (a -> b) -> a -> b
$ Query -> Journal -> Journal
filterJournalTransactions Query
initq Journal
j'
forall (m :: * -> *) a. Monad m => a -> m a
return (Journal
j',forall a. Maybe a
Nothing)
Right (Journal
_, Bool
False) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Journal
j, forall a. Maybe a
Nothing)