module Network.Wai.Middleware.Routes.Routes
(
parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, mkRoute
, routeDispatch
, showRoute
, Handler
, Routable(..)
, RenderRoute(..)
)
where
import Network.Wai (Middleware, Application, pathInfo, requestMethod)
import Network.HTTP.Types (StdMethod(GET), parseMethod, encodePath, queryTextToQuery)
import Yesod.Routes.Class (Route, RenderRoute(..))
import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)
import Yesod.Routes.TH (mkRenderRouteInstance, mkDispatchClause, ResourceTree(..))
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Blaze.ByteString.Builder (Builder, toByteString)
import Language.Haskell.TH.Syntax
import Control.Arrow (second)
mkRoute :: String -> [ResourceTree String] -> Q [Dec]
mkRoute typName routes = do
let typ = parseType typName
inst <- mkRenderRouteInstance typ $ map (fmap parseType) routes
disp <- mkDispatchClause [|runHandler|] [|dispatcher|] [|id|] routes
return $ InstanceD []
(ConT ''Routable `AppT` typ)
[FunD (mkName "dispatcher") [disp]]
: inst
type Handler master = master -> Application
runHandler
:: Handler master
-> master
-> master
-> Maybe (Route master)
-> (Route master -> Route master)
-> Handler master
runHandler h _ _ _ _ = h
class Routable master where
dispatcher
:: master
-> master
-> (Route master -> Route master)
-> Handler master
-> (Route master -> Handler master)
-> Text
-> [Text]
-> Handler master
routeDispatch :: Routable master => master -> Middleware
routeDispatch master def req = app master req
where
app = dispatcher master master id def404 def405 (T.pack $ show $ method req) (pathInfo req)
def404 = const def
def405 = const $ const def
method req' = case parseMethod $ requestMethod req' of
Right m -> m
Left _ -> GET
showRoute :: RenderRoute master => Route master -> Text
showRoute = uncurry encodePathInfo . second (map $ second Just) . renderRoute
where
encodePathInfo :: [Text] -> [(Text, Maybe Text)] -> Text
encodePathInfo segments = decodeUtf8 . toByteString . encodePath segments . queryTextToQuery