diff --git a/attoparsec-uri.cabal b/attoparsec-uri.cabal --- a/attoparsec-uri.cabal +++ b/attoparsec-uri.cabal @@ -1,5 +1,5 @@ name: attoparsec-uri -version: 0.0.1 +version: 0.0.2 synopsis: URI parser / printer using attoparsec -- description: homepage: https://github.com/athanclark/attoparsec-uri#readme @@ -20,12 +20,14 @@ Data.URI.Auth.Host build-depends: base >= 4.7 && < 5 , attoparsec + , attoparsec-ip , bytedump - , n-tuple >= 0.0.1.1 + , ip , strict , text , vector default-language: Haskell2010 + ghc-options: -Wall source-repository head type: git diff --git a/src/Data/URI.hs b/src/Data/URI.hs --- a/src/Data/URI.hs +++ b/src/Data/URI.hs @@ -10,23 +10,24 @@ import Data.URI.Auth (URIAuth, parseURIAuth) -import Prelude hiding (Maybe (..)) +import Prelude hiding (Maybe (..), takeWhile) +import qualified Prelude as P import Data.Strict.Maybe (Maybe (..), fromMaybe) import Data.Strict.Tuple (Pair (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Vector (Vector) import qualified Data.Vector as V -import Data.Attoparsec.Text (Parser, many1, notChar, char, string, sepBy, satisfy, anyChar) +import Data.Attoparsec.Text (Parser, char, string, sepBy, takeWhile, takeWhile1) import Data.List (intercalate) -import Control.Applicative ((<|>), many) +import Data.Char (isControl, isSpace) +import Control.Monad (void) +import Control.Applicative ((<|>), optional) -import Data.Data (Data, Typeable) +import Data.Data (Typeable) import GHC.Generics (Generic) -deriving instance (Data a, Data b) => Data (Pair a b) - data URI = URI { uriScheme :: !(Maybe Text) -- ^ the scheme without the colon - @https://hackage.haskell.org/@ has a scheme of @https@ , uriSlashes :: !Bool -- ^ are the slashes present? - @https://hackage.haskell.org/@ is @True@ @@ -35,7 +36,7 @@ , uriQuery :: !(Vector (Pair Text (Maybe Text))) -- ^ list of key-value pairs - @https://hackage.haskell.org/?foo=bar&baz&qux=@ is -- @[("foo", Just "bar"), ("baz", Nothing), ("qux", Just "")]@ , uriFragment :: !(Maybe Text) -- ^ uri suffix - @https://hackage.haskell.org/#some-header@ is @Just "some-header"@ - } deriving (Eq, Data, Typeable, Generic) + } deriving (Eq, Typeable, Generic) instance Show URI where @@ -58,40 +59,45 @@ parseURI :: Parser URI parseURI = - URI <$> ((Just <$> parseScheme) <|> pure Nothing) + URI <$> (toStrictMaybe <$> optional parseScheme) <*> parseSlashes <*> parseURIAuth <*> parsePath <*> parseQuery - <*> ((Just <$> parseFragment) <|> pure Nothing) + <*> (toStrictMaybe <$> optional parseFragment) where parseScheme = do - sch <- many1 (satisfy $ \c -> all (c /=) [':','/','@','.']) + sch <- takeWhile1 (\c -> all (c /=) [':','/','@','.']) _ <- char ':' - pure (T.pack sch) + pure sch parseSlashes = do - mS <- (Just <$> string "//") <|> pure Nothing + mS <- optional (string "//") case mS of - Nothing -> pure False - Just _ -> pure True + P.Nothing -> pure False + P.Just _ -> pure True parsePath = - ( do _ <- char '/' - V.fromList <$> (T.pack <$> many (satisfy $ \c -> all (c /=) ['/', '?', '=', '&', '#'])) `sepBy` (char '/') + ( do void $ char '/' + V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/' ) <|> pure V.empty parseQuery :: Parser (Vector (Pair Text (Maybe Text))) parseQuery = - ( do _ <- char '?' + ( do void $ char '?' let parse1 = do - k <- many (satisfy (\c -> all (c /=) ['=', '&', '#'])) - mV <- ( Just <$> do _ <- char '=' - v <- many (satisfy $ \c -> c /= '&' && c /= '#') - pure (T.pack v) + k <- parseChunkWithout ['=','&','#'] + mV <- ( Just <$> do void $ char '=' + parseChunkWithout ['&','#'] ) <|> ( pure Nothing ) - pure (T.pack k :!: mV) - qs <- parse1 `sepBy` (char '&') + pure (k :!: mV) + qs <- parse1 `sepBy` char '&' pure $ V.fromList qs ) <|> pure V.empty parseFragment = do - _ <- char '#' - T.pack <$> many anyChar + void $ char '#' + parseChunkWithout [] + parseChunkWithout :: [Char] -> Parser Text + parseChunkWithout xs = + takeWhile (\c -> not (isControl c || isSpace c) && all (c /=) xs) + + toStrictMaybe P.Nothing = Nothing + toStrictMaybe (P.Just x) = Just x diff --git a/src/Data/URI/Auth.hs b/src/Data/URI/Auth.hs --- a/src/Data/URI/Auth.hs +++ b/src/Data/URI/Auth.hs @@ -11,26 +11,25 @@ import Data.URI.Auth.Host (URIAuthHost, parseURIAuthHost) import Prelude hiding (Maybe (..)) +import qualified Prelude as P import Data.Strict.Maybe (Maybe (..), fromMaybe) import Data.Text (Text) import Data.Word (Word16) import qualified Data.Text as T -import Data.Attoparsec.Text (Parser, many1, char, notChar, satisfy, decimal, peekChar) +import Data.Attoparsec.Text (Parser, char, decimal, peekChar, takeWhile1) import Data.Monoid ((<>)) -import Control.Applicative ((<|>)) -import qualified GHC.Base +import Control.Monad (void) +import Control.Applicative (optional) -import Data.Data (Data, Typeable) +import Data.Data (Typeable) import GHC.Generics (Generic) -deriving instance Data a => Data (Maybe a) - data URIAuth = URIAuth { uriAuthUser :: !(Maybe Text) -- ^ a designated user - @ssh://git\@github.com@ is @git@ , uriAuthHost :: !URIAuthHost , uriAuthPort :: !(Maybe Word16) -- ^ the port, if it exists - @foobar.com:3000@ is @3000@ as a 16-bit unsigned int. - } deriving (Eq, Data, Typeable, Generic) + } deriving (Eq, Typeable, Generic) instance Show URIAuth where show URIAuth{..} = @@ -41,18 +40,21 @@ parseURIAuth :: Parser URIAuth parseURIAuth = - URIAuth <$> ((Just <$> parseUser) <|> pure Nothing) + URIAuth <$> (toStrictMaybe <$> optional parseUser) <*> parseURIAuthHost - <*> ((Just <$> parsePort) <|> pure Nothing) + <*> (toStrictMaybe <$> optional parsePort) where parseUser = do - u <- many1 $ satisfy $ \c -> all (c /=) ['@','.',':','/','?','&','='] + u <- takeWhile1 (\c -> all (c /=) ['@','.',':','/','?','&','=']) mC <- peekChar case mC of - GHC.Base.Nothing -> fail "no user @ thing" + P.Nothing -> fail "no user @ thing" _ -> do - _ <- char '@' - pure $ T.pack u + void $ char '@' + pure u parsePort = do - _ <- char ':' + void $ char ':' decimal + + toStrictMaybe P.Nothing = Nothing + toStrictMaybe (P.Just x) = Just x diff --git a/src/Data/URI/Auth/Host.hs b/src/Data/URI/Auth/Host.hs --- a/src/Data/URI/Auth/Host.hs +++ b/src/Data/URI/Auth/Host.hs @@ -2,120 +2,31 @@ DataKinds , DeriveGeneric , DeriveDataTypeable + , OverloadedStrings #-} module Data.URI.Auth.Host where import Prelude hiding (Either (..)) -import Data.Strict (Either (..)) import Data.Vector (Vector) import qualified Data.Vector as V -import Data.Text (Text) +import Data.Text (Text, unpack) import qualified Data.Text as T -import Data.NTuple (NTuple, _1, _2, _3, _4, _5, _6, _7, _8) -import qualified Data.NTuple as NTuple -import Data.Word (Word8, Word16) -import Data.Attoparsec.Text (Parser, peekChar', decimal, hexadecimal, char, notChar, sepBy1, many1, satisfy) -import Data.Char (isDigit, isHexDigit) -import Data.Bits ((.&.), shiftR) +import Data.Attoparsec.Text (Parser, char, sepBy1, takeWhile1) +import Data.Attoparsec.IP (ipv4, ipv6) import Data.List (intercalate) import Control.Applicative ((<|>)) -import Text.Read (readMaybe) -import Text.Bytedump (hexString) +import Net.Types (IPv4, IPv6) +import qualified Net.IPv4.Text as IPv4 +import qualified Net.IPv6.Text as IPv6 -import Data.Data (Data, Typeable) +import Data.Data (Typeable) import GHC.Generics (Generic) -type IPv4 = NTuple 4 Word8 - -parseIPv4 :: Parser IPv4 -parseIPv4 = do - a <- parseOctet - _ <- char '.' - b <- parseOctet - _ <- char '.' - c <- parseOctet - _ <- char '.' - d <- parseOctet - pure $ NTuple.incl _4 d - . NTuple.incl _3 c - . NTuple.incl _2 b - . NTuple.incl _1 a - $ NTuple.empty - where - parseOctet :: Parser Word8 - parseOctet = decimal - -showIPv4 :: IPv4 -> String -showIPv4 xs = - intercalate "." $ V.toList $ show <$> NTuple.toVector xs - - -type IPv6 = NTuple 8 Word16 - -parseIPv6 :: Parser IPv6 -parseIPv6 = do - a <- parseDiOctet - _ <- char ':' - b <- parseDiOctet - _ <- char ':' - c <- parseDiOctet - _ <- char ':' - d <- parseDiOctet - _ <- char ':' - let soFar = NTuple.incl _4 d - . NTuple.incl _3 c - . NTuple.incl _2 b - . NTuple.incl _1 a - $ NTuple.empty - q <- peekChar' - if q == ':' - then pure $ NTuple.incl _8 0 - . NTuple.incl _7 0 - . NTuple.incl _6 0 - . NTuple.incl _5 0 - $ soFar - else do - e <- parseDiOctet - _ <- char ':' - f <- parseDiOctet - _ <- char ':' - g <- parseDiOctet - _ <- char ':' - h <- parseDiOctet - pure $ NTuple.incl _8 h - . NTuple.incl _7 g - . NTuple.incl _6 f - . NTuple.incl _5 e - $ soFar - where - parseDiOctet :: Parser Word16 - parseDiOctet = hexadecimal - - -showIPv6 :: IPv6 -> String -showIPv6 xs = - let xs'@(a:b:c:d:qs) = V.toList $ NTuple.toVector xs - in if all (== 0) qs - then intercalate ":" (showWord16 <$> [a,b,c,d]) ++ "::" - else intercalate ":" (showWord16 <$> xs') - where - showWord16 :: Word16 -> String - showWord16 x = - let (l,r) = breakWord16 x - in hexString l ++ hexString r - where - breakWord16 :: Word16 -> (Word8, Word8) - breakWord16 x = ( fromIntegral $ (x .&. 0xFF00) `shiftR` 8 - , fromIntegral $ x .&. 0xFF - ) - - - data URIAuthHost = IPv4 !IPv4 | IPv6 !IPv6 @@ -124,33 +35,33 @@ Host { uriAuthHostName :: !(Vector Text) , uriAuthHostSuffix :: !Text - } deriving (Eq, Data, Typeable, Generic) + } deriving (Eq, Typeable, Generic) instance Show URIAuthHost where - show (IPv4 l4) = showIPv4 l4 - show (IPv6 r6) = showIPv6 r6 + show (IPv4 l4) = unpack (IPv4.encode l4) + show (IPv6 r6) = unpack (IPv6.encode r6) show Localhost = "localhost" show (Host ns c) = intercalate "." $ V.toList $ T.unpack <$> ns `V.snoc` c parseURIAuthHost :: Parser URIAuthHost parseURIAuthHost = - (IPv4 <$> parseIPv4) - <|> (IPv6 <$> parseIPv6) + (IPv4 <$> ipv4) + <|> (IPv6 <$> ipv6) <|> parseHost where parseHost :: Parser URIAuthHost parseHost = do - xss@(x:xs) <- many1 (satisfy $ \c -> all (c /=) ['.',':','/','?']) `sepBy1` char '.' + xss@(x:xs) <- takeWhile1 (\c -> all (c /=) ['.',':','/','?']) `sepBy1` char '.' if null xs then if x == "localhost" then pure Localhost - else fail "Only one term parsed" + else fail $ "Only one term parsed: " ++ show xss else let xss' :: Vector Text - xss' = T.pack <$> V.fromList xss + xss' = V.fromList xss unsnoc :: Vector a -> (Vector a, a) unsnoc x = let (fs,l) = V.splitAt (V.length x - 1) x in (fs, l V.! 0) (ns,c) = unsnoc xss' - in pure (uncurry Host $ unsnoc xss') + in pure (Host ns c)