{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, TupleSections #-}

#if __GLASGOW_HASKELL__ > 702
{-# LANGUAGE DefaultSignatures, OverloadedStrings, ScopedTypeVariables, TypeOperators #-}
#endif

module Web.Routes.PathInfo
    ( stripOverlap
    , stripOverlapBS
    , stripOverlapText
    , URLParser
    , pToken
    , segment
    , anySegment
    , patternParse
    , parseSegments
    , PathInfo(..)
    , toPathInfo
    , toPathInfoParams
    , fromPathInfo
    , fromPathInfoParams
    , mkSitePI
    , showParseError
#if __GLASGOW_HASKELL__ > 702
    -- * Re-exported for convenience
    , Generic
#endif
    ) 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.Int (Int8, Int16, Int32, Int64)
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 Data.Word (Word, Word8, Word16, Word32, Word64)
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 (decodePathInfoParams, decodePathInfo, encodePathInfo)
import Web.Routes.Site (Site(..))

#if __GLASGOW_HASKELL__ > 702
import Control.Applicative ((<$), (<*>), (<|>), pure)
import Data.Char (toLower, isUpper)
import Data.List (intercalate)
import Data.List.Split (split, dropInitBlank, keepDelimsL, whenElt)
import GHC.Generics
#endif

-- this is not very efficient. Among other things, we need only consider the last 'n' characters of x where n == length y.
stripOverlap :: (Eq a) => [a] -> [a] -> [a]
stripOverlap :: forall a. Eq a => [a] -> [a] -> [a]
stripOverlap [a]
x [a]
y = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ [ forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [a]
p [a]
y | [a]
p <- forall a. [a] -> [[a]]
List.tails [a]
x]

stripOverlapText :: Text -> Text -> Text
stripOverlapText :: Text -> Text -> Text
stripOverlapText Text
x Text
y = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ [ Text -> Text -> Maybe Text
Text.stripPrefix Text
p Text
y | Text
p <- Text -> [Text]
Text.tails Text
x ]

stripOverlapBS :: B.ByteString -> B.ByteString -> B.ByteString
stripOverlapBS :: ByteString -> ByteString -> ByteString
stripOverlapBS ByteString
x ByteString
y = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ [ ByteString -> ByteString -> Maybe ByteString
stripPrefix ByteString
p ByteString
y | ByteString
p <- ByteString -> [ByteString]
B.tails ByteString
x ] -- fromJust will never fail
    where
      stripPrefix :: B.ByteString -> B.ByteString -> Maybe B.ByteString
      stripPrefix :: ByteString -> ByteString -> Maybe ByteString
stripPrefix ByteString
x ByteString
y
          | ByteString
x ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
y = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
x) ByteString
y
          | Bool
otherwise        = forall a. Maybe a
Nothing


type URLParser a = GenParser Text () a

pToken :: tok -> (Text -> Maybe a) -> URLParser a
pToken :: forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken tok
msg Text -> Maybe a
f = do SourcePos
pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
                  forall s t a u.
Stream s Identity t =>
(t -> [Char]) -> (t -> SourcePos) -> (t -> Maybe a) -> Parsec s u a
token Text -> [Char]
unpack (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ SourcePos -> Int -> SourcePos
incSourceLine SourcePos
pos Int
1) Text -> Maybe a
f

-- | match on a specific string
segment :: Text -> URLParser Text
segment :: Text -> URLParser Text
segment Text
x = (forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const Text
x) (\Text
y -> if Text
x forall a. Eq a => a -> a -> Bool
== Text
y then forall a. a -> Maybe a
Just Text
x else forall a. Maybe a
Nothing)) forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> Text -> [Char]
unpack Text
x

-- | match on any string
anySegment :: URLParser Text
anySegment :: URLParser Text
anySegment = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"any string") forall a. a -> Maybe a
Just

-- | Only matches if all segments have been consumed
eof :: URLParser ()
eof :: URLParser ()
eof = forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy URLParser Text
anySegment forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"end of input"

