module Web.Routes.PathInfo
( stripOverlap
, stripOverlapBS
, stripOverlapText
, URLParser
, pToken
, segment
, anySegment
, patternParse
, parseSegments
, PathInfo(..)
, toPathInfo
, toPathInfoParams
, fromPathInfo
, mkSitePI
, showParseError
) where
import Blaze.ByteString.Builder (Builder, toByteString)
import Control.Applicative ((<$>), (<*))
import Control.Monad (msum)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.List as List (stripPrefix, tails)
import Data.Text as Text (Text, pack, unpack, null, tails, stripPrefix)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Read (decimal, signed)
import Data.Maybe (fromJust)
import Network.HTTP.Types
import Text.ParserCombinators.Parsec.Combinator (notFollowedBy)
import Text.ParserCombinators.Parsec.Error (ParseError, errorPos, errorMessages, showErrorMessages)
import Text.ParserCombinators.Parsec.Pos (incSourceLine, sourceName, sourceLine, sourceColumn)
import Text.ParserCombinators.Parsec.Prim ((<?>), GenParser, getInput, setInput, getPosition, token, parse, many)
import Web.Routes.Base (decodePathInfo, encodePathInfo)
import Web.Routes.Site (Site(..))
stripOverlap :: (Eq a) => [a] -> [a] -> [a]
stripOverlap x y = fromJust $ msum $ [ List.stripPrefix p y | p <- List.tails x]
stripOverlapText :: Text -> Text -> Text
stripOverlapText x y = fromJust $ msum $ [ Text.stripPrefix p y | p <- Text.tails x ]
stripOverlapBS :: B.ByteString -> B.ByteString -> B.ByteString
stripOverlapBS x y = fromJust $ msum $ [ stripPrefix p y | p <- B.tails x ]
where
stripPrefix :: B.ByteString -> B.ByteString -> Maybe B.ByteString
stripPrefix x y
| x `B.isPrefixOf` y = Just $ B.drop (B.length x) y
| otherwise = Nothing
type URLParser a = GenParser Text () a
pToken :: tok -> (Text -> Maybe a) -> URLParser a
pToken msg f = do pos <- getPosition
token unpack (const $ incSourceLine pos 1) f
segment :: Text -> URLParser Text
segment x = (pToken (const x) (\y -> if x == y then Just x else Nothing)) <?> unpack x
anySegment :: URLParser Text
anySegment = pToken (const "any string") Just
eof :: URLParser ()
eof = notFollowedBy anySegment <?> "end of input"
patternParse :: ([Text] -> Either String a) -> URLParser a
patternParse p =
do segs <- getInput
case p segs of
(Right r) ->
do setInput []
return r
(Left err) -> fail err
showParseError :: ParseError -> String
showParseError pErr =
let pos = errorPos pErr
posMsg = sourceName pos ++ " (segment " ++ show (sourceLine pos) ++ " character " ++ show (sourceColumn pos) ++ "): "
msgs = errorMessages pErr
in posMsg ++ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" msgs
parseSegments :: URLParser a -> [Text] -> Either String a
parseSegments p segments =
case parse (p <* eof) (show segments) segments of
(Left e) -> Left (showParseError e)
(Right r) -> Right r
class PathInfo url where
toPathSegments :: url -> [Text]
fromPathSegments :: URLParser url
toPathInfo :: (PathInfo url) => url -> Text
toPathInfo = decodeUtf8 . toByteString . toPathInfoUtf8
toPathInfoUtf8 :: (PathInfo url) => url -> Builder
toPathInfoUtf8 = flip encodePath [] . toPathSegments
toPathInfoParams :: (PathInfo url) =>
url
-> [(Text, Maybe Text)]
-> Text
toPathInfoParams url params = encodePathInfo (toPathSegments url) params
fromPathInfo :: (PathInfo url) => ByteString -> Either String url
fromPathInfo pi =
parseSegments fromPathSegments (decodePathInfo $ dropSlash pi)
where
dropSlash s =
if ((B.pack "/") `B.isPrefixOf` s)
then B.tail s
else s
mkSitePI :: (PathInfo url) =>
((url -> [(Text, Maybe Text)] -> Text) -> url -> a)
-> Site url a
mkSitePI handler =
Site { handleSite = handler
, formatPathSegments = (\x -> (x, [])) . toPathSegments
, parsePathSegments = parseSegments fromPathSegments
}
instance PathInfo Text where
toPathSegments = (:[])
fromPathSegments = anySegment
instance PathInfo [Text] where
toPathSegments = id
fromPathSegments = many anySegment
instance PathInfo String where
toPathSegments = (:[]) . pack
fromPathSegments = unpack <$> anySegment
instance PathInfo [String] where
toPathSegments = id . map pack
fromPathSegments = many (unpack <$> anySegment)
instance PathInfo Int where
toPathSegments i = [pack $ show i]
fromPathSegments = pToken (const "Int") checkInt
where checkInt txt =
case signed decimal txt of
(Left e) -> Nothing
(Right (n, r))
| Text.null r -> Just n
| otherwise -> Nothing
instance PathInfo Integer where
toPathSegments i = [pack $ show i]
fromPathSegments = pToken (const "Integer") checkInt
where checkInt txt =
case signed decimal txt of
(Left e) -> Nothing
(Right (n, r))
| Text.null r -> Just n
| otherwise -> Nothing