{-# LANGUAGE FlexibleContexts, FlexibleInstances,
             OverloadedStrings, RankNTypes, ScopedTypeVariables #-}
{-# language PackageImports #-}
module Web.Scotty.Route
    ( get, post, put, delete, patch, options, addroute, matchAny, notFound,
      capture, regex, function, literal
    ) where

import           Control.Arrow ((***))
import Control.Concurrent.STM (newTVarIO)
import           Control.Monad.IO.Class (MonadIO(..))
import UnliftIO (MonadUnliftIO(..))
import qualified Control.Monad.State as MS

import qualified Data.ByteString.Char8 as B

import           Data.Maybe (fromMaybe)
import           Data.String (fromString)
import qualified Data.Text.Lazy as T
import qualified Data.Text as TS

import           Network.HTTP.Types
import           Network.Wai (Request(..))

import           Prelude ()
import "base-compat-batteries" Prelude.Compat

import qualified Text.Regex as Regex

import           Web.Scotty.Action
import           Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse)
import           Web.Scotty.Util (strictByteStringToLazyText)
import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction)

-- | get = 'addroute' 'GET'
get :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
get :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
get = forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
GET

-- | post = 'addroute' 'POST'
post :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
post :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
post = forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
POST

-- | put = 'addroute' 'PUT'
put :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
put :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
put = forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
PUT

-- | delete = 'addroute' 'DELETE'
delete :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
delete :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
delete = forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
DELETE

-- | patch = 'addroute' 'PATCH'
patch :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
patch :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
patch = forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
PATCH

-- | options = 'addroute' 'OPTIONS'
options :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
options :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
options = forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
OPTIONS

-- | Add a route that matches regardless of the HTTP verb.
matchAny :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
matchAny :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
matchAny RoutePattern
pat ActionT m ()
action = forall (m :: * -> *) a. State (ScottyState m) a -> ScottyT m a
ScottyT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
MS.modify forall a b. (a -> b) -> a -> b
$ \ScottyState m
s -> forall (m :: * -> *).
(BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m
addRoute (forall (m :: * -> *).
MonadUnliftIO m =>
RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
route (forall (m :: * -> *). ScottyState m -> RouteOptions
routeOptions ScottyState m
s) (forall (m :: * -> *). ScottyState m -> Maybe (ErrorHandler m)
handler ScottyState m
s) forall a. Maybe a
Nothing RoutePattern
pat ActionT m ()
action) ScottyState m
s

-- | Specify an action to take if nothing else is found. Note: this _always_ matches,
-- so should generally be the last route specified.
notFound :: (MonadUnliftIO m) => ActionT m () -> ScottyT m ()
notFound :: forall (m :: * -> *).
MonadUnliftIO m =>
ActionT m () -> ScottyT m ()
notFound ActionT m ()
action = forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
matchAny ((Request -> Maybe [Param]) -> RoutePattern
Function (\Request
req -> forall a. a -> Maybe a
Just [(Text
"path", Request -> Text
path Request
req)])) (forall (m :: * -> *). MonadIO m => Status -> ActionT m ()
status Status
status404 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ActionT m ()
action)

-- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec,
-- and a body ('Action') which modifies the response.
--
-- > addroute GET "/" $ text "beam me up!"
--
-- The path spec can include values starting with a colon, which are interpreted
-- as /captures/. These are named wildcards that can be looked up with 'captureParam'.
--
-- > addroute GET "/foo/:bar" $ do
-- >     v <- captureParam "bar"
-- >     text v
--
-- >>> curl http://localhost:3000/foo/something
-- something
--
-- NB: the 'RouteOptions' and the exception handler of the newly-created route will be
-- copied from the previously-created routes.
addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute :: forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
method RoutePattern
pat ActionT m ()
action = forall (m :: * -> *) a. State (ScottyState m) a -> ScottyT m a
ScottyT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
MS.modify forall a b. (a -> b) -> a -> b
$ \ScottyState m
s -> forall (m :: * -> *).
(BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m
addRoute (forall (m :: * -> *).
MonadUnliftIO m =>
RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
route (forall (m :: * -> *). ScottyState m -> RouteOptions
routeOptions ScottyState m
s) (forall (m :: * -> *). ScottyState m -> Maybe (ErrorHandler m)
handler ScottyState m
s) (forall a. a -> Maybe a
Just StdMethod
method) RoutePattern
pat ActionT m ()
action) ScottyState m
s

route :: (MonadUnliftIO m) =>
         RouteOptions
      -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m
route :: forall (m :: * -> *).
MonadUnliftIO m =>
RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
route RouteOptions
opts Maybe (ErrorHandler m)
h Maybe StdMethod
method RoutePattern
pat ActionT m ()
action BodyInfo
bodyInfo Application m
app Request
req =
  let tryNext :: m Response
tryNext = Application m
app Request
req
        {- |
          We match all methods in the case where 'method' is 'Nothing'.
          See https://github.com/scotty-web/scotty/issues/196 and 'matchAny'
        -}
      methodMatches :: Bool
      methodMatches :: Bool
methodMatches = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\StdMethod
x -> (forall a b. b -> Either a b
Right StdMethod
x forall a. Eq a => a -> a -> Bool
== ByteString -> Either ByteString StdMethod
parseMethod (Request -> ByteString
requestMethod Request
req))) Maybe StdMethod
method

  in if Bool
methodMatches
     then case RoutePattern -> Request -> Maybe [Param]
matchRoute RoutePattern
pat Request
req of
            Just [Param]
captures -> do
              -- The user-facing API for "body" and "bodyReader" involve an IO action that
              -- reads the body/chunks thereof only once, so we shouldn't pass in our BodyInfo
              -- directly; otherwise, the body might get consumed and then it would be unavailable
              -- if `next` is called and we try to match further routes.
              -- Instead, make a "cloned" copy of the BodyInfo that allows the IO actions to be called
              -- without messing up the state of the original BodyInfo.
              BodyInfo
clonedBodyInfo <- forall (m :: * -> *). MonadIO m => BodyInfo -> m BodyInfo
cloneBodyInfo BodyInfo
bodyInfo

              ActionEnv
env <- forall (m :: * -> *).
MonadIO m =>
BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv
mkEnv BodyInfo
clonedBodyInfo Request
req [Param]
captures RouteOptions
opts
              Maybe Response
res <- forall (m :: * -> *).
MonadUnliftIO m =>
Maybe (ErrorHandler m)
-> ActionEnv -> ActionT m () -> m (Maybe Response)
runAction Maybe (ErrorHandler m)
h ActionEnv
env ActionT m ()
action
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Response
tryNext forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Response
res
            Maybe [Param]
Nothing -> m Response
tryNext
     else m Response
tryNext

matchRoute :: RoutePattern -> Request -> Maybe [Param]
matchRoute :: RoutePattern -> Request -> Maybe [Param]
matchRoute (Literal Text
pat)  Request
req | Text
pat forall a. Eq a => a -> a -> Bool
== Request -> Text
path Request
req = forall a. a -> Maybe a
Just []
                              | Bool
otherwise       = forall a. Maybe a
Nothing
matchRoute (Function Request -> Maybe [Param]
fun) Request
req = Request -> Maybe [Param]
fun Request
req
matchRoute (Capture Text
pat)  Request
req = [Text] -> [Text] -> [Param] -> Maybe [Param]
go ((Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
==Char
'/') Text
pat) (forall {a}. (Eq a, IsString a) => [a] -> [a]
compress forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
==Char
'/') forall a b. (a -> b) -> a -> b
$ Request -> Text
path Request
req) []
    where go :: [Text] -> [Text] -> [Param] -> Maybe [Param]