-- | apply a function to the remainder of the segments
--
-- useful if you want to just do normal pattern matching:
-- >
-- > foo ["foo", "bar"] = Right (Foo Bar)
-- > foo ["baz"]        = Right Baz
-- > foo _              = Left "parse error"
--
-- > patternParse foo
patternParse :: ([Text] -> Either String a) -> URLParser a
patternParse :: forall a. ([Text] -> Either [Char] a) -> URLParser a
patternParse [Text] -> Either [Char] a
p =
  do [Text]
segs <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
     case [Text] -> Either [Char] a
p [Text]
segs of
       (Right a
r) ->
         do forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput []
            forall (m :: * -> *) a. Monad m => a -> m a
return a
r
       (Left [Char]
err) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err

-- | show Parsec 'ParseError' using terms that relevant to parsing a url
showParseError :: ParseError -> String
showParseError :: ParseError -> [Char]
showParseError ParseError
pErr =
  let pos :: SourcePos
pos    = ParseError -> SourcePos
errorPos ParseError
pErr
      posMsg :: [Char]
posMsg = SourcePos -> [Char]
sourceName SourcePos
pos forall a. [a] -> [a] -> [a]
++ [Char]
" (segment " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (SourcePos -> Int
sourceLine SourcePos
pos) forall a. [a] -> [a] -> [a]
++ [Char]
" character " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (SourcePos -> Int
sourceColumn SourcePos
pos) forall a. [a] -> [a] -> [a]
++ [Char]
"): "
      msgs :: [Message]
msgs   = ParseError -> [Message]
errorMessages ParseError
pErr
  in [Char]
posMsg forall a. [a] -> [a] -> [a]
++ [Char]
-> [Char] -> [Char] -> [Char] -> [Char] -> [Message] -> [Char]
showErrorMessages [Char]
"or" [Char]
"unknown parse error" [Char]
"expecting" [Char]
"unexpected" [Char]
"end of input" [Message]
msgs

-- | run a 'URLParser' on a list of path segments
--
-- returns @Left "parse error"@ on failure.
--
-- returns @Right a@ on success
parseSegments :: URLParser a -> [Text] -> Either String a
parseSegments :: forall a. URLParser a -> [Text] -> Either [Char] a
parseSegments URLParser a
p [Text]
segments =
  case forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse (URLParser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* URLParser ()
eof) (forall a. Show a => a -> [Char]
show [Text]
segments) [Text]
segments of
    (Left ParseError
e)  -> forall a b. a -> Either a b
Left (ParseError -> [Char]
showParseError ParseError
e)
    (Right a
r) -> forall a b. b -> Either a b
Right a
r

{-

This requires parsec 3, can't figure out how to do it in parsec 2 yet.

p2u :: Parser a -> URLParser a
p2u p =
  mkPT $ \state@(State sInput sPos sUser) ->
  case sInput of
    (s:ss) ->
       do r <- runParsecT p (State s sPos sUser)
          return (fmap (fmap (fixReply ss)) r)

    where
      fixReply :: [String] -> (Reply String u a) -> (Reply [String] u a)
      fixReply _ (Error err) = (Error err)
      fixReply ss (Ok a (State "" sPos sUser) e) = (Ok a (State ss sPos sUser) e)
      fixReply ss (Ok a (State s sPos sUser) e) = (Ok a (State (s:ss) sPos sUser) e)
-}

{-
p2u :: Parser a -> URLParser a
p2u p =
  do (State sInput sPos sUser) <- getParserState
     case sInput of
       (s:ss) -> let r = runParser p () "" s
                 in case r of
                      (Left e) -> return e
-}

{-
  mkPT $ \state@(State sInput sPos sUser) ->
  case sInput of
    (s:ss) ->
       do r <- runParsecT p (State s sPos sUser)
          return (fmap (fmap (fixReply ss)) r)

    where
      fixReply :: [String] -> (Reply String u a) -> (Reply [String] u a)
      fixReply _ (Error err) = (Error err)
      fixReply ss (Ok a (State "" sPos sUser) e) = (Ok a (State ss sPos sUser) e)
      fixReply ss (Ok a (State s sPos sUser) e) = (Ok a (State (s:ss) sPos sUser) e)
-}

#if __GLASGOW_HASKELL__ > 702

hyphenate :: String -> Text
hyphenate :: [Char] -> Text
hyphenate =
    [Char] -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> [a] -> [[a]]
split Splitter Char
splitter
  where
    splitter :: Splitter Char
