{-# 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
import           Control.Error.Util (hush)
import           Data.Text hiding (takeWhile, map, take)
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
import           Network.URI
import           Network.HTTP.Link.Types

allConditions ∷ [a → Bool] → a → Bool
allConditions :: [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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
x Parser Text Char -> Parser () -> Parser ()
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
'"'
  [Text]
v ← Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text
stringPart
  Char -> Parser Text Char
char Char
'"'
  Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
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 (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 (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 (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 (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
';'
  Text
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' :: LinkParam
n' = Text -> LinkParam
paramName Text
n
  Char -> Parser ()
charWS Char
'='
  Text
v ← LinkParam -> Parser Text
paramValue LinkParam
n'
  (LinkParam, Text) -> Parser (LinkParam, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (LinkParam
n', Text
v)

link ∷ (IsURI uri) ⇒ Parser (Link uri)
link :: Parser (Link uri)
link = do
  Char -> Parser ()
charWS Char
'<'
  Text
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]
  Char -> Parser ()
charWS Char
'>'
  [(LinkParam, Text)]
params ← Parser (LinkParam, Text) -> Parser Text [(LinkParam, Text)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser (LinkParam, Text) -> Parser Text [(LinkParam, Text)])
-> Parser (LinkParam, Text) -> Parser Text [(LinkParam, Text)]
forall a b. (a -> b) -> a -> b
$ Parser (LinkParam, Text)
param
  Parser ()
skipSpace
  case Text -> Either String uri
forall uri. IsURI uri => Text -> Either String uri
uriFromText Text
linkText of
    Right uri
u → Link uri -> Parser (Link uri)
forall (m :: * -> *) a. Monad m => a -> m a
return (Link uri -> Parser (Link uri)) -> Link uri -> Parser (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 (Link uri)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Link uri)) -> String -> Parser (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 :: Parser [Link uri]
linkHeader = Parser (Link uri)
forall uri. IsURI uri => Parser (Link uri)
link Parser (Link uri) -> Parser Text Char -> Parser [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' :: 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 :: 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' :: 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 :: 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