81 lines
2.5 KiB
Haskell
81 lines
2.5 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module Yesod.Core.Dispatch
|
|
( -- * Quasi-quoted routing
|
|
parseRoutes
|
|
, parseRoutesNoCheck
|
|
, parseRoutesFile
|
|
, parseRoutesFileNoCheck
|
|
, mkYesod
|
|
-- ** More fine-grained
|
|
, mkYesodData
|
|
, mkYesodSubData
|
|
, mkYesodDispatch
|
|
, mkYesodSubDispatch
|
|
-- ** Path pieces
|
|
, PathPiece (..)
|
|
, PathMultiPiece (..)
|
|
, Texts
|
|
-- * Convert to WAI
|
|
, toWaiApp
|
|
-- * WAI subsites
|
|
, WaiSubsite (..)
|
|
) where
|
|
|
|
import Prelude hiding (exp)
|
|
import Yesod.Core.Internal.TH
|
|
|
|
import Web.PathPieces
|
|
|
|
import qualified Network.Wai as W
|
|
|
|
import Data.ByteString.Lazy.Char8 ()
|
|
|
|
import Data.Text (Text)
|
|
import Data.Monoid (mappend)
|
|
import qualified Data.ByteString as S
|
|
import qualified Blaze.ByteString.Builder
|
|
import Network.HTTP.Types (status301)
|
|
import Yesod.Routes.Parse
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Class.Yesod
|
|
import Yesod.Core.Class.Dispatch
|
|
import Yesod.Core.Internal.Run
|
|
|
|
-- | Convert the given argument into a WAI application, executable with any WAI
|
|
-- handler. Note that, in versions of Yesod prior to 1.2, this would include
|
|
-- some default middlewares (GZIP and autohead). This is no longer the case; if
|
|
-- you want these middlewares, you should provide them yourself.
|
|
toWaiApp :: YesodDispatch site => site -> IO W.Application
|
|
toWaiApp site = do
|
|
logger <- makeLogger site
|
|
sb <- makeSessionBackend site
|
|
let yre = YesodRunnerEnv
|
|
{ yreLogger = logger
|
|
, yreSite = site
|
|
, yreSessionBackend = sb
|
|
}
|
|
return $ \req ->
|
|
case cleanPath site $ W.pathInfo req of
|
|
Left pieces -> sendRedirect site pieces req
|
|
Right pieces -> yesodDispatch yre req
|
|
{ W.pathInfo = pieces
|
|
}
|
|
where
|
|
sendRedirect :: Yesod master => master -> [Text] -> W.Application
|
|
sendRedirect y segments' env =
|
|
return $ W.responseLBS status301
|
|
[ ("Content-Type", "text/plain")
|
|
, ("Location", Blaze.ByteString.Builder.toByteString dest')
|
|
] "Redirecting"
|
|
where
|
|
dest = joinPath y (resolveApproot y env) segments' []
|
|
dest' =
|
|
if S.null (W.rawQueryString env)
|
|
then dest
|
|
else (dest `mappend`
|
|
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
|