Scotty web framework 源码初探

scotty 是一款非常容易上手的、构建在 WAI/Wrap 之上的 Haskell web frameowrk，官方文档的 start 例子：

{-# LANGUAGE OverloadedStrings #-}
import Web.Scotty

import Data.Monoid (mconcat)

main = scotty 3000 $
    get "/:word" $ do
        beam <- param "word"
        html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]

编译运行即可体验简单的 web 应用。

放到末尾看 scotty类型，先从简单的入手。

添加 Route

增加不同的 url route 和对应的 handler方法如下：

{-# LANGUAGE OverloadedStrings #-}
import Web.Scotty

main = scotty 3000 $
    get "/foo" $ do
      ...
    get "/bar" $ do
        ...

查看文档：

scotty :: Port -> ScottyM () -> IO ()

get :: RoutePattern -> ActionM () -> ScottyM ()

这里就有点奇怪了，get方法需要两个参数 RoutePattern 和ActionM () 然后返回 ScottyM ()。多次调用 get方法每次都返回 ScottyM () ，scotty使用的只是最后一个 ScottyM ()，那中间设置的那些ScottyM ()咧？

我们继续深入看get方法的实现。

get = addroute GET

addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM ()
addroute = Trans.addroute

继续看源码

addroute :: (ScottyError e, MonadIO m) => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT e m ()
addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) (Just method) pat action) s

到这一步就能解惑了，每一次使用get方法，都会 modify ScottyT e m ()(也就是 scottyM() )，上面的方法实现里：

route :: (ScottyError e, MonadIO m) => RouteOptions -> ErrorHandler e m -> Maybe StdMethod -> RoutePattern -> ActionT e m () -> Middleware m

addRoute :: Middleware m -> ScottyState e m -> ScottyState e m
addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs }

\s -> addRoute (route ...) s

这个 lambda 中的 s::ScottyState e m。完美。

类似的还有：

post :: RoutePattern -> ActionM () -> ScottyM ()
put :: RoutePattern -> ActionM () -> ScottyM ()
delete :: RoutePattern -> ActionM () -> ScottyM ()
patch :: RoutePattern -> ActionM () -> ScottyM ()
options :: RoutePattern -> ActionM () -> ScottyM ()

RoutePattern

{-# LANGUAGE OverloadedStrings #-}
...
get "/foo/:bar" $ ...

其实就是：

get (capture "/foo/:bar") $ ...

使用了OverloadedStrings 扩展不需要显式地写 capture。源码：

instance IsString RoutePattern where
    fromString = Capture . pack

RoutePattern 的定义：

data RoutePattern = Capture   Text
                  | Literal   Text
                  | Function  (Request -> Maybe [Param])

除了上面的 capture URL 匹配方式，还支持正则匹配：

regex :: String -> RoutePattern

复杂的方法匹配：

function :: (Request -> Maybe [Param]) -> RoutePattern

以及精确匹配：

literal :: String -> RoutePattern

middleware

middleware :: Middleware -> ScottyM ()
middleware = Trans.middleware

Trans.middleware的定义：

middleware :: Middleware -> ScottyT e m ()
middleware = ScottyT . modify . addMiddleware

addMiddleware :: Wai.Middleware -> ScottyState e m -> ScottyState e m
addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms }

获取请求参数

request :: ActionM Request
request = Trans.request


-- Trans.request
-- | Get the 'Request' object.
request :: Monad m => ActionT e m Request
request = ActionT $ liftM getReq ask

比较简单，这里注意下 liftM，提升一个函数到 monad m

liftM :: Monad m => (a1 -> r) -> m a1 -> m r

getReq就是 data ActionEnv的获取getReq的函数咯：

data ActionEnv = Env { getReq       :: Request
                     , getParams    :: [Param]
                     , getBody      :: IO ByteString
                     , getBodyChunk :: IO BS.ByteString
                     , getFiles     :: [File]
                     }

newtype ActionT e m a = ActionT { runAM :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a }
    deriving ( Functor, Applicative, MonadIO )

