iri (empty) → 0.2
raw patch · 31 files changed
+2248/−0 lines, 31 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed
Dependencies added: QuickCheck, attoparsec, base, base-prelude, bug, bytestring, contravariant, ip, iri, profunctors, ptr, punycode, quickcheck-instances, rerebase, semigroups, tasty, tasty-hunit, tasty-quickcheck, template-haskell, text, text-builder, th-lift, th-lift-instances, unordered-containers, vector, vector-builder
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- iri.cabal +120/−0
- library/Iri/CodePointPredicates/Core.hs +57/−0
- library/Iri/CodePointPredicates/Rfc3986.hs +162/−0
- library/Iri/CodePointPredicates/Rfc3987.hs +211/−0
- library/Iri/Data.hs +19/−0
- library/Iri/Data/Functions.hs +30/−0
- library/Iri/Data/Instances/Eq.hs +40/−0
- library/Iri/Data/Instances/Lift.hs +41/−0
- library/Iri/Data/Instances/Show.hs +47/−0
- library/Iri/Data/Types.hs +99/−0
- library/Iri/MonadPlus.hs +30/−0
- library/Iri/Optics.hs +103/−0
- library/Iri/Parsing/Attoparsec/ByteString.hs +298/−0
- library/Iri/Parsing/Attoparsec/Text.hs +216/−0
- library/Iri/Parsing/ByteString.hs +29/−0
- library/Iri/Parsing/Text.hs +29/−0
- library/Iri/PercentEncoding.hs +26/−0
- library/Iri/Prelude.hs +64/−0
- library/Iri/QuasiQuoter.hs +63/−0
- library/Iri/Rendering/ByteString.hs +18/−0
- library/Iri/Rendering/Poke.hs +14/−0
- library/Iri/Rendering/Ptr/Poking.hs +157/−0
- library/Iri/Rendering/Text.hs +8/−0
- library/Iri/Rendering/Text/Internal.hs +18/−0
- library/Iri/Rendering/TextBuilder.hs +8/−0
- library/Iri/Rendering/TextBuilder/Internal.hs +155/−0
- library/Iri/Utf8CodePoint.hs +49/−0
- library/Iri/Vector.hs +20/−0
- tests/Main.hs +93/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2017, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ iri.cabal view
@@ -0,0 +1,120 @@+name:+ iri+version:+ 0.2+category:+ IRI, URI, URL, Data, Network+synopsis:+ RFC-based International Resource Identifier library+description:+ This library provides a universal data model for representation of both 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++source-repository head+ 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+ exposed-modules:+ Iri.Rendering.Text+ Iri.Rendering.TextBuilder+ Iri.Rendering.Ptr.Poking+ Iri.Rendering.ByteString+ Iri.Parsing.ByteString+ Iri.Parsing.Attoparsec.ByteString+ Iri.Parsing.Attoparsec.Text+ Iri.Parsing.Text+ Iri.QuasiQuoter+ Iri.Data+ Iri.Optics+ other-modules:+ Iri.Rendering.Text.Internal+ Iri.Rendering.TextBuilder.Internal+ Iri.Data.Types+ Iri.Data.Functions+ Iri.Data.Instances.Lift+ Iri.Data.Instances.Show+ Iri.Data.Instances.Eq+ Iri.Prelude+ Iri.Utf8CodePoint+ Iri.Vector+ Iri.MonadPlus+ Iri.CodePointPredicates.Core+ Iri.CodePointPredicates.Rfc3986+ Iri.CodePointPredicates.Rfc3987+ Iri.Rendering.Poke+ Iri.PercentEncoding+ 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,+ text ==1.*,+ text-builder >=0.5.1 && <0.6,+ bytestring >=0.10 && <0.11,+ vector >=0.10 && <0.13,+ 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 && <2,+ base >=4.7 && <5++test-suite tests+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ tests+ 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:+ tasty >=0.12 && <0.13,+ tasty-quickcheck >=0.9 && <0.10,+ tasty-hunit >=0.9 && <0.10,+ quickcheck-instances >=0.3.11 && <0.4,+ QuickCheck >=2.8.1 && <3,+ --+ rerebase >=1.1 && <2
+ library/Iri/CodePointPredicates/Core.hs view
@@ -0,0 +1,57 @@+module Iri.CodePointPredicates.Core+where++import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate)+import qualified Data.Vector as A+++type Predicate =+ Int -> Bool++{-# NOINLINE cached #-}+cached :: Predicate -> Predicate+cached predicate =+ case A.generate 256 predicate of+ vector -> A.unsafeIndex vector++oneOfChars :: [Char] -> Predicate+oneOfChars string i =+ elem i (fmap ord string)++infixr 2 |||+(|||) :: Predicate -> Predicate -> Predicate+(|||) left right i =+ left i || right i++infixr 3 &&&+(&&&) :: Predicate -> Predicate -> Predicate+(&&&) left right i =+ left i && right i++inRange :: Int -> Int -> Predicate+inRange min max i =+ i >= min && i <= max++inCharRange :: Char -> Char -> Predicate+inCharRange min max =+ inRange (ord min) (ord max)++{-| 7-bit -}+septimal :: Predicate+septimal i =+ i < 0x80++nonSeptimal :: Predicate+nonSeptimal i =+ i >= 0x80++control :: Predicate+control i =+ i <= 0x1F ||+ i == 0x7F++asciiAlphanumeric :: Predicate+asciiAlphanumeric =+ inCharRange 'a' 'z' |||+ inCharRange 'A' 'Z' |||+ inCharRange '0' '9'
+ library/Iri/CodePointPredicates/Rfc3986.hs view
@@ -0,0 +1,162 @@+{-|+References:+- <https://www.ietf.org/rfc/rfc3986 RFC3986: Uniform Resource Identifier (URI): Generic Syntax>++@+URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ]++hier-part = "//" authority path-abempty+ / path-absolute+ / path-rootless+ / path-empty++URI-reference = URI / relative-ref++absolute-URI = scheme ":" hier-part [ "?" query ]++relative-ref = relative-part [ "?" query ] [ "#" fragment ]++relative-part = "//" authority path-abempty+ / path-absolute+ / path-noscheme+ / path-empty++scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )++authority = [ userinfo "@" ] host [ ":" port ]+userinfo = *( unreserved / pct-encoded / sub-delims / ":" )+host = IP-literal / IPv4address / reg-name+port = *DIGIT++IP-literal = "[" ( IPv6address / IPvFuture ) "]"++IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )++IPv6address = 6( h16 ":" ) ls32+ / "::" 5( h16 ":" ) ls32+ / [ h16 ] "::" 4( h16 ":" ) ls32+ / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32+ / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32+ / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32+ / [ *4( h16 ":" ) h16 ] "::" ls32+ / [ *5( h16 ":" ) h16 ] "::" h16+ / [ *6( h16 ":" ) h16 ] "::"++h16 = 1*4HEXDIG+ls32 = ( h16 ":" h16 ) / IPv4address+IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet+dec-octet = DIGIT ; 0-9+ / %x31-39 DIGIT ; 10-99+ / "1" 2DIGIT ; 100-199+ / "2" %x30-34 DIGIT ; 200-249+ / "25" %x30-35 ; 250-255++reg-name = *( unreserved / pct-encoded / sub-delims )++path = path-abempty ; begins with "/" or is empty+ / path-absolute ; begins with "/" but not "//"+ / path-noscheme ; begins with a non-colon segment+ / path-rootless ; begins with a segment+ / path-empty ; zero characters++path-abempty = *( "/" segment )+path-absolute = "/" [ segment-nz *( "/" segment ) ]+path-noscheme = segment-nz-nc *( "/" segment )+path-rootless = segment-nz *( "/" segment )+path-empty = 0<pchar>++segment = *pchar+segment-nz = 1*pchar+segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )+ ; non-zero-length segment without any colon ":"++pchar = unreserved / pct-encoded / sub-delims / ":" / "@"++query = *( pchar / "/" / "?" )++fragment = *( pchar / "/" / "?" )++pct-encoded = "%" HEXDIG HEXDIG++unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"+reserved = gen-delims / sub-delims+gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@"+sub-delims = "!" / "$" / "&" / "'" / "(" / ")"+ / "*" / "+" / "," / ";" / "="+@++-}+module Iri.CodePointPredicates.Rfc3986+where++import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate)+import Iri.CodePointPredicates.Core+import qualified Data.Vector as A++{-|+Reference:++@+unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"+@+-}+unreserved :: Predicate+unreserved =+ asciiAlphanumeric ||| oneOfChars "-._~"++subDelims :: Predicate+subDelims =+ oneOfChars "!$&'()*+,;="++{-# NOINLINE scheme #-}+scheme :: Predicate+scheme =+ cached $+ asciiAlphanumeric ||| oneOfChars "+.-"++{-# NOINLINE domainLabel #-}+domainLabel :: Predicate+domainLabel =+ cached $+ asciiAlphanumeric ||| oneOfChars "-_~"++{-+pchar = unreserved / pct-encoded / sub-delims / ":" / "@"+-}+{-# NOINLINE unencodedPathSegment #-}+unencodedPathSegment :: Predicate+unencodedPathSegment =+ cached $+ unreserved ||| subDelims ||| oneOfChars ":@"++{-|+Reference:++@+query = *( pchar / "/" / "?" )+@++Notice that we've added the "|" char, because some real life URIs seem to contain it.+Also we've excluded the '+' char, because it gets decoded as a space char.+-}+{-# NOINLINE unencodedQuery #-}+unencodedQuery :: Predicate+unencodedQuery =+ cached $+ (unencodedPathSegment ||| oneOfChars "/?|") &&& (/= 43)++unencodedFragment :: Predicate+unencodedFragment =+ unencodedQuery++{-# NOINLINE unencodedQueryComponent #-}+unencodedQueryComponent :: Predicate+unencodedQueryComponent =+ cached $+ unencodedQuery &&& not . oneOfChars "=&;"++{-# NOINLINE unencodedUserInfoComponent #-}+unencodedUserInfoComponent :: Predicate+unencodedUserInfoComponent =+ cached $+ unreserved ||| subDelims
+ library/Iri/CodePointPredicates/Rfc3987.hs view
@@ -0,0 +1,211 @@+{-|+References:+- <https://www.ietf.org/rfc/rfc3987 RFC3987>++@+The following rules are different from those in [RFC3986]:++IRI = scheme ":" ihier-part [ "?" iquery ]+ [ "#" ifragment ]++ihier-part = "//" iauthority ipath-abempty+ / ipath-absolute+ / ipath-rootless+ / ipath-empty++IRI-reference = IRI / irelative-ref++absolute-IRI = scheme ":" ihier-part [ "?" iquery ]++irelative-ref = irelative-part [ "?" iquery ] [ "#" ifragment ]++irelative-part = "//" iauthority ipath-abempty+ / ipath-absolute++ / ipath-noscheme+ / ipath-empty++iauthority = [ iuserinfo "@" ] ihost [ ":" port ]+iuserinfo = *( iunreserved / pct-encoded / sub-delims / ":" )+ihost = IP-literal / IPv4address / ireg-name++ireg-name = *( iunreserved / pct-encoded / sub-delims )++ipath = ipath-abempty ; begins with "/" or is empty+ / ipath-absolute ; begins with "/" but not "//"+ / ipath-noscheme ; begins with a non-colon segment+ / ipath-rootless ; begins with a segment+ / ipath-empty ; zero characters++ipath-abempty = *( "/" isegment )+ipath-absolute = "/" [ isegment-nz *( "/" isegment ) ]+ipath-noscheme = isegment-nz-nc *( "/" isegment )+ipath-rootless = isegment-nz *( "/" isegment )+ipath-empty = 0<ipchar>++isegment = *ipchar+isegment-nz = 1*ipchar+isegment-nz-nc = 1*( iunreserved / pct-encoded / sub-delims+ / "@" )+ ; non-zero-length segment without any colon ":"++ipchar = iunreserved / pct-encoded / sub-delims / ":"+ / "@"++iquery = *( ipchar / iprivate / "/" / "?" )++ifragment = *( ipchar / "/" / "?" )++iunreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" / ucschar++ucschar = %xA0-D7FF / %xF900-FDCF / %xFDF0-FFEF+ / %x10000-1FFFD / %x20000-2FFFD / %x30000-3FFFD+ / %x40000-4FFFD / %x50000-5FFFD / %x60000-6FFFD+ / %x70000-7FFFD / %x80000-8FFFD / %x90000-9FFFD+ / %xA0000-AFFFD / %xB0000-BFFFD / %xC0000-CFFFD+ / %xD0000-DFFFD / %xE1000-EFFFD++iprivate = %xE000-F8FF / %xF0000-FFFFD / %x100000-10FFFD++Some productions are ambiguous. The "first-match-wins" (a.k.a.+"greedy") algorithm applies. For details, see [RFC3986].++The following rules are the same as those in [RFC3986]:++scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )++port = *DIGIT++IP-literal = "[" ( IPv6address / IPvFuture ) "]"++IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )++IPv6address = 6( h16 ":" ) ls32+ / "::" 5( h16 ":" ) ls32+ / [ h16 ] "::" 4( h16 ":" ) ls32+ / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32+ / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32+ / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32+ / [ *4( h16 ":" ) h16 ] "::" ls32+ / [ *5( h16 ":" ) h16 ] "::" h16+ / [ *6( h16 ":" ) h16 ] "::"++h16 = 1*4HEXDIG+ls32 = ( h16 ":" h16 ) / IPv4address++IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet++dec-octet = DIGIT ; 0-9+ / %x31-39 DIGIT ; 10-99+ / "1" 2DIGIT ; 100-199+ / "2" %x30-34 DIGIT ; 200-249+ / "25" %x30-35 ; 250-255++pct-encoded = "%" HEXDIG HEXDIG++unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"+reserved = gen-delims / sub-delims+gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@"+sub-delims = "!" / "$" / "&" / "'" / "(" / ")"+ / "*" / "+" / "," / ";" / "="++This syntax does not support IPv6 scoped addressing zone identifiers.+@++-}+module Iri.CodePointPredicates.Rfc3987+where++import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate)+import Iri.CodePointPredicates.Core+import qualified Iri.CodePointPredicates.Rfc3986 as A+++scheme :: Predicate+scheme =+ A.scheme++unencodedUserInfoComponent :: Predicate+unencodedUserInfoComponent =+ unreserved ||| A.subDelims++{-+ireg-name = *( iunreserved / pct-encoded / sub-delims )+-}+unencodedRegName :: Predicate+unencodedRegName =+ (unreserved ||| A.subDelims) &&& ((/=) 46)++{-+ipchar = iunreserved / pct-encoded / sub-delims / ":"+ / "@"+-}+unencodedPathSegment :: Predicate+unencodedPathSegment =+ unreserved ||| A.subDelims ||| oneOfChars ":@"++{-|+Reference:++@+iquery = *( ipchar / iprivate / "/" / "?" )+@++Notice that we've added the "|" char, because some real life URIs seem to contain it.+Also we've excluded the '+' char, because it gets decoded as a space char.+-}+unencodedQuery :: Predicate+unencodedQuery =+ (unencodedPathSegment ||| private ||| oneOfChars "/?|") &&& (/= 43)++{-|+Notice that we've added the "|" char, because some real life URIs seem to contain it.+Also we've excluded the '+' char, because it gets decoded as a space char.+-}+unencodedFragment :: Predicate+unencodedFragment =+ (unencodedPathSegment ||| oneOfChars "/?|") &&& (/= 43)++{-+iunreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" / ucschar+-}+unreserved :: Predicate+unreserved =+ A.unreserved ||| ucs++{-+ucschar = %xA0-D7FF / %xF900-FDCF / %xFDF0-FFEF+ / %x10000-1FFFD / %x20000-2FFFD / %x30000-3FFFD+ / %x40000-4FFFD / %x50000-5FFFD / %x60000-6FFFD+ / %x70000-7FFFD / %x80000-8FFFD / %x90000-9FFFD+ / %xA0000-AFFFD / %xB0000-BFFFD / %xC0000-CFFFD+ / %xD0000-DFFFD / %xE1000-EFFFD+-}+ucs :: Predicate+ucs x =+ x >= 0xA0 && x <= 0xD7FF ||+ x >= 0xF900 && x <= 0xFDCF ||+ x >= 0xFDF0 && x <= 0xFFEF ||+ x >= 0x10000 && x <= 0x1FFFD ||+ x >= 0x20000 && x <= 0x2FFFD ||+ x >= 0x30000 && x <= 0x3FFFD ||+ x >= 0x40000 && x <= 0x4FFFD ||+ x >= 0x50000 && x <= 0x5FFFD ||+ x >= 0x60000 && x <= 0x6FFFD ||+ x >= 0x70000 && x <= 0x7FFFD ||+ x >= 0x80000 && x <= 0x8FFFD ||+ x >= 0x90000 && x <= 0x9FFFD ||+ x >= 0xA0000 && x <= 0xAFFFD ||+ x >= 0xB0000 && x <= 0xBFFFD ||+ x >= 0xC0000 && x <= 0xCFFFD ||+ x >= 0xD0000 && x <= 0xDFFFD ||+ x >= 0xE1000 && x <= 0xEFFFD++{-+iprivate = %xE000-F8FF / %xF0000-FFFFD / %x100000-10FFFD+-}+private :: Predicate+private x =+ x >= 0xE000 && x <= 0xF8FF ||+ x >= 0xF0000 && x <= 0xFFFFD ||+ x >= 0x100000 && x <= 0x10FFFD
+ library/Iri/Data.hs view
@@ -0,0 +1,19 @@+{-|+References:++* <https://tools.ietf.org/rfc/rfc3986.txt URI RFC>+* <https://tools.ietf.org/rfc/rfc3987.txt IRI RFC>+-}+module Iri.Data+(+ module Iri.Data.Types,+ module Iri.Data.Functions,+)+where++import Iri.Data.Types+import Iri.Data.Functions+import Iri.Data.Instances.Lift+import Iri.Data.Instances.Eq+import Iri.Data.Instances.Show+
+ library/Iri/Data/Functions.hs view
@@ -0,0 +1,30 @@+module Iri.Data.Functions+where++import Iri.Prelude+import Iri.Data.Types+++{-| Try to specialize a general IRI to HTTP -}+httpIriFromIri :: Iri -> Either Text HttpIri+httpIriFromIri (Iri (Scheme scheme) hierarchy query fragment) =+ do+ security <- case scheme of+ "http" -> Right (Security False)+ "https" -> Right (Security True)+ _ -> Left ("Not an HTTP scheme: " <> (fromString . show) scheme)+ case hierarchy of+ AuthorisedHierarchy (Authority userInfo host port) path -> case userInfo of+ MissingUserInfo -> Right (HttpIri security host port path query fragment)+ PresentUserInfo (User user) _ -> Left ("User Info is present")+ _ -> Left ("Not an authorised hierarchy")++{-| Generalize an HTTP IRI to IRI -}+iriFromHttpIri :: HttpIri -> Iri+iriFromHttpIri (HttpIri (Security secure) host port path query fragment) =+ Iri scheme hierarchy query fragment+ where+ scheme =+ Scheme (if secure then "https" else "http")+ hierarchy =+ AuthorisedHierarchy (Authority MissingUserInfo host port) path
+ library/Iri/Data/Instances/Eq.hs view
@@ -0,0 +1,40 @@+module Iri.Data.Instances.Eq+where++import Iri.Prelude+import Iri.Data.Types+++deriving instance Eq Iri++deriving instance Eq Scheme++deriving instance Eq Hierarchy++deriving instance Eq Authority++deriving instance Eq UserInfo++deriving instance Eq User++deriving instance Eq Password++deriving instance Eq Host++deriving instance Eq RegName++deriving instance Eq DomainLabel++deriving instance Eq Port++deriving instance Eq Path++deriving instance Eq PathSegment++deriving instance Eq Query++deriving instance Eq Fragment++deriving instance Eq HttpIri++deriving instance Eq Security
+ library/Iri/Data/Instances/Lift.hs view
@@ -0,0 +1,41 @@+module Iri.Data.Instances.Lift+where++import Iri.Prelude+import Iri.Data.Types+import Language.Haskell.TH.Lift+++deriveLift ''Iri++deriveLift ''Scheme++deriveLift ''Hierarchy++deriveLift ''Authority++deriveLift ''UserInfo++deriveLift ''User++deriveLift ''Password++deriveLift ''Host++deriveLift ''RegName++deriveLift ''DomainLabel++deriveLift ''Port++deriveLift ''Path++deriveLift ''PathSegment++deriveLift ''Query++deriveLift ''Fragment++deriveLift ''HttpIri++deriveLift ''Security
+ library/Iri/Data/Instances/Show.hs view
@@ -0,0 +1,47 @@+module Iri.Data.Instances.Show+where++import Iri.Prelude+import Iri.Data.Types+import qualified Iri.Rendering.Text.Internal as A+import qualified Data.Text as B+++instance Show Iri where+ show =+ B.unpack . A.iri++instance Show HttpIri where+ show =+ B.unpack . A.httpIri++deriving instance Show Scheme++deriving instance Show Hierarchy++deriving instance Show Authority++deriving instance Show UserInfo++deriving instance Show User++deriving instance Show Password++deriving instance Show Host++deriving instance Show RegName++deriving instance Show DomainLabel++deriving instance Show Port++deriving instance Show Path++deriving instance Show PathSegment++deriving instance Show Query++deriving instance Show Fragment++deriving instance Show Security+
+ library/Iri/Data/Types.hs view
@@ -0,0 +1,99 @@+{-|+References:++* <https://tools.ietf.org/rfc/rfc3986.txt URI RFC>+* <https://tools.ietf.org/rfc/rfc3987.txt IRI RFC>+-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+module Iri.Data.Types+where++import Iri.Prelude+++{-|+Thorough structure of IRI.+-}+data Iri =+ Iri !Scheme !Hierarchy !Query !Fragment++newtype Scheme =+ Scheme ByteString++data Hierarchy =+ AuthorisedHierarchy !Authority !Path |+ AbsoluteHierarchy !Path |+ RelativeHierarchy !Path++data Authority =+ Authority !UserInfo !Host !Port++data UserInfo =+ PresentUserInfo !User !Password |+ MissingUserInfo++newtype User =+ User Text++data Password =+ PresentPassword !Text |+ MissingPassword++data Host =+ NamedHost !RegName |+ IpV4Host !IPv4 |+ IpV6Host !IPv6++newtype RegName =+ RegName (Vector DomainLabel)++newtype DomainLabel =+ DomainLabel Text++data Port =+ PresentPort !Word16 |+ MissingPort++newtype Path =+ Path (Vector PathSegment)++newtype PathSegment =+ PathSegment Text++{-|+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.++See <https://en.wikipedia.org/wiki/Query_string>.+-}+newtype Query =+ Query Text++newtype Fragment =+ Fragment Text+++-- * Special cases+-------------------------++-- ** HTTP special case+-------------------------++{-|+HTTP being by far the most common use-case for resource identifiers,+it's been isolated into a dedicated data-type,+which is optimised for that particular case.++Compared to the general IRI definition it:++* only supports the HTTP and HTTPS schemes+* misses the Username and Password components+* requires the Host component+* requires the Path component to be absolute+-}+data HttpIri =+ HttpIri !Security !Host !Port !Path !Query !Fragment++newtype Security =+ Security Bool
+ library/Iri/MonadPlus.hs view
@@ -0,0 +1,30 @@+module Iri.MonadPlus+where++import Iri.Prelude hiding (null, length)+++{-# INLINE foldl #-}+foldl :: MonadPlus m => (a -> b -> a) -> a -> m b -> m a+foldl step start elementParser =+ loop start+ where+ loop state =+ mplus+ (do+ element <- elementParser+ loop $! step state element)+ (return state)++{-# INLINE foldlM #-}+foldlM :: MonadPlus m => (a -> b -> m a) -> a -> m b -> m a+foldlM step start elementParser =+ loop start+ where+ loop state =+ join+ (mplus+ (do+ element <- elementParser+ return (step state element >>= loop))+ (return (return state)))
+ library/Iri/Optics.hs view
@@ -0,0 +1,103 @@+{-|+These are the beginnings of a Lens API.+It is compatible with the general Van Laarhoven lens libraries, such as \"lens\".++Many more definitions can be implemented, so do PRs if you miss any!+-}+module Iri.Optics+(+ -- * Definitions+ Lens,+ Lens',+ Prism,+ Prism',+ -- * Prisms+ iriHttpIriPrism,+ uriByteStringIriPrism,+ uriByteStringHttpIriPrism,+ iriTextIriPrism,+ iriTextHttpIriPrism,+ -- * Lenses+ iriSchemeLens,+ iriHierarchyLens,+ iriQueryLens,+ iriFragmentLens,+)+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+-------------------------++iriHttpIriPrism :: Prism' Iri HttpIri+iriHttpIriPrism =+ prism iriFromHttpIri (\ iri -> either (const (Left iri)) Right (httpIriFromIri iri))++uriByteStringIriPrism :: Prism' ByteString Iri+uriByteStringIriPrism =+ prism A.uri (\ bytes -> either (const (Left bytes)) Right (B.uri bytes))++uriByteStringHttpIriPrism :: Prism' ByteString HttpIri+uriByteStringHttpIriPrism =+ uriByteStringIriPrism . iriHttpIriPrism++iriTextIriPrism :: Prism' Text Iri+iriTextIriPrism =+ prism C.iri (\ text -> either (const (Left text)) Right (D.iri text))++iriTextHttpIriPrism :: Prism' Text HttpIri+iriTextHttpIriPrism =+ iriTextIriPrism . iriHttpIriPrism+++-- * Lenses+-------------------------++iriSchemeLens :: Lens' Iri ByteString+iriSchemeLens =+ lens+ (\ (Iri (Scheme x) _ _ _) -> x)+ (\ (Iri _ hierarchy query fragment) x -> Iri (Scheme x) hierarchy query fragment)++iriHierarchyLens :: Lens' Iri Hierarchy+iriHierarchyLens =+ lens+ (\ (Iri _ x _ _) -> x)+ (\ (Iri scheme _ query fragment) x -> Iri scheme x query fragment)++iriQueryLens :: Lens' Iri Text+iriQueryLens =+ lens+ (\ (Iri _ _ (Query x) _) -> x)+ (\ (Iri scheme hierarchy _ fragment) x -> Iri scheme hierarchy (Query x) fragment)++iriFragmentLens :: Lens' Iri Text+iriFragmentLens =+ lens+ (\ (Iri _ _ _ (Fragment x)) -> x)+ (\ (Iri scheme hierarchy query _) x -> Iri scheme hierarchy query (Fragment x))
+ library/Iri/Parsing/Attoparsec/ByteString.hs view
@@ -0,0 +1,298 @@+module Iri.Parsing.Attoparsec.ByteString+(+ uri,+ httpUri,+)+where++import Iri.Prelude hiding (foldl, hash)+import Iri.Data+import Data.Attoparsec.ByteString hiding (try)+import qualified Data.Attoparsec.ByteString.Char8 as F+import qualified Data.ByteString as K+import qualified Data.Text as T+import qualified Data.Text.Punycode as A+import qualified Data.Text.Encoding as B+import qualified Data.Text.Encoding.Error as L+import qualified Data.HashMap.Strict as O+import qualified Data.Vector as S+import qualified VectorBuilder.Builder as P+import qualified VectorBuilder.Vector as Q+import qualified VectorBuilder.MonadPlus as E+import qualified Iri.PercentEncoding as I+import qualified Iri.CodePointPredicates.Rfc3986 as C+import qualified Iri.MonadPlus as R+import qualified Ptr.Poking as G+import qualified Ptr.ByteString as H+import qualified Text.Builder as J+import qualified Net.IPv4 as M+import qualified Net.IPv6 as N+++{-# INLINE percent #-}+percent :: Parser Word8+percent =+ word8 37++{-# INLINE plus #-}+plus :: Parser Word8+plus =+ word8 43++{-# INLINE colon #-}+colon :: Parser Word8+colon =+ word8 58++{-# INLINE at #-}+at :: Parser Word8+at =+ word8 64++{-# INLINE forwardSlash #-}+forwardSlash :: Parser Word8+forwardSlash =+ word8 47++{-# INLINE question #-}+question :: Parser Word8+question =+ word8 63++{-# INLINE hash #-}+hash :: Parser Word8+hash =+ word8 35++{-# INLINE equality #-}+equality :: Parser Word8+equality =+ word8 61++{-# INLINE ampersand #-}+ampersand :: Parser Word8+ampersand =+ word8 38++{-# INLINE semicolon #-}+semicolon :: Parser Word8+semicolon =+ word8 59++{-# INLINE labeled #-}+labeled :: String -> Parser a -> Parser a+labeled label parser =+ parser <?> label++{-|+Parser of a well-formed URI conforming to the RFC3986 standard into IRI.+Performs URL- and Punycode-decoding.+-}+{-# INLINABLE uri #-}+uri :: Parser Iri+uri =+ labeled "URI" $ do+ parsedScheme <- scheme+ colon+ parsedHierarchy <- hierarchy+ parsedQuery <- query+ parsedFragment <- fragment+ return (Iri parsedScheme parsedHierarchy parsedQuery parsedFragment)++{-|+Same as 'uri', but optimized specifially for the case of HTTP URIs.+-}+{-# INLINABLE httpUri #-}+httpUri :: Parser HttpIri+httpUri =+ labeled "HTTP URI" $ do+ satisfy (\ x -> x == 104 || x == 72)+ satisfy (\ x -> x == 116 || x == 84)+ satisfy (\ x -> x == 116 || x == 84)+ satisfy (\ x -> x == 112 || x == 80)+ secure <- satisfy (\ b -> b == 115 || b == 83) $> True <|> pure False+ string "://"+ parsedHost <- host+ parsedPort <- PresentPort <$> (colon *> port) <|> pure MissingPort+ parsedPath <- (forwardSlash *> path) <|> pure (Path mempty)+ parsedQuery <- query+ parsedFragment <- fragment+ return (HttpIri (Security secure) parsedHost parsedPort parsedPath parsedQuery parsedFragment)++{-# INLINE hierarchy #-}+hierarchy :: Parser Hierarchy+hierarchy =+ do+ slashPresent <- forwardSlash $> True <|> pure False+ if slashPresent+ then do+ slashPresent <- forwardSlash $> True <|> pure False+ if slashPresent+ then authorisedHierarchyBody AuthorisedHierarchy+ else AbsoluteHierarchy <$> path+ else RelativeHierarchy <$> path++{-# INLINE authorisedHierarchyBody #-}+authorisedHierarchyBody :: (Authority -> Path -> body) -> Parser body+authorisedHierarchyBody body =+ do+ parsedUserInfo <- (presentUserInfo PresentUserInfo <* at) <|> pure MissingUserInfo+ parsedHost <- host+ parsedPort <- PresentPort <$> (colon *> port) <|> pure MissingPort+ parsedPath <- (forwardSlash *> path) <|> pure (Path mempty)+ return (body (Authority parsedUserInfo parsedHost parsedPort) parsedPath)++{-# INLINE scheme #-}+scheme :: Parser Scheme+scheme =+ labeled "Scheme" $+ fmap Scheme (takeWhile1 (C.scheme . fromIntegral))++{-# INLINABLE presentUserInfo #-}+presentUserInfo :: (User -> Password -> a) -> Parser a+presentUserInfo result =+ labeled "User info" $+ do+ user <- User <$> urlEncodedString (C.unencodedUserInfoComponent . fromIntegral)+ passwordFollows <- True <$ colon <|> pure False+ if passwordFollows+ then do+ password <- PresentPassword <$> urlEncodedString (C.unencodedUserInfoComponent . fromIntegral)+ return (result user password)+ else return (result user MissingPassword)++{-# INLINE host #-}+host :: Parser Host+host =+ labeled "Host" $+ IpV6Host <$> ipV6 <|>+ IpV4Host <$> M.parserUtf8 <|>+ NamedHost <$> domainName++{-# INLINABLE ipV6 #-}+ipV6 :: Parser IPv6+ipV6 =+ do+ a <- F.hexadecimal+ colon+ b <- F.hexadecimal+ colon+ c <- F.hexadecimal+ colon+ d <- F.hexadecimal+ colon+ mplus+ (do+ e <- F.hexadecimal+ colon+ f <- F.hexadecimal+ colon+ g <- F.hexadecimal+ colon+ h <- F.hexadecimal+ return (N.fromWord16s a b c d e f g h))+ (do+ colon+ return (N.fromWord16s a b c d 0 0 0 0))++{-# INLINE domainName #-}+domainName :: Parser RegName+domainName =+ fmap RegName (E.sepBy1 domainLabel (word8 46))++{-|+Domain label with Punycode decoding applied.+-}+{-# INLINE domainLabel #-}+domainLabel :: Parser DomainLabel+domainLabel =+ labeled "Domain label" $ do+ punycodeFollows <- True <$ string "xn--" <|> pure False+ ascii <- takeWhile1 (C.domainLabel . fromIntegral)+ if punycodeFollows+ then case A.decode ascii of+ Right text -> return (DomainLabel text)+ Left exception -> fail (showString "Punycode decoding exception: " (show exception))+ else return (DomainLabel (B.decodeUtf8 ascii))++{-# INLINE port #-}+port :: Parser Word16+port =+ F.decimal++{-# INLINE path #-}+path :: Parser Path+path =+ do+ segments <- E.sepBy pathSegment forwardSlash+ if segmentsAreEmpty segments+ then return (Path mempty)+ else return (Path segments)+ where+ segmentsAreEmpty segments =+ S.length segments == 1 &&+ (case S.unsafeHead segments of PathSegment headSegmentText -> T.null headSegmentText)++{-# INLINE pathSegment #-}+pathSegment :: Parser PathSegment+pathSegment =+ fmap PathSegment (urlEncodedString (C.unencodedPathSegment . fromIntegral))++{-# INLINABLE utf8Chunks #-}+utf8Chunks :: Parser ByteString -> Parser Text+utf8Chunks chunk =+ labeled "UTF8 chunks" $+ R.foldlM progress (mempty, mempty, B.streamDecodeUtf8) chunk >>= finish+ where+ progress (!builder, _, decode) bytes =+ case unsafeDupablePerformIO (try (evaluate (decode bytes))) of+ Right (B.Some decodedChunk undecodedBytes newDecode) ->+ return (builder <> J.text decodedChunk, undecodedBytes, newDecode)+ Left (L.DecodeError error _) ->+ fail (showString "UTF8 decoding: " error)+ finish (builder, undecodedBytes, _) =+ if K.null undecodedBytes+ then return (J.run builder)+ else fail (showString "UTF8 decoding: Bytes remaining: " (show undecodedBytes))++{-# INLINABLE urlEncodedString #-}+urlEncodedString :: (Word8 -> Bool) -> Parser Text+urlEncodedString unencodedBytesPredicate =+ labeled "URL-encoded string" $+ utf8Chunks $+ takeWhile1 unencodedBytesPredicate <|> encoded+ where+ encoded =+ K.singleton <$> percentEncodedByte++{-# INLINE percentEncodedByte #-}+percentEncodedByte :: Parser Word8+percentEncodedByte =+ labeled "Percent-encoded byte" $ do+ percent + byte1 <- anyWord8+ byte2 <- anyWord8+ I.matchPercentEncodedBytes (fail "Broken percent encoding") return byte1 byte2++{-# INLINABLE query #-}+query :: Parser Query+query =+ labeled "Query" $+ (question *> (Query <$> queryOrFragmentBody)) <|> pure (Query mempty)++{-# INLINABLE fragment #-}+fragment :: Parser Fragment+fragment =+ labeled "Fragment" $+ (hash *> (Fragment <$> queryOrFragmentBody)) <|> pure (Fragment mempty)++{-|+The stuff after the question or the hash mark.+-}+{-# INLINABLE queryOrFragmentBody #-}+queryOrFragmentBody :: Parser Text+queryOrFragmentBody =+ utf8Chunks $+ takeWhile1 (C.unencodedQuery . fromIntegral) <|>+ " " <$ plus <|>+ K.singleton <$> percentEncodedByte
+ library/Iri/Parsing/Attoparsec/Text.hs view
@@ -0,0 +1,216 @@+module Iri.Parsing.Attoparsec.Text+(+ iri,+ httpIri,+)+where++import Iri.Prelude+import Iri.Data+import Data.Attoparsec.Text hiding (try)+import qualified Data.ByteString as K+import qualified Data.Text as T+import qualified Data.Text.Encoding as B+import qualified Data.Text.Encoding.Error as L+import qualified Data.Vector as S+import qualified VectorBuilder.MonadPlus as E+import qualified Iri.CodePointPredicates.Rfc3987 as C+import qualified Iri.MonadPlus as R+import qualified Text.Builder as J+import qualified Net.IPv4 as M+import qualified Net.IPv6 as N+++{-# INLINE labeled #-}+labeled :: String -> Parser a -> Parser a+labeled label parser =+ parser <?> label++{-|+Parser of a well-formed IRI conforming to the RFC3987 standard into IRI.+Performs URL-decoding.+-}+{-# INLINABLE iri #-}+iri :: Parser Iri+iri =+ labeled "IRI" $ do+ parsedScheme <- scheme+ char ':'+ parsedHierarchy <- hierarchy+ parsedQuery <- query+ parsedFragment <- fragment+ return (Iri parsedScheme parsedHierarchy parsedQuery parsedFragment)++{-|+Same as 'iri', but optimized specifially for the case of HTTP IRIs.+-}+{-# INLINABLE httpIri #-}+httpIri :: Parser HttpIri+httpIri =+ labeled "HTTP IRI" $ do+ asciiCI "http"+ secure <- satisfy (\ x -> x == 's' || x == 'S') $> True <|> pure False+ string "://"+ parsedHost <- host+ parsedPort <- PresentPort <$> (char ':' *> port) <|> pure MissingPort+ parsedPath <- ((char '/') *> path) <|> pure (Path mempty)+ parsedQuery <- query+ parsedFragment <- fragment+ return (HttpIri (Security secure) parsedHost parsedPort parsedPath parsedQuery parsedFragment)++{-# INLINE hierarchy #-}+hierarchy :: Parser Hierarchy+hierarchy =+ do+ slashPresent <- (char '/') $> True <|> pure False+ if slashPresent+ then do+ slashPresent <- (char '/') $> True <|> pure False+ if slashPresent+ then authorisedHierarchyBody AuthorisedHierarchy+ else AbsoluteHierarchy <$> path+ else RelativeHierarchy <$> path++{-# INLINE authorisedHierarchyBody #-}+authorisedHierarchyBody :: (Authority -> Path -> body) -> Parser body+authorisedHierarchyBody body =+ do+ parsedUserInfo <- (presentUserInfo PresentUserInfo <* char '@') <|> pure MissingUserInfo+ parsedHost <- host+ parsedPort <- PresentPort <$> (char ':' *> port) <|> pure MissingPort+ parsedPath <- ((char '/') *> path) <|> pure (Path mempty)+ return (body (Authority parsedUserInfo parsedHost parsedPort) parsedPath)++{-# INLINE scheme #-}+scheme :: Parser Scheme+scheme =+ labeled "Scheme" $+ fmap (Scheme . B.encodeUtf8) (takeWhile1 (C.scheme . ord))++{-# INLINABLE presentUserInfo #-}+presentUserInfo :: (User -> Password -> a) -> Parser a+presentUserInfo result =+ labeled "User info" $+ do+ user <- User <$> urlEncodedComponent (C.unencodedUserInfoComponent . ord)+ passwordFollows <- True <$ char ':' <|> pure False+ if passwordFollows+ then do+ password <- PresentPassword <$> urlEncodedComponent (C.unencodedUserInfoComponent . ord)+ return (result user password)+ else return (result user MissingPassword)++{-# INLINE host #-}+host :: Parser Host+host =+ labeled "Host" $+ IpV6Host <$> N.parser <|>+ IpV4Host <$> M.parser <|>+ NamedHost <$> domainName++{-# INLINE domainName #-}+domainName :: Parser RegName+domainName =+ fmap RegName (E.sepBy1 domainLabel (char '.'))++{-|+Domain label with Punycode decoding applied.+-}+{-# INLINE domainLabel #-}+domainLabel :: Parser DomainLabel+domainLabel =+ labeled "Domain label" $+ DomainLabel <$> takeWhile1 (C.unencodedRegName . ord)++{-# INLINE port #-}+port :: Parser Word16+port =+ decimal++{-# INLINE path #-}+path :: Parser Path+path =+ do+ segments <- E.sepBy pathSegment (char '/')+ if segmentsAreEmpty segments+ then return (Path mempty)+ else return (Path segments)+ where+ segmentsAreEmpty segments =+ S.length segments == 1 &&+ (case S.unsafeHead segments of PathSegment headSegmentText -> T.null headSegmentText)++{-# INLINE pathSegment #-}+pathSegment :: Parser PathSegment+pathSegment =+ fmap PathSegment (urlEncodedComponent (C.unencodedPathSegment . ord))++{-# INLINABLE urlEncodedComponent #-}+urlEncodedComponent :: (Char -> Bool) -> Parser Text+urlEncodedComponent unencodedCharPredicate =+ labeled "URL-encoded component" $+ fmap J.run $+ R.foldl mappend mempty $+ (J.text <$> takeWhile1 unencodedCharPredicate) <|> urlEncodedSequence++{-# INLINABLE urlEncodedSequence #-}+urlEncodedSequence :: Parser J.Builder+urlEncodedSequence =+ labeled "URL-encoded sequence" $ do+ start <- progress (mempty, mempty, B.streamDecodeUtf8) =<< urlEncodedByte+ R.foldlM progress (start) urlEncodedByte >>= finish+ where+ progress (!builder, _ :: ByteString, decode) byte =+ case unsafeDupablePerformIO (try (evaluate (decode (K.singleton byte)))) of+ Right (B.Some decodedChunk undecodedBytes newDecode) ->+ return (builder <> J.text decodedChunk, undecodedBytes, newDecode)+ Left (L.DecodeError error _) ->+ fail (showString "UTF8 decoding: " error)+ finish (builder, undecodedBytes, _) =+ if K.null undecodedBytes+ then return builder+ else fail (showString "UTF8 decoding: Bytes remaining: " (show undecodedBytes))++{-# INLINE urlEncodedByte #-}+urlEncodedByte :: Parser Word8+urlEncodedByte =+ do+ char '%' + digit1 <- fromIntegral <$> hexadecimalDigit+ digit2 <- fromIntegral <$> hexadecimalDigit+ return (shiftL digit1 4 .|. digit2)++{-# INLINE hexadecimalDigit #-}+hexadecimalDigit :: Parser Int+hexadecimalDigit =+ do+ c <- anyChar+ let x = ord c+ if x >= 48 && x < 58+ then return (x - 48)+ else if x >= 65 && x < 71+ then return (x - 55)+ else if x >= 97 && x < 103+ then return (x - 97)+ else fail ("Not a hexadecimal digit: " <> show c)++{-# INLINABLE query #-}+query :: Parser Query+query =+ labeled "Query" $+ (char '?' *> queryBody) <|> pure (Query mempty)++{-|+The stuff after the question mark.+-}+{-# INLINABLE queryBody #-}+queryBody :: Parser Query+queryBody =+ fmap Query (urlEncodedComponent (C.unencodedQuery . ord))++{-# INLINABLE fragment #-}+fragment :: Parser Fragment+fragment =+ labeled "Fragment" $+ (char '#' *> (Fragment <$> urlEncodedComponent (C.unencodedFragment . ord))) <|>+ pure (Fragment mempty)
+ library/Iri/Parsing/ByteString.hs view
@@ -0,0 +1,29 @@+module Iri.Parsing.ByteString+(+ uri,+ httpUri,+)+where++import Iri.Prelude+import Iri.Data+import qualified Iri.Parsing.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString as B+++{-|+Parser of a well-formed URI conforming to the RFC3986 standard into IRI.+Performs URL- and Punycode-decoding.+-}+uri :: ByteString -> Either Text Iri+uri =+ either (Left . fromString) Right .+ B.parseOnly (A.uri <* B.endOfInput)++{-|+Same as 'uri', but optimized specifially for the case of HTTP URIs.+-}+httpUri :: ByteString -> Either Text HttpIri+httpUri =+ either (Left . fromString) Right .+ B.parseOnly (A.httpUri <* B.endOfInput)
+ library/Iri/Parsing/Text.hs view
@@ -0,0 +1,29 @@+module Iri.Parsing.Text+(+ iri,+ httpIri,+)+where++import Iri.Prelude+import Iri.Data+import qualified Iri.Parsing.Attoparsec.Text as A+import qualified Data.Attoparsec.Text as B+++{-|+Parser of a well-formed IRI conforming to the RFC3987 standard into IRI.+Performs URL-decoding.+-}+iri :: Text -> Either Text Iri+iri =+ either (Left . fromString) Right .+ B.parseOnly (A.iri <* B.endOfInput)++{-|+Same as 'iri', but optimized specifially for the case of HTTP IRIs.+-}+httpIri :: Text -> Either Text HttpIri+httpIri =+ either (Left . fromString) Right .+ B.parseOnly (A.httpIri <* B.endOfInput)
+ library/Iri/PercentEncoding.hs view
@@ -0,0 +1,26 @@+module Iri.PercentEncoding where++import Iri.Prelude+++{-# INLINE matchHexByte #-}+matchHexByte :: a -> (Word8 -> a) -> Word8 -> a+matchHexByte failure success x =+ if x >= 48 && x <= 57+ then success (x - 48)+ else if x >= 65 && x <= 70+ then success (x - 55)+ else if x >= 97 && x <= 102+ then success (x - 87)+ else failure++{-# INLINE matchPercentEncodedBytes #-}+matchPercentEncodedBytes :: a -> (Word8 -> a) -> Word8 -> Word8 -> a+matchPercentEncodedBytes failure success byte1 byte2 =+ matchHexByte failure firstByteSuccess byte1+ where+ firstByteSuccess decodedByte1 =+ matchHexByte failure secondByteSuccess byte2+ where+ secondByteSuccess decodedByte2 =+ success (shiftL decodedByte1 4 .|. decodedByte2)
+ library/Iri/Prelude.hs view
@@ -0,0 +1,64 @@+module Iri.Prelude+(+ module Exports,+)+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)++-- contravariant+-------------------------+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports++-- profunctors+-------------------------+import Data.Profunctor.Unsafe as Exports+import Data.Profunctor.Choice as Exports+import Data.Profunctor.Strong as Exports++-- semigroups+-------------------------+import Data.Semigroup as Exports++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- text+-------------------------+import Data.Text as Exports (Text)++-- ip+-------------------------+import Net.IPv4 as Exports (IPv4)+import Net.IPv6 as Exports (IPv6)++-- vector+-------------------------+import Data.Vector as Exports (Vector)++-- unordered-containers+-------------------------+import Data.HashMap.Strict as Exports (HashMap)++-- th-lift-instances+-------------------------+import Instances.TH.Lift as Exports++-- bug+-------------------------+import Bug as Exports++--------------------------------------------------------------------------------++import qualified Language.Haskell.TH.Lift as A+A.deriveLift ''IPv4+A.deriveLift ''IPv6
+ library/Iri/QuasiQuoter.hs view
@@ -0,0 +1,63 @@+module Iri.QuasiQuoter+(+ uri,+ httpUri,+)+where++import Iri.Prelude hiding (exp)+import Iri.Data+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote+import qualified Iri.Parsing.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString as B+import qualified Data.Attoparsec.Text as C+import qualified Iri.Parsing.Attoparsec.Text as D+++exp :: (String -> Q Exp) -> QuasiQuoter+exp exp =+ QuasiQuoter exp unsupported unsupported unsupported+ where+ unsupported _ =+ fail "Not supported"++{-|+IRI literal parsed from textual URI.+-}+uri :: QuasiQuoter+uri =+ exp $ \ string ->+ case B.parseOnly (A.uri <* B.endOfInput) (fromString string) of+ Right iri -> lift iri+ Left error -> fail (showString "URI parsing: " error)++{-|+HTTP IRI literal parsed from textual URI.+-}+httpUri :: QuasiQuoter+httpUri =+ exp $ \ string ->+ case B.parseOnly (A.httpUri <* B.endOfInput) (fromString string) of+ Right iri -> lift iri+ Left error -> fail (showString "HTTP URI parsing: " error)++{-|+IRI literal parsed from textual IRI.+-}+iri :: QuasiQuoter+iri =+ exp $ \ string ->+ case C.parseOnly (D.iri <* C.endOfInput) (fromString string) of+ Right iri -> lift iri+ Left error -> fail (showString "IRI parsing: " error)++{-|+HTTP IRI literal parsed from textual IRI.+-}+httpIri :: QuasiQuoter+httpIri =+ exp $ \ string ->+ case C.parseOnly (D.httpIri <* C.endOfInput) (fromString string) of+ Right iri -> lift iri+ Left error -> fail (showString "HTTP IRI parsing: " error)
+ library/Iri/Rendering/ByteString.hs view
@@ -0,0 +1,18 @@+module Iri.Rendering.ByteString+where++import Iri.Prelude+import Iri.Data+import qualified Iri.Rendering.Ptr.Poking as A+import qualified Ptr.ByteString as F+++{-| Render as URI ASCII bytes -}+uri :: Iri -> ByteString+uri =+ F.poking . A.uri++{-| Render as URI ASCII bytes -}+httpUri :: HttpIri -> ByteString+httpUri =+ F.poking . A.httpUri
+ library/Iri/Rendering/Poke.hs view
@@ -0,0 +1,14 @@+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)
+ library/Iri/Rendering/Ptr/Poking.hs view
@@ -0,0 +1,157 @@+module Iri.Rendering.Ptr.Poking+(+ uri,+ httpUri,+ scheme,+ host,+ path,+ query,+)+where++import Iri.Prelude hiding (null, poke)+import Iri.Data+import Ptr.Poking+import qualified Data.Text.Encoding as A+import qualified Data.Text.Encoding.Error as A+import qualified Data.Text.Punycode as B+import qualified Data.Text as C+import qualified Data.HashMap.Strict as G+import qualified Data.Vector as H+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.Rfc3986 as I+import qualified Iri.Utf8CodePoint as K+import qualified Iri.Rendering.Poke as L+++uri :: Iri -> Poking+uri (Iri schemeValue hierarchyValue queryValue fragmentValue) =+ scheme schemeValue <> + asciiChar ':' <>+ hierarchy hierarchyValue <>+ (prependIfNotNull+ (asciiChar '?')+ (query queryValue)) <>+ (prependIfNotNull+ (asciiChar '#')+ (fragment fragmentValue))++httpUri :: HttpIri -> Poking+httpUri (HttpIri (Security secure) hostValue portValue pathValue queryValue fragmentValue) =+ (if secure then bytes "https://" else bytes "http://") <>+ host hostValue <>+ prependIfNotNull (asciiChar ':') (port portValue) <>+ prependIfNotNull (asciiChar '/') (path pathValue) <>+ prependIfNotNull (asciiChar '?') (query queryValue) <>+ prependIfNotNull (asciiChar '#') (fragment fragmentValue)++scheme :: Scheme -> Poking+scheme (Scheme value) =+ bytes value++hierarchy :: Hierarchy -> Poking+hierarchy =+ \ case+ AuthorisedHierarchy authorityValue pathValue ->+ bytes "//" <> authority authorityValue <> prependIfNotNull (asciiChar '/') (path pathValue)+ AbsoluteHierarchy pathValue ->+ asciiChar '/' <> path pathValue+ RelativeHierarchy pathValue ->+ path pathValue++authority :: Authority -> Poking+authority (Authority userInfoValue hostValue portValue) =+ appendIfNotNull (asciiChar '@') (userInfo userInfoValue) <>+ host hostValue <>+ prependIfNotNull (asciiChar ':') (port portValue)++userInfo :: UserInfo -> Poking+userInfo =+ \ case+ PresentUserInfo (User user) password -> case password of+ PresentPassword password -> userInfoComponent user <> asciiChar ':' <> userInfoComponent password+ MissingPassword -> userInfoComponent user+ MissingUserInfo -> mempty++userInfoComponent :: Text -> Poking+userInfoComponent =+ urlEncodedText I.unencodedUserInfoComponent++host :: Host -> Poking+host =+ \ case+ NamedHost value -> domainName value+ IpV4Host value -> ipV4 value+ IpV6Host value -> ipV6 value++domainName :: RegName -> Poking+domainName (RegName vector) =+ F.intercalate domainLabel (asciiChar '.') vector++domainLabel :: DomainLabel -> Poking+domainLabel (DomainLabel value) =+ if C.all (< '\x80') value+ then bytes (A.encodeUtf8 value)+ else bytes "xn--" <> bytes (B.encode value)++ipV4 :: IPv4 -> Poking+ipV4 =+ bytes . A.encodeUtf8 . D.encode++ipV6 :: IPv6 -> Poking+ipV6 =+ bytes . A.encodeUtf8 . E.encode++port :: Port -> Poking+port =+ \ case+ PresentPort value -> asciiIntegral value+ MissingPort -> mempty++path :: Path -> Poking+path (Path pathSegmentVector) =+ F.intercalate pathSegment (asciiChar '/') pathSegmentVector++pathSegment :: PathSegment -> Poking+pathSegment (PathSegment value) =+ urlEncodedText I.unencodedPathSegment value++query :: Query -> Poking+query (Query value) =+ urlEncodedText I.unencodedQuery value++fragment :: Fragment -> Poking+fragment (Fragment value) =+ urlEncodedText I.unencodedFragment value++{-| Apply URL-encoding to text -}+urlEncodedText :: I.Predicate -> Text -> Poking+urlEncodedText unencodedPredicate =+ C.foldl' (\ poking -> mappend poking . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty++urlEncodedUnicodeCodePoint :: I.Predicate -> Int -> Poking+urlEncodedUnicodeCodePoint unencodedPredicate codePoint =+ K.unicodeCodePoint codePoint+ (\ b1 -> if unencodedPredicate codePoint then word8 b1 else urlEncodedByte b1)+ (\ b1 b2 -> urlEncodedByte b1 <> urlEncodedByte b2)+ (\ b1 b2 b3 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3)+ (\ b1 b2 b3 b4 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3 <> urlEncodedByte b4)++urlEncodedByte :: Word8 -> Poking+urlEncodedByte =+ poke L.urlEncodedByte++prependIfNotNull :: Poking -> Poking -> Poking+prependIfNotNull prepended it =+ if null it+ then mempty+ else prepended <> it++appendIfNotNull :: Poking -> Poking -> Poking+appendIfNotNull appended it =+ if null it+ then mempty+ else it <> appended
+ library/Iri/Rendering/Text.hs view
@@ -0,0 +1,8 @@+module Iri.Rendering.Text+(+ module Iri.Rendering.Text.Internal,+)+where++import Iri.Rendering.Text.Internal+import Iri.Data
+ library/Iri/Rendering/Text/Internal.hs view
@@ -0,0 +1,18 @@+module Iri.Rendering.Text.Internal+where++import Iri.Prelude+import Iri.Data.Types+import qualified Iri.Rendering.TextBuilder.Internal as A+import qualified Text.Builder as B+++{-| Render as a Unicode IRI text -}+iri :: Iri -> Text+iri =+ B.run . A.iri++{-| Render as a Unicode IRI text -}+httpIri :: HttpIri -> Text+httpIri =+ B.run . A.httpIri
+ library/Iri/Rendering/TextBuilder.hs view
@@ -0,0 +1,8 @@+module Iri.Rendering.TextBuilder+(+ module Iri.Rendering.TextBuilder.Internal,+)+where++import Iri.Rendering.TextBuilder.Internal+import Iri.Data.Types
+ library/Iri/Rendering/TextBuilder/Internal.hs view
@@ -0,0 +1,155 @@+module Iri.Rendering.TextBuilder.Internal+(+ iri,+ httpIri,+)+where++import Iri.Prelude hiding (null)+import Iri.Data.Types+import Text.Builder+import qualified Data.Text.Encoding as A+import qualified Data.Text.Encoding.Error as A+import qualified Data.Text.Punycode as B+import qualified Data.Text as C+import qualified Data.HashMap.Strict as G+import qualified Data.Vector as H+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.Utf8CodePoint as K+++iri :: Iri -> Builder+iri (Iri schemeValue hierarchyValue queryValue fragmentValue) =+ scheme schemeValue <> + char ':' <>+ hierarchy hierarchyValue <>+ (prependIfNotNull+ (char '?')+ (query queryValue)) <>+ (prependIfNotNull+ (char '#')+ (fragment fragmentValue))++httpIri :: HttpIri -> Builder+httpIri (HttpIri (Security secure) hostValue portValue pathValue queryValue fragmentValue) =+ (if secure then string "https://" else string "http://") <>+ host hostValue <>+ prependIfNotNull (char ':') (port portValue) <>+ prependIfNotNull (char '/') (path pathValue) <>+ prependIfNotNull (char '?') (query queryValue) <>+ prependIfNotNull (char '#') (fragment fragmentValue)++scheme :: Scheme -> Builder+scheme (Scheme bytes) =+ text (A.decodeUtf8With A.lenientDecode bytes)++hierarchy :: Hierarchy -> Builder+hierarchy =+ \ case+ AuthorisedHierarchy authorityValue pathValue ->+ string "//" <> authority authorityValue <> prependIfNotNull (char '/') (path pathValue)+ AbsoluteHierarchy pathValue ->+ char '/' <> path pathValue+ RelativeHierarchy pathValue ->+ path pathValue++authority :: Authority -> Builder+authority (Authority userInfoValue hostValue portValue) =+ appendIfNotNull (char '@') (userInfo userInfoValue) <>+ host hostValue <>+ prependIfNotNull (char ':') (port portValue)++userInfo :: UserInfo -> Builder+userInfo =+ \ case+ PresentUserInfo (User user) password -> case password of+ PresentPassword password -> userInfoComponent user <> char ':' <> userInfoComponent password+ MissingPassword -> userInfoComponent user+ MissingUserInfo -> mempty++userInfoComponent :: Text -> Builder+userInfoComponent =+ urlEncodedText I.unencodedUserInfoComponent++host :: Host -> Builder+host =+ \ case+ NamedHost value -> domainName value+ IpV4Host value -> ipV4 value+ IpV6Host value -> ipV6 value++domainName :: RegName -> Builder+domainName (RegName vector) =+ F.intercalate domainLabel (char '.') vector++domainLabel :: DomainLabel -> Builder+domainLabel (DomainLabel value) =+ text value++ipV4 :: IPv4 -> Builder+ipV4 =+ text . D.encode++ipV6 :: IPv6 -> Builder+ipV6 =+ text . E.encode++port :: Port -> Builder+port =+ \ case+ PresentPort value -> unsignedDecimal value+ MissingPort -> mempty++path :: Path -> Builder+path (Path pathSegmentVector) =+ F.intercalate pathSegment (char '/') pathSegmentVector++pathSegment :: PathSegment -> Builder+pathSegment (PathSegment value) =+ urlEncodedText I.unencodedPathSegment value++query :: Query -> Builder+query (Query value) =+ urlEncodedText I.unencodedQuery value++fragment :: Fragment -> Builder+fragment (Fragment value) =+ urlEncodedText I.unencodedFragment value++{-| Apply URL-encoding to text -}+urlEncodedText :: I.Predicate -> Text -> Builder+urlEncodedText unencodedPredicate =+ C.foldl' (\ builder -> mappend builder . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty++urlEncodedUnicodeCodePoint :: I.Predicate -> Int -> Builder+urlEncodedUnicodeCodePoint unencodedPredicate codePoint =+ if unencodedPredicate codePoint+ then+ unicodeCodePoint codePoint+ else+ K.unicodeCodePoint codePoint+ (\ b1 -> urlEncodedByte b1)+ (\ b1 b2 -> urlEncodedByte b1 <> urlEncodedByte b2)+ (\ b1 b2 b3 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3)+ (\ b1 b2 b3 b4 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3 <> urlEncodedByte b4)++urlEncodedByte :: Word8 -> Builder+urlEncodedByte x =+ case divMod x 16 of+ (d1, d2) -> char '%' <> hexadecimalDigit d1 <> hexadecimalDigit d2++prependIfNotNull :: Builder -> Builder -> Builder+prependIfNotNull prepended it =+ if null it+ then mempty+ else prepended <> it++appendIfNotNull :: Builder -> Builder -> Builder+appendIfNotNull appended it =+ if null it+ then mempty+ else it <> appended
+ library/Iri/Utf8CodePoint.hs view
@@ -0,0 +1,49 @@+{- |+Utilities for the UTF-8 encoding.+-}+module Iri.Utf8CodePoint where++import Iri.Prelude+++{-|+Church encoding of a UTF8-encoded character.+-}+type Utf8CodePoint =+ forall a.+ (Word8 -> a) ->+ (Word8 -> Word8 -> a) ->+ (Word8 -> Word8 -> Word8 -> a) ->+ (Word8 -> Word8 -> Word8 -> Word8 -> a) ->+ a++{-# INLINE char #-}+char :: Char -> Utf8CodePoint+char =+ unicodeCodePoint . ord++{-# INLINE unicodeCodePoint #-}+unicodeCodePoint :: Int -> Utf8CodePoint+unicodeCodePoint x f1 f2 f3 f4 =+ if x <= 0x7F+ then+ f1 (fromIntegral x)+ else + if x <= 0x07FF+ then+ f2+ (fromIntegral ((x `shiftR` 6) + 0xC0))+ (fromIntegral ((x .&. 0x3F) + 0x80))+ else+ if x <= 0xFFFF+ then+ f3+ (fromIntegral (x `shiftR` 12) + 0xE0)+ (fromIntegral ((x `shiftR` 6) .&. 0x3F) + 0x80)+ (fromIntegral (x .&. 0x3F) + 0x80)+ else+ f4+ (fromIntegral (x `shiftR` 18) + 0xF0)+ (fromIntegral ((x `shiftR` 12) .&. 0x3F) + 0x80)+ (fromIntegral ((x `shiftR` 6) .&. 0x3F) + 0x80)+ (fromIntegral (x .&. 0x3F) + 0x80)
+ library/Iri/Vector.hs view
@@ -0,0 +1,20 @@+module Iri.Vector+where++import Iri.Prelude hiding (null, length)+import Data.Vector+++{-# INLINE intercalate #-}+intercalate :: (Semigroup monoid, Monoid monoid) => (element -> monoid) -> monoid -> Vector element -> monoid+intercalate project separator vector =+ if null vector+ then mempty+ else project (unsafeIndex vector 0) <> iterate 1+ where+ vectorLength =+ length vector+ iterate !index =+ if index < vectorLength+ then separator <> project (unsafeIndex vector index) <> iterate (succ index)+ else mempty
+ tests/Main.hs view
@@ -0,0 +1,93 @@+module Main where++import Prelude+import Test.QuickCheck.Instances+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Iri.QuasiQuoter+import qualified Iri.Data as A+import qualified Iri.Parsing.ByteString as D+import qualified Iri.Parsing.Text as F+import qualified Iri.Rendering.Text as C+import qualified Iri.Rendering.ByteString as E+++main =+ defaultMain $+ testGroup "All tests" $+ [+ testCase "No path" $+ assertEqual ""+ (Right "https://ru.wikipedia.org?query")+ (fmap C.iri+ (D.uri "https://ru.wikipedia.org?query"))+ ,+ testCase "Cyrillic path" $ do+ assertEqual ""+ (Right "https://ru.wikipedia.org/wiki/Баренцбург")+ (fmap C.iri+ (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"))+ ,+ testCase "Complex query" $ do+ assertEqual ""+ (Right "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb")+ (fmap C.iri+ (D.uri "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb"))+ ,+ testCase "Rendering" $+ let+ inputs =+ [+ "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"+ ,+ "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb"+ ]+ in+ forM_ inputs $ \ input ->+ let+ Right iri = D.uri input+ in assertEqual "" input (E.uri iri)+ ,+ testCase "about:blank" $ assertEqual "" "about:blank" (E.uri [uri|about:blank|])+ ,+ testCase "Empty hierarchy" $ assertEqual "" "about:" (E.uri [uri|about:|])+ ,+ testCase "HTTP URI Text Rendering" $+ assertEqual ""+ "https://ru.wikipedia.org/wiki/Баренцбург"+ (C.httpIri [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|])+ ,+ testCase "HTTP URI Show" $+ assertEqual ""+ "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 "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 "Mess" $+ [+ testCase "1" $+ assertEqual ""+ (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"))+ ]+ ]