module Web.Routes.PathInfo where
import Control.Applicative (pure, (*>),(<*>))
import Control.Monad (msum)
import Data.List (stripPrefix, tails)
import Data.Maybe (fromJust)
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, pzero,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 $ [ stripPrefix p y | p <- tails x]
type URLParser a = GenParser String () a
pToken :: tok -> (String -> Maybe a) -> URLParser a
pToken msg f = do pos <- getPosition
token id (const $ incSourceLine pos 1) f
segment :: String -> URLParser String
segment x = (pToken (const x) (\y -> if x == y then Just x else Nothing)) <?> x
anySegment :: URLParser String
anySegment = pToken (const "any string") Just
patternParse :: ([String] -> Either String a) -> URLParser a
patternParse p =
do segs <- getInput
case p segs of
(Right r) ->
do setInput []
return r
(Left err) -> fail err
parseSegments :: URLParser a -> [String] -> Either String a
parseSegments p segments =
case parse p (show segments) segments of
(Left e) -> Left (showParseError e)
(Right r) -> Right r
class PathInfo url where
toPathSegments :: url -> [String]
fromPathSegments :: URLParser url
toPathInfo :: (PathInfo url) => url -> String
toPathInfo = ('/' :) . flip encodePathInfo [] . toPathSegments
toPathInfoParams :: (PathInfo url) =>
url
-> [(String, String)]
-> String
toPathInfoParams url params = ('/' :) . flip encodePathInfo params . toPathSegments $ url
fromPathInfo :: (PathInfo url) => String -> Either String url
fromPathInfo pi =
parseSegments fromPathSegments (decodePathInfo $ dropSlash pi)
where
dropSlash ('/':rs) = rs
dropSlash x = x
mkSitePI :: (PathInfo url) =>
((url -> [(String, String)] -> String) -> url -> a)
-> Site url a
mkSitePI handler =
Site { handleSite = handler
, formatPathSegments = (\x -> (x, [])) . toPathSegments
, parsePathSegments = parseSegments fromPathSegments
}
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
instance PathInfo [String] where
toPathSegments = id
fromPathSegments = many anySegment
instance PathInfo String where
toPathSegments = (:[])
fromPathSegments = anySegment
instance PathInfo Int where
toPathSegments i = [show i]
fromPathSegments = pToken (const "int") checkInt
where checkInt str =
case reads str of
[(n,[])] -> Just n
_ -> Nothing
instance PathInfo Integer where
toPathSegments i = [show i]
fromPathSegments = pToken (const "integer") checkInteger
where checkInteger str =
case reads str of
[(n,[])] -> Just n
_ -> Nothing