splitter = forall a. Splitter a -> Splitter a
dropInitBlank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> Splitter a
keepDelimsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Splitter a
whenElt forall a b. (a -> b) -> a -> b
$ Char -> Bool
isUpper

class GPathInfo f where
  gtoPathSegments :: f url -> [Text]
  gfromPathSegments :: URLParser (f url)

instance GPathInfo U1 where
  gtoPathSegments :: forall url. U1 url -> [Text]
gtoPathSegments U1 url
U1 = []
  gfromPathSegments :: forall url. URLParser (U1 url)
gfromPathSegments = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1

instance GPathInfo a => GPathInfo (D1 c a) where
  gtoPathSegments :: forall url. D1 c a url -> [Text]
gtoPathSegments = forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
  gfromPathSegments :: forall url. URLParser (D1 c a url)
gfromPathSegments = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments

instance GPathInfo a => GPathInfo (S1 c a) where
  gtoPathSegments :: forall url. S1 c a url -> [Text]
gtoPathSegments = forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
  gfromPathSegments :: forall url. URLParser (S1 c a url)
gfromPathSegments = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments

instance forall c a. (GPathInfo a, Constructor c) => GPathInfo (C1 c a) where
  gtoPathSegments :: forall url. C1 c a url -> [Text]
gtoPathSegments m :: C1 c a url
m@(M1 a url
x) = ([Char] -> Text
hyphenate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName) C1 c a url
m forall a. a -> [a] -> [a]
: forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments a url
x
  gfromPathSegments :: forall url. URLParser (C1 c a url)
gfromPathSegments = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> URLParser Text
segment ([Char] -> Text
hyphenate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName forall a b. (a -> b) -> a -> b
$ (forall a. HasCallStack => a
undefined :: C1 c a r))
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments

instance (GPathInfo a, GPathInfo b) => GPathInfo (a :*: b) where
  gtoPathSegments :: forall url. (:*:) a b url -> [Text]
gtoPathSegments (a url
a :*: b url
b) = forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments a url
a forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments b url
b
  gfromPathSegments :: forall url. URLParser ((:*:) a b url)
gfromPathSegments = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments

instance (GPathInfo a, GPathInfo b) => GPathInfo (a :+: b) where
  gtoPathSegments :: forall url. (:+:) a b url -> [Text]
gtoPathSegments (L1 a url
x) = forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments a url
x
  gtoPathSegments (R1 b url
x) = forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments b url
x
  gfromPathSegments :: forall url. URLParser ((:+:) a b url)
gfromPathSegments = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments

instance PathInfo a => GPathInfo (K1 i a) where
  gtoPathSegments :: forall url. K1 i a url -> [Text]
gtoPathSegments = forall url. PathInfo url => url -> [Text]
toPathSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). K1 i c p -> c
unK1
  gfromPathSegments :: forall url. URLParser (K1 i a url)
gfromPathSegments = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall url. PathInfo url => URLParser url
fromPathSegments

#endif

-- | Simple parsing and rendering for a type to and from URL path segments.
--
-- If you're using GHC 7.2 or later, you can use @DeriveGeneric@ to derive
-- instances of this class:
--
-- > {-# LANGUAGE DeriveGeneric #-}
-- > data Sitemap = Home | BlogPost Int deriving Generic
-- > instance PathInfo Sitemap
--
-- This results in the following instance:
--
-- > instance PathInfo Sitemap where
-- >     toPathSegments Home = ["home"]
-- >     toPathSegments (BlogPost x) = "blog-post" : toPathSegments x
-- >     fromPathSegments = Home <$ segment "home"
-- >                    <|> BlogPost <$ segment "blog-post" <*> fromPathSegments
--
-- And here it is in action:
--
-- >>> toPathInfo (BlogPost 123)
-- "/blog-post/123"
-- >>> fromPathInfo "/blog-post/123" :: Either String Sitemap
-- Right (BlogPost 123)
--
-- To instead derive instances using @TemplateHaskell@, see
-- <http://hackage.haskell.org/package/web-routes-th web-routes-th>.
class PathInfo url where
  toPathSegments :: url -> [Text]
  fromPathSegments :: URLParser url

#if __GLASGOW_HASKELL__ > 702
  default toPathSegments :: (Generic url, GPathInfo (Rep url)) => url -> [Text]
  toPathSegments = forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from
  default fromPathSegments :: (Generic url, GPathInfo (Rep url)) => URLParser url
  fromPathSegments = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments
#endif

-- |convert url into the path info portion of a URL
toPathInfo :: (PathInfo url) => url -> Text
toPathInfo :: forall url. PathInfo url => url -> Text
toPathInfo =  ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall url. PathInfo url => url -> Builder
toPathInfoUtf8

-- |convert url into the path info portion of a URL
toPathInfoUtf8 :: (PathInfo url) => url -> Builder
toPathInfoUtf8 :: forall url. PathInfo url => url -> Builder
toPathInfoUtf8 =  forall a b c. (a -> b -> c) -> b -> a -> c
flip [Text] -> Query -> Builder
encodePath [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall url. PathInfo url => url -> [Text]
toPathSegments

-- |convert url + params into the path info portion of a URL + a query string
toPathInfoParams :: (PathInfo url) =>
                    url -- ^ url
                 -> [(Text, Maybe Text)] -- ^ query string parameter
                 -> Text
toPathInfoParams :: forall url. PathInfo url => url -> [(Text, Maybe Text)] -> Text
toPathInfoParams url
url [(Text, Maybe Text)]
params = [Text] -> [(Text, Maybe Text)] -> Text
encodePathInfo (forall url. PathInfo url => url -> [Text]
toPathSegments url
url) [(Text, Maybe Text)]
params

-- should this fail if not all the input was consumed?
--
-- in theory we
-- require the pathInfo to have the initial '/', but this code will
-- still work if it is missing.
--

-- If there are multiple //// at the beginning, we only drop the first
-- one, because we only added one in toPathInfo. Hence the others
-- should be significant.
--
-- However, if the pathInfo was prepend with http://example.org/ with
-- a trailing slash, then things might not line up.

-- | parse a 'String' into 'url' using 'PathInfo'.
--
-- returns @Left "parse error"@ on failure
--
-- returns @Right url@ on success

fromPathInfo :: (PathInfo url) => ByteString -> Either String url
fromPathInfo :: forall url. PathInfo url => ByteString -> Either [Char] url
fromPathInfo ByteString
pi =
  forall a. URLParser a -> [Text] -> Either [Char] a
parseSegments forall url. PathInfo url => URLParser url
fromPathSegments (ByteString -> [Text]
decodePathInfo forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
dropSlash ByteString
pi)

-- | parse a 'String' into '(url, Query)' using 'PathInfo'.
--
-- returns @Left "parse error"@ on failure
--
-- returns @Right (url, Query@ on success

fromPathInfoParams :: (PathInfo url) => ByteString -> Either String (url, [(Text, Maybe Text)])
fromPathInfoParams :: forall url.
PathInfo url =>
ByteString -> Either [Char] (url, [(Text, Maybe Text)])
fromPathInfoParams ByteString
pi =
  (,[(Text, Maybe Text)]
query) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. URLParser a -> [Text] -> Either [Char] a
parseSegments forall url. PathInfo url => URLParser url
fromPathSegments [Text]
url
  where
    ([Text]
url, [(Text, Maybe Text)]
query) = ByteString -> ([Text], [(Text, Maybe Text)])
decodePathInfoParams forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
dropSlash ByteString
pi

-- | Removes a leading slash, if it exists
dropSlash :: ByteString -> ByteString
dropSlash :: ByteString -> ByteString
dropSlash ByteString
s =
  if ((Char -> ByteString
B.singleton Char
'/') ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
s)
  then HasCallStack => ByteString -> ByteString
B.tail ByteString
s
  else ByteString
s

-- | turn a routing function into a 'Site' value using the 'PathInfo' class
mkSitePI :: (PathInfo url) =>
            ((url -> [(Text, Maybe Text)] -> Text) -> url -> a) -- ^ a routing function
         -> Site url a
mkSitePI :: forall url a.
PathInfo url =>
((url -> [(Text, Maybe Text)] -> Text) -> url -> a) -> Site url a
mkSitePI (url -> [(Text, Maybe Text)] -> Text) -> url -> a
handler =
  Site { handleSite :: (url -> [(Text, Maybe Text)] -> Text) -> url -> a
handleSite         = (url -> [(Text, Maybe Text)] -> Text) -> url -> a
handler
       , formatPathSegments :: url -> ([Text], [(Text, Maybe Text)])
formatPathSegments = (\[Text]
x -> ([Text]
x, [])) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall url. PathInfo url => url -> [Text]
toPathSegments
       , parsePathSegments :: [Text] -> Either [Char] url
parsePathSegments  = forall a. URLParser a -> [Text] -> Either [Char] a
parseSegments forall url. PathInfo url => URLParser url
fromPathSegments
       }

-- it's instances all the way down

instance PathInfo Text where
  toPathSegments :: Text -> [Text]
toPathSegments = (forall a. a -> [a] -> [a]
:[])
  fromPathSegments :: URLParser Text
fromPathSegments = URLParser Text
anySegment

instance PathInfo [Text] where
  toPathSegments :: [Text] -> [Text]
toPathSegments = forall a. a -> a
id
  fromPathSegments :: URLParser [Text]
fromPathSegments = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many URLParser Text
anySegment

instance PathInfo String where
  toPathSegments :: [Char] -> [Text]
toPathSegments = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack
  fromPathSegments :: URLParser [Char]
fromPathSegments = Text -> [Char]
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URLParser Text
anySegment

instance PathInfo [String] where
  toPathSegments :: [[Char]] -> [Text]
toPathSegments = forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
pack
  fromPathSegments :: URLParser [[Char]]
fromPathSegments = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Text -> [Char]
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URLParser Text
anySegment)

instance PathInfo Int where
  toPathSegments :: Int -> [Text]
toPathSegments Int
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
i]
  fromPathSegments :: URLParser Int
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Int") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Int8 where
  toPathSegments :: Int8 -> [Text]
toPathSegments Int8
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int8
i]
  fromPathSegments :: URLParser Int8
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Int8") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Int16 where
  toPathSegments :: Int16 -> [Text]
toPathSegments Int16
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int16
i]
  fromPathSegments :: URLParser Int16
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Int16") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Int32 where
  toPathSegments :: Int32 -> [Text]
toPathSegments Int32
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int32
i]
  fromPathSegments :: URLParser Int32
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Int32") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Int64 where
  toPathSegments :: Int64 -> [Text]
toPathSegments Int64
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int64
i]
  fromPathSegments :: URLParser Int64
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Int64") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Integer where
  toPathSegments :: Integer -> [Text]
toPathSegments Integer
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Integer
i]
  fromPathSegments :: URLParser Integer
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Integer") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Word where
  toPathSegments :: Word -> [Text]
toPathSegments Word
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word
i]
  fromPathSegments :: URLParser Word
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Word") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Word8 where
  toPathSegments :: Word8 -> [Text]
toPathSegments Word8
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word8
i]
  fromPathSegments :: URLParser Word8
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Word8") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Word16 where
  toPathSegments :: Word16 -> [Text]
toPathSegments Word16
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word16
i]
  fromPathSegments :: URLParser Word16
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Word16") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Word32 where
  toPathSegments :: Word32 -> [Text]
toPathSegments Word32
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word32
i]
  fromPathSegments :: URLParser Word32
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Word32") forall a. Integral a => Text -> Maybe a
checkIntegral

instance PathInfo Word64 where
  toPathSegments :: Word64 -> [Text]
toPathSegments Word64
i = [[Char] -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word64
i]
  fromPathSegments :: URLParser Word64
fromPathSegments = forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (forall a b. a -> b -> a
const [Char]
"Word64") forall a. Integral a => Text -> Maybe a
checkIntegral

checkIntegral :: Integral a => Text -> Maybe a
checkIntegral :: forall a. Integral a => Text -> Maybe a
checkIntegral Text
txt =
  case forall a. Num a => Reader a -> Reader a
signed forall a. Integral a => Reader a
decimal Text
txt of
    (Left [Char]
e) -> forall a. Maybe a
Nothing
    (Right (a
n, Text
r))
       | Text -> Bool
Text.null Text
r -> forall a. a -> Maybe a
Just a
n
       | Bool
otherwise -> forall a. Maybe a
Nothing