attoparsec-uri 0.0.1 → 0.0.2

raw patch · 4 files changed

+68/−147 lines, 4 filesdep +attoparsec-ipdep +ipdep −n-tuplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec-ip, ip

Dependencies removed: n-tuple

API changes (from Hackage documentation)

Files

• attoparsec-uri.cabal +4/−2
• src/Data/URI.hs +31/−25
• src/Data/URI/Auth.hs +16/−14
• src/Data/URI/Auth/Host.hs +17/−106

@@ -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

@@ -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

@@ -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

@@ -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)