{-# 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.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 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 :: (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 = State (ScottyState m) () -> ScottyT m ()
forall (m :: * -> *) a. State (ScottyState m) a -> ScottyT m a
ScottyT (State (ScottyState m) () -> ScottyT m ())
-> State (ScottyState m) () -> ScottyT m ()
forall a b. (a -> b) -> a -> b
$ (ScottyState m -> ScottyState m) -> State (ScottyState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
MS.modify ((ScottyState m -> ScottyState m) -> State (ScottyState m) ())
-> (ScottyState m -> ScottyState m) -> 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 (RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
forall (m :: * -> *).
MonadUnliftIO m =>
RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
route (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 = State (ScottyState m) () -> ScottyT m ()
forall (m :: * -> *) a. State (ScottyState m) a -> ScottyT m a
ScottyT (State (ScottyState m) () -> ScottyT m ())
-> State (ScottyState m) () -> ScottyT m ()
forall a b. (a -> b) -> a -> b
$ (ScottyState m -> ScottyState m) -> State (ScottyState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
MS.modify ((ScottyState m -> ScottyState m) -> State (ScottyState m) ())
-> (ScottyState m -> ScottyState m) -> 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 (RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
forall (m :: * -> *).
MonadUnliftIO m =>
RouteOptions
-> Maybe (ErrorHandler m)
-> Maybe StdMethod
-> RoutePattern
-> ActionT m ()
-> BodyInfo
-> Middleware m
route (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) =>
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
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
clonedBodyInfo <- 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
clonedBodyInfo Request
req [Param]
captures RouteOptions
opts
Maybe Response
res <- Maybe (ErrorHandler m)
-> ActionEnv -> ActionT m () -> m (Maybe Response)
forall (m :: * -> *).
MonadUnliftIO m =>
Maybe (ErrorHandler m)
-> ActionEnv -> ActionT m () -> m (Maybe Response)
runAction 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
$ (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Request -> Text
path 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 | 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
| Text -> Bool
T.null Text
p = Maybe [Param]
forall a. Maybe a
Nothing
| HasCallStack => Text -> Char
Text -> Char
T.head Text
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' = [Text] -> [Text] -> [Param] -> Maybe [Param]
go [Text]
ps [Text]
rs ([Param] -> Maybe [Param]) -> [Param] -> Maybe [Param]
forall a b. (a -> b) -> a -> b
$ (HasCallStack => Text -> Text
Text -> Text
T.tail Text
p, Text
r) Param -> [Param] -> [Param]
forall a. a -> [a] -> [a]
: [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 = Text -> Text
T.fromStrict (Text -> Text) -> (Request -> Text) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
TS.cons Char
'/' (Text -> Text) -> (Request -> Text) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
TS.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]
captureps RouteOptions
opts = do
([Param]
formps, [File ByteString]
bodyFiles) <- IO ([Param], [File ByteString]) -> m ([Param], [File ByteString])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Param], [File ByteString]) -> m ([Param], [File ByteString]))
-> IO ([Param], [File ByteString])
-> m ([Param], [File ByteString])
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 (ByteString -> [Param]) -> ByteString -> [Param]
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 <- 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]
-> [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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
v) | (Text
k,Maybe Text
v) <- ByteString -> QueryText
parseQueryText ByteString
bs ]
regex :: String -> RoutePattern
regex :: String -> RoutePattern
regex String
pattern = (Request -> Maybe [Param]) -> RoutePattern
Function ((Request -> Maybe [Param]) -> RoutePattern)
-> (Request -> Maybe [Param]) -> RoutePattern
forall a b. (a -> b) -> a -> b
$ \ Request
req -> ((String, String, String, [String]) -> [Param])
-> Maybe (String, String, String, [String]) -> 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, String) -> Param) -> [(Int, String)] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> (String -> Text) -> (Int, String) -> 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')
*** String -> Text
T.pack) ([(Int, String)] -> [Param])
-> ((String, String, String, [String]) -> [(Int, String)])
-> (String, String, String, [String])
-> [Param]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ([String] -> [(Int, String)])
-> ((String, String, String, [String]) -> [String])
-> (String, String, String, [String])
-> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String, String, [String]) -> [String]
forall {a} {a} {c}. (a, a, c, [a]) -> [a]
strip)
(Regex -> String -> Maybe (String, String, String, [String])
Regex.matchRegexAll Regex
rgx (String -> Maybe (String, String, String, [String]))
-> String -> Maybe (String, String, String, [String])
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
subs
capture :: String -> RoutePattern
capture :: String -> RoutePattern
capture = String -> RoutePattern
forall a. IsString a => String -> a
fromString
function :: (Request -> Maybe [Param]) -> RoutePattern
function :: (Request -> Maybe [Param]) -> RoutePattern
function = (Request -> Maybe [Param]) -> RoutePattern
Function
literal :: String -> RoutePattern
literal :: String -> RoutePattern
literal = Text -> RoutePattern
Literal (Text -> RoutePattern)
-> (String -> Text) -> String -> RoutePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack