    {-# LANGUAGE OverloadedStrings, UnicodeSyntax, Safe, CPP #-}
    {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}

    -- | The parser for the HTTP Link header as defined in RFC 5988.
    -- More liberal than the RFC though:
    -- does not validate URLs and other deep stuff,
    -- accepts whitespace in weird places.
    module Network.HTTP.Link.Parser (
      linkHeader
    , parseLinkHeader'
    , parseLinkHeader
    , parseLinkHeaderBS'
    , parseLinkHeaderBS
    ) where

    import           Prelude hiding (takeWhile, take)
    import           Control.Applicative ((<|>), many)
    import           Control.Error.Util (hush)
    import           Data.Text (Text, pack, unpack)
    import           Data.Text.Encoding (decodeUtf8)
    import           Data.ByteString (ByteString)
    import           Data.Char (isSpace)
    #if !MIN_VERSION_base(4,8,0)
    import           Data.Monoid (mconcat)
    #endif
    import           Data.Attoparsec.Text (Parser, parseOnly, char, sepBy', many', skipSpace, takeWhile, takeWhile1, take, inClass)
    import           Network.URI (unEscapeString)
    import           Network.HTTP.Link.Types

    allConditions ∷ [a → Bool] → a → Bool
    allConditions :: forall a. [a -> Bool] -> a -> Bool
    allConditions [a -> Bool]
    cs a
    x = [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    and ([Bool] -> Bool) -> [Bool] -> Bool
    forall a b. (a -> b) -> a -> b
    $ ((a -> Bool) -> Bool) -> [a -> Bool] -> [Bool]
    forall a b. (a -> b) -> [a] -> [b]
    map ((a -> Bool) -> a -> Bool
    forall a b. (a -> b) -> a -> b
    $ a
    x) [a -> Bool]
    cs

    charWS ∷ Char → Parser ()
    charWS :: Char -> Parser ()
    charWS Char
    x = Parser ()
    skipSpace Parser () -> Parser Text Char -> Parser Text Char
    forall a b. Parser Text a -> Parser Text b -> Parser Text b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Char -> Parser Text Char
    char Char
    x Parser Text Char -> Parser () -> Parser ()
    forall a b. Parser Text a -> Parser Text b -> Parser Text b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Parser ()
    skipSpace

    quotedString ∷ Parser Text
    quotedString :: Parser Text
    quotedString = do
      Char -> Parser Text Char
    char Char
    '"'
      v ← Parser Text -> Parser Text [Text]
    forall a. Parser Text a -> Parser Text [a]
    forall (f :: * -> *) a. Alternative f => f a -> f [a]
    many Parser Text
    stringPart
      char '"'
      return $ pack $ unEscapeString $ unpack $ mconcat v
      where stringPart :: Parser Text
    stringPart = (Char -> Bool) -> Parser Text
    takeWhile1 ([Char -> Bool] -> Char -> Bool
    forall a. [a -> Bool] -> a -> Bool
    allConditions [(Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '"'), (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\\')]) Parser Text -> Parser Text -> Parser Text
    forall a. Parser Text a -> Parser Text a -> Parser Text a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Parser Text
    escapedChar
            escapedChar :: Parser Text
    escapedChar = Char -> Parser Text Char
    char Char
    '\\' Parser Text Char -> Parser Text -> Parser Text
    forall a b. Parser Text a -> Parser Text b -> Parser Text b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Int -> Parser Text
    take Int
    1

    paramName ∷ Text → LinkParam
    paramName :: Text -> LinkParam
    paramName Text
    "rel"       = LinkParam
    Rel
    paramName Text
    "anchor"    = LinkParam
    Anchor
    paramName Text
    "rev"       = LinkParam
    Rev
    paramName Text
    "hreflang"  = LinkParam
    Hreflang
    paramName Text
    "media"     = LinkParam
    Media
    paramName Text
    "title"     = LinkParam
    Title
    paramName Text
    "title*"    = LinkParam
    Title'
    paramName Text
    "type"      = LinkParam
    ContentType
    paramName Text
    x           = Text -> LinkParam
    Other Text
    x

    relType ∷ Parser Text
    relType :: Parser Text
    relType = (Char -> Bool) -> Parser Text
    takeWhile1 ((Char -> Bool) -> Parser Text) -> (Char -> Bool) -> Parser Text
    forall a b. (a -> b) -> a -> b
    $ String -> Char -> Bool
    inClass String
    "-0-9a-z."

    paramValue ∷ LinkParam → Parser Text
    paramValue :: LinkParam -> Parser Text
    paramValue LinkParam
    Rel    = Parser Text
    quotedString Parser Text -> Parser Text -> Parser Text
    forall a. Parser Text a -> Parser Text a -> Parser Text a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Parser Text
    relType
    paramValue LinkParam
    Rev    = Parser Text
    quotedString Parser Text -> Parser Text -> Parser Text
    forall a. Parser Text a -> Parser Text a -> Parser Text a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Parser Text
    relType
    paramValue LinkParam
    Title' = (Char -> Bool) -> Parser Text
    takeWhile ([Char -> Bool] -> Char -> Bool
    forall a. [a -> Bool] -> a -> Bool
    allConditions [Bool -> Bool
    not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> Bool
    isSpace])
    paramValue LinkParam
    _      = Parser Text
    quotedString

    param ∷ Parser (LinkParam, Text)
    param :: Parser (LinkParam, Text)
    param = do
      Char -> Parser ()
    charWS Char
    ';'
      n ← (Char -> Bool) -> Parser Text
    takeWhile ([Char -> Bool] -> Char -> Bool
    forall a. [a -> Bool] -> a -> Bool
    allConditions [(Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '='), Bool -> Bool
    not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> Bool
    isSpace])
      let n' = Text -> LinkParam
    paramName Text
    n
      charWS '='
      v ← paramValue n'
      return (n', v)

    link ∷ (IsURI uri) ⇒ Parser (Link uri)
    link :: forall uri. IsURI uri => Parser (Link uri)
    link = do
      Char -> Parser ()
    charWS Char
    '<'
      linkText ← (Char -> Bool) -> Parser Text
    takeWhile1 ((Char -> Bool) -> Parser Text) -> (Char -> Bool) -> Parser Text
    forall a b. (a -> b) -> a -> b
    $ [Char -> Bool] -> Char -> Bool
    forall a. [a -> Bool] -> a -> Bool
    allConditions [(Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '>'), Bool -> Bool
    not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> Bool
    isSpace]
      charWS '>'
      params ← many' $ param
      skipSpace
      case uriFromText linkText of
        Right uri
    u → Link uri -> Parser Text (Link uri)
    forall a. a -> Parser Text a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Link uri -> Parser Text (Link uri))
    -> Link uri -> Parser Text (Link uri)
    forall a b. (a -> b) -> a -> b
    $ uri -> [(LinkParam, Text)] -> Link uri
    forall uri. uri -> [(LinkParam, Text)] -> Link uri
    Link uri
    u [(LinkParam, Text)]
    params
        Left String
    e → String -> Parser Text (Link uri)
    forall a. String -> Parser Text a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser Text (Link uri))
    -> String -> Parser Text (Link uri)
    forall a b. (a -> b) -> a -> b
    $ String
    "Couldn't parse the URI " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Text -> String
    forall a. Show a => a -> String
    show Text
    linkText String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ if String
    e String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    "" then String
    "" else String
    ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    e

    -- | The Attoparsec parser for the Link header.
    linkHeader ∷ (IsURI uri) ⇒ Parser [Link uri]
    linkHeader :: forall uri. IsURI uri => Parser [Link uri]
    linkHeader = Parser (Link uri)
    forall uri. IsURI uri => Parser (Link uri)
    link Parser (Link uri) -> Parser Text Char -> Parser Text [Link uri]
    forall (m :: * -> *) a s. MonadPlus m => m a -> m s -> m [a]
    `sepBy'` (Char -> Parser Text Char
    char Char
    ',')

    -- | Parses a Link header, returns an Either, where Left is the Attoparsec
    -- error string (probably not a useful one).
    parseLinkHeader' ∷ (IsURI uri) ⇒ Text → Either String [Link uri]
    parseLinkHeader' :: forall uri. IsURI uri => Text -> Either String [Link uri]
    parseLinkHeader' = Parser [Link uri] -> Text -> Either String [Link uri]
    forall a. Parser a -> Text -> Either String a
    parseOnly Parser [Link uri]
    forall uri. IsURI uri => Parser [Link uri]
    linkHeader

    -- | Parses a Link header, returns a Maybe.
    parseLinkHeader ∷ (IsURI uri) ⇒ Text → Maybe [Link uri]
    parseLinkHeader :: forall uri. IsURI uri => Text -> Maybe [Link uri]
    parseLinkHeader = Either String [Link uri] -> Maybe [Link uri]
    forall a b. Either a b -> Maybe b
    hush (Either String [Link uri] -> Maybe [Link uri])
    -> (Text -> Either String [Link uri]) -> Text -> Maybe [Link uri]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Either String [Link uri]
    forall uri. IsURI uri => Text -> Either String [Link uri]
    parseLinkHeader'

    -- | Parses a Link header, returns an Either, where Left is the Attoparsec
    -- error string (probably not a useful one).
    parseLinkHeaderBS' ∷ (IsURI uri) ⇒ ByteString → Either String [Link uri]
    parseLinkHeaderBS' :: forall uri. IsURI uri => ByteString -> Either String [Link uri]
    parseLinkHeaderBS' = Text -> Either String [Link uri]
    forall uri. IsURI uri => Text -> Either String [Link uri]
    parseLinkHeader' (Text -> Either String [Link uri])
    -> (ByteString -> Text) -> ByteString -> Either String [Link uri]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> Text
    decodeUtf8

    -- | Parses a Link header, returns a Maybe.
    parseLinkHeaderBS ∷ (IsURI uri) ⇒ ByteString → Maybe [Link uri]
    parseLinkHeaderBS :: forall uri. IsURI uri => ByteString -> Maybe [Link uri]
    parseLinkHeaderBS = Text -> Maybe [Link uri]
    forall uri. IsURI uri => Text -> Maybe [Link uri]
    parseLinkHeader (Text -> Maybe [Link uri])
    -> (ByteString -> Text) -> ByteString -> Maybe [Link uri]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> Text
    decodeUtf8