这里有点复杂，我们知道ask :: m r ，这是个多态函数，所以具体是什么类型？

我们注意到：

request :: Monad m => ActionT e m Request
request = ActionT $ ...

这里的ActionT显然是数据构造子（data constructor），它的类型是 ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a -> ActionT e m a

那么 liftM getReq ask的类型就是 ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a 又结合 request::ActionT e m Request 所以：

liftM getReq ask :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) Request

liftM getReq ask 的计算顺序是先ask 然后再 liftM getReq

我们知道 liftM :: Monad m => (a1 -> r) -> m a1 -> m r，不改变 m 而是修改 m里的 a1，那么:

ask :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a

我们先用a 代表 ask :: m r 中的 r 。我们当然猜测它是ActionEnv，但是还需要严密地推断。

这时候，就需要一个额外知识:

instance MonadReader r m => MonadReader r (ExceptT e m) where
    ask   = lift ask
    local = mapExceptT . local
    reader = lift . reader

ExceptT e m 实现里 MonadReader r m，所以我们关注的 ask 就是 ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a的 ask

MonadReader r (ExceptT e m) 的 ask = lift ask 。

结合 lift :: (MonadTrans t, Monad m) => m a -> t m a 的定义， m a 提升（lift）到了 t m a 。

这里就是： (ReaderT ActionEnv (StateT ScottyResponse m)) a 提升（lift）到了 ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a。

(ReaderT ActionEnv (StateT ScottyResponse m)) 的 ask 我们熟悉， ask :: Monad m => ReaderT r m r 也就是 (ReaderT ActionEnv (StateT ScottyResponse m)) ActionEnv 把这个结构lift到 ExceptT ... 最终得到：

ask :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) ActionEnv

呼呼。

至于 liftM getReq ask的类型就得到 liftM getReq ask :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) Request

然后再结合上最前面的ActionT 得到 request :: ActionT e m Request

此外，我们在源码里有：

instance (Monad m, ScottyError e) => Monad.Monad (ActionT e m) where
    return = ActionT . return
    ActionT m >>= k = ActionT (m >>= runAM . k)
#if !(MIN_VERSION_base(4,13,0))
    fail = Fail.fail
#endif

instance ScottyError e => MonadTrans (ActionT e) where
    lift = ActionT . lift . lift . lift

