attoparsec-uri 0.0.4 → 0.0.5
raw patch · 4 files changed
+113/−40 lines, 4 filesdep +QuickCheckdep +purescript-isodep +quickcheck-instancesdep ~basedep ~ip
Dependencies added: QuickCheck, purescript-iso, quickcheck-instances
Dependency ranges changed: base, ip
Files
- attoparsec-uri.cabal +68/−30
- src/Data/URI.hs +15/−6
- src/Data/URI/Auth/Host.hs +25/−4
- test/Spec.hs +5/−0
attoparsec-uri.cabal view
@@ -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 <https://github.com/githubuser/purescript-iso#readme>+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
src/Data/URI.hs view
@@ -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 []
src/Data/URI/Auth/Host.hs view
@@ -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)
+ test/Spec.hs view
@@ -0,0 +1,5 @@+import Test.Tasty (testGroup)+import qualified Test.Tasty.QuickCheck as Q++main :: IO ()+main = putStrLn "Test suite not yet implemented"