{-|
Most of the definition of the web app is here.
In the usual Yesod style, this defines the web app's core types and configuration,
and then Application.hs completes the job.
-}

{-# 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.App where

import Control.Applicative ((<|>))
import Control.Monad (join, when, unless)
-- import Control.Monad.Except (runExceptT)  -- now re-exported by Hledger
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)
import Data.List (isPrefixOf)

-- | 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
    { App -> AppConfig DefaultEnv Extra
settings :: AppConfig DefaultEnv Extra
    , App -> Static
getStatic :: Static -- ^ Settings for static file serving.
    , App -> Manager
httpManager :: Manager
      --
    , App -> WebOpts
appOpts    :: WebOpts
    , App -> IORef Journal
appJournal :: IORef Journal
        -- ^ the current journal, filtered by the initial command line query
        --   but ignoring any depth limit.
    }


-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/handler
--
-- This function does three things:
--
-- * Creates the route datatype AppRoute. Every valid URL in your
--   application can be represented as a value of this type.
-- * 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 Handler.hs by the call to
--   mkYesodDispatch
--
-- What this function does *not* do is create a YesodSite instance for App.
-- AppCreating that instance requires all of the handler functions
-- for our application to be in scope. However, the handler functions
-- usually require access to the AppRoute datatype. Therefore, we
-- split these actions into two functions and place the other in a
-- separate file (Application.hs).
-- mkYesodData defines things like:
--
-- * type Handler = HandlerFor App   -- HandlerT App IO, https://www.yesodweb.com/book/routing-and-handlers#routing-and-handlers_handler_monad
-- * type Widget = WidgetFor App ()  -- WidgetT App IO (), https://www.yesodweb.com/book/widgets
--
mkYesodData "App" $(parseRoutesFile "config/routes")

type AppRoute = Route App
type Form a = Html -> MForm Handler (FormResult a, Widget)

-- 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

  -- Configure the app root, AKA base url, which is prepended to relative hyperlinks.
  -- 1. when a --base-url was specified, use that
  -- 2. otherwise, guess it from request headers, which helps us respond from the same hostname/IP address when accessible via multiple IPs
  -- 3. otherwise, leave it empty (relative links stay relative).
  -- Past issues: #2099, #2100, #2127, #hledger-2024-07-18
  approot :: Approot App
approot
    | Bool
hasbaseurl = (App -> Text) -> Approot App
forall master. (master -> Text) -> Approot master
ApprootMaster (String -> Text
T.pack (String -> Text) -> (App -> String) -> App -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebOpts -> String
base_url_ (WebOpts -> String) -> (App -> WebOpts) -> App -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App -> WebOpts
appOpts)
    | Bool
otherwise  = Approot App -> Approot App
forall site. Approot site -> Approot site
guessApprootOr ((App -> Text) -> Approot App
forall master. (master -> Text) -> Approot master
ApprootMaster (AppConfig DefaultEnv Extra -> Text
forall environment extra. AppConfig environment extra -> Text
appRoot (AppConfig DefaultEnv Extra -> Text)
-> (App -> AppConfig DefaultEnv Extra) -> App -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App -> AppConfig DefaultEnv Extra
settings))
    where
      hasbaseurl :: Bool
hasbaseurl = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
"--base-url" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
progArgs
        -- needs unsafePerformIO; does not detect abbreviations like --base

  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
    SessionBackend -> Maybe SessionBackend
forall a. a -> Maybe a
Just (SessionBackend -> Maybe SessionBackend)
-> IO SessionBackend -> IO (Maybe SessionBackend)
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 site () -> HandlerFor site Html
  defaultLayout :: WidgetFor App () -> HandlerFor App Html
defaultLayout WidgetFor App ()
widget = do

    -- Don't run if server-side UI is disabled.
    -- This single check probably covers all the HTML-returning handlers,
    -- but for now they do the check as well.
    Handler ()
checkServerSideUiEnabled

    App
master <- HandlerFor App (HandlerSite (HandlerFor App))
HandlerFor App App
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Route App
here <- Route App -> Maybe (Route App) -> Route App
forall a. a -> Maybe a -> a
fromMaybe Route App
RootR (Maybe (Route App) -> Route App)
-> HandlerFor App (Maybe (Route App)) -> HandlerFor App (Route App)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor App (Maybe (Route (HandlerSite (HandlerFor App))))
HandlerFor App (Maybe (Route App))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
    VD{WebOpts
opts :: WebOpts
opts :: ViewData -> WebOpts
opts, Journal
j :: Journal
j :: ViewData -> Journal
j, Text
qparam :: Text
qparam :: ViewData -> Text
qparam, Query
q :: Query
q :: ViewData -> Query
q, [QueryOpt]
qopts :: [QueryOpt]
qopts :: ViewData -> [QueryOpt]
qopts, [Permission]
perms :: [Permission]
perms :: ViewData -> [Permission]
perms} <- Handler ViewData
getViewData
    Maybe Html
