{-|
hledger-web - a basic but robust web UI and JSON API server for hledger.

SPDX-License-Identifier: GPL-3.0-or-later
Copyright (c) 2007-2025 (each year in this range) Simon Michael <simon@joyful.com> and contributors.

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with this program.
If not, see <https://www.gnu.org/licenses/>.

-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Hledger.Web.Main where

import Control.Exception (bracket)
#if MIN_VERSION_base(4,20,0)
import Control.Exception.Backtrace (setBacktraceMechanismState, BacktraceMechanism(..))
#endif
import Control.Monad (when)
import Data.String (fromString)
import qualified Data.Text as T
import Network.Socket
import Network.Wai (Application)
import Network.Wai.Handler.Warp (runSettings, runSettingsSocket, defaultSettings, setHost, setPort)
import Network.Wai.Handler.Launch (runHostPortFullUrl)
import System.Directory (removeFile)
import System.Environment ( getArgs, withArgs )
import System.IO (hFlush, stdout)
import System.PosixCompat.Files (getFileStatus, isSocket)
import Text.Printf (printf)
import Yesod.Default.Config
import Yesod.Default.Main (defaultDevelApp)

import Hledger
import Hledger.Cli hiding (progname,prognameandversion)
import Hledger.Web.Application (makeApplication)
import Hledger.Web.Settings (Extra(..), parseExtra)
import Hledger.Web.Test (hledgerWebTest)
import Hledger.Web.WebOptions

-- Run in fast reloading mode for yesod devel.
hledgerWebDev :: IO (Int, Application)
hledgerWebDev :: IO (Int, Application)
hledgerWebDev =
  CliOpts
-> (Journal -> IO (Int, Application)) -> IO (Int, Application)
forall a. CliOpts -> (Journal -> IO a) -> IO a
withJournalDo (WebOpts -> CliOpts
cliopts_ WebOpts
defwebopts) (IO (AppConfig DefaultEnv Extra)
-> (AppConfig DefaultEnv Extra -> IO Application)
-> IO (Int, Application)
forall env extra.
IO (AppConfig env extra)
-> (AppConfig env extra -> IO Application) -> IO (Int, Application)
defaultDevelApp IO (AppConfig DefaultEnv Extra)
loader ((AppConfig DefaultEnv Extra -> IO Application)
 -> IO (Int, Application))
-> (Journal -> AppConfig DefaultEnv Extra -> IO Application)
-> Journal
-> IO (Int, Application)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application
makeApplication WebOpts
defwebopts)
  where
    loader :: IO (AppConfig DefaultEnv Extra)
loader =
      ConfigSettings DefaultEnv Extra -> IO (AppConfig DefaultEnv Extra)
forall environment extra.
ConfigSettings environment extra
-> IO (AppConfig environment extra)
Yesod.Default.Config.loadConfig
        (DefaultEnv -> ConfigSettings DefaultEnv ()
forall env. Show env => env -> ConfigSettings env ()
configSettings DefaultEnv
Development) {csParseExtra = parseExtra}

-- Run normally.
hledgerWebMain :: IO ()
hledgerWebMain :: IO ()
hledgerWebMain = IO () -> IO ()
handleExit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall {a}. a -> a
withGhcDebug' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GhcDebugMode
ghcDebugMode GhcDebugMode -> GhcDebugMode -> Bool
forall a. Eq a => a -> a -> Bool
== GhcDebugMode
GDPauseAtStart) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
ghcDebugPause'

#if MIN_VERSION_base(4,20,0)
  -- Control ghc 9.10+'s stack traces.
  -- CostCentreBacktrace   - collect cost-centre stack backtraces (only available when built with profiling)
  -- HasCallStackBacktrace - collect HasCallStack backtraces
  -- ExecutionBacktrace    - collect backtraces from native execution stack unwinding
  -- IPEBacktrace          - collect backtraces from Info Table Provenance Entries
#ifdef DEBUG
  setBacktraceMechanismState HasCallStackBacktrace True
#else
  BacktraceMechanism -> Bool -> IO ()
setBacktraceMechanismState BacktraceMechanism
HasCallStackBacktrace Bool
False
#endif
#endif

  -- try to encourage user's $PAGER to properly display ANSI (in command line help)
  usecolor <- IO Bool
useColorOnStdout
  when usecolor setupPager

  wopts@WebOpts{cliopts_=copts@CliOpts{debug_, rawopts_}} <- getHledgerWebOpts
  when (debug_ > 0) $ printf "%s\n" prognameandversion >> printf "opts: %s\n" (show wopts)
  if
    | boolopt "help"            rawopts_ -> runPager $ showModeUsage webmode ++ "\n"
    | boolopt "tldr"            rawopts_ -> runTldrForPage "hledger-web"
    | boolopt "info"            rawopts_ -> runInfoForTopic "hledger-web" Nothing
    | boolopt "man"             rawopts_ -> runManForTopic  "hledger-web" Nothing
    | boolopt "version"         rawopts_ -> putStrLn prognameandversion
    -- boolopt "binary-filename" rawopts_ -> putStrLn (binaryfilename progname)
    | boolopt "test"            rawopts_ -> do
      -- remove --test and --, leaving other args for hspec
      (`withArgs` hledgerWebTest) . filter (`notElem` ["--test","--"]) =<< getArgs
    | otherwise                              -> withJournalDo copts (web wopts)

  when (ghcDebugMode == GDPauseAtEnd) $ ghcDebugPause'

