public
Last active

boomerang in snap without webroutes

  • Download Gist
RouteBoomerang.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
{-# 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 ]}

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.