content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE LambdaCase #-}
  
  module Hledger.Web.WebOptions where
  
  import Data.ByteString (ByteString)
  import Data.ByteString.Char8 qualified as BC
  import Data.ByteString.UTF8 (fromString)
  import Data.Default (Default(def))
  import Data.Maybe (fromMaybe)
  import Data.Text (Text)
  import GitHash (tGitInfoCwdTry)
  import System.Environment (getArgs)
  import Network.Wai as WAI
  import Network.Wai.Middleware.Cors
  import Safe (lastMay)
  
  import Hledger.Cli hiding (packageversion, progname, prognameandversion)
  import Hledger.Web.Settings (defhost, defport, defbaseurl)
  import Data.Text qualified as T
  import Data.Char (toLower)
  import Data.List (isPrefixOf)
  import Data.Either (fromRight)
  
  -- cf Hledger.Cli.Version
  
  packageversion :: PackageVersionString
  packageversion =
  #ifdef VERSION
    VERSION
  #else
    ""
  #endif
  
  -- | The name of this program's executable.
  progname :: ProgramName
  progname = "hledger-web"
  
  -- | Generate the version string for this program.
  -- The template haskell call is here rather than in Hledger.Cli.Version to avoid wasteful recompilation.
  prognameandversion :: String
  prognameandversion =
    versionStringWith
    $$tGitInfoCwdTry
  #ifdef GHCDEBUG
    True
  #else
    False
  #endif
    progname
    packageversion
  
  binaryinfo :: HledgerBinaryInfo
  binaryinfo = fromRight nullbinaryinfo $ parseHledgerVersion prognameandversion
  
  webflags :: [Flag RawOpts]
  webflags =
    [ flagNone
        ["serve-browse"]
        (setboolopt "serve-browse")
        (serveprefix ++ "serve the web UI and JSON API, and open a browser, and exit if inactive for 2m (default)")
    , flagNone
        ["serve"]
        (setboolopt "serve")
        (serveprefix ++ "just serve the web UI and JSON API")
    , flagNone
        ["serve-api"]
        (setboolopt "serve-api")
        (serveprefix ++ "just serve the JSON API")
    , flagReq
        ["allow"]
        (\s opts -> Right $ setopt "allow" s opts)
        "view|add|edit"
        "set the user's access level for changing data (default: `add`). It also accepts `sandstorm` for use on that platform (reads permissions from the `X-Sandstorm-Permissions` request header)."
    , flagReq
        ["cors"]
        (\s opts -> Right $ setopt "cors" s opts)
        "ORIGIN"
        ("allow cross-origin requests from the specified origin; setting ORIGIN to \"*\" allows requests from any origin")
    , flagReq
        ["host"]
        (\s opts -> Right $ setopt "host" s opts)
        "IPADDR"
        ("listen on this IP address (default: " ++ defhost ++ ")")
    , flagReq
        ["port"]
        (\s opts -> Right $ setopt "port" s opts)
        "PORT"
        ("listen on this TCP port (default: " ++ show defport ++ ")")
    , flagReq
        ["socket"]
        (\s opts -> Right $ setopt "socket" s opts)
        "SOCKET"
        "listen on the given unix socket instead of an IP address and port (only on unix)"
    , flagReq
        ["base-url"]
        (\s opts -> Right $ setopt "base-url" s opts)
        "BASEURL"
        "set the base url (default: http://IPADDR:PORT)"
    -- XXX #2139
    -- , flagReq
    --     ["file-url"]
    --     (\s opts -> Right $ setopt "file-url" s opts)
    --     "FILEURL"
    --     "set a different base url for static files (default: `BASEURL/static/`)"
    , flagNone
        ["test"]
        (setboolopt "test")
        "run hledger-web's tests and exit. hspec test runner args may follow a --, eg: hledger-web --test -- --help"
    ]
    where
      serveprefix = "server mode: "
  
  webmode :: Mode RawOpts
  webmode =
    (mode
       "hledger-web"
       (setopt "command" "web" def)
       "start serving the hledger web interface"
       (argsFlag "[PATTERNS]")
       [])
    { modeGroupFlags =
        Group
        { groupUnnamed = webflags
        , groupHidden = hiddenflags
            ++
            [flagNone ["server"] (setboolopt "serve") "old flag, use --serve instead"]
        , groupNamed = mkgeneralflagsgroups1 helpflags
        }
    , modeHelpSuffix = []
    }
  
  data ServerMode = ServeBrowse | Serve | ServeJson deriving (Show, Eq)
  
  -- hledger-web options, used in hledger-web and above
  data WebOpts = WebOpts
    { server_mode_        :: !ServerMode
    , cors_               :: !(Maybe String)
    , host_               :: !String
    , port_               :: !Int
    , base_url_           :: !String
    , file_url_           :: !(Maybe String)
    , allow_              :: !AccessLevel
    , cliopts_            :: !CliOpts
    , socket_             :: !(Maybe String)
    } deriving (Show)
  
  defwebopts :: WebOpts
  defwebopts = WebOpts
    { server_mode_        = ServeBrowse
    , cors_               = Nothing
    , host_               = ""
    , port_               = def
    , base_url_           = ""
    , file_url_           = Nothing
    , allow_              = AddAccess
    , cliopts_            = def
    , socket_             = Nothing
    }
  
  instance Default WebOpts where def = defwebopts
  
  rawOptsToWebOpts :: RawOpts -> IO WebOpts
  rawOptsToWebOpts rawopts =
    checkWebOpts <$> do
      cliopts <- rawOptsToCliOpts rawopts
      let
        h = fromMaybe defhost $ maybestringopt "host" rawopts
        p = fromMaybe defport $ maybeposintopt "port" rawopts
        -- Always set a base-url, constructing it from host and port if not specified.
        -- This will be used when opening a web browser, eg.
        -- App.hs approot will use it if it was specified by --base-url,
        -- otherwise it will infer a better one from the request, which browsers prefer.
        b = maybe (defbaseurl h p) stripTrailingSlash $ maybestringopt "base-url" rawopts
        sock = stripTrailingSlash <$> maybestringopt "socket" rawopts
        access =
          case lastMay $ listofstringopt "allow" rawopts of
            Nothing -> AddAccess
            Just t ->
              case parseAccessLevel t of
                Right al -> al
                Left err -> error' ("Unknown access level: " ++ err)  -- PARTIAL:
      return
        defwebopts
        { server_mode_ = servermodeopt rawopts
        , cors_ = maybestringopt "cors" rawopts
        , host_ = h
        , port_ = p
        , base_url_ = b
        , file_url_ = stripTrailingSlash <$> maybestringopt "file-url" rawopts
        , allow_ = access
        , cliopts_ = cliopts
        , socket_ = sock
        }
    where
      stripTrailingSlash = reverse . dropWhile (== '/') . reverse -- yesod don't like it
  
  servermodeopt :: RawOpts -> ServerMode
  servermodeopt =
    fromMaybe ServeBrowse . choiceopt parse
   where
    parse = \case
      "serve-browse" -> Just ServeBrowse
      "serve"        -> Just Serve
      "serve-api"    -> Just ServeJson
      _ -> Nothing
  
  checkWebOpts :: WebOpts -> WebOpts
  checkWebOpts wopts@WebOpts{..}
    | not $ null base_url_ || "http://" `isPrefixOf` base_url_ || "https://" `isPrefixOf` base_url_ =
        error' "please begin the --base-url value with http:// or https://"
    | otherwise = wopts
  
  getHledgerWebOpts :: IO WebOpts
  getHledgerWebOpts = do
    args <- fmap (ensureDebugFlagHasVal . replaceNumericFlags) . expandArgsAt =<< getArgs
    rawOptsToWebOpts . either usageError id $ process webmode args
  
  data Permission
    = ViewPermission  -- ^ allow viewing things (read only)
    | AddPermission   -- ^ allow adding transactions, or more generally allow appending text to input files 
    | EditPermission  -- ^ allow editing input files
    deriving (Eq, Ord, Bounded, Enum, Show)
  
  parsePermission :: ByteString -> Either Text Permission
  parsePermission "view" = Right ViewPermission
  parsePermission "add"  = Right AddPermission
  parsePermission "edit" = Right EditPermission
  parsePermission x = Left $ T.pack $ BC.unpack x
  
  -- | Convert to the lower case permission name.
  showPermission :: Permission -> String
  showPermission p = map toLower $ reverse $ drop 10 $ reverse $ show p
  
  -- | For the --allow option: how much access to allow to hledger-web users ?
  data AccessLevel =
      ViewAccess       -- ^ view permission only
    | AddAccess        -- ^ view and add permissions
    | EditAccess       -- ^ view, add and edit permissions
    | SandstormAccess  -- ^ the permissions specified by the X-Sandstorm-Permissions HTTP request header
    deriving (Eq, Ord, Bounded, Enum, Show)
  
  parseAccessLevel :: String -> Either String AccessLevel
  parseAccessLevel "view"      = Right ViewAccess
  parseAccessLevel "add"       = Right AddAccess
  parseAccessLevel "edit"      = Right EditAccess
  parseAccessLevel "sandstorm" = Right SandstormAccess
  parseAccessLevel s = Left $ s <> ", should be one of: view, add, edit, sandstorm"
  
  -- | Convert an --allow access level to the permissions used internally.
  -- SandstormAccess generates an empty list, to be filled in later.
  accessLevelToPermissions :: AccessLevel -> [Permission]
  accessLevelToPermissions ViewAccess      = [ViewPermission]
  accessLevelToPermissions AddAccess       = [ViewPermission, AddPermission]
  accessLevelToPermissions EditAccess      = [ViewPermission, AddPermission, EditPermission]
  accessLevelToPermissions SandstormAccess = []  -- detected from request header
  
  simplePolicyWithOrigin :: Origin -> CorsResourcePolicy
  simplePolicyWithOrigin origin =
      simpleCorsResourcePolicy { corsOrigins = Just ([origin], False) }
  
  corsPolicyFromString :: String -> WAI.Middleware
  corsPolicyFromString origin =
    let
      policy = case origin of
          "*" -> simpleCorsResourcePolicy
          url -> simplePolicyWithOrigin $ fromString url
    in
      cors (const $ Just policy)
  
  corsPolicy :: WebOpts -> (Application -> Application)
  corsPolicy opts =
    maybe id corsPolicyFromString $ cors_ opts
  