module Network.HTTP.Link.Parser (
linkHeader
, parseLinkHeader'
, parseLinkHeader
) where
import Prelude hiding (takeWhile, take)
import Control.Applicative
import Control.Error.Util (hush)
import Data.Text hiding (takeWhile, map, take)
import Data.Char (isSpace)
import Data.Monoid (mconcat)
import Data.Attoparsec.Text
import Network.URI
import Network.HTTP.Link.Types
allConditions :: [a -> Bool] -> a -> Bool
allConditions cs x = and $ map ($ x) cs
charWS :: Char -> Parser ()
charWS x = skipSpace >> char x >> skipSpace
quotedString :: Parser Text
quotedString = do
char '"'
v <- many stringPart
char '"'
return $ pack $ unEscapeString $ unpack $ mconcat v
where stringPart = takeWhile1 (allConditions [(/= '"'), (/= '\\')]) <|> escapedChar
escapedChar = char '\\' >> take 1
paramName :: Text -> LinkParam
paramName "rel" = Rel
paramName "anchor" = Anchor
paramName "rev" = Rev
paramName "hreflang" = Hreflang
paramName "media" = Media
paramName "title" = Title
paramName "title*" = Title'
paramName "type" = ContentType
paramName x = Other x
relType :: Parser Text
relType = takeWhile1 $ inClass "-0-9a-z."
paramValue :: LinkParam -> Parser Text
paramValue Rel = quotedString <|> relType
paramValue Rev = quotedString <|> relType
paramValue Title' = takeWhile (allConditions [not . isSpace])
paramValue _ = quotedString
param :: Parser (LinkParam, Text)
param = do
charWS ';'
n <- takeWhile (allConditions [(/= '='), not . isSpace])
let n' = paramName n
charWS '='
v <- paramValue n'
return (n', v)
link :: Parser Link
link = do
charWS '<'
linkText <- takeWhile1 $ allConditions [(/= '>'), not . isSpace]
charWS '>'
params <- many' $ param
skipSpace
case parseURIReference $ unpack linkText of
Just u -> return $ Link u params
Nothing -> fail "Couldn't parse the URI"
linkHeader :: Parser [Link]
linkHeader = link `sepBy'` (char ',')
parseLinkHeader' :: Text -> Either String [Link]
parseLinkHeader' = parseOnly linkHeader
parseLinkHeader :: Text -> Maybe [Link]
parseLinkHeader = hush . parseLinkHeader'