diff --git a/attoparsec-uri.cabal b/attoparsec-uri.cabal --- a/attoparsec-uri.cabal +++ b/attoparsec-uri.cabal @@ -1,34 +1,72 @@ -name: attoparsec-uri -version: 0.0.4 -synopsis: URI parser / printer using attoparsec --- description: -homepage: https://github.com/athanclark/attoparsec-uri#readme -license: BSD3 -license-file: LICENSE -author: Athan Clark -maintainer: athan.clark@gmail.com -copyright: 2017 Athan Clark -category: Network -build-type: Simple -extra-source-files: README.md -cabal-version: >=1.10 +-- This file has been generated from package.yaml by hpack version 0.21.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 0ae9f20b928e639e246cb20ca5770cdfb9f4458893cd265a957a279465db2137 -library - hs-source-dirs: src - exposed-modules: Data.URI - Data.URI.Auth - Data.URI.Auth.Host - build-depends: base >= 4.7 && < 5 - , attoparsec - , attoparsec-ip >= 0.0.1 - , bytedump - , ip >= 1.1.0 - , strict - , text - , vector - default-language: Haskell2010 - ghc-options: -Wall +name: attoparsec-uri +version: 0.0.5 +synopsis: URI parser / printer using attoparsec +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/athanclark/attoparsec-uri#readme +bug-reports: https://github.com/athanclark/attoparsec-uri/issues +author: Athan Clark +maintainer: athan.clark@localcooking.com +copyright: 2018 (c) Local Cooking Inc. +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.md + source-repository head - type: git + type: git location: https://github.com/athanclark/attoparsec-uri + +library + exposed-modules: + Data.URI + Data.URI.Auth + Data.URI.Auth.Host + other-modules: + Paths_attoparsec_uri + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + QuickCheck + , attoparsec + , attoparsec-ip >=0.0.1 + , base >=4.7 && <4.11 + , bytedump + , ip >=1.3.0 + , quickcheck-instances + , strict + , text + , vector + default-language: Haskell2010 + +test-suite attoparsec-uri-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_attoparsec_uri + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , attoparsec + , attoparsec-ip >=0.0.1 + , base >=4.7 && <4.11 + , bytedump + , ip >=1.3.0 + , purescript-iso + , quickcheck-instances + , strict + , text + , vector + default-language: Haskell2010 diff --git a/src/Data/URI.hs b/src/Data/URI.hs --- a/src/Data/URI.hs +++ b/src/Data/URI.hs @@ -31,7 +31,7 @@ { 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@ , uriAuthority :: !URIAuth - , uriPath :: !(Vector Text) -- ^ slash-separated list - @https://hackage.haskell.org/foo@ is @["foo"]@ + , uriPath :: !(Maybe (Vector Text)) -- ^ slash-separated list - @https://hackage.haskell.org/foo@ is @["foo"]@ , 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"@ @@ -43,7 +43,10 @@ maybe "" (<> ":") uriScheme <> (if uriSlashes then "//" else "") <> printURIAuth uriAuthority - <> "/" <> T.intercalate "/" (V.toList uriPath) + <> ( case uriPath of + Just xs -> "/" <> T.intercalate "/" (V.toList xs) + Nothing -> "" + ) <> ( if null uriQuery then "" else "?" @@ -72,22 +75,27 @@ <*> parseQuery <*> (toStrictMaybe <$> optional parseFragment) where + parseScheme :: Parser Text parseScheme = do sch <- takeWhile1 (\c -> c `notElem` [':','/','@','.']) _ <- char ':' pure sch + parseSlashes :: Parser Bool parseSlashes = do mS <- optional (string "//") case mS of P.Nothing -> pure False P.Just _ -> pure True + parsePath :: Parser (Maybe (Vector Text)) parsePath = - ( do void $ char '/' - V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/' - ) <|> pure V.empty + let withRoot = do + void (char '/') + Just . V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/' + withoutRoot = pure Nothing + in withRoot <|> withoutRoot parseQuery :: Parser (Vector (Pair Text (Maybe Text))) parseQuery = - ( do void $ char '?' + ( do void (char '?') let parse1 = do k <- parseChunkWithout ['=','&','#'] mV <- ( Just <$> do void $ char '=' @@ -97,6 +105,7 @@ qs <- parse1 `sepBy` char '&' pure $ V.fromList qs ) <|> pure V.empty + parseFragment :: Parser Text parseFragment = do void $ char '#' parseChunkWithout [] 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 @@ -22,12 +22,16 @@ import Data.Data (Typeable) import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (oneof) +import Test.QuickCheck.Instances () data URIAuthHost - = IPv4 !IPv4 + = Glob + | IPv4 !IPv4 | IPv6 !IPv6 | Localhost | -- | @Host ["foo","bar"] "com"@ represents @foo.bar.com@ @@ -36,8 +40,24 @@ , uriAuthHostSuffix :: !Text } deriving (Eq, Typeable, Generic) +instance Arbitrary URIAuthHost where + arbitrary = oneof + [ pure Glob + , IPv4 <$> arbitraryIPv4 + , IPv6 <$> arbitraryIPv6 + , pure Localhost + , Host <$> arbitrary <*> arbitrary + ] + where + arbitraryIPv4 = + IPv4.ipv4 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitraryIPv6 = + IPv6.ipv6 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + printURIAuthHost :: URIAuthHost -> Text printURIAuthHost x = case x of + Glob -> "*" IPv4 l4 -> IPv4.encode l4 IPv6 r6 -> IPv6.encode r6 Localhost -> "localhost" @@ -54,9 +74,10 @@ parseHost = do xss@(x:xs) <- takeWhile1 (\c -> c `notElem` ['.',':','/','?']) `sepBy1` char '.' if null xs - then if x == "localhost" - then pure Localhost - else fail $ "Only one term parsed: " ++ show xss + then case () of + _ | x == "localhost" -> pure Localhost + | x == "*" -> pure Glob + | otherwise -> fail ("Only one term parsed: " ++ show xss) else let xss' :: Vector Text xss' = V.fromList xss unsnoc :: Vector a -> (Vector a, a) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,5 @@ +import Test.Tasty (testGroup) +import qualified Test.Tasty.QuickCheck as Q + +main :: IO () +main = putStrLn "Test suite not yet implemented"