我有以下Web服务器:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
import Data.Text (Text)
import Yesod
data App = App
mkYesod "App" [parseRoutes|
/ HomeR GET
/link1 Link1R GET
/link2 Link2R GET
/link3 Link3R GET
/link4 Link4R GET
|]
instance Yesod App where
getHomeR :: Handler Html
getHomeR = defaultLayout $ do
setTitle "Redirects"
[whamlet|
<p>
<a href=@{Link1R}>Click to start the redirect chain!
|]
getLink1R, getLink2R, getLink3R :: Handler ()
getLink1R = redirect Link2R -- /link2
getLink2R = redirect (Link3R, [("foo", "bar")]) -- /link3?foo=bar
getLink3R = redirect $ Link4R :#: ("baz" :: Text) -- /link4#baz
getLink4R :: Handler Html
getLink4R = defaultLayout
[whamlet|
<p>You made it!
|]
main :: IO ()
main = warp 3000 App
但是我有来自诸如环境变量之类的路由前缀:
/prefix/ HomeR GET
/prefix/link1 Link1R GET
/prefix/link2 Link2R GET
/prefix/link3 Link3R GET
/prefix/link4 Link4R GET
我如何实现?
我尝试过approot
,但似乎不起作用...
我正在使用cleanPath
删除前缀:
cleanPath app s =
if corrected == s
then Right $ dropPrefix $ map dropDash s
else Left corrected
where
corrected = filter (not . T.null) s
dropDash t
| T.all (== '-') t = T.drop 1 t
| otherwise = t
dropPrefix s' = case routePrefix $ appSettings app of
Nothing -> s'
Just prefix -> case headMay s' of
Just t -> if t == prefix then drop 1 s' else ["wrong prefix"]
Nothing -> ["wrong prefix"]
[如果您知道更好的方法,请评论或添加答案。谢谢!