{-# 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.Default (Default(def))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
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 qualified Data.Text as T
import Data.Char (toLower)

-- cf Hledger.Cli.Version

packageversion :: PackageVersion
packageversion :: String
packageversion =
#ifdef VERSION
  VERSION
#else
  ""
#endif

progname :: ProgramName
progname :: String
progname = String
"hledger-web"

prognameandversion :: VersionString
prognameandversion :: String
prognameandversion = String -> String -> String
versionString String
progname String
packageversion


webflags :: [Flag RawOpts]
webflags :: [Flag RawOpts]
webflags =
  [ [String] -> (RawOpts -> RawOpts) -> String -> Flag RawOpts
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone
      [String
"serve", String
"server"]
      (String -> RawOpts -> RawOpts
setboolopt String
"serve")
      String
"serve and log requests, don't browse or auto-exit"
  , [String] -> (RawOpts -> RawOpts) -> String -> Flag RawOpts
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone
      [String
"serve-api"]
      (String -> RawOpts -> RawOpts
setboolopt String
"serve-api")
      String
"like --serve, but serve only the JSON web API, not the web UI"
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"allow"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"allow" String
s RawOpts
opts)
      String
"view|add|edit"
      String
"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)."
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"cors"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"cors" String
s RawOpts
opts)
      String
"ORIGIN"
      (String
"allow cross-origin requests from the specified origin; setting ORIGIN to \"*\" allows requests from any origin")
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"host"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"host" String
s RawOpts
opts)
      String
"IPADDR"
      (String
"listen on this IP address (default: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
defhost String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"port"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"port" String
s RawOpts
opts)
      String
"PORT"
      (String
"listen on this TCP port (default: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
defport String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"socket"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"socket" String
s RawOpts
opts)
      String
"SOCKET"
      String
"listen on the given unix socket instead of an IP address and port (unix only; implies --serve)"
  , [String] -> Update RawOpts -> String -> String -> Flag RawOpts
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
      [String
"base-url"]
      (\String
s RawOpts
opts -> RawOpts -> Either String RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either String RawOpts)
-> RawOpts -> Either String RawOpts
forall a b. (a -> b) -> a -> b
$ String -> String -> RawOpts -> RawOpts
setopt String
"base-url" String
s RawOpts
opts)
      String
"BASEURL"
      String
"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/`)"
  , [String] -> (RawOpts -> RawOpts) -> String -> Flag RawOpts
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone
      [String
"test"]
      (String -> RawOpts -> RawOpts
setboolopt String
"test")
      String
"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 =
  (String
-> RawOpts
-> String
-> Arg RawOpts
-> [Flag RawOpts]
-> Mode RawOpts
forall a. String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode
     String
"hledger-web"
     (String -> String -> RawOpts -> RawOpts
setopt String
"command" String
"web" RawOpts
forall a. Default a => a
def)
     String
"start serving the hledger web interface"
     (String -> Arg RawOpts
argsFlag String
"[PATTERNS]")
     [])
  { modeGroupFlags =
      Group
      { groupUnnamed = webflags
      , groupHidden =
          hiddenflags 
          -- ++
          -- [ flagNone
          --     ["binary-filename"]
          --     (setboolopt "binary-filename")
          --     "show the download filename for this executable, and exit"
          -- ]
      , groupNamed = [generalflagsgroup1]
      }
  , modeHelpSuffix = []
  }

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

