{-|

hledger-web - a hledger add-on providing a web interface.
Copyright (c) 2007-2020 Simon Michael <simon@joyful.com>
Released under GPL version 3 or later.

-}

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

module Hledger.Web.Main where

import Control.Exception (bracket)
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.Exit (exitSuccess, exitFailure)
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 :: DefaultEnv -> Object -> Parser Extra
csParseExtra = DefaultEnv -> Object -> Parser Extra
parseExtra}

-- Run normally.
hledgerWebMain :: IO ()
hledgerWebMain :: IO ()
hledgerWebMain = do
  wopts :: WebOpts
wopts@WebOpts{cliopts_ :: WebOpts -> CliOpts
cliopts_=copts :: CliOpts
copts@CliOpts{Int
debug_ :: CliOpts -> Int
debug_ :: Int
debug_, RawOpts
rawopts_ :: CliOpts -> RawOpts
rawopts_ :: RawOpts
rawopts_}} <- IO WebOpts
getHledgerWebOpts
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
debug_ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%s\n" String
prognameandversion IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"opts: %s\n" (WebOpts -> String
forall a. Show a => a -> String
show WebOpts
wopts)
  if
    | String
"help"            String -> RawOpts -> Bool
`inRawOpts` RawOpts
rawopts_ -> String -> IO ()
putStr (Mode RawOpts -> String
forall a. Mode a -> String
showModeUsage Mode RawOpts
webmode) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
    | String
"info"            String -> RawOpts -> Bool
`inRawOpts` RawOpts
rawopts_ -> String -> Maybe String -> IO ()
runInfoForTopic String
"hledger-web" Maybe String
forall a. Maybe a
Nothing
    | String
"man"             String -> RawOpts -> Bool
`inRawOpts` RawOpts
rawopts_ -> String -> Maybe String -> IO ()
runManForTopic  String
"hledger-web" Maybe String
forall a. Maybe a
Nothing
    | String
"version"         String -> RawOpts -> Bool
`inRawOpts` RawOpts
rawopts_ -> String -> IO ()
putStrLn String
prognameandversion IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
    --  "binary-filename" `inRawOpts` rawopts_ -> putStrLn (binaryfilename progname)
    | String
"test"            String -> RawOpts -> Bool
`inRawOpts` RawOpts
rawopts_ -> do
      -- remove --test and --, leaving other args for hspec
      ([String] -> IO () -> IO ()
forall a. [String] -> IO a -> IO a
`withArgs` IO ()
hledgerWebTest) ([String] -> IO ()) -> ([String] -> [String]) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"--test",String
"--"]) ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
getArgs
    | Bool
otherwise                              -> CliOpts -> (Journal -> IO ()) -> IO ()
forall a. CliOpts -> (Journal -> IO a) -> IO a
withJournalDo CliOpts
copts (WebOpts -> Journal -> IO ()
web WebOpts
wopts)

-- | The hledger web command.
web :: WebOpts -> Journal -> IO ()
web :: WebOpts -> Journal -> IO ()
web WebOpts
opts Journal
j = do
  let initq :: Query
initq = 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
initq 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
      appconfig :: AppConfig DefaultEnv Extra
appconfig = AppConfig :: forall environment extra.
environment
-> Int
-> Text
-> HostPreference
-> extra
-> AppConfig environment extra
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
                           }
  Application
app <- WebOpts -> Journal -> AppConfig DefaultEnv Extra -> IO Application
makeApplication WebOpts
opts Journal
j' AppConfig DefaultEnv Extra
appconfig
  -- XXX would like to allow a host name not just an IP address here
  ()
_ <- String -> String -> String -> Int -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"Serving web %s on %s:%d with base url %s\n"
         (if WebOpts -> Bool
serve_api_ WebOpts
opts then String
"API" else String
"UI and API" :: String) String
h Int
p String
u
  if WebOpts -> Bool
serve_ WebOpts
opts Bool -> Bool -> Bool
|| WebOpts -> Bool
serve_api_ WebOpts
opts
    then do
      String -> IO ()
putStrLn String
"Press ctrl-c to quit"
      Handle -> IO ()
hFlush Handle
stdout
      let warpsettings :: Settings
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 WebOpts -> Maybe String
socket_ WebOpts
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
                  Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
0
                  Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
                  Socket -> SockAddr -> IO ()
bind Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SockAddr
SockAddrUnix String
s
                  Socket -> Int -> IO ()
listen Socket
sock Int
maxListenQueue
                  Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
              )
              (\Socket
_ -> do
                  FileStatus
sockstat <-  String -> IO FileStatus
getFileStatus String
s
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileStatus -> Bool
isSocket FileStatus
sockstat) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
s
              )
              (\Socket
sock -> Settings -> Socket -> Application -> IO ()
Network.Wai.Handler.Warp.runSettingsSocket Settings
warpsettings Socket
sock Application
app)
            else do
              String -> IO ()
putStrLn String
"Unix domain sockets are not available on your operating system"
              String -> IO ()
putStrLn String
"Please try again without --socket"
              IO ()
forall a. IO a
exitFailure
        Maybe String
Nothing -> Settings -> Application -> IO ()
Network.Wai.Handler.Warp.runSettings Settings
warpsettings Application
app
    else do
      String -> IO ()
putStrLn String
"This server will exit after 2m with no browser windows open (or press ctrl-c)"
      String -> IO ()
putStrLn String
"Opening web browser..."
      Handle -> IO ()
hFlush Handle
stdout
      -- exits after 2m of inactivity (hardcoded)
      String -> Int -> String -> Application -> IO ()
Network.Wai.Handler.Launch.runHostPortFullUrl String
h Int
p String
u Application
app