Настраиваемый префикс пути с Yesod - PullRequest
Новая
       60

Настраиваемый префикс пути с Yesod

1 голос
/ 27 января 2020

У меня есть следующий веб-сервер: 

{-# 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, но, похоже, не работает ...

1 Ответ

0 голосов
/ 29 января 2020

Я использую 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"]

Если вы знаете лучший способ сделать это, пожалуйста, прокомментируйте или добавьте ответ. Спасибо!

...