defwebopts :: WebOpts
defwebopts :: WebOpts
defwebopts = WebOpts
  { serve_ :: Bool
serve_              = Bool
False
  , serve_api_ :: Bool
serve_api_          = Bool
False
  , cors_ :: Maybe String
cors_               = Maybe String
forall a. Maybe a
Nothing
  , host_ :: String
host_               = String
""
  , port_ :: Int
port_               = Int
forall a. Default a => a
def
  , base_url_ :: String
base_url_           = String
""
  , file_url_ :: Maybe String
file_url_           = Maybe String
forall a. Maybe a
Nothing
  , allow_ :: AccessLevel
allow_              = AccessLevel
AddAccess
  , cliopts_ :: CliOpts
cliopts_            = CliOpts
forall a. Default a => a
def
  , socket_ :: Maybe String
socket_             = Maybe String
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 (WebOpts -> WebOpts) -> IO WebOpts -> IO WebOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    CliOpts
cliopts <- RawOpts -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts
    let h :: String
h = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defhost (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> Maybe String
maybestringopt String
"host" RawOpts
rawopts
        p :: Int
p = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defport (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> Maybe Int
maybeposintopt String
"port" RawOpts
rawopts
        b :: String
b = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Int -> String
defbaseurl String
h Int
p) String -> String
stripTrailingSlash (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> Maybe String
maybestringopt String
"base-url" RawOpts
rawopts
        sock :: Maybe String
sock = String -> String
stripTrailingSlash (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RawOpts -> Maybe String
maybestringopt String
"socket" RawOpts
rawopts
        access :: AccessLevel
access =
          case [String] -> Maybe String
forall a. [a] -> Maybe a
lastMay ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> RawOpts -> [String]
listofstringopt String
"allow" RawOpts
rawopts of
            Maybe String
Nothing -> AccessLevel
AddAccess
            Just String
t ->
              case String -> Either String AccessLevel
parseAccessLevel String
t of
                Right AccessLevel
al -> AccessLevel
al
                Left String
err -> String -> AccessLevel
forall a. String -> a
error' (String
"Unknown access level: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)  -- PARTIAL:
    WebOpts -> IO WebOpts
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      WebOpts
defwebopts
      { serve_ = case sock of
          Just String
_ -> Bool
True
          Maybe String
Nothing -> String -> RawOpts -> Bool
boolopt String
"serve" RawOpts
rawopts
      , serve_api_ = boolopt "serve-api" 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 :: String -> String
stripTrailingSlash = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse -- yesod don't like it

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

getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts :: IO WebOpts
getHledgerWebOpts = do
  [String]
args <- ([String] -> [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> [String]
replaceNumericFlags ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall {t :: * -> *}.
(Eq (t Char), IsString (t Char), Foldable t) =>
[t Char] -> [t Char]
ensureDebugHasArg) (IO [String] -> IO [String])
-> ([String] -> IO [String]) -> [String] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> IO [String]
expandArgsAt ([String] -> IO [String]) -> IO [String] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
getArgs
  RawOpts -> IO WebOpts
rawOptsToWebOpts (RawOpts -> IO WebOpts)
-> (Either String RawOpts -> RawOpts)
-> Either String RawOpts
-> IO WebOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> RawOpts)
-> (RawOpts -> RawOpts) -> Either String RawOpts -> RawOpts
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> RawOpts
forall a. String -> a
usageError RawOpts -> RawOpts
forall a. a -> a
id (Either String RawOpts -> IO WebOpts)
-> Either String RawOpts -> IO WebOpts
forall a b. (a -> b) -> a -> b
$ Mode RawOpts -> [String] -> Either String RawOpts
forall a. Mode a -> [String] -> Either String a
process Mode RawOpts
webmode [String]
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 (Permission -> Permission -> Bool
(Permission -> Permission -> Bool)
-> (Permission -> Permission -> Bool) -> Eq Permission
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Permission -> Permission -> Bool
== :: Permission -> Permission -> Bool
$c/= :: Permission -> Permission -> Bool
/= :: Permission -> Permission -> Bool
Eq, Eq Permission
Eq Permission =>
(Permission -> Permission -> Ordering)
-> (Permission -> Permission -> Bool)
-> (Permission -> Permission -> Bool)
-> (Permission -> Permission -> Bool)
-> (Permission -> Permission -> Bool)
-> (Permission -> Permission -> Permission)
-> (Permission -> Permission -> Permission)
-> Ord Permission
Permission -> Permission -> Bool
Permission -> Permission -> Ordering
Permission -> Permission -> Permission
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
$ccompare :: Permission -> Permission -> Ordering
compare :: Permission -> Permission -> Ordering
$c< :: Permission -> Permission -> Bool
< :: Permission -> Permission -> Bool
$c<= :: Permission -> Permission -> Bool
<= :: Permission -> Permission -> Bool
$c> :: Permission -> Permission -> Bool
> :: Permission -> Permission -> Bool
$c>= :: Permission -> Permission -> Bool
>= :: Permission -> Permission -> Bool
$cmax :: Permission -> Permission -> Permission
max :: Permission -> Permission -> Permission
$cmin :: Permission -> Permission -> Permission
min :: Permission -> Permission -> Permission
Ord, Permission
Permission -> Permission -> Bounded Permission
forall a. a -> a -> Bounded a
$cminBound :: Permission
minBound :: Permission
$cmaxBound :: Permission
maxBound :: Permission
Bounded, Int -> Permission
Permission -> Int
Permission -> [Permission]
Permission -> Permission
Permission -> Permission -> [Permission]
Permission -> Permission -> Permission -> [Permission]
(Permission -> Permission)
-> (Permission -> Permission)
-> (Int -> Permission)
-> (Permission -> Int)
-> (Permission -> [Permission])
-> (Permission -> Permission -> [Permission])
-> (Permission -> Permission -> [Permission])
-> (Permission -> Permission -> Permission -> [Permission])
-> Enum Permission
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Permission -> Permission
succ :: Permission -> Permission
$cpred :: Permission -> Permission
pred :: Permission -> Permission
$ctoEnum :: Int -> Permission
toEnum :: Int -> Permission
$cfromEnum :: Permission -> Int
fromEnum :: Permission -> Int
$cenumFrom :: Permission -> [Permission]
enumFrom :: Permission -> [Permission]
$cenumFromThen :: Permission -> Permission -> [Permission]
enumFromThen :: Permission -> Permission -> [Permission]
$cenumFromTo :: Permission -> Permission -> [Permission]
enumFromTo :: Permission -> Permission -> [Permission]
$cenumFromThenTo :: Permission -> Permission -> Permission -> [Permission]
enumFromThenTo :: Permission -> Permission -> Permission -> [Permission]
Enum, Int -> Permission -> String -> String
[Permission] -> String -> String
Permission -> String
(Int -> Permission -> String -> String)
-> (Permission -> String)
-> ([Permission] -> String -> String)
-> Show Permission
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Permission -> String -> String
showsPrec :: Int -> Permission -> String -> String
$cshow :: Permission -> String
show :: Permission -> String
$cshowList :: [Permission] -> String -> String
showList :: [Permission] -> String -> String
Show)

parsePermission :: ByteString -> Either Text Permission
parsePermission :: ByteString -> Either Text Permission
parsePermission ByteString
"view" = Permission -> Either Text Permission
forall a b. b -> Either a b
Right Permission
ViewPermission
parsePermission ByteString
"add"  = Permission -> Either Text Permission
forall a b. b -> Either a b
Right Permission
AddPermission
parsePermission ByteString
"edit" = Permission -> Either Text Permission
forall a b. b -> Either a b
Right Permission
EditPermission
parsePermission ByteString
x = Text -> Either Text Permission
forall a b. a -> Either a b
Left (Text -> Either Text Permission) -> Text -> Either Text Permission
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
x

-- | Convert to the lower case permission name.
showPermission :: Permission -> String
showPermission :: Permission -> String
showPermission Permission
p = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
10 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Permission -> String
forall a. Show a => a -> String
show Permission
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 (AccessLevel -> AccessLevel -> Bool
(AccessLevel -> AccessLevel -> Bool)
-> (AccessLevel -> AccessLevel -> Bool) -> Eq AccessLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AccessLevel -> AccessLevel -> Bool
== :: AccessLevel -> AccessLevel -> Bool
$c/= :: AccessLevel -> AccessLevel -> Bool
/= :: AccessLevel -> AccessLevel -> Bool
Eq, Eq AccessLevel
Eq AccessLevel =>
(AccessLevel -> AccessLevel -> Ordering)
-> (AccessLevel -> AccessLevel -> Bool)
-> (AccessLevel -> AccessLevel -> Bool)
-> (AccessLevel -> AccessLevel -> Bool)
-> (AccessLevel -> AccessLevel -> Bool)
-> (AccessLevel -> AccessLevel -> AccessLevel)
-> (AccessLevel -> AccessLevel -> AccessLevel)
-> Ord AccessLevel
AccessLevel -> AccessLevel -> Bool
AccessLevel -> AccessLevel -> Ordering
AccessLevel -> AccessLevel -> AccessLevel
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
$ccompare :: AccessLevel -> AccessLevel -> Ordering
compare :: AccessLevel -> AccessLevel -> Ordering
$c< :: AccessLevel -> AccessLevel -> Bool
< :: AccessLevel -> AccessLevel -> Bool
$c<= :: AccessLevel -> AccessLevel -> Bool
<= :: AccessLevel -> AccessLevel -> Bool
$c> :: AccessLevel -> AccessLevel -> Bool
> :: AccessLevel -> AccessLevel -> Bool
$c>= :: AccessLevel -> AccessLevel -> Bool
>= :: AccessLevel -> AccessLevel -> Bool
$cmax :: AccessLevel -> AccessLevel -> AccessLevel
max :: AccessLevel -> AccessLevel -> AccessLevel
$cmin :: AccessLevel -> AccessLevel -> AccessLevel
min :: AccessLevel -> AccessLevel -> AccessLevel
Ord, AccessLevel
AccessLevel -> AccessLevel -> Bounded AccessLevel
forall a. a -> a -> Bounded a
$cminBound :: AccessLevel
minBound :: AccessLevel
$cmaxBound :: AccessLevel
maxBound :: AccessLevel
Bounded, Int -> AccessLevel
AccessLevel -> Int
AccessLevel -> [AccessLevel]
AccessLevel -> AccessLevel
AccessLevel -> AccessLevel -> [AccessLevel]
AccessLevel -> AccessLevel -> AccessLevel -> [AccessLevel]
(AccessLevel -> AccessLevel)
-> (AccessLevel -> AccessLevel)
-> (Int -> AccessLevel)
-> (AccessLevel -> Int)
-> (AccessLevel -> [AccessLevel])
-> (AccessLevel -> AccessLevel -> [AccessLevel])
-> (AccessLevel -> AccessLevel -> [AccessLevel])
-> (AccessLevel -> AccessLevel -> AccessLevel -> [AccessLevel])
-> Enum AccessLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: AccessLevel -> AccessLevel
succ :: AccessLevel -> AccessLevel
$cpred :: AccessLevel -> AccessLevel
pred :: AccessLevel -> AccessLevel
$ctoEnum :: Int -> AccessLevel
toEnum :: Int -> AccessLevel
$cfromEnum :: AccessLevel -> Int
fromEnum :: AccessLevel -> Int
$cenumFrom :: AccessLevel -> [AccessLevel]
enumFrom :: AccessLevel -> [AccessLevel]
$cenumFromThen :: AccessLevel -> AccessLevel -> [AccessLevel]
enumFromThen :: AccessLevel -> AccessLevel -> [AccessLevel]
$cenumFromTo :: AccessLevel -> AccessLevel -> [AccessLevel]
enumFromTo :: AccessLevel -> AccessLevel -> [AccessLevel]
$cenumFromThenTo :: AccessLevel -> AccessLevel -> AccessLevel -> [AccessLevel]
enumFromThenTo :: AccessLevel -> AccessLevel -> AccessLevel -> [AccessLevel]
Enum, Int -> AccessLevel -> String -> String
[AccessLevel] -> String -> String
AccessLevel -> String
(Int -> AccessLevel -> String -> String)
-> (AccessLevel -> String)
-> ([AccessLevel] -> String -> String)
-> Show AccessLevel
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AccessLevel -> String -> String
showsPrec :: Int -> AccessLevel -> String -> String
$cshow :: AccessLevel -> String
show :: AccessLevel -> String
$cshowList :: [AccessLevel] -> String -> String
showList :: [AccessLevel] -> String -> String
Show)

parseAccessLevel :: String -> Either String AccessLevel
parseAccessLevel :: String -> Either String AccessLevel
parseAccessLevel String
"view"      = AccessLevel -> Either String AccessLevel
forall a b. b -> Either a b
Right AccessLevel
ViewAccess
parseAccessLevel String
"add"       = AccessLevel -> Either String AccessLevel
forall a b. b -> Either a b
Right AccessLevel
AddAccess
parseAccessLevel String
"edit"      = AccessLevel -> Either String AccessLevel
forall a b. b -> Either a b
Right AccessLevel
EditAccess
parseAccessLevel String
"sandstorm" = AccessLevel -> Either String AccessLevel
forall a b. b -> Either a b
Right AccessLevel
SandstormAccess
parseAccessLevel String
s = String -> Either String AccessLevel
forall a b. a -> Either a b
Left (String -> Either String AccessLevel)
-> String -> Either String AccessLevel
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", 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 :: AccessLevel -> [Permission]
accessLevelToPermissions AccessLevel
ViewAccess      = [Permission
ViewPermission]
accessLevelToPermissions AccessLevel
AddAccess       = [Permission
ViewPermission, Permission
AddPermission]
accessLevelToPermissions AccessLevel
EditAccess      = [Permission
ViewPermission, Permission
AddPermission, Permission
EditPermission]
accessLevelToPermissions AccessLevel
SandstormAccess = []  -- detected from request header

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

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

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