-- | The hledger web command.
web :: WebOpts -> Journal -> IO ()
web :: WebOpts -> Journal -> IO ()
web WebOpts
opts Journal
j = do
  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) -> (CliOpts -> Query) -> CliOpts -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReportSpec -> Query
_rsQuery (ReportSpec -> Query)
-> (CliOpts -> ReportSpec) -> CliOpts -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CliOpts -> ReportSpec
reportspec_ (CliOpts -> Query) -> CliOpts -> Query
forall a b. (a -> b) -> a -> b
$ WebOpts -> CliOpts
cliopts_ WebOpts
opts
      j' :: Journal
j' = Query -> Journal -> Journal
filterJournalTransactions Query
depthlessinitialq Journal
j
      h :: String
h = WebOpts -> String
host_ WebOpts
opts
      p :: Int
p = WebOpts -> Int
port_ WebOpts
opts
      u :: String
u = WebOpts -> String
base_url_ WebOpts
opts
      staticRoot :: Maybe Text
staticRoot = String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WebOpts -> Maybe String
file_url_ WebOpts
opts  -- XXX not used #2139
      appconfig :: AppConfig DefaultEnv Extra
appconfig = AppConfig{appEnv :: DefaultEnv
appEnv = DefaultEnv
Development
                           ,appHost :: HostPreference
appHost = String -> HostPreference
forall a. IsString a => String -> a
fromString String
h
                           ,appPort :: Int
appPort = Int
p
                           ,appRoot :: Text
appRoot = String -> Text
T.pack String
u
                           ,appExtra :: Extra
appExtra = Text -> Maybe Text -> Maybe Text -> Extra
Extra Text
"" Maybe Text
forall a. Maybe a
Nothing Maybe Text
staticRoot
                           }
  app <- WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application
makeApplication WebOpts
opts Journal
j' AppConfig DefaultEnv Extra
appconfig

  -- show configuration
  let
    services
      | WebOpts -> ServerMode
server_mode_ WebOpts
opts ServerMode -> ServerMode -> Bool
forall a. Eq a => a -> a -> Bool
== ServerMode
ServeJson = String
"json API"
      | Bool
otherwise                      = String
"web UI and json API"
    prettyip String
ip
        | String
ip String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"127.0.0.1" = String
ip String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (local access)"
        | String
ip String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"0.0.0.0"   = String
ip String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (all interfaces)"
        | Bool
otherwise         = String
ip
    listenat =
      case WebOpts -> Maybe String
socket_ WebOpts
opts of
        Just String
s  -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"socket %s" String
s
        Maybe String
Nothing -> String -> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"IP address %s, port %d" (String -> String
prettyip String
h) Int
p
  printf "Serving %s at %s\nwith base url %s\n" (services::String) (listenat::String) u
  case file_url_ opts of
    Just String
fu -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"and static files base url %s\n" String
fu
    Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- start server and maybe browser
  if server_mode_ opts == ServeBrowse
    then do
      putStrLn "This server will exit after 2m with no browser windows open (or press ctrl-c)"
      putStrLn "Opening web browser..."
      hFlush stdout
      -- exits after 2m of inactivity (hardcoded)
      Network.Wai.Handler.Launch.runHostPortFullUrl h p u app

    else do
      putStrLn "Press ctrl-c to quit"
      hFlush stdout
      let warpsettings = HostPreference -> Settings -> Settings
setHost (String -> HostPreference
forall a. IsString a => String -> a
fromString String
h) (Int -> Settings -> Settings
setPort Int
p Settings
defaultSettings)
      case socket_ opts of
        Just String
s -> do
          if Bool
isUnixDomainSocketAvailable then
            IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
              (do
                  sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
0
                  setSocketOption sock ReuseAddr 1
                  bind sock $ SockAddrUnix s
                  listen sock maxListenQueue
                  return sock
              )
              (\Socket
_ -> do
                  sockstat <-  String -> IO FileStatus
getFileStatus String
s
                  when (isSocket sockstat) $ removeFile s
              )
              (\Socket
sock -> Settings -> Socket -> Application -> IO ()
Network.Wai.Handler.Warp.runSettingsSocket Settings
warpsettings Socket
sock Application
app)
            else String -> IO ()
forall a. String -> a
error' (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
              [String
"Unix domain sockets are not available on your operating system."
              ,String
"Please try again without --socket."
              ]

        Maybe String
Nothing -> Settings -> Application -> IO ()
Network.Wai.Handler.Warp.runSettings Settings
warpsettings Application
app