msg <- HandlerFor App (Maybe Html)
forall (m :: * -> *). MonadHandler m => m (Maybe Html)
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_ = ALTree  -- force tree mode for sidebar
          ,empty_           = True    -- show zero items by default
          }
        rspec' :: ReportSpec
rspec' = ReportSpec
rspec{_rsQuery=q,_rsReportOpts=ropts'}

    Bool
hideEmptyAccts <- if ReportOpts -> Bool
empty_ ReportOpts
ropts
                         then Bool -> HandlerFor App Bool
forall a. a -> HandlerFor App a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         else (Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"1") (Maybe Text -> Bool)
-> (YesodRequest -> Maybe Text) -> YesodRequest -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"hideemptyaccts" ([(Text, Text)] -> Maybe Text)
-> (YesodRequest -> [(Text, Text)]) -> YesodRequest -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodRequest -> [(Text, Text)]
reqCookies (YesodRequest -> Bool)
-> HandlerFor App YesodRequest -> HandlerFor App Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor App YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest

    let accounts :: HtmlUrl (Route App)
accounts =
          (Route App, Route App)
-> Route App
-> Bool
-> Journal
-> Text
-> [QueryOpt]
-> BalanceReport
-> HtmlUrl (Route App)
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
qparam [QueryOpt]
qopts (BalanceReport -> HtmlUrl (Route App))
-> BalanceReport -> HtmlUrl (Route App)
forall a b. (a -> b) -> a -> b
$
          Map Text AmountStyle -> BalanceReport -> BalanceReport
forall a. HasAmounts a => Map Text AmountStyle -> a -> a
styleAmounts (Rounding -> Journal -> Map Text AmountStyle
journalCommodityStylesWith Rounding
HardRounding Journal
j) (BalanceReport -> BalanceReport) -> BalanceReport -> BalanceReport
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

    -- 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
    -- value passed to hamletToRepHtml cannot be a widget, this allows
    -- you to use normal widget features in default-layout.
    PageContent (Route App)
pc <- WidgetFor App () -> HandlerFor App (PageContent (Route App))
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent (WidgetFor App () -> HandlerFor App (PageContent (Route App)))
-> WidgetFor App () -> HandlerFor App (PageContent (Route App))
forall a b. (a -> b) -> a -> b
$ do
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
css_bootstrap_min_css
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
css_bootstrap_datepicker_standalone_min_css
      -- load these things early, in HEAD:
      HtmlUrl (Route App) -> WidgetFor App ()
forall site a (m :: * -> *).
(ToWidgetHead site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ App) =>
HtmlUrl (Route App) -> m ()
toWidgetHead HtmlUrl (Route App)
[hamlet|
        <script type="text/javascript" src="@{StaticR js_jquery_min_js}">
        <script type="text/javascript" src="@{StaticR js_typeahead_bundle_min_js}">
      |]
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_bootstrap_min_js
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_bootstrap_datepicker_min_js
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_url_js
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_cookie_js
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_hotkeys_js
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_flot_min_js
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_flot_selection_min_js
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_flot_time_min_js
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
js_jquery_flot_tooltip_min_js
      HtmlUrl (Route App) -> WidgetFor App ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ App) =>
HtmlUrl (Route App) -> m ()
toWidget HtmlUrl (Route App)
[hamlet| \<!--[if lte IE 8]> <script type="text/javascript" src="@{StaticR js_excanvas_min_js}"></script> <![endif]--> |]
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addStylesheet (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
hledger_css
      Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript (Route (HandlerSite (WidgetFor App)) -> WidgetFor App ())
-> Route (HandlerSite (WidgetFor App)) -> WidgetFor App ()
forall a b. (a -> b) -> a -> b
$ Route Static -> Route App
StaticR Route Static
hledger_js
      $(widgetFile "default-layout")

    ((Route (HandlerSite (HandlerFor App)) -> [(Text, Text)] -> Text)
 -> Html)
-> HandlerFor App Html
forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")

-- XXX why disabled during development ? Affects ghci, ghcid, tests, #2139 ?
#ifndef DEVELOPMENT
  -- 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 :: Text
-> Text
-> ByteString
-> HandlerFor App (Maybe (Either Text (Route App, [(Text, Text)])))
addStaticContent = (ByteString -> Either String ByteString)
-> (ByteString -> String)
-> String
-> ([Text] -> Route App)
-> Text
-> Text
-> ByteString
-> HandlerFor App (Maybe (Either Text (Route App, [(Text, Text)])))
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 (Route Static -> Route App)
-> ([Text] -> Route Static) -> [Text] -> Route App
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> [(Text, Text)] -> Route Static)
-> [(Text, Text)] -> [Text] -> Route Static
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Text] -> [(Text, Text)] -> Route Static
StaticRoute [])
#endif

