{-# 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 :: (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 :: (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 :: (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 :: (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 :: (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 :: (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
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
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)
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
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
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
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
| Bool
otherwise = forall a. Maybe a
Nothing
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
| Bool
otherwise = forall a. Maybe a
Nothing
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
| Text -> Bool
T.null Text
p = forall a. Maybe a
Nothing
| 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
| Bool
otherwise = 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 forall a. a -> [a] -> [a]
: [a] -> [a]
compress [a]
xs
compress [] = []
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
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 ]
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
capture :: String -> RoutePattern
capture :: String -> RoutePattern
capture = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack