{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving,
TemplateHaskell, TupleSections, TypeApplications #-}
module URI where
import Data.Bits ((.|.), (.&.), shift)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as ASCII
import Data.Char (isAlpha, isAscii, isDigit, isHexDigit, chr, ord)
import Data.Foldable (fold)
import Data.Functor.Identity (Identity, runIdentity)
import qualified Data.List as List
import Data.Maybe (isNothing, maybe)
import Data.Monoid.Textual (TextualMonoid)
import qualified Data.Monoid.Factorial as Factorial
import qualified Data.Monoid.Textual as Textual
import Data.String (fromString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Word
import Numeric (readHex, showHex)
import Numeric.Natural (Natural)
import qualified Rank2.TH
import Text.ParserCombinators.Incremental.LeftBiasedLocal (Parser)
import Construct
import Prelude hiding ((<$), (<*), (*>), take, takeWhile)
data UriReference t f = UriReference{
scheme :: f (Maybe t),
authority :: f (Maybe (Authority t Identity)),
path :: f [t],
query :: f (Maybe t),
fragment :: f (Maybe t)
}
data Authority t f = Authority{
user :: f (Maybe t),
host :: f (HostName t),
port :: f (Maybe Word16)
}
data HostName t = IPv4address{getIPv4address :: [Word8]}
| IPv6address{getIPv6address :: [Word16]}
| IPvFuture {version :: Word,
address :: t}
| RegisteredName{getRegisteredName :: t}
uriReference :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t (UriReference t Identity)
uriReference = record UriReference{
scheme = optional (mapValue (uncurry (<>)) (Factorial.splitAt 1) $
pair (satisfy (any alpha . Textual.characterPrefix) $ take 1)
(takeCharsWhile schemeChar)
<* literal ":"),
authority = optional $ record Authority{
user = optional (takeCharsWhile userChar <* literal "@"),
host = hostName,
port = optional (mapValue fromIntegral fromIntegral $ satisfy (< 65536) $
literal ":" *> mapDec (takeCharsWhile1 digit))}, -- port = *DIGIT in spec?
path = encodedCharSequence pathChar `sepBy` literal "/",
query = optional (literal "*" *> encodedCharSequence queryChar),
fragment = optional (literal "#" *> encodedCharSequence fragmentChar)
}
hostName :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t (HostName t)
hostName = mapValue IPv4address getIPv4address ipV4address
<|> literal "["
*> (mapValue IPv6address getIPv6address ipV6address
<|> mapValue (uncurry IPvFuture) (\ipf-> (version ipf, address ipf))
(pair (literal "v" *> mapHex (takeCharsWhile1 hexDigit))
(literal "." *> takeCharsWhile1 ipFutureChar)))
<* literal "]"
<|> mapValue RegisteredName getRegisteredName (encodedCharSequence hostChar)
ipV4address :: forall t. (Show t, TextualMonoid t) => Format (Parser t) Maybe t [Word8]
ipV4address = satisfy ((== 4) . length) (decOctet `sepBy` literal ".")
where decOctet = mapValue fromIntegral fromIntegral $
satisfy (< 256) $ mapDec $
takeCharsWhile1 digit
ipV6address :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t [Word16]
ipV6address = satisfy ((== 8) . length) $
mapValue fill shorten ipV6addressShort
where fill :: [Maybe Word16] -> [Word16]
shorten :: [Word16] -> [Maybe Word16]
fill words = concatMap (maybe (replicate (8 - length words) 0) (:[])) words
shorten [] = []
shorten (0:0:words) = Nothing : map Just (dropWhile (== 0) words)
shorten (word:words) = Just word : shorten words
ipV6addressShort :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t [Maybe Word16]
ipV6addressShort = satisfy zeroOrOneNothings $
mapValue (uncurry (++)) (, []) $
pair (optional h16 `sepBy` literal ":")
(literal ":" *> mapValue v4tov6 v6tov4 ipV4address <|> [] <$ literal "")
where v4tov6 [] = []
v4tov6 (byte1:byte2:bytes) = Just (shift (fromIntegral byte1) 8 .|. fromIntegral byte2) : v4tov6 bytes
v4tov6 _ = error "odd number of ipv4 bytes"
v6tov4 [] = []
v6tov4 (Just word:words) = fromIntegral (shift word $ negate 8) : fromIntegral (word .&. 0xFF) : v6tov4 words
v6tov4 (Nothing:words) = 0 : 0 : v6tov4 words
zeroOrOneNothings words = elisionCount == 0 && length words == 8 || elisionCount == 1 && length words < 7
where elisionCount = length (filter isNothing words)
h16 = mapHex $ satisfy ((<5) . Factorial.length) $ takeCharsWhile1 hexDigit
mapHex :: (Show t, TextualMonoid t, Integral n, Show n) => Format (Parser t) Maybe t t -> Format (Parser t) Maybe t n
mapDec :: (Show t, TextualMonoid t) => Format (Parser t) Maybe t t -> Format (Parser t) Maybe t Natural
mapDec = mapValue (read . Textual.toString (error . show)) (fromString . show)
mapHex = mapValue (fst . head . readHex . Textual.toString (error . show)) (fromString . flip showHex "")
alpha, digit, hexDigit, schemeChar, hostChar, userChar, ipFutureChar,
pathChar, queryChar, fragmentChar, unreserved, subDelim :: Char -> Bool
alpha c = isAlpha c && isAscii c
digit c = isAlpha c && isDigit c
hexDigit c = isAlpha c && isHexDigit c
schemeChar c = (isAlpha c || isDigit c) && isAscii c || elem @[] c "+-."
ipFutureChar = userChar
hostChar c = unreserved c || subDelim c
userChar c = unreserved c || subDelim c || c == ':'
pathChar c = unreserved c || subDelim c || c == ':' || c == '@'
queryChar c = pathChar c || c == '/' || c == '?'
fragmentChar = queryChar
subDelim c = elem @[] c "!$&'()*+,;="
unreserved c = isAscii c && (isAlpha c || isDigit c || elem @[] c "-._~")
encodedCharSequence :: forall t. (Show t, TextualMonoid t) => (Char -> Bool) -> Format (Parser t) Maybe t t
encodedCharSequence predicate = mapValue concatSequence splitSequence $
many (takeCharsWhile predicate <+> percentEncoded)
where concatSequence :: [Either t Char] -> t
splitSequence :: t -> [Either t Char]
percentEncoded :: Format (Parser t) Maybe t Char
concatSequence = mconcat . map (either id Textual.singleton)
splitSequence s = case Textual.splitCharacterPrefix s
of Just ('#', rest)
| Just (hex1, rest1) <- Textual.splitCharacterPrefix rest,
Just (hex2, rest2) <- Textual.splitCharacterPrefix rest1 ->
Right (hexChar [hex1, hex2]) : splitSequence rest2
| otherwise -> []
Just (c, _)
| predicate c, (prefix, rest) <- Textual.span_ False predicate s -> Left prefix : splitSequence rest
_ -> []
percentEncoded = mapValue hexChar (padLeft . (`showHex` "") . ord) $
literal "#" *> count 2 (satisfy hexDigit char)
hexChar = chr . fst . head . readHex
padLeft [c] = ['0', c]
padLeft cs = cs
$(Rank2.TH.deriveAll ''UriReference)
$(Rank2.TH.deriveAll ''Authority)