iri 0.3.4.1 → 0.4

raw patch · 19 files changed

+381/−256 lines, 19 filesdep −base-preludedep −bugdep ~basedep ~rerebasedep ~text-builderPVP ok

version bump matches the API change (PVP)

Dependencies removed: base-prelude, bug

Dependency ranges changed: base, rerebase, text-builder

API changes (from Hackage documentation)

Files

• iri.cabal +43/−72
• library/Iri/CodePointPredicates/Core.hs +1/−1
• library/Iri/CodePointPredicates/Rfc3986.hs +1/−2
• library/Iri/Data/Types.hs +9/−10
• library/Iri/MonadPlus.hs +13/−1
• library/Iri/Optics.hs +4/−92
• library/Iri/Optics/Basics.hs +36/−0
• library/Iri/Optics/Defs.hs +70/−0
• library/Iri/Parsing/Attoparsec/ByteString.hs +9/−9
• library/Iri/Parsing/Attoparsec/Text.hs +17/−7
• library/Iri/Parsing/ByteString.hs +18/−0
• library/Iri/Parsing/Text.hs +1/−1
• library/Iri/Prelude.hs +62/−9
• library/Iri/QuasiQuoter.hs +8/−6
• library/Iri/Rendering/Poke.hs +0/−14
• library/Iri/Rendering/Ptr/Poke.hs +14/−0
• library/Iri/Rendering/Ptr/Poking.hs +17/−7
• library/Iri/Rendering/TextBuilder/Internal.hs +28/−11
• test/Main.hs +30/−14

@@ -1,51 +1,30 @@-name:-  iri-version:-  0.3.4.1-category:-  URI, URL, IRI, Network-synopsis:-  RFC-based International Resource Identifier library+name: iri+version: 0.4+category: URI, URL, IRI, Network+synopsis: RFC-based resource identifier library description:-  This library provides a universal data model for representation of both URI (URL) and IRI.+  This library provides a universal data model for representation of URI, URL and IRI.   It comes packed with parsing, rendering and serialisation functionality.   It is implemented in conformance with the RFC-3986 and RFC-3987 specifications and   is intended as a standard tool for all tasks related to resource identifiers.-  .-  The data is represented in Unicode,-  and the API automates all the encoding fuss.-homepage:-  https://github.com/nikita-volkov/iri -bug-reports:-  https://github.com/nikita-volkov/iri/issues -author:-  Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer:-  Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:-  (c) 2017, Nikita Volkov-license:-  MIT-license-file:-  LICENSE-build-type:-  Simple-cabal-version:-  >=1.10+homepage: https://github.com/nikita-volkov/iri+bug-reports: https://github.com/nikita-volkov/iri/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Metrix.AI Tech Team <tech@metrix.ai>+copyright: (c) 2017 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >=1.10  source-repository head-  type:-    git-  location:-    git://github.com/nikita-volkov/iri.git+  type: git+  location: git://github.com/nikita-volkov/iri.git  library-  hs-source-dirs:-    library-  default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010+  hs-source-dirs: library+  default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language: Haskell2010   exposed-modules:     Iri.Rendering.Text     Iri.Rendering.TextBuilder@@ -76,50 +55,42 @@     Iri.CodePointPredicates.Core     Iri.CodePointPredicates.Rfc3986     Iri.CodePointPredicates.Rfc3987-    Iri.Rendering.Poke+    Iri.Rendering.Ptr.Poke     Iri.PercentEncoding+    Iri.Optics.Basics+    Iri.Optics.Defs   build-depends:-    th-lift-instances >=0.1.11 && <0.2,-    th-lift >=0.7.7 && <0.8,-    template-haskell >=2.9 && <3,-    unordered-containers >=0.2 && <0.3,-    ptr >=0.16.1 && <0.17,     attoparsec >=0.13 && <0.14,-    punycode >=2 && <3,-    ip >=1.1 && <2,+    base >=4.9 && <5,+    bytestring >=0.10 && <0.11,+    contravariant >=1.4 && <2,     hashable >=1.2 && <2,+    ip >=1.1 && <2,+    profunctors >=5.2 && <6,+    ptr >=0.16.1 && <0.17,+    punycode >=2 && <3,+    semigroups >=0.18 && <0.20,+    template-haskell >=2.9 && <3,     text ==1.*,-    text-builder >=0.6.4 && <0.7,-    bytestring >=0.10 && <0.11,+    text-builder >=0.6.5 && <0.7,+    th-lift >=0.7.7 && <0.8,+    th-lift-instances >=0.1.11 && <0.2,+    unordered-containers >=0.2 && <0.3,     vector >=0.10 && <0.13,-    vector-instances >=3.4 && <4,     vector-builder >=0.3.4 && <0.4,-    profunctors >=5.2 && <6,-    contravariant >=1.4 && <2,-    semigroups >=0.18 && <0.20,-    bug ==1.*,-    base-prelude >=1.3 && <2,-    base >=4.7 && <5+    vector-instances >=3.4 && <4  test-suite test-  type:-    exitcode-stdio-1.0-  hs-source-dirs:-    test-  main-is:-    Main.hs-  default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language: Haskell2010   build-depends:-    --      iri,-    -- testing:     QuickCheck >=2.8.1 && <3,     quickcheck-instances >=0.3.11 && <0.4,+    rerebase <2,     tasty >=0.12 && <2,     tasty-hunit >=0.9 && <0.11,-    tasty-quickcheck >=0.9 && <0.11,-    ---    rerebase >=1.1 && <2+    tasty-quickcheck >=0.9 && <0.11