instance (MonadReader r m, ScottyError e) => MonadReader r (ActionT e m) where
    {-# INLINE ask #-}
    ask = lift ask
    {-# INLINE local #-}
    local f = ActionT . mapExceptT (mapReaderT (mapStateT $ local f)) . runAM

这里稍微注意一下 return = ActionT . retrun 。左边的 return 是 Monad.Monad (ActionT e m) 的，右边的return:

return a = ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a

然后再用ActionT包装了一下。

>>= 操作也是类似，实质上是先将 ActionT脱去做计算，最后再包上ActionT。

类似的还有：

header :: Text -> ActionM (Maybe Text)
headers :: ActionM [(Text, Text)]
body :: ActionM ByteString

bodyReader :: ActionM (IO ByteString)

param :: Parsable a => Text -> ActionM a
params :: ActionM [Param]

jsonData :: FromJSON a => ActionM a
files :: ActionM [File]

修改Response

status :: Status -> ActionM ()
addHeader :: Text -> Text -> ActionM ()
setHeader :: Text -> Text -> ActionM ()
redirect :: Text -> ActionM a

设置 Response

text :: Text -> ActionM ()
html :: Text -> ActionM ()
file :: FilePath -> ActionM ()
json :: ToJSON a => a -> ActionM ()
stream :: StreamingBody -> ActionM ()
raw :: ByteString -> ActionM ()

Exception

raise :: Text -> ActionM a
raiseStatus :: Status -> Text -> ActionM a
rescue :: ActionM a -> (Text -> ActionM a) -> ActionM a
next :: ActionM a
finish :: ActionM a
defaultHandler :: (Text -> ActionM ()) -> ScottyM ()
liftAndCatchIO :: IO a -> ActionM a

Scotty

type ScottyM = ScottyT Text IO
type ActionM = ActionT Text IO

-- | Run a scotty application using the warp server.
scotty :: Port -> ScottyM () -> IO ()
scotty p = Trans.scottyT p id

跟进 Trans.scottyT 看看

-- | Run a scotty application using the warp server.
-- NB: scotty p === scottyT p id
scottyT :: (Monad m, MonadIO n)
        => Port
        -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.
        -> ScottyT e m ()
        -> n ()
scottyT p = scottyOptsT $ def { settings = setPort p (settings def) }

主要是设置 settings 的端口。

还有个 def :: forall a. Default a => a 主要是获取 a 的默认值。

-- | Run a scotty application using the warp server, passing extra options.
-- NB: scottyOpts opts === scottyOptsT opts id
scottyOptsT :: (Monad m, MonadIO n)
            => Options
            -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.
            -> ScottyT e m ()
            -> n ()
scottyOptsT opts runActionToIO s = do
    when (verbose opts > 0) $
        liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)"
    liftIO . runSettings (settings opts) =<< scottyAppT runActionToIO s

这里要注意 =<< 操作符：

=<< :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b

回忆一下 >>= 的类型:

>>= ::  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b

最后就是 scottyAppT

-- | Turn a scotty application into a WAI 'Application', which can be
-- run with any WAI handler.
-- NB: scottyApp === scottyAppT id
scottyAppT :: (Monad m, Monad n)
           => (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action.
           -> ScottyT e m ()
           -> n Application
scottyAppT runActionToIO defs = do
    let s = execState (runS defs) def
    let rapp req callback = runActionToIO (foldl (flip ($)) notFoundApp (routes s) req) >>= callback
    return $ foldl (flip ($)) rapp (middlewares s)

runS 的定义：

newtype ScottyT e m a = ScottyT { runS :: State (ScottyState e m) a }
    deriving ( Functor, Applicative, Monad )

let s = execState (runS defs) def 的结果 s :: ScottyState e m 它的默认值定义：

instance Default (ScottyState e m) where
    def = ScottyState [] [] Nothing def

----- Transformer Aware Applications/Middleware -----
type Middleware m = Application m -> Application m
type Application m = Request -> m Response

--------------- Scotty Applications -----------------
data ScottyState e m =
    ScottyState { middlewares :: [Wai.Middleware]
                , routes :: [Middleware m]
                , handler :: ErrorHandler e m
                , routeOptions :: RouteOptions
                }

notFoundApp :: Monad m => Scotty.Application m
notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")]
                       $ fromByteString "<h1>404: File Not Found!</h1>"

这里比较复杂点的代码是：

    let rapp req callback = runActionToIO (foldl (flip ($)) notFoundApp (routes s) req) >>= callback

先看

foldl (flip ($)) notFoundApp (routes s) req

这里是以 notFoundApp 为初始值，取 routes s :: [Middleware m] 数组里的第一个值，结合 flip ($) 元算，就是 Middleware m $ notFoundApp 结果依然是一个 Application m 毕竟 Middleware m 作为中间件只是包裹了一下 Application m 不改变其类型。得到结果后，依次取数组的值一直执行，这里就是把所有的 routes s 都挂载到初始的 Application m 上（notFoundApp就是初始的 App ，对所有的请求都返回 404）

我们知道 type Application m = Request -> m Response 然后给一个 req 之后，会返回 m response

然后再由 runActionToIO 执行，最后 >>= callback

注意 rapp :: Request -> (Response -> IO b) -> IO b等下回头看。

整个函数最后的结果:

    return $ foldl (flip ($)) rapp (middlewares s)

这里也是用类似的 foldl 将 [Wai.Middleware] 应用到 rapp 上。

这里要注意，middlewares s :: [Wai.Middleware]

而 Wai.Middleware的定义：

type Middleware = Application -> Application
type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived.

可以看出来刚刚提到的 rapp 就是 Wai.Application 。 callback :: Response -> IO ResponseReceived。

2023-02-06

blog