{-# 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 (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 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 = Maybe [a] -> [a]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [a] -> [a]) -> Maybe [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [Maybe [a]] -> Maybe [a]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe [a]] -> Maybe [a]) -> [Maybe [a]] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ [ [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [a]
p [a]
y | [a]
p <- [a] -> [[a]]
forall a. [a] -> [[a]]
List.tails [a]
x]

stripOverlapText :: Text -> Text -> Text
stripOverlapText :: Text -> Text -> Text
stripOverlapText Text
x Text
y = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> Maybe Text
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Text] -> Maybe Text) -> [Maybe Text] -> Maybe Text
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 = Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe ByteString] -> Maybe ByteString
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe ByteString] -> Maybe ByteString)
-> [Maybe ByteString] -> Maybe ByteString
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 = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
x) ByteString
y
          | Bool
otherwise        = Maybe ByteString
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 <- ParsecT [Text] () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
                  (Text -> [Char])
-> (Text -> SourcePos) -> (Text -> Maybe a) -> URLParser a
forall s t a u.
Stream s Identity t =>
(t -> [Char]) -> (t -> SourcePos) -> (t -> Maybe a) -> Parsec s u a
token Text -> [Char]
unpack (SourcePos -> Text -> SourcePos
forall a b. a -> b -> a
const (SourcePos -> Text -> SourcePos) -> SourcePos -> Text -> SourcePos
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 = ((Any -> Text) -> (Text -> Maybe Text) -> URLParser Text
forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (Text -> Any -> Text
forall a b. a -> b -> a
const Text
x) (\Text
y -> if Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
y then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x else Maybe Text
forall a. Maybe a
Nothing)) URLParser Text -> [Char] -> URLParser Text
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 = (Any -> [Char]) -> (Text -> Maybe Text) -> URLParser Text
forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken ([Char] -> Any -> [Char]
forall a b. a -> b -> a
const [Char]
"any string") Text -> Maybe Text
forall a. a -> Maybe a
Just

-- | Only matches if all segments have been consumed
eof :: URLParser ()
eof :: URLParser ()
eof = URLParser Text -> URLParser ()
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 URLParser () -> [Char] -> URLParser ()
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 <- ParsecT [Text] () Identity [Text]
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 [Text] -> URLParser ()
forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput []
            a -> URLParser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
       (Left [Char]
err) -> [Char] -> URLParser a
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 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (segment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (SourcePos -> Int
sourceLine SourcePos
pos) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" character " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (SourcePos -> Int
sourceColumn SourcePos
pos) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"): "
      msgs :: [Message]
msgs   = ParseError -> [Message]
errorMessages ParseError
pErr
  in [Char]
posMsg [Char] -> [Char] -> [Char]
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 URLParser a -> [Char] -> [Text] -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse (URLParser a
p URLParser a -> URLParser () -> URLParser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* URLParser ()
eof) ([Text] -> [Char]
forall a. Show a => a -> [Char]
show [Text]
segments) [Text]
segments of
    (Left ParseError
e)  -> [Char] -> Either [Char] a
forall a b. a -> Either a b
Left (ParseError -> [Char]
showParseError ParseError
e)
    (Right a
r) -> a -> Either [Char] a
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 ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter Char -> [Char] -> [[Char]]
forall a. Splitter a -> [a] -> [[a]]
split Splitter Char
splitter
  where
    splitter :: Splitter Char
splitter = Splitter Char -> Splitter Char
forall a. Splitter a -> Splitter a
dropInitBlank (Splitter Char -> Splitter Char)
-> ((Char -> Bool) -> Splitter Char)
-> (Char -> Bool)
-> Splitter Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter Char -> Splitter Char
forall a. Splitter a -> Splitter a
keepDelimsL (Splitter Char -> Splitter Char)
-> ((Char -> Bool) -> Splitter Char)
-> (Char -> Bool)
-> Splitter Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Splitter Char
forall a. (a -> Bool) -> Splitter a
whenElt ((Char -> Bool) -> Splitter Char)
-> (Char -> Bool) -> Splitter Char
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 = U1 url -> ParsecT [Text] () Identity (U1 url)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 url
forall k (p :: k). U1 p
U1

instance GPathInfo a => GPathInfo (D1 c a) where
  gtoPathSegments :: forall url. D1 c a url -> [Text]
gtoPathSegments = a url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments (a url -> [Text])
-> (M1 D c a url -> a url) -> M1 D c a url -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 D c a url -> a url
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 = a url -> M1 D c a url
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a url -> M1 D c a url)
-> ParsecT [Text] () Identity (a url)
-> ParsecT [Text] () Identity (M1 D c a url)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity (a url)
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 = a url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments (a url -> [Text])
-> (M1 S c a url -> a url) -> M1 S c a url -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 S c a url -> a url
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 = a url -> M1 S c a url
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a url -> M1 S c a url)
-> ParsecT [Text] () Identity (a url)
-> ParsecT [Text] () Identity (M1 S c a url)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity (a url)
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 ([Char] -> Text) -> (C1 c a url -> [Char]) -> C1 c a url -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 c a url -> [Char]
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 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: a url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments a url
x
  gfromPathSegments :: forall url. URLParser (C1 c a url)
gfromPathSegments = a url -> M1 C c a url
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a url -> M1 C c a url)
-> URLParser Text
-> ParsecT [Text] () Identity (a url -> M1 C c a url)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> URLParser Text
segment ([Char] -> Text
hyphenate ([Char] -> Text)
-> (M1 C c a Any -> [Char]) -> M1 C c a Any -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 C c a Any -> [Char]
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (M1 C c a Any -> Text) -> M1 C c a Any -> Text
forall a b. (a -> b) -> a -> b
$ (forall {r}. C1 c a r
forall a. HasCallStack => a
undefined :: C1 c a r))
                         ParsecT [Text] () Identity (a url -> M1 C c a url)
-> ParsecT [Text] () Identity (a url)
-> ParsecT [Text] () Identity (M1 C c a url)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT [Text] () Identity (a url)
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) = a url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments a url
a [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ b url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments b url
b
  gfromPathSegments :: forall url. URLParser ((:*:) a b url)
gfromPathSegments = a url -> b url -> (:*:) a b url
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a url -> b url -> (:*:) a b url)
-> ParsecT [Text] () Identity (a url)
-> ParsecT [Text] () Identity (b url -> (:*:) a b url)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity (a url)
forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments ParsecT [Text] () Identity (b url -> (:*:) a b url)
-> ParsecT [Text] () Identity (b url)
-> ParsecT [Text] () Identity ((:*:) a b url)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT [Text] () Identity (b url)
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) = a url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments a url
x
  gtoPathSegments (R1 b url
x) = b url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments b url
x
  gfromPathSegments :: forall url. URLParser ((:+:) a b url)
gfromPathSegments = a url -> (:+:) a b url
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a url -> (:+:) a b url)
-> ParsecT [Text] () Identity (a url)
-> ParsecT [Text] () Identity ((:+:) a b url)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity (a url)
forall (f :: * -> *) url. GPathInfo f => URLParser (f url)
gfromPathSegments
                  ParsecT [Text] () Identity ((:+:) a b url)
-> ParsecT [Text] () Identity ((:+:) a b url)
-> ParsecT [Text] () Identity ((:+:) a b url)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> b url -> (:+:) a b url
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b url -> (:+:) a b url)
-> ParsecT [Text] () Identity (b url)
-> ParsecT [Text] () Identity ((:+:) a b url)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity (b url)
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 = a -> [Text]
forall url. PathInfo url => url -> [Text]
toPathSegments (a -> [Text]) -> (K1 i a url -> a) -> K1 i a url -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a url -> a
forall k i c (p :: k). K1 i c p -> c
unK1
  gfromPathSegments :: forall url. URLParser (K1 i a url)
gfromPathSegments = a -> K1 i a url
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a url)
-> ParsecT [Text] () Identity a
-> ParsecT [Text] () Identity (K1 i a url)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity a
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 = Rep url Any -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments (Rep url Any -> [Text]) -> (url -> Rep url Any) -> url -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. url -> Rep url Any
forall a x. Generic a => a -> Rep a x
from
  default fromPathSegments :: (Generic url, GPathInfo (Rep url)) => URLParser url
  fromPathSegments = Rep url Any -> url
forall a x. Generic a => Rep a x -> a
to (Rep url Any -> url)
-> ParsecT [Text] () Identity (Rep url Any) -> URLParser url
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Text] () Identity (Rep url Any)
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 (ByteString -> Text) -> (url -> ByteString) -> url -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toByteString (Builder -> ByteString) -> (url -> Builder) -> url -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. url -> Builder
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 =  ([Text] -> Query -> Builder) -> Query -> [Text] -> Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Text] -> Query -> Builder
encodePath [] ([Text] -> Builder) -> (url -> [Text]) -> url -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. url -> [Text]
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 (url -> [Text]
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 =
  URLParser url -> [Text] -> Either [Char] url
forall a. URLParser a -> [Text] -> Either [Char] a
parseSegments URLParser url
forall url. PathInfo url => URLParser url
fromPathSegments (ByteString -> [Text]
decodePathInfo (ByteString -> [Text]) -> ByteString -> [Text]
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) (url -> (url, [(Text, Maybe Text)]))
-> Either [Char] url -> Either [Char] (url, [(Text, Maybe Text)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URLParser url -> [Text] -> Either [Char] url
forall a. URLParser a -> [Text] -> Either [Char] a
parseSegments URLParser url
forall url. PathInfo url => URLParser url
fromPathSegments [Text]
url
  where
    ([Text]
url, [(Text, Maybe Text)]
query) = ByteString -> ([Text], [(Text, Maybe Text)])
decodePathInfoParams (ByteString -> ([Text], [(Text, Maybe Text)]))
-> ByteString -> ([Text], [(Text, Maybe Text)])
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 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 :: forall url a.
((url -> [(Text, Maybe Text)] -> Text) -> url -> a)
-> (url -> ([Text], [(Text, Maybe Text)]))
-> ([Text] -> Either [Char] url)
-> Site url a
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, [])) ([Text] -> ([Text], [(Text, Maybe Text)]))
-> (url -> [Text]) -> url -> ([Text], [(Text, Maybe Text)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. url -> [Text]
forall url. PathInfo url => url -> [Text]
toPathSegments
       , parsePathSegments :: [Text] -> Either [Char] url
parsePathSegments  = URLParser url -> [Text] -> Either [Char] url
forall a. URLParser a -> [Text] -> Either [Char] a
parseSegments URLParser url
forall url. PathInfo url => URLParser url
fromPathSegments
       }

-- it's instances all the way down

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

instance PathInfo [Text] where
  toPathSegments :: [Text] -> [Text]
toPathSegments = [Text] -> [Text]
forall a. a -> a
id
  fromPathSegments :: ParsecT [Text] () Identity [Text]
fromPathSegments = URLParser Text -> ParsecT [Text] () Identity [Text]
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 = (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[]) (Text -> [Text]) -> ([Char] -> Text) -> [Char] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack
  fromPathSegments :: URLParser [Char]
fromPathSegments = Text -> [Char]
unpack (Text -> [Char]) -> URLParser Text -> URLParser [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URLParser Text
anySegment

instance PathInfo [String] where
  toPathSegments :: [[Char]] -> [Text]
toPathSegments = [Text] -> [Text]
forall a. a -> a
id ([Text] -> [Text]) -> ([[Char]] -> [Text]) -> [[Char]] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
pack
  fromPathSegments :: URLParser [[Char]]
fromPathSegments = URLParser [Char] -> URLParser [[Char]]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Text -> [Char]
unpack (Text -> [Char]) -> URLParser Text -> URLParser [Char]
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 ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i]
  fromPathSegments :: URLParser Int
fromPathSegments = (Any -> [Char]) -> (Text -> Maybe Int) -> URLParser Int
forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken ([Char] -> Any -> [Char]
forall a b. a -> b -> a
const [Char]
"Int") Text -> Maybe Int
forall a. Integral a => Text -> Maybe a
checkIntegral

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

instance PathInfo Int64 where
  toPathSegments :: Int64 -> [Text]
toPathSegments Int64
i = [[Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> [Char]
forall a. Show a => a -> [Char]
show Int64
i]
  fromPathSegments :: URLParser Int64
fromPathSegments = (Any -> [Char]) -> (Text -> Maybe Int64) -> URLParser Int64
forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken ([Char] -> Any -> [Char]
forall a b. a -> b -> a
const [Char]
"Int64") Text -> Maybe Int64
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 Reader a -> Reader a
forall a. Num a => Reader a -> Reader a
signed Reader a
forall a. Integral a => Reader a
decimal Text
txt of
    (Left [Char]
e) -> Maybe a
forall a. Maybe a
Nothing
    (Right (a
n, Text
r))
       | Text -> Bool
Text.null Text
r -> a -> Maybe a
forall a. a -> Maybe a
Just a
n
       | Bool
otherwise -> Maybe a
forall a. Maybe a
Nothing