go [] [] [Param]
prs = forall a. a -> Maybe a
Just [Param]
prs -- request string and pattern match!
          go [] [Text]
r  [Param]
prs | Text -> Bool
T.null (forall a. Monoid a => [a] -> a
mconcat [Text]
r)  = forall a. a -> Maybe a
Just [Param]
prs -- in case request has trailing slashes
                       | Bool
otherwise           = forall a. Maybe a
Nothing  -- request string is longer than pattern
          go [Text]
p  [] [Param]
prs | Text -> Bool
T.null (forall a. Monoid a => [a] -> a
mconcat [Text]
p)  = forall a. a -> Maybe a
Just [Param]
prs -- in case pattern has trailing slashes
                       | Bool
otherwise           = forall a. Maybe a
Nothing  -- request string is not long enough
          go (Text
p:[Text]
ps) (Text
r:[Text]
rs) [Param]
prs | Text
p forall a. Eq a => a -> a -> Bool
== Text
r          = [Text] -> [Text] -> [Param] -> Maybe [Param]
go [Text]
ps [Text]
rs [Param]
prs -- equal literals, keeping checking
                               | Text -> Bool
T.null Text
p        = forall a. Maybe a
Nothing      -- p is null, but r is not, fail
                               | Text -> Char
T.head Text
p forall a. Eq a => a -> a -> Bool
== Char
':' = [Text] -> [Text] -> [Param] -> Maybe [Param]
go [Text]
ps [Text]
rs forall a b. (a -> b) -> a -> b
$ (Text -> Text
T.tail Text
p, Text
r) forall a. a -> [a] -> [a]
: [Param]
prs -- p is a capture, add to params
                               | Bool
otherwise       = forall a. Maybe a
Nothing      -- both literals, but unequal, fail
          compress :: [a] -> [a]