-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
    renderMessage :: App -> [Text] -> FormMessage -> Text
renderMessage App
_ [Text]
_ = FormMessage -> Text
defaultFormMessage


----------------------------------------------------------------------
-- template and handler utilities

-- view data, used by the add form and handlers
-- XXX Parameter p - show/hide postings

-- | A bundle of data useful for hledger-web request handlers and templates.
data ViewData = VD
  { ViewData -> WebOpts
opts  :: WebOpts    -- ^ the command-line options at startup
  , ViewData -> Day
today :: Day        -- ^ today's date (for queries containing relative dates)
  , ViewData -> Journal
j     :: Journal    -- ^ the up-to-date parsed unfiltered journal    -- XXX rename
  , ViewData -> Text
qparam :: Text       -- ^ the current "q" request parameter
  , ViewData -> Query
q     :: Query      -- ^ a query parsed from the q parameter
  , ViewData -> [QueryOpt]
qopts :: [QueryOpt] -- ^ query options parsed from the q parameter
  , ViewData -> [Permission]
perms :: [Permission]  -- ^ permissions enabled for this request (by --allow and/or X-Sandstorm-Permissions)
  } deriving (Int -> ViewData -> ShowS
[ViewData] -> ShowS
ViewData -> String
(Int -> ViewData -> ShowS)
-> (ViewData -> String) -> ([ViewData] -> ShowS) -> Show ViewData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ViewData -> ShowS
showsPrec :: Int -> ViewData -> ShowS
$cshow :: ViewData -> String
show :: ViewData -> String
$cshowList :: [ViewData] -> ShowS
showList :: [ViewData] -> ShowS
Show)

instance Show Text.Blaze.Markup where show :: Html -> String
show Html
_ = String
"<blaze markup>"

-- | Gather data used by handlers and templates in the current request.
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 :: ReportSpec -> ReportOpts
_rsReportOpts :: ReportOpts
_rsReportOpts, Query
_rsQuery :: ReportSpec -> Query
_rsQuery :: Query
_rsQuery} } },
    IORef Journal
appJournal :: App -> IORef Journal
appJournal :: IORef Journal
appJournal
  } <- HandlerFor App (HandlerSite (HandlerFor App))
HandlerFor App App
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
  let today :: Day
today = ReportSpec -> Day
_rsDay ReportSpec
rspec

  -- try to read the latest journal content, keeping the old content
  -- if there's an error
  (Journal
j, Maybe String
mjerr) <- IORef Journal -> CliOpts -> Day -> Handler (Journal, Maybe String)
getCurrentJournal
                IORef Journal
appJournal
                CliOpts
copts{reportspec_=rspec{_rsReportOpts=_rsReportOpts{no_elide_=True}}}
                Day
today

  -- Get the query specified by the q request parameter, or no query if this fails.
  Text
