module Network.URLb where
import Control.Applicative
import Control.Monad
import Data.Bits
import Data.ByteString.Char8 (groupBy, pack)
import Data.ByteString hiding (groupBy, pack, take, takeWhile)
import Data.Either
import Data.Maybe
import Data.Monoid
import Data.String
import Data.Word
import Prelude hiding (concatMap, drop, null, take, takeWhile)
import Data.Attoparsec.ByteString
import Data.Attoparsec.ByteString.Char8 (hexadecimal, decimal, char)
data URL = URL { scheme :: Scheme
, authority :: Maybe Authority
, path :: ByteString
, query :: ByteString
, fragment :: ByteString }
deriving (Eq, Ord, Show)
instance IsString URL where fromString = fromRight . fromString'
instance Parse URL where parser = url <$> (parser <* string "://")
<*> authorityPath
<*> option "" (char '?' *> qf)
<*> option "" (char '#' *> qf)
where url a (b, c) d e = URL a b c d e
qf = option "" queryFragmentP
instance Encode URL where
encode URL{..} = mconcat
[ encode scheme, "://"
, maybe "" encode authority
, "/" `concatNonEmpty` pathEncode path
, "?" `concatNonEmpty` selectiveEncode queryFragmentOctet query
, "#" `concatNonEmpty` selectiveEncode queryFragmentOctet fragment ]
data Authority = Authority { userinfo :: ByteString
, host :: ByteString
, port :: Maybe Word16 }
deriving (Eq, Ord, Show)
instance IsString Authority where fromString = fromRight . fromString'
instance Parse Authority where parser = Authority
<$> option "" (userinfoP <* char '@')
<*> regNameP
<*> optional (char ':' *> decimal)
instance Encode Authority where
encode Authority{..} = mconcat
[ selectiveEncode userinfoOctet userinfo `concatNonEmpty` "@"
, selectiveEncode regNameOctet host
, maybe "" (mappend ":" . pack . show) port ]
newtype Scheme = Scheme ByteString deriving (Eq, Ord, Show)
instance IsString Scheme where fromString = fromRight . fromString'
instance Encode Scheme where encode (Scheme b) = b
instance Parse Scheme where parser = (Scheme .) . cons
<$> satisfy (inClass "a-zA-Z")
<*> takeWhile (inClass "a-zA-Z0-9.+-")
class Encode t where encode :: t -> ByteString
class Parse t where parser :: Parser t
userinfoOctet :: Word8 -> Bool
userinfoOctet = inClass "-a-zA-Z0-9._~!$&'()*+,;=:"
userinfoP :: Parser ByteString
userinfoP = withPercents userinfoOctet
regNameOctet :: Word8 -> Bool
regNameOctet = inClass "-a-zA-Z0-9._~!$&'()*+,;="
regNameP :: Parser ByteString
regNameP = withPercents regNameOctet
percent :: Parser Word8
percent = char '%' *> usingOnly 2 hexadecimal
pathRootlessP :: Parser ByteString
pathRootlessP = mappend <$> segment <*> option "" next
where segment = withPercents segmentOctet
next = char '/' *> (mappend "/" <$> pathRootlessP)
segmentOctet :: Word8 -> Bool
segmentOctet = inClass "-a-zA-Z0-9._~!$&'()*+,;=:@"
authorityPath :: Parser (Maybe Authority, ByteString)
authorityPath = (,) <$> (Just <$> parser) <*> option "" (char '/' *> pathP)
<|> (,) <$> (char '/' *> pure Nothing) <*> pathP
where pathP = option "" pathRootlessP
queryFragmentOctet :: Word8 -> Bool
queryFragmentOctet = inClass "-a-zA-Z0-9._~!$&'()*+,;=:@/?"
queryFragmentP :: Parser ByteString
queryFragmentP = withPercents queryFragmentOctet
usingOnly :: Int -> Parser t -> Parser t
usingOnly c p = either (const mzero) return . parseOnly p =<< take c
withPercents :: (Word8 -> Bool) -> Parser ByteString
withPercents predicate = cons <$> one <*> (option "" more)
where more = withPercents predicate
one = satisfy predicate <|> percent
percentEncode :: Word8 -> ByteString
percentEncode w = "%" `snoc` mod' (w `shiftR` 4) `snoc` mod' w
where mod' w' = "0123456789ABCDEF" `index` fromIntegral (w' `mod` 16)
selectiveEncode :: (Word8 -> Bool) -> ByteString -> ByteString
selectiveEncode predicate bytes = unfoldr f ("", bytes)
where f (queued, remaining) = dequeue <|> next
where
dequeue = do (w, queued') <- uncons queued
Just (w, (queued', remaining))
next = do (w, remaining') <- uncons remaining
if predicate w then Just (w, (queued, remaining'))
else f (percentEncode w, remaining')
concatNonEmpty a b | null a || null b = ""
| otherwise = mappend a b
pathEncode :: ByteString -> ByteString
pathEncode = mconcat . fmap enc . groupBy neitherSlash
where
enc s | "/" == s = "/"
| isPrefixOf "//" s = "/" `mappend` concatMap percentEncode (drop 1 s)
| otherwise = selectiveEncode regNameOctet s
neitherSlash a b = (a /= '/' && b /= '/') || (a == '/' && b == '/')
fromString' s = parseOnly (parser <* endOfInput) (fromString s)
fromRight (Right x) = x
fromRight (Left s) = error s