module Network.Protocol.Uri.Parser where
import Control.Applicative hiding (empty)
import Control.Category
import Data.Char
import Control.Monad
import Control.Applicative
import Data.List
import Data.Maybe
import Data.Record.Label
import Network.Protocol.Uri.Data
import Network.Protocol.Uri.Encode
import Network.Protocol.Uri.Printer ()
import Network.Protocol.Uri.Query
import Prelude hiding ((.), id, mod)
import Safe
import Text.ParserCombinators.Parsec hiding (many, (<|>))
instance Applicative (GenParser Char st) where
pure = return
(<*>) = ap
instance Alternative (GenParser Char st) where
empty = mzero
(<|>) = mplus
host :: Uri :-> String
host = (show <-> either (const mkHost) id . parseHost) `iso` (_host . authority)
path :: Uri :-> FilePath
path = (decode . show <-> either (const mkPath) id . parsePath . encode) `iso` _path
pathAndQuery :: Uri :-> String
pathAndQuery = values "?" `osi` Label ((\p q -> [p, q]) <$> idx 0 `for` path <*> idx 1 `for` query)
where idx = flip (atDef "")
toUri :: String -> Uri
toUri = either (const mkUri) id . parseUri
parseUri :: String -> Either ParseError Uri
parseUri = parse pUriReference ""
parseAbsoluteUri :: String -> Either ParseError Uri
parseAbsoluteUri = parse pAbsoluteUri ""
parseAuthority :: String -> Either ParseError Authority
parseAuthority = parse pAuthority ""
parsePath :: String -> Either ParseError Path
parsePath = parse pPath ""
parseHost :: String -> Either ParseError Host
parseHost = parse pHost ""
pAlpha, pDigit, pAlphanum :: CharParser st Char
pAlpha = letter
pDigit = digit
pAlphanum = alphaNum
pUnreserved :: GenParser Char st Char
pUnreserved = pAlphanum <|> oneOf "-._~"
pReserved :: GenParser Char st Char
pReserved = pGenDelims <|> pSubDelims
pGenDelims :: CharParser st Char
pGenDelims = oneOf ":/?#[]@"
pSubDelims :: CharParser st Char
pSubDelims = oneOf "!$&'()*+,;="
pPctEncoded :: GenParser Char st String
pPctEncoded = (:) <$> char '%' <*> pHex
pHex :: GenParser Char st String
pHex = (\a b -> a:b:[])
<$> hexDigit
<*> hexDigit
pUri :: GenParser Char st Uri
pUri = (\a (b,c) d e -> Uri False a b c d e)
<$> (pScheme <* string ":")
<*> (q <|> p)
<*> option "" (string "?" *> pQuery)
<*> option "" (string "#" *> pFragment)
where
q = (,) <$> (string "//" *> pAuthority) <*> pPathAbempty
p = ((,) mkAuthority) <$> (pPathAbsolute <|> pPathRootless )
pScheme :: GenParser Char st String
pScheme = (:) <$> pAlpha <*> many (pAlphanum <|> oneOf "+_.")
pAuthority :: GenParser Char st Authority
pAuthority = Authority
<$> option mkUserinfo (try (pUserinfo <* string "@"))
<*> pHost
<*> option Nothing (string ":" *> pPort)
pUserinfo :: GenParser Char st String
pUserinfo = concat <$> many (
(pure <$> pUnreserved)
<|> ( pPctEncoded)
<|> (pure <$> pSubDelims)
<|> (pure <$> oneOf ":")
)
pHost :: GenParser Char st Host
pHost = diff <$> pRegName
where
diff a = either (const (RegName a)) sep (parse pHostname "" a)
sep a = if hst a then Hostname (Domain a) else ipreg a
ipreg a = if ip a then IP (toIP a) else RegName (intercalate "." a)
hst = not . all isDigit . headDef "" . dropWhile null . reverse
ip a = length a == 4 && length (mapMaybe (either (const Nothing) Just . parse pDecOctet "") a) == 4
toIP [a, b, c, d] = IPv4 (read a) (read b) (read c) (read d)
toIP _ = IPv4 0 0 0 0
pIPv4address :: GenParser Char st [Int]
pIPv4address = (:) <$> pDecOctet <*> (count 3 $ char '.' *> pDecOctet)
pDecOctet :: GenParser Char st Int
pDecOctet = read <$> choice [
try ((\a b c -> [a,b,c]) <$> char '2' <*> char '5' <*> oneOf "012345")
, try ((\a b c -> [a,b,c]) <$> char '2' <*> oneOf "01234" <*> digit)
, try ((\a b c -> [a,b,c]) <$> char '1' <*> digit <*> digit)
, try ((\a b -> [a,b]) <$> digit <*> digit)
, (pure <$> digit)
]
pRegName :: GenParser Char st String
pRegName = concat <$> many1 (
(pure <$> pUnreserved)
<|> pPctEncoded
<|> (pure <$> pSubDelims))
pHostname :: GenParser Char st [String]
pHostname = sepBy (option "" pDomainlabel) (string ".")
pDomainlabel :: GenParser Char st String
pDomainlabel = intercalate "-" <$> sepBy1 (some pAlphanum) (string "-")
pPort :: GenParser Char st (Maybe Port)
pPort = readMay <$> some pDigit
pQuery :: GenParser Char st String
pQuery = concat <$> many (pPchar <|> pure <$> oneOf "/?")
pFragment :: GenParser Char st String
pFragment = concat <$> many (pPchar <|> pure <$> oneOf "/?" )
pPath, pPathAbempty, pPathAbsolute, pPathNoscheme, pPathRootless, pPathEmpty :: GenParser Char st Path
pPath =
try pPathAbsolute
<|> try pPathNoscheme
<|> try pPathRootless
<|> pPathEmpty
pPathAbempty = Path . ("":) <$> _pSlashSegments
pPathAbsolute = (char '/' *>) $ Path . ("":) <$> (option [] $ (:) <$> pSegmentNz <*> _pSlashSegments)
pPathNoscheme = Path <$> ((:) <$> pSegmentNzNc <*> _pSlashSegments)
pPathRootless = Path <$> ((:) <$> pSegmentNz <*> _pSlashSegments)
pPathEmpty = Path [] <$ string ""
pSegment, pSegmentNz, pSegmentNzNc :: GenParser Char st String
pSegment = concat <$> many pPchar
pSegmentNz = concat <$> some pPchar
pSegmentNzNc = concat <$> some (
(pure <$> pUnreserved)
<|> pPctEncoded
<|> (pure <$> pSubDelims)
<|> (pure <$> oneOf "@" ))
_pSlashSegments :: GenParser Char st [PathSegment]
_pSlashSegments = (many $ (:) <$> char '/' *> pSegment)
pPchar :: GenParser Char st String
pPchar = choice
[ pure <$> pUnreserved
, pPctEncoded
, pure <$> pSubDelims
, pure <$> oneOf ":@"
]
pUriReference :: GenParser Char st Uri
pUriReference = try pAbsoluteUri <|> pRelativeRef
pRelativeRef :: GenParser Char st Uri
pRelativeRef = ($)
<$> (try pRelativePart
<|> ((Uri True mkScheme mkAuthority)
<$> (pPathAbsolute <|> pPathRootless <|> pPathEmpty)))
<*> option "" (string "?" *> pQuery)
<*> option "" (string "#" *> pFragment)
pRelativePart :: GenParser Char st (Query -> Fragment -> Uri)
pRelativePart = Uri True mkScheme <$> (string "//" *> pAuthority) <*> pPathAbempty
pAbsoluteUri :: GenParser Char st Uri
pAbsoluteUri = pUri