{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Hledger.Web.WebOptions where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BC
import Data.ByteString.UTF8 (fromString)
import Data.CaseInsensitive (CI, mk)
import Data.Default (Default(def))
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Text (Text)
import System.Environment (getArgs)
import Network.Wai as WAI
import Network.Wai.Middleware.Cors

import Hledger.Cli hiding (packageversion, progname, prognameandversion)
import Hledger.Web.Settings (defhost, defport, defbaseurl)

-- cf Hledger.Cli.Version

packageversion :: PackageVersion
packageversion :: [Char]
packageversion =
#ifdef VERSION
  VERSION
#else
  ""
#endif

progname :: ProgramName
progname :: [Char]
progname = [Char]
"hledger-web"

prognameandversion :: VersionString
prognameandversion :: [Char]
prognameandversion = [Char] -> [Char] -> [Char]
versionString [Char]
progname [Char]
packageversion


webflags :: [Flag RawOpts]
webflags :: [Flag RawOpts]
webflags =
  [ forall a. [[Char]] -> (a -> a) -> [Char] -> Flag a
flagNone
      [[Char]
"serve", [Char]
"server"]
      ([Char] -> RawOpts -> RawOpts
setboolopt [Char]
"serve")
      [Char]
"serve and log requests, don't browse or auto-exit"
  , forall a. [[Char]] -> (a -> a) -> [Char] -> Flag a
flagNone
      [[Char]
"serve-api"]
      ([Char] -> RawOpts -> RawOpts
setboolopt [Char]
"serve-api")
      [Char]
"like --serve, but serve only the JSON web API, without the server-side web UI"
  , forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
      [[Char]
"cors"]
      (\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"cors" [Char]
s RawOpts
opts)
      [Char]
"ORIGIN"
      ([Char]
"allow cross-origin requests from the specified origin; setting ORIGIN to \"*\" allows requests from any origin")
  , forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
      [[Char]
"socket"]
      (\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"socket" [Char]
s RawOpts
opts)
      [Char]
"SOCKET"
      [Char]
"use the given socket instead of the given IP and port (implies --serve)"
  , forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
      [[Char]
"host"]
      (\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"host" [Char]
s RawOpts
opts)
      [Char]
"IPADDR"
      ([Char]
"listen on this IP address (default: " forall a. [a] -> [a] -> [a]
++ [Char]
defhost forall a. [a] -> [a] -> [a]
++ [Char]
")")
  , forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
      [[Char]
"port"]
      (\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"port" [Char]
s RawOpts
opts)
      [Char]
"PORT"
      ([Char]
"listen on this TCP port (default: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
defport forall a. [a] -> [a] -> [a]
++ [Char]
")")
  , forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
      [[Char]
"base-url"]
      (\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"base-url" [Char]
s RawOpts
opts)
      [Char]
"BASEURL"
      [Char]
"set the base url (default: http://IPADDR:PORT)"
  , forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
      [[Char]
"file-url"]
      (\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"file-url" [Char]
s RawOpts
opts)
      [Char]
"FILEURL"
      [Char]
"set the static files url (default: BASEURL/static)"
  , forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
      [[Char]
"capabilities"]
      (\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"capabilities" [Char]
s RawOpts
opts)
      [Char]
"CAP[,CAP..]"
      [Char]
"enable the view, add, and/or manage capabilities (default: view,add)"
  , forall a. [[Char]] -> Update a -> [Char] -> [Char] -> Flag a
flagReq
      [[Char]
"capabilities-header"]
      (\[Char]
s RawOpts
opts -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"capabilities-header" [Char]
s RawOpts
opts)
      [Char]
"HTTPHEADER"
      [Char]
"read capabilities to enable from a HTTP header, like X-Sandstorm-Permissions (default: disabled)"
  , forall a. [[Char]] -> (a -> a) -> [Char] -> Flag a
flagNone
      [[Char]
"test"]
      ([Char] -> RawOpts -> RawOpts
setboolopt [Char]
"test")
      [Char]
"run hledger-web's tests and exit. hspec test runner args may follow a --, eg: hledger-web --test -- --help"
  ]

webmode :: Mode RawOpts
webmode :: Mode RawOpts
webmode =
  (forall a. [Char] -> a -> [Char] -> Arg a -> [Flag a] -> Mode a
mode
     [Char]
"hledger-web"
     ([Char] -> [Char] -> RawOpts -> RawOpts
setopt [Char]
"command" [Char]
"web" forall a. Default a => a
def)
     [Char]
"start serving the hledger web interface"
     ([Char] -> Arg RawOpts
argsFlag [Char]
"[PATTERNS]")
     [])
  { modeGroupFlags :: Group (Flag RawOpts)
modeGroupFlags =
      Group
      { groupUnnamed :: [Flag RawOpts]
groupUnnamed = [Flag RawOpts]
webflags
      , groupHidden :: [Flag RawOpts]
groupHidden =
          [Flag RawOpts]
hiddenflags 
          -- ++
          -- [ flagNone
          --     ["binary-filename"]
          --     (setboolopt "binary-filename")
          --     "show the download filename for this executable, and exit"
          -- ]
      , groupNamed :: [([Char], [Flag RawOpts])]
groupNamed = [([Char], [Flag RawOpts])
generalflagsgroup1]
      }
  , modeHelpSuffix :: [[Char]]
modeHelpSuffix = []
  }

-- hledger-web options, used in hledger-web and above
data WebOpts = WebOpts
  { WebOpts -> Bool
serve_ :: Bool
  , WebOpts -> Bool
serve_api_ :: Bool
  , WebOpts -> Maybe [Char]
cors_ :: Maybe String
  , WebOpts -> [Char]
host_ :: String
  , WebOpts -> Int
port_ :: Int
  , WebOpts -> [Char]
base_url_ :: String
  , WebOpts -> Maybe [Char]
file_url_ :: Maybe String
  , WebOpts -> [Capability]
capabilities_ :: [Capability]
  , WebOpts -> Maybe (CI ByteString)
capabilitiesHeader_ :: Maybe (CI ByteString)
  , WebOpts -> CliOpts
cliopts_ :: CliOpts
  , WebOpts -> Maybe [Char]
socket_ :: Maybe String
  } deriving (Int -> WebOpts -> [Char] -> [Char]
[WebOpts] -> [Char] -> [Char]
WebOpts -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [WebOpts] -> [Char] -> [Char]
$cshowList :: [WebOpts] -> [Char] -> [Char]
show :: WebOpts -> [Char]
$cshow :: WebOpts -> [Char]
showsPrec :: Int -> WebOpts -> [Char] -> [Char]
$cshowsPrec :: Int -> WebOpts -> [Char] -> [Char]
Show)

defwebopts :: WebOpts
defwebopts :: WebOpts
defwebopts = WebOpts
  { serve_ :: Bool
serve_              = Bool
False
  , serve_api_ :: Bool
serve_api_          = Bool
False
  , cors_ :: Maybe [Char]
cors_               = forall a. Maybe a
Nothing
  , host_ :: [Char]
host_               = [Char]
""
  , port_ :: Int
port_               = forall a. Default a => a
def
  , base_url_ :: [Char]
base_url_           = [Char]
""
  , file_url_ :: Maybe [Char]
file_url_           = forall a. Maybe a
Nothing
  , capabilities_ :: [Capability]
capabilities_       = [Capability
CapView, Capability
CapAdd]
  , capabilitiesHeader_ :: Maybe (CI ByteString)
capabilitiesHeader_ = forall a. Maybe a
Nothing
  , cliopts_ :: CliOpts
cliopts_            = forall a. Default a => a
def
  , socket_ :: Maybe [Char]
socket_             = forall a. Maybe a
Nothing
  }

instance Default WebOpts where def :: WebOpts
def = WebOpts
defwebopts

rawOptsToWebOpts :: RawOpts -> IO WebOpts
rawOptsToWebOpts :: RawOpts -> IO WebOpts
rawOptsToWebOpts RawOpts
rawopts =
  WebOpts -> WebOpts
checkWebOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    CliOpts
cliopts <- RawOpts -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts
    let h :: [Char]
h = forall a. a -> Maybe a -> a
fromMaybe [Char]
defhost forall a b. (a -> b) -> a -> b
$ [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"host" RawOpts
rawopts
        p :: Int
p = forall a. a -> Maybe a -> a
fromMaybe Int
defport forall a b. (a -> b) -> a -> b
$ [Char] -> RawOpts -> Maybe Int
maybeposintopt [Char]
"port" RawOpts
rawopts
        b :: [Char]
b =
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Int -> [Char]
defbaseurl [Char]
h Int
p) [Char] -> [Char]
stripTrailingSlash forall a b. (a -> b) -> a -> b
$
          [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"base-url" RawOpts
rawopts
        caps' :: [Text]
caps' = Text -> Text -> [Text]
T.splitOn Text
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> RawOpts -> [[Char]]
listofstringopt [Char]
"capabilities" RawOpts
rawopts
        caps :: [Capability]
caps = case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either Text Capability
capabilityFromText [Text]
caps' of
          Left Text
e -> forall a. [Char] -> a
error' ([Char]
"Unknown capability: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
e)  -- PARTIAL:
          Right [] -> [Capability
CapView, Capability
CapAdd]
          Right [Capability]
xs -> [Capability]
xs
        sock :: Maybe [Char]
sock = [Char] -> [Char]
stripTrailingSlash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"socket" RawOpts
rawopts
    forall (m :: * -> *) a. Monad m => a -> m a
return
      WebOpts
defwebopts
      { serve_ :: Bool
serve_ = case Maybe [Char]
sock of
          Just [Char]
_ -> Bool
True
          Maybe [Char]
Nothing -> [Char] -> RawOpts -> Bool
boolopt [Char]
"serve" RawOpts
rawopts
      , serve_api_ :: Bool
serve_api_ = [Char] -> RawOpts -> Bool
boolopt [Char]
"serve-api" RawOpts
rawopts
      , cors_ :: Maybe [Char]
cors_ = [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"cors" RawOpts
rawopts
      , host_ :: [Char]
host_ = [Char]
h
      , port_ :: Int
port_ = Int
p
      , base_url_ :: [Char]
base_url_ = [Char]
b
      , file_url_ :: Maybe [Char]
file_url_ = [Char] -> [Char]
stripTrailingSlash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"file-url" RawOpts
rawopts
      , capabilities_ :: [Capability]
capabilities_ = [Capability]
caps
      , capabilitiesHeader_ :: Maybe (CI ByteString)
capabilitiesHeader_ = forall s. FoldCase s => s -> CI s
mk forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BC.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> RawOpts -> Maybe [Char]
maybestringopt [Char]
"capabilities-header" RawOpts
rawopts
      , cliopts_ :: CliOpts
cliopts_ = CliOpts
cliopts
      , socket_ :: Maybe [Char]
socket_ = Maybe [Char]
sock
      }
  where
    stripTrailingSlash :: [Char] -> [Char]
stripTrailingSlash = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse -- yesod don't like it

checkWebOpts :: WebOpts -> WebOpts
checkWebOpts :: WebOpts -> WebOpts
checkWebOpts = forall a. a -> a
id

getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts = do
  [[Char]]
args <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[Char]] -> [[Char]]
replaceNumericFlags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *}.
(Eq (t Char), IsString (t Char), Foldable t) =>
[t Char] -> [t Char]
ensureDebugHasArg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> IO [[Char]]
expandArgsAt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [[Char]]
getArgs
  RawOpts -> IO WebOpts