compress (a
"":rest :: [a]
rest@(a
"":[a]
_)) = [a] -> [a]
compress [a]
rest
          compress (a
x:[a]
xs) = a
x forall a. a -> [a] -> [a]
: [a] -> [a]
compress [a]
xs
          compress [] = []

-- Pretend we are at the top level.
path :: Request -> T.Text
path :: Request -> Text
path = Text -> Text
T.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
TS.cons Char
'/' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
TS.intercalate Text
"/" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo

-- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response
mkEnv :: MonadIO m => BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv
mkEnv :: forall (m :: * -> *).
MonadIO m =>
BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv
mkEnv BodyInfo
bodyInfo Request
req [Param]
captureps RouteOptions
opts = do
  ([Param]
formps, [File ByteString]
bodyFiles) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Request
-> BodyInfo -> RouteOptions -> IO ([Param], [File ByteString])
getFormParamsAndFilesAction Request
req BodyInfo
bodyInfo RouteOptions
opts
  let
    queryps :: [Param]
queryps = ByteString -> [Param]
parseEncodedParams forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawQueryString Request
req
    bodyFiles' :: [(Text, FileInfo ByteString)]
bodyFiles' = [ (ByteString -> Text
strictByteStringToLazyText ByteString
k, FileInfo ByteString
fi) | (ByteString
k,FileInfo ByteString
fi) <- [File ByteString]
bodyFiles ]
  TVar ScottyResponse
responseInit <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO ScottyResponse
defaultScottyResponse
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Request
-> [Param]
-> [Param]
-> [Param]
-> IO ByteString
-> IO ByteString
-> [(Text, FileInfo ByteString)]
-> TVar ScottyResponse
-> ActionEnv
Env Request
req [Param]
captureps [Param]
formps [Param]
queryps (BodyInfo -> RouteOptions -> IO ByteString
getBodyAction BodyInfo
bodyInfo RouteOptions
opts) (BodyInfo -> IO ByteString
getBodyChunkAction BodyInfo
bodyInfo) [(Text, FileInfo ByteString)]
bodyFiles' TVar ScottyResponse
responseInit


parseEncodedParams :: B.ByteString -> [Param]
parseEncodedParams :: ByteString -> [Param]
parseEncodedParams ByteString
bs = [ (Text -> Text
T.fromStrict Text
k, Text -> Text
T.fromStrict forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
v) | (Text
k,Maybe Text
v) <- ByteString -> QueryText
parseQueryText ByteString
bs ]

-- | Match requests using a regular expression.
--   Named captures are not yet supported.
--
-- > get (regex "^/f(.*)r$") $ do
-- >    path <- param "0"
-- >    cap <- param "1"
-- >    text $ mconcat ["Path: ", path, "\nCapture: ", cap]
--
-- >>> curl http://localhost:3000/foo/bar
-- Path: /foo/bar
-- Capture: oo/ba
--
regex :: String -> RoutePattern
regex :: String -> RoutePattern
regex String
pattern = (Request -> Maybe [Param]) -> RoutePattern
Function forall a b. (a -> b) -> a -> b
$ \ Request
req -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
T.pack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a} {c}. (a, a, c, [a]) -> [a]
strip)
                                         (Regex -> String -> Maybe (String, String, String, [String])
Regex.matchRegexAll Regex
rgx forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Request -> Text
path Request
req)
    where rgx :: Regex
rgx = String -> Regex
Regex.mkRegex String
pattern
          strip :: (a, a, c, [a]) -> [a]
strip (a
_, a
match, c
_, [a]
subs) = a
match forall a. a -> [a] -> [a]
: [a]
subs

-- | Standard Sinatra-style route. Named captures are prepended with colons.
--   This is the default route type generated by OverloadedString routes. i.e.
--
-- > get (capture "/foo/:bar") $ ...
--
--   and
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > ...
-- > get "/foo/:bar" $ ...
--
--   are equivalent.
capture :: String -> RoutePattern
capture :: String -> RoutePattern
capture = forall a. IsString a => String -> a
fromString

-- | Build a route based on a function which can match using the entire 'Request' object.
--   'Nothing' indicates the route does not match. A 'Just' value indicates
--   a successful match, optionally returning a list of key-value pairs accessible
--   by 'param'.
--
-- > get (function $ \req -> Just [("version", T.pack $ show $ httpVersion req)]) $ do
-- >     v <- param "version"
-- >     text v
--
-- >>> curl http://localhost:3000/
-- HTTP/1.1
--
function :: (Request -> Maybe [Param]) -> RoutePattern
function :: (Request -> Maybe [Param]) -> RoutePattern
function = (Request -> Maybe [Param]) -> RoutePattern
Function

-- | Build a route that requires the requested path match exactly, without captures.
literal :: String -> RoutePattern
literal :: String -> RoutePattern
literal = Text -> RoutePattern
Literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack