boomerang in snap without webroutes

RouteBoomerang.hs

{-# 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 ]}