qparam <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text)
-> HandlerFor App (Maybe Text) -> HandlerFor App Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HandlerFor App (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"q"
  (Query
q1, [QueryOpt]
qopts, Maybe String
mqerr) <- do
    case Day -> Text -> Either String (Query, [QueryOpt])
parseQuery Day
today Text
qparam of
      Right (Query
q0, [QueryOpt]
qopts) -> (Query, [QueryOpt], Maybe String)
-> HandlerFor App (Query, [QueryOpt], Maybe String)
forall a. a -> HandlerFor App a
forall (m :: * -> *) a. Monad m => a -> m a
return (Query
q0, [QueryOpt]
qopts, Maybe String
forall a. Maybe a
Nothing)
      Left String
err         -> (Query, [QueryOpt], Maybe String)
-> HandlerFor App (Query, [QueryOpt], Maybe String)
forall a. a -> HandlerFor App a
forall (m :: * -> *) a. Monad m => a -> m a
return (Query
Any, [], String -> Maybe String
forall a. a -> Maybe a
Just String
err)
  -- To this, add any depth limit from the initial startup query, preserving that.
  let
    initialdepthq :: Query
initialdepthq = (Query -> Bool) -> Query -> Query
filterQuery Query -> Bool
queryIsDepth Query
_rsQuery
    q :: Query
q = Query -> Query
simplifyQuery (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$ [Query] -> Query
And [Query
q1, Query
initialdepthq]

  -- if either of the above gave an error, display it
  Handler () -> (String -> Handler ()) -> Maybe String -> Handler ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Handler ()
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Html -> Handler ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage (Html -> Handler ()) -> (String -> Html) -> String -> Handler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
forall a. ToMarkup a => a -> Html
toHtml) (Maybe String -> Handler ()) -> Maybe String -> Handler ()
forall a b. (a -> b) -> a -> b
$ Maybe String
mjerr Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
mqerr

  -- find out which permissions are enabled
  [Permission]
perms <- case WebOpts -> AccessLevel
allow_ WebOpts
opts of
    -- if started with --allow=sandstorm, take permissions from X-Sandstorm-Permissions header
    AccessLevel
SandstormAccess -> do
      let h :: HeaderName
h = HeaderName
"X-Sandstorm-Permissions"
      [[ByteString]]
hs <- ((HeaderName, ByteString) -> [ByteString])
-> [(HeaderName, ByteString)] -> [[ByteString]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> ByteString -> [ByteString]
BC.split Char
',' (ByteString -> [ByteString])
-> ((HeaderName, ByteString) -> ByteString)
-> (HeaderName, ByteString)
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) ([(HeaderName, ByteString)] -> [[ByteString]])
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> [[ByteString]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
h) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> [(HeaderName, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
requestHeaders (Request -> [[ByteString]])
-> HandlerFor App Request -> HandlerFor App [[ByteString]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor App Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
      ([[Permission]] -> [Permission])
-> HandlerFor App [[Permission]] -> HandlerFor App [Permission]
forall a b. (a -> b) -> HandlerFor App a -> HandlerFor App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Permission]] -> [Permission]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (HandlerFor App [[Permission]] -> HandlerFor App [Permission])
-> ((ByteString -> HandlerFor App [Permission])
    -> HandlerFor App [[Permission]])
-> (ByteString -> HandlerFor App [Permission])
-> HandlerFor App [Permission]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString]
-> (ByteString -> HandlerFor App [Permission])
-> HandlerFor App [[Permission]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([[ByteString]] -> [ByteString]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[ByteString]]
hs) ((ByteString -> HandlerFor App [Permission])
 -> HandlerFor App [Permission])
-> (ByteString -> HandlerFor App [Permission])
-> HandlerFor App [Permission]
forall a b. (a -> b) -> a -> b
$ \ByteString
x -> case ByteString -> Either Text Permission
parsePermission ByteString
x of
        Left  Text
e -> [] [Permission] -> Handler () -> HandlerFor App [Permission]
forall a b. a -> HandlerFor App b -> HandlerFor App a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Html -> Handler ()
forall (m :: * -> *). MonadHandler m => Text -> Html -> m ()
addMessage Text
"" (Html
"Unknown permission: " Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Text -> Html
forall a. ToMarkup a => a -> Html
toHtml Text
e)
        Right Permission
p -> [Permission] -> HandlerFor App [Permission]
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Permission
p]
    -- otherwise take them from the access level specified by --allow's access level
    AccessLevel
cliaccess -> [Permission] -> HandlerFor App [Permission]
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Permission] -> HandlerFor App [Permission])
-> [Permission] -> HandlerFor App [Permission]
forall a b. (a -> b) -> a -> b
$ AccessLevel -> [Permission]
accessLevelToPermissions AccessLevel
cliaccess

  ViewData -> Handler ViewData
forall a. a -> HandlerFor App a
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
qparam :: Text
qparam :: Text
qparam, Query
q :: Query
q :: Query
q, [QueryOpt]
qopts :: [QueryOpt]
qopts :: [QueryOpt]
qopts, [Permission]
perms :: [Permission]
perms :: [Permission]
perms}

checkServerSideUiEnabled :: Handler ()
checkServerSideUiEnabled :: Handler ()
checkServerSideUiEnabled = do
  VD{opts :: ViewData -> WebOpts
opts=WebOpts{Bool
serve_api_ :: Bool
serve_api_ :: WebOpts -> Bool
serve_api_}} <- Handler ViewData
getViewData
  Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
serve_api_ (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
    -- this one gives 500 internal server error when called from defaultLayout:
    --  permissionDenied "server-side UI is disabled due to --serve-api"
    Status -> Text -> Handler ()
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)

