diff --git a/attoparsec-uri.cabal b/attoparsec-uri.cabal --- a/attoparsec-uri.cabal +++ b/attoparsec-uri.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 07ffc6b69a931d7889f054fc0d6e305812310b32cd8122bd4190144bbced0dc0 +-- hash: bdaa2e48589f1806d65a49d9fa241e83bc84e827bbe422e7f29f7a99f822fdee name: attoparsec-uri -version: 0.0.8.1 +version: 0.0.9 synopsis: URI parser / printer using attoparsec description: Please see the README on GitHub at category: Web diff --git a/src/Data/URI.hs b/src/Data/URI.hs --- a/src/Data/URI.hs +++ b/src/Data/URI.hs @@ -1,57 +1,72 @@ -{-# LANGUAGE - OverloadedStrings - , RecordWildCards - , DeriveGeneric - , DeriveDataTypeable - #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Data.URI where -import Data.URI.Auth (URIAuth, parseURIAuth, printURIAuth) +import Data.URI.Auth (URIAuth (uriAuthPassword), + parseURIAuth, printURIAuth) -import Prelude hiding (Maybe (..), takeWhile, maybe) -import qualified Prelude as P -import Data.Strict.Maybe (Maybe (..), maybe) -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.Monoid ((<>)) -import Data.Attoparsec.Text (Parser, char, string, sepBy, takeWhile, takeWhile1, ()) -import Data.Char (isControl, isSpace) -import Control.Monad (void, when) -import Control.Applicative ((<|>), optional) +import Control.Applicative (optional, (<|>)) +import Control.Monad (void, when) +import Data.Attoparsec.Text (Parser, char, sepBy, string, + takeWhile, takeWhile1, ()) +import Data.Char (isControl, isSpace) +import Data.Strict.Maybe (Maybe (..), isJust, maybe) +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 Prelude hiding (Maybe (..), maybe, takeWhile) +import qualified Prelude as P -import Data.Data (Typeable) -import GHC.Generics (Generic) -import Test.QuickCheck (Arbitrary (..)) -import Test.QuickCheck.Gen (oneof, listOf, listOf1, elements) -import Test.QuickCheck.Instances () +import Data.Data (Typeable) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (elements, listOf, listOf1, oneof) +import Test.QuickCheck.Instances () +data DirOrFile = Dir | File + deriving (Show, Eq, Typeable, Generic) + +instance Arbitrary DirOrFile where + arbitrary = oneof [pure Dir, pure File] + 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@ , uriAuthority :: !URIAuth - , uriPath :: !(Maybe (Vector Text)) -- ^ slash-separated list - @https://hackage.haskell.org/foo@ is @["foo"]@ + , uriPath :: !(Maybe (Vector Text, DirOrFile)) -- ^ slash-separated list - @https://hackage.haskell.org/foo@ is @["foo"]@, second value is if the path has a trailing slash , 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 (Show, Eq, Typeable, Generic) instance Arbitrary URI where - arbitrary = URI <$> arbitraryScheme - <*> arbitrary - <*> arbitrary - <*> arbitraryPath - <*> arbitraryQuery - <*> arbitraryScheme + arbitrary = do + auth <- arbitrary + scheme <- if isJust (uriAuthPassword auth) + then Just <$> arbitraryNonEmptyText + else arbitraryScheme + slashes <- arbitrary + path <- arbitraryPath + query <- arbitraryQuery + fragment <- arbitraryScheme + pure $ URI scheme slashes auth path query fragment where arbitraryScheme = oneof [pure Nothing, Just <$> arbitraryNonEmptyText] arbitraryNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z']) arbitraryPath = - oneof [pure Nothing, Just . V.fromList <$> listOf1 arbitraryNonEmptyText] + oneof + [ pure Nothing + , do + xs <- V.fromList <$> listOf1 arbitraryNonEmptyText + y <- arbitrary + pure $ Just (xs, y) + ] arbitraryQuery = V.fromList <$> listOf go where @@ -68,7 +83,7 @@ <> (if uriSlashes then "//" else "") <> printURIAuth uriAuthority <> ( case uriPath of - Just xs -> "/" <> T.intercalate "/" (V.toList xs) + Just (xs, f) -> "/" <> T.intercalate "/" (V.toList xs) <> (if f == Dir && not (null xs) then "/" else "") Nothing -> "" ) <> ( if null uriQuery @@ -86,7 +101,7 @@ ) <> case uriFragment of Nothing -> "" - Just f -> "#" <> f + Just f -> "#" <> f @@ -111,11 +126,18 @@ case mS of P.Nothing -> pure False P.Just _ -> pure True - parsePath :: Parser (Maybe (Vector Text)) + parsePath :: Parser (Maybe (Vector Text, DirOrFile)) parsePath = let withRoot = do void (char '/') "root" - (Just . V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/') "path" + ( + do + xs <- V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/' + pure . Just $ + if not (null xs) && V.last xs == "" + then (V.init xs, Dir) + else (xs, File) + ) "path" withoutRoot = pure Nothing "empty path" in withRoot <|> withoutRoot parseQuery :: Parser (Vector (Pair Text (Maybe Text))) @@ -138,5 +160,5 @@ parseChunkWithout xs = takeWhile (\c -> not (isControl c || isSpace c) && c `notElem` xs) - toStrictMaybe P.Nothing = Nothing + 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 @@ -15,9 +15,7 @@ import Data.Text (Text) import Data.Word (Word16) import qualified Data.Text as T -import Data.Attoparsec.Text ( Parser, char, decimal, takeWhile1, () - , satisfy, peekChar') -import Data.Monoid ((<>)) +import Data.Attoparsec.Text ( Parser, char, decimal, takeWhile1, ()) import Control.Monad (void) import Control.Applicative (optional) 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 @@ -14,7 +14,6 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Attoparsec.Text (Parser, char, sepBy1, takeWhile1, ()) -import Data.Monoid ((<>)) import Control.Monad (void) import Control.Applicative ((<|>)) import Net.Types (IPv4, IPv6) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,7 +16,7 @@ main = defaultMain $ testGroup "URI tests" [ Q.testProperty "URIAuthHost" (parsePrintIso printURIAuthHost parseURIAuthHost) , Q.testProperty "URIAuth" (parsePrintIso printURIAuth parseURIAuth) - -- , Q.testProperty "URI" (parsePrintIso printURI parseURI) + , Q.testProperty "URI" (parsePrintIso printURI parseURI) ] @@ -26,7 +26,7 @@ run q = case q of Fail leftover es e -> let go = unsafePerformIO $ do - putStr "Original value: " + putStr "\nOriginal value: " print x putStr "Printed Text: " putStrLn $ T.unpack $ print' x @@ -42,7 +42,7 @@ | y == x -> succeeded | otherwise -> let go = unsafePerformIO $ do - putStr "Original value: " + putStr "\nOriginal value: " print x putStr "Printed Text: " putStrLn $ T.unpack $ print' x