rawOptsToWebOpts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. [Char] -> a
usageError forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> [[Char]] -> Either [Char] a
process Mode RawOpts
webmode [[Char]]
args

data Capability
  = CapView
  | CapAdd
  | CapManage
  deriving (Capability -> Capability -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Capability -> Capability -> Bool
$c/= :: Capability -> Capability -> Bool
== :: Capability -> Capability -> Bool
$c== :: Capability -> Capability -> Bool
Eq, Eq Capability
Capability -> Capability -> Bool
Capability -> Capability -> Ordering
Capability -> Capability -> Capability
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Capability -> Capability -> Capability
$cmin :: Capability -> Capability -> Capability
max :: Capability -> Capability -> Capability
$cmax :: Capability -> Capability -> Capability
>= :: Capability -> Capability -> Bool
$c>= :: Capability -> Capability -> Bool
> :: Capability -> Capability -> Bool
$c> :: Capability -> Capability -> Bool
<= :: Capability -> Capability -> Bool
$c<= :: Capability -> Capability -> Bool
< :: Capability -> Capability -> Bool
$c< :: Capability -> Capability -> Bool
compare :: Capability -> Capability -> Ordering
$ccompare :: Capability -> Capability -> Ordering
Ord, Capability
forall a. a -> a -> Bounded a
maxBound :: Capability
$cmaxBound :: Capability
minBound :: Capability
$cminBound :: Capability
Bounded, Int -> Capability
Capability -> Int
Capability -> [Capability]
Capability -> Capability
Capability -> Capability -> [Capability]
Capability -> Capability -> Capability -> [Capability]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Capability -> Capability -> Capability -> [Capability]
$cenumFromThenTo :: Capability -> Capability -> Capability -> [Capability]
enumFromTo :: Capability -> Capability -> [Capability]
$cenumFromTo :: Capability -> Capability -> [Capability]
enumFromThen :: Capability -> Capability -> [Capability]
$cenumFromThen :: Capability -> Capability -> [Capability]
enumFrom :: Capability -> [Capability]
$cenumFrom :: Capability -> [Capability]
fromEnum :: Capability -> Int
$cfromEnum :: Capability -> Int
toEnum :: Int -> Capability
$ctoEnum :: Int -> Capability
pred :: Capability -> Capability
$cpred :: Capability -> Capability
succ :: Capability -> Capability
$csucc :: Capability -> Capability
Enum, Int -> Capability -> [Char] -> [Char]
[Capability] -> [Char] -> [Char]
Capability -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Capability] -> [Char] -> [Char]
$cshowList :: [Capability] -> [Char] -> [Char]
show :: Capability -> [Char]
$cshow :: Capability -> [Char]
showsPrec :: Int -> Capability -> [Char] -> [Char]
$cshowsPrec :: Int -> Capability -> [Char] -> [Char]
Show)

