{-# LANGUAGE OverloadedStrings #-}
module Network.CiscoSpark.Internal where
import Prelude hiding (concat, takeWhile)
import Control.Applicative ((<|>))
import Data.Attoparsec.ByteString
import Data.ByteString (ByteString, concat, pack,
singleton)
import Data.ByteString.Char8 (unpack)
import Data.Char (toLower)
import Data.Either (rights)
import Data.Maybe (listToMaybe)
import Data.Word (Word8)
import Data.BitSetWord8 (member, rfc3986UriReference,
rfc7230QDText, rfc7230QuotedPair,
rfc7230TChar)
import Network.HTTP.Simple (Response, getResponseHeader)
import Network.URI (URI (..), URIAuth (..), parseURI)
dropAndLow
:: Int
-> String
-> String
dropAndLow n = toLowerHead . drop n
where
toLowerHead [] = []
toLowerHead (c:cs) = toLower c : cs
data LinkParam = Rel | Other ByteString deriving (Eq, Show)
data LinkHeader = LinkHeader
{ linkHeaderUrl :: ByteString
, linkHeaderParams :: [(LinkParam, ByteString)]
}deriving (Eq, Show)
dQuote :: Parser Word8
dQuote = word8 0x22
semicolon :: Parser Word8
semicolon = word8 0x3b
equalChar :: Parser Word8
equalChar = word8 0x3d
lessThan :: Parser Word8
lessThan = word8 0x3c
greaterThan :: Parser Word8
greaterThan = word8 0x3e
skipSpace :: Parser ()
skipSpace = skipWhile (\c -> c == 0x20 || c == 0x09)
token :: Parser ByteString
token = takeWhile1 (member rfc7230TChar)
quotedPair :: Parser Word8
quotedPair = word8 0x5c >> satisfy (member rfc7230QuotedPair)
quotedString :: Parser ByteString
quotedString = do
dQuote
bss <- many' $ takeWhile1 (member rfc7230QDText) <|> (singleton <$> quotedPair)
dQuote
pure $ concat bss
paramValue :: Parser ByteString
paramValue = quotedString <|> token
paramName :: ByteString -> LinkParam
paramName "rel" = Rel
paramName x = Other x
param :: Parser (LinkParam, ByteString)
param = do
semicolon
skipSpace
name <- paramName <$> token
skipSpace
equalChar
skipSpace
val <- paramValue
pure (name, val)
linkHeader :: Parser LinkHeader
linkHeader = do
skipSpace
lessThan
uri <- takeWhile (member rfc3986UriReference)
greaterThan
skipSpace
params <- many' param
pure $ LinkHeader uri params
extractNextUrl :: [ByteString] -> [ByteString]
extractNextUrl = map linkHeaderUrl . filter isNextRel . rights . map (parseOnly linkHeader)
where
isNextRel = any (\(param, str) -> param == Rel && str == "next") . linkHeaderParams
getNextUrl :: Response a -> Maybe ByteString
getNextUrl = listToMaybe . extractNextUrl . getResponseHeader "Link"
validateUrl :: String -> URIAuth -> ByteString -> Maybe ByteString
validateUrl scheme uriAuth url = do
uri <- parseURI $ unpack url
auth <- uriAuthority uri
if (uriScheme uri == scheme) && (auth == uriAuth) then pure url else Nothing