@@ -2,7 +2,7 @@ where  import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate)-import qualified Data.Vector as A+import qualified Data.Vector.Unboxed as A   type Predicate =

@@ -91,7 +91,6 @@  import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate) import Iri.CodePointPredicates.Core-import qualified Data.Vector as A  {-| Reference:@@ -143,7 +142,7 @@ unencodedQuery :: Predicate unencodedQuery =   cached $-  (unencodedPathSegment ||| oneOfChars "/?|") &&& (/= 43)+  (unencodedPathSegment ||| oneOfChars "/?|[]\"'") &&& (/= 43)  unencodedFragment :: Predicate unencodedFragment =

@@ -12,7 +12,7 @@   {-|-Thorough structure of IRI.+Thorough structure of IRI or URI. -} data Iri =   Iri !Scheme !Hierarchy !Query !Fragment@@ -33,10 +33,10 @@   MissingUserInfo  newtype User =-  User Text+  User ByteString  data Password =-  PresentPassword !Text |+  PresentPassword !ByteString |   MissingPassword  data Host =@@ -47,8 +47,7 @@ newtype RegName =   RegName (Vector DomainLabel) -newtype DomainLabel =-  DomainLabel Text+data DomainLabel = DomainLabel Text  data Port =   PresentPort !Word16 |@@ -58,20 +57,20 @@   Path (Vector PathSegment)  newtype PathSegment =-  PathSegment Text+  PathSegment ByteString  {-| Since the exact structure of the query string is not standardised and methods used to parse the query string may differ between websites,-we simply represent it as a decoded Unicode string.+we simply represent it as percent-decoded bytes.  See <https://en.wikipedia.org/wiki/Query_string>. -} newtype Query =-  Query Text+  Query ByteString  newtype Fragment =-  Fragment Text+  Fragment ByteString   -- * Special cases@@ -85,7 +84,7 @@ it's been isolated into a dedicated data-type, which is optimised for that particular case. -Compared to the general IRI definition it:+Compared to the general URI definition it:  * only supports the HTTP and HTTPS schemes * misses the Username and Password components

@@ -1,7 +1,9 @@ module Iri.MonadPlus where -import Iri.Prelude hiding (null, length)+import Iri.Prelude hiding (foldl)+import qualified Ptr.ByteString as ByteString+import qualified Ptr.Poking as Poking   {-# INLINE foldl #-}@@ -28,3 +30,13 @@             element <- elementParser             return (step state element >>= loop))           (return (return state)))++{-# INLINE foldByteString #-}+foldByteString :: MonadPlus m => m ByteString -> m ByteString+foldByteString =+  fmap ByteString.poking .+  foldl (\ poking -> mappend poking . Poking.bytes) mempty++{-# INLINE fold #-}+fold :: (MonadPlus m, Monoid a) => m a -> m a+fold = foldl mappend mempty

@@ -6,98 +6,10 @@ -} module Iri.Optics (-  -- * Definitions-  Lens,-  Lens',-  Prism,-  Prism',-  -- * Prisms-  iriHttpIri,-  uriByteStringIri,-  uriByteStringHttpIri,-  iriTextIri,-  iriTextHttpIri,-  -- * Lenses-  iriScheme,-  iriHierarchy,-  iriQuery,-  iriFragment,+  module Basics,+  module Defs, ) where -import Iri.Prelude-import Iri.Data-import qualified Iri.Rendering.ByteString as A-import qualified Iri.Parsing.ByteString as B-import qualified Iri.Rendering.Text as C-import qualified Iri.Parsing.Text as D---type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t--type Lens' s a = Lens s s a a--type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)--type Prism' s a = Prism s s a a--{-# INLINE prism #-}-prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b-prism bt seta =-  dimap seta (either pure (fmap bt)) . right'--{-# INLINE lens #-}-lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b-lens sa sbt afb s =-  sbt s <$> afb (sa s)---- * Prisms----------------------------iriHttpIri :: Prism' Iri HttpIri-iriHttpIri =-  prism iriFromHttpIri (\ iri -> either (const (Left iri)) Right (httpIriFromIri iri))--uriByteStringIri :: Prism' ByteString Iri-uriByteStringIri =-  prism A.uri (\ bytes -> either (const (Left bytes)) Right (B.uri bytes))--uriByteStringHttpIri :: Prism' ByteString HttpIri-uriByteStringHttpIri =-  uriByteStringIri . iriHttpIri--iriTextIri :: Prism' Text Iri-iriTextIri =-  prism C.iri (\ text -> either (const (Left text)) Right (D.iri text))--iriTextHttpIri :: Prism' Text HttpIri-iriTextHttpIri =-  iriTextIri . iriHttpIri----- * Lenses----------------------------iriScheme :: Lens' Iri ByteString-iriScheme =-  lens-    (\ (Iri (Scheme x) _ _ _) -> x)-    (\ (Iri _ hierarchy query fragment) x -> Iri (Scheme x) hierarchy query fragment)--iriHierarchy :: Lens' Iri Hierarchy-iriHierarchy =-  lens-    (\ (Iri _ x _ _) -> x)-    (\ (Iri scheme _ query fragment) x -> Iri scheme x query fragment)--iriQuery :: Lens' Iri Text-iriQuery =-  lens-    (\ (Iri _ _ (Query x) _) -> x)-    (\ (Iri scheme hierarchy _ fragment) x -> Iri scheme hierarchy (Query x) fragment)--iriFragment :: Lens' Iri Text-iriFragment =-  lens-    (\ (Iri _ _ _ (Fragment x)) -> x)-    (\ (Iri scheme hierarchy query _) x -> Iri scheme hierarchy query (Fragment x))+import Iri.Optics.Basics as Basics (Lens, Lens', Prism, Prism', Traversal, Traversal')+import Iri.Optics.Defs as Defs

@@ -0,0 +1,36 @@+module Iri.Optics.Basics+where++import Iri.Prelude+++type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t++type Lens' s a = Lens s s a a++type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)++type Prism' s a = Prism s s a a++type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++type Traversal' s a = Traversal s s a a++type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)++type Iso' s a = Iso s s a a++{-# INLINE prism #-}+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism bt seta =+  dimap seta (either pure (fmap bt)) . right'++{-# INLINE prism' #-}+prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a+prism' as sma =+  prism as (\s -> maybe (Left s) Right (sma s))++{-# INLINE lens #-}+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens sa sbt afb s =+  sbt s <$> afb (sa s)

@@ -0,0 +1,70 @@+module Iri.Optics.Defs+where++import Iri.Prelude+import Iri.Data+import Iri.Optics.Basics+import qualified Iri.Rendering.ByteString as A+import qualified Iri.Parsing.ByteString as B+import qualified Iri.Rendering.Text as C+import qualified Iri.Parsing.Text as D+import qualified Data.Text.Encoding as Text+++-- * Definitions by source+-------------------------++-- ** Text+-------------------------++textIriIri :: Prism' Text Iri+textIriIri =+  prism C.iri (\ text -> either (const (Left text)) Right (D.iri text))++textIriHttpIri :: Prism' Text HttpIri+textIriHttpIri =+  textIriIri . iriHttpIri++-- ** ByteString+-------------------------++byteStringIri :: Prism' ByteString Iri+byteStringIri =+  prism A.uri (\ bytes -> either (const (Left bytes)) Right (B.uri bytes))++byteStringHttpIri :: Prism' ByteString HttpIri+byteStringHttpIri =+  byteStringIri . iriHttpIri++byteStringTextInUtf8 :: Prism' ByteString Text+byteStringTextInUtf8 = prism' Text.encodeUtf8 (either (const Nothing) Just . Text.decodeUtf8')++-- ** IRI+-------------------------++iriHttpIri :: Prism' Iri HttpIri+iriHttpIri = prism' iriFromHttpIri (either (const Nothing) Just . httpIriFromIri)++iriScheme :: Lens' Iri Scheme+iriScheme = lens (\ (Iri x _ _ _) -> x) (\ (Iri _ hierarchy query fragment) x -> Iri x hierarchy query fragment)++iriHierarchy :: Lens' Iri Hierarchy+iriHierarchy = lens (\ (Iri _ x _ _) -> x) (\ (Iri scheme _ query fragment) x -> Iri scheme x query fragment)++iriQuery :: Lens' Iri Query+iriQuery = lens (\ (Iri _ _ x _) -> x) (\ (Iri scheme hierarchy _ fragment) x -> Iri scheme hierarchy x fragment)++iriFragment :: Lens' Iri Fragment+iriFragment = lens (\ (Iri _ _ _ x) -> x) (\ (Iri scheme hierarchy query _) x -> Iri scheme hierarchy query x)++-- ** Scheme+-------------------------++schemeByteString :: Lens' Scheme ByteString+schemeByteString = lens (\ (Scheme x) -> x) (const Scheme)++-- ** Fragment+-------------------------++fragmentByteString :: Lens' Fragment ByteString+fragmentByteString = lens (\ (Fragment x) -> x) (const Fragment)

@@ -86,7 +86,7 @@   parser <?> label  {-|-Parser of a well-formed URI conforming to the RFC3986 standard into IRI.+Parser of a well-formed URI conforming to the RFC3986 or RFC3987 standards. Performs URL- and Punycode-decoding. -} {-# INLINABLE uri #-}@@ -202,7 +202,7 @@   fmap RegName (E.sepBy1 domainLabel (word8 46))  {-|-Domain label with Punycode decoding applied.+Domain label with Punycode decoding applied if need be. -} {-# INLINE domainLabel #-} domainLabel :: Parser DomainLabel@@ -232,7 +232,7 @@   where     segmentsAreEmpty segments =       S.length segments == 1 &&-      (case S.unsafeHead segments of PathSegment headSegmentText -> T.null headSegmentText)+      (case S.unsafeHead segments of PathSegment headSegment -> K.null headSegment)  {-# INLINE pathSegment #-} pathSegment :: Parser PathSegment@@ -257,10 +257,10 @@         else fail (showString "UTF8 decoding: Bytes remaining: " (show undecodedBytes))  {-# INLINABLE urlEncodedString #-}-urlEncodedString :: (Word8 -> Bool) -> Parser Text+urlEncodedString :: (Word8 -> Bool) -> Parser ByteString urlEncodedString unencodedBytesPredicate =   labeled "URL-encoded string" $-  utf8Chunks $+  R.foldByteString $   takeWhile1 unencodedBytesPredicate <|> encoded   where     encoded =@@ -275,13 +275,13 @@     byte2 <- anyWord8     I.matchPercentEncodedBytes (fail "Broken percent encoding") return byte1 byte2 -{-# INLINABLE query #-}+{-# INLINE query #-} query :: Parser Query query =   labeled "Query" $   (question *> (Query <$> queryOrFragmentBody)) <|> pure (Query mempty) -{-# INLINABLE fragment #-}+{-# INLINE fragment #-} fragment :: Parser Fragment fragment =   labeled "Fragment" $@@ -291,9 +291,9 @@ The stuff after the question or the hash mark. -} {-# INLINABLE queryOrFragmentBody #-}-queryOrFragmentBody :: Parser Text+queryOrFragmentBody :: Parser ByteString queryOrFragmentBody =-  utf8Chunks $+  R.foldByteString $   takeWhile1 (C.unencodedQuery . fromIntegral) <|>   " " <$ plus <|>   K.singleton <$> percentEncodedByte

@@ -19,6 +19,8 @@ import qualified Text.Builder as J import qualified Net.IPv4 as M import qualified Net.IPv6 as N+import qualified Ptr.ByteString as ByteString+import qualified Ptr.Poking as Poking   {-# INLINE labeled #-}@@ -27,7 +29,7 @@   parser <?> label  {-|-Parser of a well-formed IRI conforming to the RFC3987 standard into IRI.+Parser of a well-formed IRI conforming to the RFC3987 standard into 'Iri'. Performs URL-decoding. -} {-# INLINABLE iri #-}@@ -138,7 +140,7 @@   where     segmentsAreEmpty segments =       S.length segments == 1 &&-      (case S.unsafeHead segments of PathSegment headSegmentText -> T.null headSegmentText)+      (case S.unsafeHead segments of PathSegment headSegment -> K.null headSegment)  {-# INLINE pathSegment #-} pathSegment :: Parser PathSegment@@ -146,16 +148,24 @@   fmap PathSegment (urlEncodedComponent (C.unencodedPathSegment . ord))  {-# INLINABLE urlEncodedComponent #-}-urlEncodedComponent :: (Char -> Bool) -> Parser Text+urlEncodedComponent :: (Char -> Bool) -> Parser ByteString urlEncodedComponent unencodedCharPredicate =   labeled "URL-encoded component" $+  fmap ByteString.poking $+  R.fold $+  (Poking.bytes . B.encodeUtf8 <$> takeWhile1 unencodedCharPredicate) <|> (Poking.word8 <$> urlEncodedByte)++{-# INLINABLE urlEncodedComponentText #-}+urlEncodedComponentText :: (Char -> Bool) -> Parser Text+urlEncodedComponentText unencodedCharPredicate =+  labeled "URL-encoded component" $   fmap J.run $   R.foldl mappend mempty $-  (J.text <$> takeWhile1 unencodedCharPredicate) <|> urlEncodedSequence+  (J.text <$> takeWhile1 unencodedCharPredicate) <|> urlEncodedSequenceTextBuilder -{-# INLINABLE urlEncodedSequence #-}-urlEncodedSequence :: Parser J.Builder-urlEncodedSequence =+{-# INLINABLE urlEncodedSequenceTextBuilder #-}+urlEncodedSequenceTextBuilder :: Parser J.Builder+urlEncodedSequenceTextBuilder =   labeled "URL-encoded sequence" $ do     start <- progress (mempty, mempty, B.streamDecodeUtf8) =<< urlEncodedByte     R.foldlM progress (start) urlEncodedByte >>= finish

@@ -3,6 +3,7 @@   uri,   httpUri,   regName,+  uriQuery, ) where @@ -10,6 +11,7 @@ import Iri.Data import qualified Iri.Parsing.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString as B+import qualified Data.ByteString as ByteString   parser parser =@@ -37,3 +39,19 @@ regName :: ByteString -> Either Text RegName regName =   parser A.regName++{-|+Assuming we have a valid URI as input, extract the query part from it.+-}+uriQuery :: ByteString -> Query+uriQuery x =+  case ByteString.break (== 63) x of+    (beforeQuestion, questionAndAfterQuestion) -> case ByteString.uncons questionAndAfterQuestion of+      Just (_, afterQuestion) -> case ByteString.break (== 35) afterQuestion of+        (beforeHash, hashAndAfterHash) -> Query beforeHash++{-|+Assuming we have a valid URI as input, extract the fragment part from it.+-}+uriFragment :: ByteString -> Fragment+uriFragment = ByteString.break (== 35) >>> snd >>> ByteString.drop 1 >>> Fragment

@@ -12,7 +12,7 @@   {-|-Parser of a well-formed IRI conforming to the RFC3987 standard into IRI.+Parser of a well-formed IRI conforming to the RFC3987 standard into 'Iri'. Performs URL-decoding. -} iri :: Text -> Either Text Iri

@@ -5,13 +5,70 @@ where  --- base-prelude---------------------------import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, (<>), First(..), Last(..), ProtocolError, traceEvent, traceEventIO, traceMarker, traceMarkerIO)- -- base --------------------------import Foreign as Exports hiding (void)+import Control.Applicative as Exports+import Control.Arrow as Exports+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.IO.Class as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Functor.Identity as Exports+import Data.Int as Exports+import Data.IORef as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Last(..), First(..))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports hiding (sizeOf, alignment)+import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)+import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Numeric as Exports+import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (printf, hPrintf)+import Text.Read as Exports (Read(..), readMaybe, readEither)+import Unsafe.Coerce as Exports  -- contravariant -------------------------@@ -60,10 +117,6 @@ -- th-lift-instances ------------------------- import Instances.TH.Lift as Exports---- bug---------------------------import Bug as Exports  -------------------------------------------------------------------------------- 

@@ -2,6 +2,8 @@ (   uri,   httpUri,+  iri,+  httpIri, ) where @@ -23,27 +25,27 @@       fail "Not supported"  {-|-IRI literal parsed from textual URI.+'Iri' literal from ASCII representation. -} uri :: QuasiQuoter uri =   exp $ \ string ->   case B.parseOnly (A.uri <* B.endOfInput) (fromString string) of-    Right iri -> lift iri+    Right uri -> lift uri     Left error -> fail (showString "URI parsing: " error)  {-|-HTTP IRI literal parsed from textual URI.+'HttpIri' literal from ASCII representation. -} httpUri :: QuasiQuoter httpUri =   exp $ \ string ->   case B.parseOnly (A.httpUri <* B.endOfInput) (fromString string) of-    Right iri -> lift iri+    Right uri -> lift uri     Left error -> fail (showString "HTTP URI parsing: " error)  {-|-IRI literal parsed from textual IRI.+'Iri' literal from IRI representation. -} iri :: QuasiQuoter iri =@@ -53,7 +55,7 @@     Left error -> fail (showString "IRI parsing: " error)  {-|-HTTP IRI literal parsed from textual IRI.+'HttpIri' literal from IRI representation. -} httpIri :: QuasiQuoter httpIri =

@@ -1,14 +0,0 @@-module Iri.Rendering.Poke-where--import Iri.Prelude-import Iri.Data-import Ptr.Poke---{-# NOINLINE urlEncodedByte #-}-urlEncodedByte :: Poke Word8-urlEncodedByte =-  divide (\byte -> ('%', byte))-    asciiChar-    (divide (flip divMod 16) asciiHexDigit asciiHexDigit)

@@ -0,0 +1,14 @@+module Iri.Rendering.Ptr.Poke+where++import Iri.Prelude+import Iri.Data+import Ptr.Poke+++{-# NOINLINE urlEncodedByte #-}+urlEncodedByte :: Poke Word8+urlEncodedByte =+  divide (\byte -> ('%', byte))+    asciiChar+    (divide (flip divMod 16) asciiHexDigit asciiHexDigit)

@@ -16,6 +16,7 @@ import qualified Data.Text.Encoding.Error as A import qualified Data.Text.Punycode as B import qualified Data.Text as C+import qualified Data.ByteString as ByteString import qualified Data.HashMap.Strict as G import qualified Data.Vector as H import qualified Net.IPv4 as D@@ -24,7 +25,7 @@ import qualified Iri.CodePointPredicates.Core as I import qualified Iri.CodePointPredicates.Rfc3986 as I import qualified Iri.Utf8CodePoint as K-import qualified Iri.Rendering.Poke as L+import qualified Iri.Rendering.Ptr.Poke as L   uri :: Iri -> Poking@@ -41,7 +42,7 @@  httpUri :: HttpIri -> Poking httpUri (HttpIri (Security secure) hostValue portValue pathValue queryValue fragmentValue) =-  (if secure then bytes "https://" else bytes "http://") <>+  (if secure then "https://" else "http://") <>   host hostValue <>   prependIfNotNull (asciiChar ':') (port portValue) <>   prependIfNotNull (asciiChar '/') (path pathValue) <>@@ -76,9 +77,9 @@       MissingPassword -> userInfoComponent user     MissingUserInfo -> mempty -userInfoComponent :: Text -> Poking+userInfoComponent :: ByteString -> Poking userInfoComponent =-  urlEncodedText I.unencodedUserInfoComponent+  urlEncodedBytes I.unencodedUserInfoComponent  host :: Host -> Poking host =@@ -117,15 +118,24 @@  pathSegment :: PathSegment -> Poking pathSegment (PathSegment value) =-  urlEncodedText I.unencodedPathSegment value+  urlEncodedBytes I.unencodedPathSegment value  query :: Query -> Poking query (Query value) =-  urlEncodedText I.unencodedQuery value+  urlEncodedBytes I.unencodedQuery value  fragment :: Fragment -> Poking fragment (Fragment value) =-  urlEncodedText I.unencodedFragment value+  urlEncodedBytes I.unencodedFragment value++urlEncodedBytes :: I.Predicate -> ByteString -> Poking+urlEncodedBytes unencodedPredicate =+  ByteString.foldl' (\ poking -> mappend poking . byte) mempty+  where+    byte x =+      if unencodedPredicate (fromIntegral x)+        then word8 x+        else urlEncodedByte x  {-| Apply URL-encoding to text -} urlEncodedText :: I.Predicate -> Text -> Poking

@@ -17,9 +17,11 @@ import qualified Net.IPv4 as D import qualified Net.IPv6 as E import qualified Iri.Vector as F-import qualified Iri.CodePointPredicates.Core as I-import qualified Iri.CodePointPredicates.Rfc3987 as I+import qualified Iri.CodePointPredicates.Core as CorePredicates+import qualified Iri.CodePointPredicates.Rfc3987 as Rfc3987Predicates+import qualified Iri.CodePointPredicates.Rfc3986 as Rfc3986Predicates import qualified Iri.Utf8CodePoint as K+import qualified Data.ByteString as ByteString   iri :: Iri -> Builder@@ -71,9 +73,9 @@       MissingPassword -> userInfoComponent user     MissingUserInfo -> mempty -userInfoComponent :: Text -> Builder+userInfoComponent :: ByteString -> Builder userInfoComponent =-  urlEncodedText I.unencodedUserInfoComponent+  urlEncodedBytesOrText Rfc3987Predicates.unencodedUserInfoComponent Rfc3986Predicates.unencodedUserInfoComponent  host :: Host -> Builder host =@@ -87,8 +89,8 @@   F.intercalate domainLabel (char '.') vector  domainLabel :: DomainLabel -> Builder-domainLabel (DomainLabel value) =-  text value+domainLabel (DomainLabel x) =+  text x  ipV4 :: IPv4 -> Builder ipV4 =@@ -110,22 +112,37 @@  pathSegment :: PathSegment -> Builder pathSegment (PathSegment value) =-  urlEncodedText I.unencodedPathSegment value+  urlEncodedBytesOrText Rfc3987Predicates.unencodedPathSegment Rfc3986Predicates.unencodedPathSegment value  query :: Query -> Builder query (Query value) =-  urlEncodedText I.unencodedQuery value+  urlEncodedBytesOrText Rfc3987Predicates.unencodedQuery Rfc3986Predicates.unencodedQuery value  fragment :: Fragment -> Builder fragment (Fragment value) =-  urlEncodedText I.unencodedFragment value+  urlEncodedBytesOrText Rfc3987Predicates.unencodedFragment Rfc3986Predicates.unencodedFragment value +urlEncodedBytesOrText :: CorePredicates.Predicate -> CorePredicates.Predicate -> ByteString -> Builder+urlEncodedBytesOrText unencodedPredicate1 unencodedPredicate2 bytes =+  case A.decodeUtf8' bytes of+    Right text -> urlEncodedText unencodedPredicate1 text+    Left _ -> urlEncodedBytes unencodedPredicate2 bytes+ {-| Apply URL-encoding to text -}-urlEncodedText :: I.Predicate -> Text -> Builder+urlEncodedBytes :: CorePredicates.Predicate -> ByteString -> Builder+urlEncodedBytes unencodedPredicate =+  ByteString.foldl'+    (\ builder -> mappend builder . \ byte -> if unencodedPredicate (fromIntegral byte)+      then utf8CodeUnits1 byte+      else urlEncodedByte byte)+    mempty++{-| Apply URL-encoding to text -}+urlEncodedText :: CorePredicates.Predicate -> Text -> Builder urlEncodedText unencodedPredicate =   C.foldl' (\ builder -> mappend builder . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty -urlEncodedUnicodeCodePoint :: I.Predicate -> Int -> Builder+urlEncodedUnicodeCodePoint :: CorePredicates.Predicate -> Int -> Builder urlEncodedUnicodeCodePoint unencodedPredicate codePoint =   if unencodedPredicate codePoint     then

@@ -64,12 +64,6 @@       "https://ru.wikipedia.org/wiki/Баренцбург"       (show [httpUri|https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3|])     ,-    parsing-  ]--parsing =-  testGroup "Parsing" $-  [     testCase "Messed up URIs" $     let       testUri uri =@@ -83,10 +77,24 @@     testCase "User Info" $     assertEqual "" (Right "http://user:password@localhost:993") (fmap E.uri (D.uri "http://user:password@localhost:993"))     ,-    testCase "URI, IRI" $-    assertEqual ""-      (D.uri "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3")-      (F.iri "https://ru.wikipedia.org/wiki/Баренцбург")+    testGroup "IRI parser vs. URI parser" $ let+      testUriIri iri uri =+        testCase (iri <> " vs. " <> uri) $+        assertEqual "" (F.iri (fromString iri)) (D.uri (fromString uri))+      in+        [+          testUriIri+            "https://ru.wikipedia.org/wiki/Баренцбург"+            "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3"+          ,+          testUriIri+            "https://www.w3.org/International/articles/idn-and-iri/JP納豆/引き割り納豆.html"+            "https://www.w3.org/International/articles/idn-and-iri/JP%E7%B4%8D%E8%B1%86/%E5%BC%95%E3%81%8D%E5%89%B2%E3%82%8A%E7%B4%8D%E8%B1%86.html"+          ,+          testUriIri+            "http://点心和烤鸭.w3.mag.keio.ac.jp"+            "http://xn--0trv4xfvn8el34t.w3.mag.keio.ac.jp/"+        ]     ,     testGroup "Mess" $     [@@ -95,9 +103,17 @@         (Right "https://www.kupivip.ru/catalog/muzhchinam/odezhda?srcid=goo-tm-open&lpu=|source:google|medium:cpc|adposition:1t1|creative:195388077752|term:%2B%D0%B2%D0%B8%D0%BF%20%2B%D0%BA%D1%83%D0%BF%D0%B8|campaignid:801742449|campaign:goo_tm_mob_s_male|other:m|ad:1|&gclid=CjwKEAjwgb3OBRDNi_2TwZ6u7D4SJADsmW8QKiRxDZZ0hRAnyspAcVW582c7zzQSA7CC0FavPR63dBoCrKPw_wcB")         (fmap E.uri (D.uri "https://www.kupivip.ru/catalog/muzhchinam/odezhda?srcid=goo-tm-open&lpu=|source:google|medium:cpc|adposition:1t1|creative:195388077752|term:%2B%D0%B2%D0%B8%D0%BF%20%2B%D0%BA%D1%83%D0%BF%D0%B8|campaignid:801742449|campaign:goo_tm_mob_s_male|other:m|ad:1|&gclid=CjwKEAjwgb3OBRDNi_2TwZ6u7D4SJADsmW8QKiRxDZZ0hRAnyspAcVW582c7zzQSA7CC0FavPR63dBoCrKPw_wcB"))       ,-      testCase "2" $-      assertEqual ""-        (Right "https://www.pleer.ru/search_%E4%EB%FF+%E1%E5%EB%FC%FF+%F1%F3%F8%E8%EB%EA%E0.html")-        (fmap show (D.uri "https://www.pleer.ru/search_%E4%EB%FF+%E1%E5%EB%FC%FF+%F1%F3%F8%E8%EB%EA%E0.html"))+      testGroup "2" $+      [+        testCase "show" $+        assertEqual ""+          (Right "https://www.pleer.ru/search_%e4%eb%ff+%e1%e5%eb%fc%ff+%f1%f3%f8%e8%eb%ea%e0.html")+          (fmap show (D.uri "https://www.pleer.ru/search_%e4%eb%ff+%e1%e5%eb%fc%ff+%f1%f3%f8%e8%eb%ea%e0.html"))+        ,+        testCase "Text rendering" $+        assertEqual ""+          (Right "https://www.pleer.ru/search_%e4%eb%ff+%e1%e5%eb%fc%ff+%f1%f3%f8%e8%eb%ea%e0.html")+          (fmap C.iri (D.uri "https://www.pleer.ru/search_%e4%eb%ff+%e1%e5%eb%fc%ff+%f1%f3%f8%e8%eb%ea%e0.html"))+      ]     ]   ]