Skip to content

@sopvop /RouteBoomerang.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
boomerang in snap without webroutes
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Snap.Extras.RouteBoomerang
( showUrl
, showUrlMay
, showUrlWithParamsMay
, showUrlWithParams
, routeUrl
, parseUrlMaybe
, parseUrlEither
, RouteParser
, TopRouteParser )
where
import Control.Applicative
import qualified Blaze.ByteString.Builder as B (Builder,
fromByteString,
toByteString)
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.List (intersperse)
import qualified Data.Map as Map
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import Text.Boomerang hiding ((<>))
import Text.Boomerang.Texts
import Snap
type RouteParser r x = PrinterParser TextsError [Text] x (r :- x)
type TopRouteParser r = RouteParser r ()
decodePath :: ByteString -> Maybe [Text]
decodePath = sequence . map (fmap T.decodeUtf8 . urlDecode) . B.split '/'
joinPath :: [Text] -> B.Builder
joinPath = mconcat . intersperse (B.fromChar '/')
. map (urlEncodeBuilder . T.encodeUtf8)
parseUrlEither :: TopRouteParser r -> ByteString -> Either TextsError r
parseUrlEither pp bs = maybe (Left err) id $ parseTexts pp <$> decodePath bs
where
err = ParserError Nothing [Message "Failed in urlDecode"]
parseUrlMaybe :: TopRouteParser r -> ByteString -> Maybe r
parseUrlMaybe pp url = case parseUrlEither pp url of
Left _ -> Nothing
Right r -> Just r
showUrl :: ByteString -> TopRouteParser r -> r -> ByteString
showUrl host pp loc = case showUrlMay host pp loc of
Nothing -> error "Could not route" -- serious error?
Just r -> r
buildUrl :: ByteString -> [Text] -> B.Builder
buildUrl host = mappend (B.fromByteString host) . joinPath
showUrlMay :: ByteString -> TopRouteParser r -> r -> Maybe ByteString
showUrlMay host pp loc = B.toByteString . buildUrl host <$> unparseTexts pp loc
showUrlWithParamsMay :: ByteString -> TopRouteParser r -> r -> Params
-> Maybe ByteString
showUrlWithParamsMay host pp loc params =
B.toByteString . go . buildUrl host <$> unparseTexts pp loc
where
go url | Map.null params = url
| otherwise = url <> B.fromChar '?' <> buildUrlEncoded params
showUrlWithParams :: ByteString -> TopRouteParser r -> r -> Params -> ByteString
showUrlWithParams host pp loc params =
case showUrlWithParamsMay host pp loc params of
Nothing -> error "Could not route"
Just url -> url
routeUrl :: MonadSnap m => TopRouteParser r -> (r -> m b) -> m b
routeUrl pp action = do
url <- getsRequest rqPathInfo
case parseUrlMaybe pp url of
Nothing -> pass
Just loc -> localRequest fixCP $ action loc
where
fixCP req = req {
rqContextPath = B.concat [rqContextPath req, "/" ,rqPathInfo req ]}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.