capabilityFromText :: Text -> Either Text Capability
capabilityFromText :: Text -> Either Text Capability
capabilityFromText Text
"view" = forall a b. b -> Either a b
Right Capability
CapView
capabilityFromText Text
"add" = forall a b. b -> Either a b
Right Capability
CapAdd
capabilityFromText Text
"manage" = forall a b. b -> Either a b
Right Capability
CapManage
capabilityFromText Text
x = forall a b. a -> Either a b
Left Text
x

capabilityFromBS :: ByteString -> Either ByteString Capability
capabilityFromBS :: ByteString -> Either ByteString Capability
capabilityFromBS ByteString
"view" = forall a b. b -> Either a b
Right Capability
CapView
capabilityFromBS ByteString
"add" = forall a b. b -> Either a b
Right Capability
CapAdd
capabilityFromBS ByteString
"manage" = forall a b. b -> Either a b
Right Capability
CapManage
capabilityFromBS ByteString
x = forall a b. a -> Either a b
Left ByteString
x

simplePolicyWithOrigin :: Origin -> CorsResourcePolicy
simplePolicyWithOrigin :: ByteString -> CorsResourcePolicy
simplePolicyWithOrigin ByteString
origin =
    CorsResourcePolicy
simpleCorsResourcePolicy { corsOrigins :: Maybe ([ByteString], Bool)
corsOrigins = forall a. a -> Maybe a
Just ([ByteString
origin], Bool
False) }


corsPolicyFromString :: String -> WAI.Middleware
corsPolicyFromString :: [Char] -> Middleware
corsPolicyFromString [Char]
origin =
  let
    policy :: CorsResourcePolicy
policy = case [Char]
origin of
        [Char]
"*" -> CorsResourcePolicy
simpleCorsResourcePolicy
        [Char]
url -> ByteString -> CorsResourcePolicy
simplePolicyWithOrigin forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
fromString [Char]
url
  in
    (Request -> Maybe CorsResourcePolicy) -> Middleware
cors (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just CorsResourcePolicy
policy)

corsPolicy :: WebOpts -> (Application -> Application)
corsPolicy :: WebOpts -> Middleware
corsPolicy WebOpts
opts =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id [Char] -> Middleware
corsPolicyFromString forall a b. (a -> b) -> a -> b
$ WebOpts -> Maybe [Char]
cors_ WebOpts
opts