-- | Find out if the sidebar should be visible. Show it, unless there is a
-- showsidebar cookie set to "0", or a ?sidebar=0 query parameter.
shouldShowSidebar :: Handler Bool
shouldShowSidebar :: HandlerFor App Bool
shouldShowSidebar = do
  Maybe Text
msidebarparam <- Text -> HandlerFor App (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"sidebar"
  Maybe Text
msidebarcookie <- Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"showsidebar" ([(Text, Text)] -> Maybe Text)
-> (YesodRequest -> [(Text, Text)]) -> YesodRequest -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodRequest -> [(Text, Text)]
reqCookies (YesodRequest -> Maybe Text)
-> HandlerFor App YesodRequest -> HandlerFor App (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor App YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
  Bool -> HandlerFor App Bool
forall a. a -> HandlerFor App a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> HandlerFor App Bool) -> Bool -> HandlerFor App Bool
forall a b. (a -> b) -> a -> b
$
    let disablevalues :: [Text]
disablevalues = [Text
"",Text
"0"]
    in Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
disablevalues) (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe Text
msidebarparam Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
msidebarcookie

-- | Update our copy of the journal if the file changed. If there is an
-- error while reloading, keep the old one and return the error, and set a
-- ui message.
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
  -- re-apply any initial filter specified at startup
  let depthlessinitialq :: Query
depthlessinitialq = (Query -> Bool) -> Query -> Query
filterQuery (Bool -> Bool
not (Bool -> Bool) -> (Query -> Bool) -> Query -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> Bool
queryIsDepth) (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$ ReportSpec -> Query
_rsQuery (ReportSpec -> Query) -> ReportSpec -> Query
forall a b. (a -> b) -> a -> b
$ CliOpts -> ReportSpec
reportspec_ CliOpts
opts
  -- XXX put this inside atomicModifyIORef' for thread safety
  Journal
j <- IO Journal -> HandlerFor App Journal
forall a. IO a -> HandlerFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Journal -> IO Journal
forall a. IORef a -> IO a
readIORef IORef Journal
jref)
  Either String (Journal, Bool)
ej <- IO (Either String (Journal, Bool))
-> HandlerFor App (Either String (Journal, Bool))
forall a. IO a -> HandlerFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String (Journal, Bool))
 -> HandlerFor App (Either String (Journal, Bool)))
-> (ExceptT String IO (Journal, Bool)
    -> IO (Either String (Journal, Bool)))
-> ExceptT String IO (Journal, Bool)
-> HandlerFor App (Either String (Journal, Bool))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String IO (Journal, Bool)
-> IO (Either String (Journal, Bool))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO (Journal, Bool)
 -> HandlerFor App (Either String (Journal, Bool)))
-> ExceptT String IO (Journal, Bool)
-> HandlerFor App (Either String (Journal, Bool))
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
      Html -> Handler ()
forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage Html
"error while reading journal"
      (Journal, Maybe String) -> Handler (Journal, Maybe String)
forall a. a -> HandlerFor App a
forall (m :: * -> *) a. Monad m => a -> m a
return (Journal
j, String -> Maybe String
forall a. a -> Maybe a
Just String
e)
    Right (Journal
j', Bool
True) -> do
      IO () -> Handler ()
forall a. IO a -> HandlerFor App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ())
-> (Journal -> IO ()) -> Journal -> Handler ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Journal -> Journal -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Journal
jref (Journal -> Handler ()) -> Journal -> Handler ()
forall a b. (a -> b) -> a -> b
$ Query -> Journal -> Journal
filterJournalTransactions Query
depthlessinitialq Journal
j'
      (Journal, Maybe String) -> Handler (Journal, Maybe String)
forall a. a -> HandlerFor App a
forall (m :: * -> *) a. Monad m => a -> m a
return (Journal
j',Maybe String
forall a. Maybe a
Nothing)
    Right (Journal
_, Bool
False) -> (Journal, Maybe String) -> Handler (Journal, Maybe String)
forall a. a -> HandlerFor App a
forall (m :: * -> *) a. Monad m => a -> m a
return (Journal
j, Maybe String
forall a. Maybe a
Nothing)

-- | In a request handler, check for the given permission
-- and fail with a message if it's not present.
require :: Permission -> Handler ()
require :: Permission -> Handler ()
require Permission
p = do
  VD{[Permission]
perms :: ViewData -> [Permission]
perms :: [Permission]
perms} <- Handler ViewData
getViewData
  Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Permission
p Permission -> [Permission] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Permission]
perms) (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$ Text -> Handler ()
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$
    Text
"Missing the '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Permission -> String
showPermission Permission
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' permission"