{-# LANGUAGE FlexibleContexts, FlexibleInstances,
OverloadedStrings, RankNTypes, ScopedTypeVariables #-}
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.Reader as MR
import qualified Control.Monad.State as MS
import Control.Monad.Trans.Resource (InternalState)
import Data.String (fromString)
import qualified Data.Text as T
import Network.HTTP.Types
import Network.Wai (Request(..))
import qualified Text.Regex as Regex
import Web.Scotty.Action
import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, File, handler, addRoute, defaultScottyResponse)
import Web.Scotty.Util (decodeUtf8Lenient)
import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction)
get :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
get :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
get = StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
GET
post :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
post :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
post = StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
POST
put :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
put :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
put = StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
PUT
delete :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
delete :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
delete = StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
DELETE
patch :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
patch :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
patch = StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
PATCH
options :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
options :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
options = StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
forall (m :: * -> *).
MonadUnliftIO m =>
StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
addroute StdMethod
OPTIONS
matchAny :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
matchAny :: forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
matchAny RoutePattern
pat ActionT m ()
action =
ReaderT Options (State (ScottyState m)) () -> ScottyT m ()
forall (m :: * -> *) a.
ReaderT Options (State (ScottyState m)) a -> ScottyT m a
ScottyT (ReaderT Options (State (ScottyState m)) () -> ScottyT m ())
-> ReaderT Options (State (ScottyState m)) () -> ScottyT m ()
forall a b. (a -> b) -> a -> b
$ do
Options
serverOptions <- ReaderT Options (State (ScottyState m)) Options
forall r (m :: * -> *). MonadReader r m => m r
MR.ask
(ScottyState m -> ScottyState m)
-> ReaderT Options (State (ScottyState m)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
MS.modify ((ScottyState m -> ScottyState m)
-> ReaderT Options (State (ScottyState m)) ())
-> (ScottyState m -> ScottyState m)
-> ReaderT Options (State (ScottyState m)) ()
forall a b. (a -> b) -> a -> b
$ \ScottyState m
s ->
(BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m
forall (m :: * -> *).
(BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m
addRoute
(Options
-> RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
forall (m :: * -> *).
MonadUnliftIO m =>
Options
-> RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
route Options
serverOptions (ScottyState m -> RouteOptions
forall (m :: * -> *). ScottyState m -> RouteOptions
routeOptions ScottyState m
s) (ScottyState m -> Maybe (ErrorHandler m)
forall (m :: * -> *). ScottyState m -> Maybe (ErrorHandler m)
handler ScottyState m
s) Maybe StdMethod
forall a. Maybe a
Nothing RoutePattern
pat ActionT m ()
action)
ScottyState m
s
notFound :: (MonadUnliftIO m) => ActionT m () -> ScottyT m ()
notFound :: forall (m :: * -> *).
MonadUnliftIO m =>
ActionT m () -> ScottyT m ()
notFound ActionT m ()
action = RoutePattern -> ActionT m () -> ScottyT m ()
forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
matchAny ((Request -> Maybe [Param]) -> RoutePattern
Function (\Request
req -> [Param] -> Maybe [Param]
forall a. a -> Maybe a
Just [(Text
"path", Request -> Text
path Request
req)])) (Status -> ActionT m ()
forall (m :: * -> *). MonadIO m => Status -> ActionT m ()
status Status
status404 ActionT m () -> ActionT m () -> ActionT m ()
forall a b. ActionT m a -> ActionT m b -> ActionT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ActionT m ()
action)
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 =
ReaderT Options (State (ScottyState m)) () -> ScottyT m ()
forall (m :: * -> *) a.
ReaderT Options (State (ScottyState m)) a -> ScottyT m a
ScottyT (ReaderT Options (State (ScottyState m)) () -> ScottyT m ())
-> ReaderT Options (State (ScottyState m)) () -> ScottyT m ()
forall a b. (a -> b) -> a -> b
$ do
Options
serverOptions <- ReaderT Options (State (ScottyState m)) Options
forall r (m :: * -> *). MonadReader r m => m r
MR.ask
(ScottyState m -> ScottyState m)
-> ReaderT Options (State (ScottyState m)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
MS.modify ((ScottyState m -> ScottyState m)
-> ReaderT Options (State (ScottyState m)) ())
-> (ScottyState m -> ScottyState m)
-> ReaderT Options (State (ScottyState m)) ()
forall a b. (a -> b) -> a -> b
$ \ScottyState m
s ->
(BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m
forall (m :: * -> *).
(BodyInfo -> Middleware m) -> ScottyState m -> ScottyState m
addRoute
(Options
-> RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
forall (m :: * -> *).
MonadUnliftIO m =>
Options
-> RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
route Options
serverOptions (ScottyState m -> RouteOptions
forall (m :: * -> *). ScottyState m -> RouteOptions
routeOptions ScottyState m
s) (ScottyState m -> Maybe (ErrorHandler m)
forall (m :: * -> *). ScottyState m -> Maybe (ErrorHandler m)
handler ScottyState m
s) (StdMethod -> Maybe StdMethod
forall a. a -> Maybe a
Just StdMethod
method) RoutePattern
pat ActionT m ()
action)
ScottyState m
s
route :: (MonadUnliftIO m) =>
Options
-> RouteOptions
-> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m
route :: forall (m :: * -> *).
MonadUnliftIO m =>
Options
-> RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
route Options
serverOpts 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
methodMatches :: Bool
methodMatches :: Bool
methodMatches = Bool -> (StdMethod -> Bool) -> Maybe StdMethod -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\StdMethod
x -> (StdMethod -> Either ByteString StdMethod
forall a b. b -> Either a b
Right StdMethod
x Either ByteString StdMethod -> Either ByteString StdMethod -> Bool
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
BodyInfo
cbi <- BodyInfo -> m BodyInfo
forall (m :: * -> *). MonadIO m => BodyInfo -> m BodyInfo
cloneBodyInfo BodyInfo
bodyInfo
ActionEnv
env <- BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv
forall (m :: * -> *).
MonadIO m =>
BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv
mkEnv BodyInfo
cbi Request
req [Param]
captures RouteOptions
opts
Maybe Response
res <- Options
-> Maybe (ErrorHandler m)
-> ActionEnv
-> ActionT m ()
-> m (Maybe Response)
forall (m :: * -> *).
MonadUnliftIO m =>
Options
-> Maybe (ErrorHandler m)
-> ActionEnv
-> ActionT m ()
-> m (Maybe Response)
runAction Options
serverOpts Maybe (ErrorHandler m)
h ActionEnv
env ActionT m ()
action
m Response
-> (Response -> m Response) -> Maybe Response -> m Response
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Response
tryNext Response -> m Response
forall a. a -> m a
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Request -> Text
path Request
req = [Param] -> Maybe [Param]
forall a. a -> Maybe a
Just []
| Bool
otherwise = Maybe [Param]
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') Text
pat) ([Text] -> [Text]
forall {a}. (Eq a, IsString a) => [a] -> [a]
compress ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
""Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:Request -> [Text]
pathInfo Request
req) []
where go :: [Text] -> [Text] -> [Param] -> Maybe [Param]
go [] [] [Param]
prs = [Param] -> Maybe [Param]
forall a. a -> Maybe a
Just [Param]
prs
go [] [Text]
r [Param]
prs | Text -> Bool
T.null ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
r) = [Param] -> Maybe [Param]
forall a. a -> Maybe a
Just [Param]
prs
| Bool
otherwise = Maybe [Param]
forall a. Maybe a
Nothing
go [Text]
p [] [Param]
prs | Text -> Bool
T.null ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
p) = [Param] -> Maybe [Param]
forall a. a -> Maybe a
Just [Param]
prs
| Bool
otherwise = Maybe [Param]
forall a. Maybe a
Nothing
go (Text
p:[Text]
ps) (Text
r:[Text]
rs) [Param]
prs = case Text -> Maybe (Char, Text)
T.uncons Text
p of
Just (Char
':', Text
name) -> [Text] -> [Text] -> [Param] -> Maybe [Param]
go [Text]
ps [Text]
rs ([Param] -> Maybe [Param]) -> [Param] -> Maybe [Param]
forall a b. (a -> b) -> a -> b
$ (Text
name, Text
r) Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: [Param]
prs
Maybe (Char, Text)
_ | Text
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
r -> [Text] -> [Text] -> [Param] -> Maybe [Param]
go [Text]
ps [Text]
rs [Param]
prs
| Bool
otherwise -> Maybe [Param]
forall a. Maybe a
Nothing
compress :: [a] -> [a]
compress (a
"":rest :: [a]
rest@(a
"":[a]
_)) = [a] -> [a]
compress [a]
rest
compress (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
compress [a]
xs
compress [] = []
path :: Request -> T.Text
path :: Request -> Text
path = Char -> Text -> Text
T.cons Char
'/' (Text -> Text) -> (Request -> Text) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> (Request -> [Text]) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo
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]
pathps RouteOptions
opts = do
let
getFormData :: InternalState -> ParseRequestBodyOptions -> IO ([Param], [File FilePath])
getFormData :: InternalState
-> ParseRequestBodyOptions -> IO ([Param], [File FilePath])
getFormData InternalState
istate ParseRequestBodyOptions
prbo = InternalState
-> ParseRequestBodyOptions
-> Request
-> BodyInfo
-> RouteOptions
-> IO ([Param], [File FilePath])
getFormParamsAndFilesAction InternalState
istate ParseRequestBodyOptions
prbo Request
req BodyInfo
bodyInfo RouteOptions
opts
queryps :: [Param]
queryps = Query -> [Param]
parseEncodedParams (Query -> [Param]) -> Query -> [Param]
forall a b. (a -> b) -> a -> b
$ Request -> Query
queryString Request
req
TVar ScottyResponse
responseInit <- IO (TVar ScottyResponse) -> m (TVar ScottyResponse)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar ScottyResponse) -> m (TVar ScottyResponse))
-> IO (TVar ScottyResponse) -> m (TVar ScottyResponse)
forall a b. (a -> b) -> a -> b
$ ScottyResponse -> IO (TVar ScottyResponse)
forall a. a -> IO (TVar a)
newTVarIO ScottyResponse
defaultScottyResponse
ActionEnv -> m ActionEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ActionEnv -> m ActionEnv) -> ActionEnv -> m ActionEnv
forall a b. (a -> b) -> a -> b
$ Request
-> [Param]
-> [Param]
-> (InternalState
-> ParseRequestBodyOptions -> IO ([Param], [File FilePath]))
-> IO ByteString
-> IO ByteString
-> TVar ScottyResponse
-> ActionEnv
Env Request
req [Param]
pathps [Param]
queryps InternalState
-> ParseRequestBodyOptions -> IO ([Param], [File FilePath])
getFormData (BodyInfo -> RouteOptions -> IO ByteString
getBodyAction BodyInfo
bodyInfo RouteOptions
opts) (BodyInfo -> IO ByteString
getBodyChunkAction BodyInfo
bodyInfo) TVar ScottyResponse
responseInit
parseEncodedParams :: Query -> [Param]
parseEncodedParams :: Query -> [Param]
parseEncodedParams Query
qs = [ ( ByteString -> Text
decodeUtf8Lenient ByteString
k, Text -> (ByteString -> Text) -> Maybe ByteString -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ByteString -> Text
decodeUtf8Lenient Maybe ByteString
v) | (ByteString
k,Maybe ByteString
v) <- Query
qs ]
regex :: String -> RoutePattern
regex :: FilePath -> RoutePattern
regex FilePath
pat = (Request -> Maybe [Param]) -> RoutePattern
Function ((Request -> Maybe [Param]) -> RoutePattern)
-> (Request -> Maybe [Param]) -> RoutePattern
forall a b. (a -> b) -> a -> b
$ \ Request
req -> ((FilePath, FilePath, FilePath, [FilePath]) -> [Param])
-> Maybe (FilePath, FilePath, FilePath, [FilePath])
-> Maybe [Param]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Int, FilePath) -> Param) -> [(Int, FilePath)] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack (FilePath -> Text) -> (Int -> FilePath) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> Text) -> (FilePath -> Text) -> (Int, FilePath) -> Param
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** FilePath -> Text
T.pack) ([(Int, FilePath)] -> [Param])
-> ((FilePath, FilePath, FilePath, [FilePath])
-> [(Int, FilePath)])
-> (FilePath, FilePath, FilePath, [FilePath])
-> [Param]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [FilePath] -> [(Int, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ([FilePath] -> [(Int, FilePath)])
-> ((FilePath, FilePath, FilePath, [FilePath]) -> [FilePath])
-> (FilePath, FilePath, FilePath, [FilePath])
-> [(Int, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath, FilePath, [FilePath]) -> [FilePath]
forall {a} {a} {c}. (a, a, c, [a]) -> [a]
strip)
(Regex
-> FilePath -> Maybe (FilePath, FilePath, FilePath, [FilePath])
Regex.matchRegexAll Regex
rgx (FilePath -> Maybe (FilePath, FilePath, FilePath, [FilePath]))
-> FilePath -> Maybe (FilePath, FilePath, FilePath, [FilePath])
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Request -> Text
path Request
req)
where rgx :: Regex
rgx = FilePath -> Regex
Regex.mkRegex FilePath
pat
strip :: (a, a, c, [a]) -> [a]
strip (a
_, a
match, c
_, [a]
subs) = a
match a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
subs
capture :: String -> RoutePattern
capture :: FilePath -> RoutePattern
capture = FilePath -> RoutePattern
forall a. IsString a => FilePath -> a
fromString
function :: (Request -> Maybe [Param]) -> RoutePattern
function :: (Request -> Maybe [Param]) -> RoutePattern
function = (Request -> Maybe [Param]) -> RoutePattern
Function
literal :: String -> RoutePattern
literal :: FilePath -> RoutePattern
literal = Text -> RoutePattern
Literal (Text -> RoutePattern)
-> (FilePath -> Text) -> FilePath -> RoutePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack