{-# 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 :: [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 :: 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 -> String)
-> (Text -> SourcePos) -> (Text -> Maybe a) -> URLParser a
forall s t a u.
Stream s Identity t =>
(t -> String) -> (t -> SourcePos) -> (t -> Maybe a) -> Parsec s u a
token Text -> String
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 -> String -> URLParser Text
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> Text -> String
unpack Text
x

-- | match on any string
anySegment :: URLParser Text
anySegment :: URLParser Text
anySegment = (Any -> String) -> (Text -> Maybe Text) -> URLParser Text
forall tok a. tok -> (Text -> Maybe a) -> URLParser a
pToken (String -> Any -> String
forall a b. a -> b -> a
const String
"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 () -> String -> URLParser ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"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 :: ([Text] -> Either String a) -> URLParser a
patternParse [Text] -> Either String a
p =
  do [Text]
segs <- ParsecT [Text] () Identity [Text]
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
     case [Text] -> Either String 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 String
err) -> String -> URLParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err

-- | show Parsec 'ParseError' using terms that relevant to parsing a url
showParseError :: ParseError -> String
showParseError :: ParseError -> String
showParseError ParseError
pErr =
  let pos :: SourcePos
pos    = ParseError -> SourcePos
errorPos ParseError
pErr
      posMsg :: String
posMsg = SourcePos -> String
sourceName SourcePos
pos String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (segment " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SourcePos -> Int
sourceLine SourcePos
pos) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" character " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SourcePos -> Int
sourceColumn SourcePos
pos) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"): "
      msgs :: [Message]
msgs   = ParseError -> [Message]
errorMessages ParseError
pErr
  in String
posMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> String -> String -> String -> String -> [Message] -> String
showErrorMessages String
"or" String
"unknown parse error" String
"expecting" String
"unexpected" String
"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 :: URLParser a -> [Text] -> Either String a
parseSegments URLParser a
p [Text]
segments =
  case URLParser a -> String -> [Text] -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> 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] -> String
forall a. Show a => a -> String
show [Text]
segments) [Text]
segments of
    (Left ParseError
e)  -> String -> Either String a
forall a b. a -> Either a b
Left (ParseError -> String
showParseError ParseError
e)
    (Right a
r) -> a -> Either String 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 :: String -> Text
hyphenate =
    String -> Text
pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter Char -> String -> [String]
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 :: U1 url -> [Text]
gtoPathSegments U1 url
U1 = []
  gfromPathSegments :: URLParser (U1 url)
gfromPathSegments = U1 url -> URLParser (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 :: D1 c a url -> [Text]
gtoPathSegments = a url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments (a url -> [Text]) -> (D1 c a url -> a url) -> D1 c a url -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D1 c a url -> a url
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
  gfromPathSegments :: URLParser (D1 c a url)
gfromPathSegments = a url -> D1 c a url
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a url -> D1 c a url)
-> ParsecT [Text] () Identity (a url) -> URLParser (D1 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 :: S1 c a url -> [Text]
gtoPathSegments = a url -> [Text]
forall (f :: * -> *) url. GPathInfo f => f url -> [Text]
gtoPathSegments (a url -> [Text]) -> (S1 c a url -> a url) -> S1 c a url -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 c a url -> a url
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
  gfromPathSegments :: URLParser (S1 c a url)
gfromPathSegments = a url -> S1 c a url
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a url -> S1 c a url)
-> ParsecT [Text] () Identity (a url) -> URLParser (S1 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 :: C1 c a url -> [Text]
gtoPathSegments m :: C1 c a url
m@(M1 a url
x) = (String -> Text
hyphenate (String -> Text) -> (C1 c a url -> String) -> C1 c a url -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 c a url -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
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 :: URLParser (C1 c a url)
gfromPathSegments = a url -> C1 c a url
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a url -> C1 c a url)
-> URLParser Text
-> ParsecT [Text] () Identity (a url -> C1 c a url)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> URLParser Text
segment (String -> Text
hyphenate (String -> Text)
-> (M1 C c a Any -> String) -> M1 C c a Any -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 C c a Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (M1 C c a Any -> Text) -> M1 C c a Any -> Text
forall a b. (a -> b) -> a -> b
$ (forall r. M1 C c a r
forall a. HasCallStack => a
undefined :: C1 c a r))
                         ParsecT [Text] () Identity (a url -> C1 c a url)
-> ParsecT [Text] () Identity (a url) -> URLParser (C1 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 :: (:*:) 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 :: 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) -> URLParser ((:*:) 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 :: (:+:) 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 :: 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) -> URLParser ((:+:) 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
                  URLParser ((:+:) a b url)
-> URLParser ((:+:) a b url) -> URLParser ((:+:) 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) -> URLParser ((:+:) 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 :: 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 i c k (p :: k). K1 i c p -> c
unK1
  gfromPathSegments :: 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 -> URLParser (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 :: 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 :: 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 :: 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 :: ByteString -> Either String url
fromPathInfo ByteString
pi =
  URLParser url -> [Text] -> Either String url
forall a. URLParser a -> [Text] -> Either String 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 :: ByteString -> Either String (url, [(Text, Maybe Text)])
fromPathInfoParams ByteString
pi =
  (,[(Text, Maybe Text)]
query) (url -> (url, [(Text, Maybe Text)]))
-> Either String url -> Either String (url, [(Text, Maybe Text)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URLParser url -> [Text] -> Either String url
forall a. URLParser a -> [Text] -> Either String 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 :: ((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 String 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 String url
parsePathSegments  = URLParser url -> [Text] -> Either String url
forall a. URLParser a -> [Text] -> Either String 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 :: String -> [Text]
toPathSegments = (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[]) (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
  fromPathSegments :: URLParser String
fromPathSegments = Text -> String
unpack (Text -> String) -> URLParser Text -> URLParser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URLParser Text
anySegment

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

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

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

checkIntegral :: Integral a => Text -> Maybe a
checkIntegral :: 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 String
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