diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/iri.cabal b/iri.cabal --- a/iri.cabal +++ b/iri.cabal @@ -1,120 +1,169 @@ -name: - iri -version: - 0.2 -category: - IRI, URI, URL, Data, Network -synopsis: - RFC-based International Resource Identifier library +cabal-version: 3.0 +name: iri +version: 0.5.1.2 +category: URI, URL, IRI, Network +synopsis: RFC-compliant universal resource identifier library (URL, URI, IRI) 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 -maintainer: - Nikita Volkov -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 +maintainer: Nikita Volkov +copyright: (c) 2017 Nikita Volkov +license: MIT +license-file: LICENSE + source-repository head - type: - git - location: - git://github.com/nikita-volkov/iri.git + type: git + location: https://github.com/nikita-volkov/iri -library - hs-source-dirs: - library +common base + default-language: Haskell2010 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 + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + NumericUnderscores + OverloadedStrings + ParallelListComp + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + ViewPatterns + +common executable + import: base + ghc-options: + -O2 + -threaded + -with-rtsopts=-N + -rtsopts + -funbox-strict-fields + +common test + import: base + ghc-options: + -threaded + -with-rtsopts=-N + +library + import: base + hs-source-dirs: library exposed-modules: - Iri.Rendering.Text - Iri.Rendering.TextBuilder - Iri.Rendering.Ptr.Poking - Iri.Rendering.ByteString - Iri.Parsing.ByteString + Iri.Data + Iri.Optics Iri.Parsing.Attoparsec.ByteString Iri.Parsing.Attoparsec.Text + Iri.Parsing.ByteString Iri.Parsing.Text Iri.QuasiQuoter - Iri.Data - Iri.Optics + Iri.Rendering.ByteString + Iri.Rendering.Ptr.Poking + Iri.Rendering.Text + Iri.Rendering.TextBuilder + other-modules: - Iri.Rendering.Text.Internal - Iri.Rendering.TextBuilder.Internal - Iri.Data.Types + Iri.CodePointPredicates.Core + Iri.CodePointPredicates.Rfc3986 + Iri.CodePointPredicates.Rfc3987 Iri.Data.Functions + Iri.Data.Instances.Eq + Iri.Data.Instances.Generic + Iri.Data.Instances.Hashable Iri.Data.Instances.Lift + Iri.Data.Instances.Ord Iri.Data.Instances.Show - Iri.Data.Instances.Eq + Iri.Data.Types + Iri.MonadPlus + Iri.Optics.Basics + Iri.Optics.Defs + Iri.PercentEncoding Iri.Prelude + Iri.Rendering.Ptr.Poke + Iri.Rendering.Text.Internal + Iri.Rendering.TextBuilder.Internal 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, + attoparsec >=0.13 && <0.15, + base >=4.15 && <5, + bytestring >=0.10 && <0.13, + contravariant >=1.4 && <2, + hashable >=1.2 && <2, + ip >=1.7.8 && <2, + iri:punycode, + profunctors >=5.2 && <6, 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, + template-haskell >=2.17 && <3, + text >=2 && <3, + text-builder ^>=1, + th-lift >=0.8 && <0.9, + th-lift-instances >=0.1.20 && <0.2, + unordered-containers >=0.2 && <0.3, + vector >=0.13 && <0.14, 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 + vector-instances >=3.4 && <4, + wide-word >=0.1.6 && <2, -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 +library punycode + hs-source-dirs: punycode + default-language: Haskell2010 build-depends: - -- + base >=4.13 && <5, + bytestring >=0.10 && <0.13, + cereal >=0.5.8.3 && <0.6, + mtl >=2 && <3, + text >=2 && <3, + + exposed-modules: Data.Text.Punycode + other-modules: + Data.Text.Punycode.Decode + Data.Text.Punycode.Encode + Data.Text.Punycode.Shared + +test-suite test + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + 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 + rerebase <2, + tasty >=0.12 && <2, + tasty-hunit >=0.9 && <0.11, diff --git a/library/Iri/CodePointPredicates/Core.hs b/library/Iri/CodePointPredicates/Core.hs --- a/library/Iri/CodePointPredicates/Core.hs +++ b/library/Iri/CodePointPredicates/Core.hs @@ -1,9 +1,7 @@ -module Iri.CodePointPredicates.Core -where - -import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate) -import qualified Data.Vector as A +module Iri.CodePointPredicates.Core where +import qualified Data.Vector.Unboxed as A +import Iri.Prelude hiding (Predicate, inRange, (&&&), (|||)) type Predicate = Int -> Bool @@ -19,11 +17,13 @@ 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 @@ -36,7 +36,7 @@ inCharRange min max = inRange (ord min) (ord max) -{-| 7-bit -} +-- | 7-bit septimal :: Predicate septimal i = i < 0x80 @@ -47,11 +47,13 @@ control :: Predicate control i = - i <= 0x1F || - i == 0x7F + i + <= 0x1F + || i + == 0x7F asciiAlphanumeric :: Predicate asciiAlphanumeric = - inCharRange 'a' 'z' ||| - inCharRange 'A' 'Z' ||| - inCharRange '0' '9' + inCharRange 'a' 'z' + ||| inCharRange 'A' 'Z' + ||| inCharRange '0' '9' diff --git a/library/Iri/CodePointPredicates/Rfc3986.hs b/library/Iri/CodePointPredicates/Rfc3986.hs --- a/library/Iri/CodePointPredicates/Rfc3986.hs +++ b/library/Iri/CodePointPredicates/Rfc3986.hs @@ -1,105 +1,100 @@ -{-| -References: -- - -@ -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 - -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 +-- | +-- References: +-- - +-- +-- @ +-- 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 +-- +-- 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: +import Iri.Prelude hiding (Predicate, inRange, (&&&), (|||)) -@ -unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" -@ --} +-- | +-- Reference: +-- +-- @ +-- unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +-- @ unreserved :: Predicate unreserved = asciiAlphanumeric ||| oneOfChars "-._~" @@ -111,14 +106,16 @@ {-# NOINLINE scheme #-} scheme :: Predicate scheme = - cached $ - asciiAlphanumeric ||| oneOfChars "+.-" + cached + $ asciiAlphanumeric + ||| oneOfChars "+.-" {-# NOINLINE domainLabel #-} domainLabel :: Predicate domainLabel = - cached $ - asciiAlphanumeric ||| oneOfChars "-_~" + cached + $ asciiAlphanumeric + ||| oneOfChars "-_~" {- pchar = unreserved / pct-encoded / sub-delims / ":" / "@" @@ -126,24 +123,26 @@ {-# NOINLINE unencodedPathSegment #-} unencodedPathSegment :: Predicate unencodedPathSegment = - cached $ - unreserved ||| subDelims ||| oneOfChars ":@" - -{-| -Reference: - -@ -query = *( pchar / "/" / "?" ) -@ + cached + $ unreserved + ||| subDelims + ||| oneOfChars ":@" -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. --} +-- | +-- 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) + cached + $ (unencodedPathSegment ||| oneOfChars "/?|[]\"'") + &&& (/= 43) unencodedFragment :: Predicate unencodedFragment = @@ -152,11 +151,14 @@ {-# NOINLINE unencodedQueryComponent #-} unencodedQueryComponent :: Predicate unencodedQueryComponent = - cached $ - unencodedQuery &&& not . oneOfChars "=&;" + cached + $ unencodedQuery + &&& not + . oneOfChars "=&;" {-# NOINLINE unencodedUserInfoComponent #-} unencodedUserInfoComponent :: Predicate unencodedUserInfoComponent = - cached $ - unreserved ||| subDelims + cached + $ unreserved + ||| subDelims diff --git a/library/Iri/CodePointPredicates/Rfc3987.hs b/library/Iri/CodePointPredicates/Rfc3987.hs --- a/library/Iri/CodePointPredicates/Rfc3987.hs +++ b/library/Iri/CodePointPredicates/Rfc3987.hs @@ -1,125 +1,121 @@ -{-| -References: -- - -@ -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 - -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 +-- | +-- References: +-- - +-- +-- @ +-- 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 +-- +-- 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 - +import Iri.Prelude hiding (Predicate, inRange, (&&&), (|||)) scheme :: Predicate scheme = @@ -144,24 +140,22 @@ 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. --} +-- | +-- 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. --} +-- | +-- 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) @@ -183,29 +177,89 @@ -} 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 + 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 + x + >= 0xE000 + && x + <= 0xF8FF + || x + >= 0xF0000 + && x + <= 0xFFFFD + || x + >= 0x100000 + && x + <= 0x10FFFD diff --git a/library/Iri/Data.hs b/library/Iri/Data.hs --- a/library/Iri/Data.hs +++ b/library/Iri/Data.hs @@ -1,19 +1,19 @@ -{-| -References: - -* -* --} +-- | +-- References: +-- +-- * +-- * module Iri.Data -( - module Iri.Data.Types, - module Iri.Data.Functions, -) + ( 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 - +import Iri.Data.Instances.Eq () +import Iri.Data.Instances.Generic () +import Iri.Data.Instances.Hashable () +import Iri.Data.Instances.Lift () +import Iri.Data.Instances.Ord () +import Iri.Data.Instances.Show () +import Iri.Data.Types diff --git a/library/Iri/Data/Functions.hs b/library/Iri/Data/Functions.hs --- a/library/Iri/Data/Functions.hs +++ b/library/Iri/Data/Functions.hs @@ -1,11 +1,9 @@ -module Iri.Data.Functions -where +module Iri.Data.Functions where -import Iri.Prelude import Iri.Data.Types - +import Iri.Prelude -{-| Try to specialize a general IRI to HTTP -} +-- | Try to specialize a general IRI to HTTP httpIriFromIri :: Iri -> Either Text HttpIri httpIriFromIri (Iri (Scheme scheme) hierarchy query fragment) = do @@ -16,10 +14,10 @@ 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") + PresentUserInfo (User _) _ -> Left ("User Info is present") _ -> Left ("Not an authorised hierarchy") -{-| Generalize an HTTP IRI to IRI -} +-- | Generalize an HTTP IRI to IRI iriFromHttpIri :: HttpIri -> Iri iriFromHttpIri (HttpIri (Security secure) host port path query fragment) = Iri scheme hierarchy query fragment diff --git a/library/Iri/Data/Instances/Eq.hs b/library/Iri/Data/Instances/Eq.hs --- a/library/Iri/Data/Instances/Eq.hs +++ b/library/Iri/Data/Instances/Eq.hs @@ -1,9 +1,9 @@ -module Iri.Data.Instances.Eq -where +{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude -import Iri.Data.Types +module Iri.Data.Instances.Eq where +import Iri.Data.Types +import Iri.Prelude deriving instance Eq Iri diff --git a/library/Iri/Data/Instances/Generic.hs b/library/Iri/Data/Instances/Generic.hs new file mode 100644 --- /dev/null +++ b/library/Iri/Data/Instances/Generic.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Iri.Data.Instances.Generic where + +import Iri.Data.Types +import Iri.Prelude + +deriving instance Generic Iri + +deriving instance Generic Scheme + +deriving instance Generic Hierarchy + +deriving instance Generic Authority + +deriving instance Generic UserInfo + +deriving instance Generic User + +deriving instance Generic Password + +deriving instance Generic Host + +deriving instance Generic RegName + +deriving instance Generic DomainLabel + +deriving instance Generic Port + +deriving instance Generic Path + +deriving instance Generic PathSegment + +deriving instance Generic Query + +deriving instance Generic Fragment + +deriving instance Generic HttpIri + +deriving instance Generic Security diff --git a/library/Iri/Data/Instances/Hashable.hs b/library/Iri/Data/Instances/Hashable.hs new file mode 100644 --- /dev/null +++ b/library/Iri/Data/Instances/Hashable.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Iri.Data.Instances.Hashable where + +import Iri.Data.Instances.Eq () +import Iri.Data.Instances.Generic () +import Iri.Data.Types +import Iri.Prelude + +instance Hashable Iri + +instance Hashable Scheme + +instance Hashable Hierarchy + +instance Hashable Authority + +instance Hashable UserInfo + +instance Hashable User + +instance Hashable Password + +instance Hashable Host + +instance Hashable RegName + +instance Hashable DomainLabel + +instance Hashable Port + +instance Hashable Path + +instance Hashable PathSegment + +instance Hashable Query + +instance Hashable Fragment + +instance Hashable HttpIri + +instance Hashable Security diff --git a/library/Iri/Data/Instances/Lift.hs b/library/Iri/Data/Instances/Lift.hs --- a/library/Iri/Data/Instances/Lift.hs +++ b/library/Iri/Data/Instances/Lift.hs @@ -1,41 +1,47 @@ -module Iri.Data.Instances.Lift -where +{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude +module Iri.Data.Instances.Lift where + +import qualified Data.WideWord.Word128 import Iri.Data.Types +import Iri.Prelude 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 +import Language.Haskell.TH.Syntax +import qualified Net.IPv6 -deriveLift ''Query +fmap concat + $ traverse deriveLift + $ [ ''RegName, + ''DomainLabel + ] -deriveLift ''Fragment +instance Lift Host where + lift = \case + NamedHost regName -> + AppE (ConE 'NamedHost) <$> lift regName + IpV4Host ipV4 -> + AppE (ConE 'IpV4Host) <$> $(makeLift ''IPv4) ipV4 + IpV6Host (Net.IPv6.IPv6 word128) -> do + word128Exp <- $(makeLift ''Data.WideWord.Word128.Word128) word128 + pure (AppE (ConE 'IpV6Host) (AppE (ConE 'Net.IPv6.IPv6) word128Exp)) -deriveLift ''HttpIri + liftTyped = + Code . fmap TExp . lift -deriveLift ''Security +fmap concat + $ traverse deriveLift + $ [ ''Authority, + ''Fragment, + ''Hierarchy, + ''HttpIri, + ''Iri, + ''Password, + ''Path, + ''PathSegment, + ''Port, + ''Query, + ''Scheme, + ''Security, + ''User, + ''UserInfo + ] diff --git a/library/Iri/Data/Instances/Ord.hs b/library/Iri/Data/Instances/Ord.hs new file mode 100644 --- /dev/null +++ b/library/Iri/Data/Instances/Ord.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Iri.Data.Instances.Ord where + +import Iri.Data.Instances.Eq () +import Iri.Data.Types +import Iri.Prelude + +deriving instance Ord Iri + +deriving instance Ord Scheme + +deriving instance Ord Hierarchy + +deriving instance Ord Authority + +deriving instance Ord UserInfo + +deriving instance Ord User + +deriving instance Ord Password + +deriving instance Ord Host + +deriving instance Ord RegName + +deriving instance Ord DomainLabel + +deriving instance Ord Port + +deriving instance Ord Path + +deriving instance Ord PathSegment + +deriving instance Ord Query + +deriving instance Ord Fragment + +deriving instance Ord HttpIri + +deriving instance Ord Security diff --git a/library/Iri/Data/Instances/Show.hs b/library/Iri/Data/Instances/Show.hs --- a/library/Iri/Data/Instances/Show.hs +++ b/library/Iri/Data/Instances/Show.hs @@ -1,19 +1,19 @@ -module Iri.Data.Instances.Show -where +{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude +module Iri.Data.Instances.Show where + +import qualified Data.Text as B import Iri.Data.Types +import Iri.Prelude import qualified Iri.Rendering.Text.Internal as A -import qualified Data.Text as B - instance Show Iri where show = - B.unpack . A.iri + mappend "\"" . flip mappend "\"" . B.unpack . A.iri instance Show HttpIri where show = - B.unpack . A.httpIri + mappend "\"" . flip mappend "\"" . B.unpack . A.httpIri deriving instance Show Scheme @@ -44,4 +44,3 @@ deriving instance Show Fragment deriving instance Show Security - diff --git a/library/Iri/Data/Types.hs b/library/Iri/Data/Types.hs --- a/library/Iri/Data/Types.hs +++ b/library/Iri/Data/Types.hs @@ -1,99 +1,83 @@ -{-| -References: - -* -* --} {-# OPTIONS_GHC -funbox-strict-fields #-} -module Iri.Data.Types -where -import Iri.Prelude - - -{-| -Thorough structure of IRI. --} -data Iri = - Iri !Scheme !Hierarchy !Query !Fragment +-- | +-- References: +-- +-- * +-- * +module Iri.Data.Types where -newtype Scheme = - Scheme ByteString +import Iri.Prelude -data Hierarchy = - AuthorisedHierarchy !Authority !Path | - AbsoluteHierarchy !Path | - RelativeHierarchy !Path +-- | +-- Thorough structure of IRI or URI. +data Iri = Iri !Scheme !Hierarchy !Query !Fragment -data Authority = - Authority !UserInfo !Host !Port +newtype Scheme = Scheme ByteString -data UserInfo = - PresentUserInfo !User !Password | - MissingUserInfo +data Hierarchy + = AuthorisedHierarchy !Authority !Path + | AbsoluteHierarchy !Path + | RelativeHierarchy !Path -newtype User = - User Text +data Authority = Authority !UserInfo !Host !Port -data Password = - PresentPassword !Text | - MissingPassword +data UserInfo + = PresentUserInfo !User !Password + | MissingUserInfo -data Host = - NamedHost !RegName | - IpV4Host !IPv4 | - IpV6Host !IPv6 +newtype User = User ByteString -newtype RegName = - RegName (Vector DomainLabel) +data Password + = PresentPassword !ByteString + | MissingPassword -newtype DomainLabel = - DomainLabel Text +data Host + = NamedHost !RegName + | IpV4Host !IPv4 + | IpV6Host !IPv6 -data Port = - PresentPort !Word16 | - MissingPort +newtype RegName = RegName (Vector DomainLabel) -newtype Path = - Path (Vector PathSegment) +data DomainLabel = DomainLabel Text -newtype PathSegment = - PathSegment Text +data Port + = PresentPort !Word16 + | MissingPort -{-| -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. +newtype Path = Path (Vector PathSegment) -See . --} -newtype Query = - Query Text +newtype PathSegment = PathSegment ByteString -newtype Fragment = - Fragment 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 percent-decoded bytes. +-- +-- See . +newtype Query = Query ByteString +newtype Fragment = Fragment ByteString -- * 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. +-- ** HTTP special 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 +-- | +-- 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 URI 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 +newtype Security = Security Bool diff --git a/library/Iri/MonadPlus.hs b/library/Iri/MonadPlus.hs --- a/library/Iri/MonadPlus.hs +++ b/library/Iri/MonadPlus.hs @@ -1,30 +1,43 @@ -module Iri.MonadPlus -where - -import Iri.Prelude hiding (null, length) +module Iri.MonadPlus where +import Iri.Prelude hiding (foldl) +import qualified Ptr.ByteString as ByteString +import qualified Ptr.Poking as Poking {-# INLINE foldl #-} -foldl :: MonadPlus m => (a -> b -> a) -> a -> m b -> m a +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) + ( do + element <- elementParser + loop $! step state element + ) (return state) {-# INLINE foldlM #-} -foldlM :: MonadPlus m => (a -> b -> m a) -> a -> m b -> m a +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))) + ( mplus + ( do + 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 diff --git a/library/Iri/Optics.hs b/library/Iri/Optics.hs --- a/library/Iri/Optics.hs +++ b/library/Iri/Optics.hs @@ -1,103 +1,13 @@ -{-| -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! --} +-- | +-- 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, -) + ( 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 -------------------------- - -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)) +import Iri.Optics.Basics as Basics (Lens, Lens', Prism, Prism', Traversal, Traversal') +import Iri.Optics.Defs as Defs diff --git a/library/Iri/Optics/Basics.hs b/library/Iri/Optics/Basics.hs new file mode 100644 --- /dev/null +++ b/library/Iri/Optics/Basics.hs @@ -0,0 +1,34 @@ +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) diff --git a/library/Iri/Optics/Defs.hs b/library/Iri/Optics/Defs.hs new file mode 100644 --- /dev/null +++ b/library/Iri/Optics/Defs.hs @@ -0,0 +1,74 @@ +module Iri.Optics.Defs where + +import qualified Data.Text.Encoding as Text +import Iri.Data +import Iri.Optics.Basics +import qualified Iri.Parsing.ByteString as B +import qualified Iri.Parsing.Text as D +import Iri.Prelude +import qualified Iri.Rendering.ByteString as A +import qualified Iri.Rendering.Text as C + +-- * 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) diff --git a/library/Iri/Parsing/Attoparsec/ByteString.hs b/library/Iri/Parsing/Attoparsec/ByteString.hs --- a/library/Iri/Parsing/Attoparsec/ByteString.hs +++ b/library/Iri/Parsing/Attoparsec/ByteString.hs @@ -1,33 +1,28 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + module Iri.Parsing.Attoparsec.ByteString -( - uri, - httpUri, -) + ( uri, + httpUri, + regName, + ) 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.Text.Punycode as A 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 Iri.Data 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 Iri.PercentEncoding as I +import Iri.Prelude hiding (foldl, hash) import qualified Net.IPv4 as M import qualified Net.IPv6 as N - +import qualified TextBuilder as J +import qualified VectorBuilder.MonadPlus as E {-# INLINE percent #-} percent :: Parser Word8 @@ -84,34 +79,32 @@ 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 #-} +-- | +-- Parser of a well-formed URI conforming to the RFC3986 or RFC3987 standards. +-- Performs URL- and Punycode-decoding. +{-# INLINEABLE uri #-} uri :: Parser Iri uri = labeled "URI" $ do parsedScheme <- scheme - colon + _ <- 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 #-} +-- | +-- Same as 'uri', but optimized specifially for the case of HTTP URIs. +{-# INLINEABLE 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 "://" + _ <- 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) @@ -145,64 +138,67 @@ {-# INLINE scheme #-} scheme :: Parser Scheme scheme = - labeled "Scheme" $ - fmap Scheme (takeWhile1 (C.scheme . fromIntegral)) + labeled "Scheme" + $ fmap Scheme (takeWhile1 (C.scheme . fromIntegral)) -{-# INLINABLE presentUserInfo #-} +{-# INLINEABLE 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) + 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 + labeled "Host" + $ asum + [ IpV6Host <$> ipV6, + IpV4Host <$> M.parserUtf8, + NamedHost <$> regName + ] -{-# INLINABLE ipV6 #-} +{-# INLINEABLE ipV6 #-} ipV6 :: Parser IPv6 ipV6 = do a <- F.hexadecimal - colon + _ <- colon b <- F.hexadecimal - colon + _ <- colon c <- F.hexadecimal - colon + _ <- colon d <- F.hexadecimal - colon + _ <- 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)) + ( 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 = +{-# INLINE regName #-} +regName :: Parser RegName +regName = 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 domainLabel = @@ -230,19 +226,21 @@ else return (Path segments) where segmentsAreEmpty segments = - S.length segments == 1 && - (case S.unsafeHead segments of PathSegment headSegmentText -> T.null headSegmentText) + S.length segments + == 1 + && (case S.unsafeHead segments of PathSegment headSegment -> K.null headSegment) {-# INLINE pathSegment #-} pathSegment :: Parser PathSegment pathSegment = fmap PathSegment (urlEncodedString (C.unencodedPathSegment . fromIntegral)) -{-# INLINABLE utf8Chunks #-} +{-# INLINEABLE utf8Chunks #-} utf8Chunks :: Parser ByteString -> Parser Text utf8Chunks chunk = - labeled "UTF8 chunks" $ - R.foldlM progress (mempty, mempty, B.streamDecodeUtf8) chunk >>= finish + labeled "UTF8 chunks" + $ R.foldlM progress (mempty, mempty, B.streamDecodeUtf8) chunk + >>= finish where progress (!builder, _, decode) bytes = case unsafeDupablePerformIO (try (evaluate (decode bytes))) of @@ -250,17 +248,20 @@ return (builder <> J.text decodedChunk, undecodedBytes, newDecode) Left (L.DecodeError error _) -> fail (showString "UTF8 decoding: " error) + Left _ -> + fail "Unexpected decoding error" finish (builder, undecodedBytes, _) = if K.null undecodedBytes - then return (J.run builder) + then return (J.toText builder) else fail (showString "UTF8 decoding: Bytes remaining: " (show undecodedBytes)) -{-# INLINABLE urlEncodedString #-} -urlEncodedString :: (Word8 -> Bool) -> Parser Text +{-# INLINEABLE urlEncodedString #-} +urlEncodedString :: (Word8 -> Bool) -> Parser ByteString urlEncodedString unencodedBytesPredicate = - labeled "URL-encoded string" $ - utf8Chunks $ - takeWhile1 unencodedBytesPredicate <|> encoded + labeled "URL-encoded string" + $ R.foldByteString + $ takeWhile1 unencodedBytesPredicate + <|> encoded where encoded = K.singleton <$> percentEncodedByte @@ -269,30 +270,33 @@ percentEncodedByte :: Parser Word8 percentEncodedByte = labeled "Percent-encoded byte" $ do - percent + _ <- percent byte1 <- anyWord8 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) + labeled "Query" + $ (question *> (Query <$> queryOrFragmentBody)) + <|> pure (Query mempty) -{-# INLINABLE fragment #-} +{-# INLINE fragment #-} fragment :: Parser Fragment fragment = - labeled "Fragment" $ - (hash *> (Fragment <$> queryOrFragmentBody)) <|> pure (Fragment mempty) + labeled "Fragment" + $ (hash *> (Fragment <$> queryOrFragmentBody)) + <|> pure (Fragment mempty) -{-| -The stuff after the question or the hash mark. --} -{-# INLINABLE queryOrFragmentBody #-} -queryOrFragmentBody :: Parser Text +-- | +-- The stuff after the question or the hash mark. +{-# INLINEABLE queryOrFragmentBody #-} +queryOrFragmentBody :: Parser ByteString queryOrFragmentBody = - utf8Chunks $ - takeWhile1 (C.unencodedQuery . fromIntegral) <|> - " " <$ plus <|> - K.singleton <$> percentEncodedByte + R.foldByteString + $ takeWhile1 (C.unencodedQuery . fromIntegral) + <|> " " + <$ plus + <|> K.singleton + <$> percentEncodedByte diff --git a/library/Iri/Parsing/Attoparsec/Text.hs b/library/Iri/Parsing/Attoparsec/Text.hs --- a/library/Iri/Parsing/Attoparsec/Text.hs +++ b/library/Iri/Parsing/Attoparsec/Text.hs @@ -1,56 +1,65 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + module Iri.Parsing.Attoparsec.Text -( - iri, - httpIri, -) + ( iri, + httpIri, + hierarchy, + scheme, + host, + regName, + domainLabel, + port, + path, + pathSegment, + query, + fragment, + ) 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 Iri.Data import qualified Iri.MonadPlus as R -import qualified Text.Builder as J +import Iri.Prelude import qualified Net.IPv4 as M import qualified Net.IPv6 as N - +import qualified Ptr.ByteString as ByteString +import qualified Ptr.Poking as Poking +import qualified TextBuilder as J +import qualified VectorBuilder.MonadPlus as E {-# 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 #-} +-- | +-- Parser of a well-formed IRI conforming to the RFC3987 standard into 'Iri'. +-- Performs URL-decoding. +{-# INLINEABLE iri #-} iri :: Parser Iri iri = labeled "IRI" $ do parsedScheme <- scheme - char ':' + _ <- 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 #-} +-- | +-- Same as 'iri', but optimized specifially for the case of HTTP IRIs. +{-# INLINEABLE httpIri #-} httpIri :: Parser HttpIri httpIri = labeled "HTTP IRI" $ do - asciiCI "http" - secure <- satisfy (\ x -> x == 's' || x == 'S') $> True <|> pure False - string "://" + _ <- 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) @@ -84,43 +93,46 @@ {-# INLINE scheme #-} scheme :: Parser Scheme scheme = - labeled "Scheme" $ - fmap (Scheme . B.encodeUtf8) (takeWhile1 (C.scheme . ord)) + labeled "Scheme" + $ fmap (Scheme . B.encodeUtf8) (takeWhile1 (C.scheme . ord)) -{-# INLINABLE presentUserInfo #-} +{-# INLINEABLE 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) + 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 + labeled "Host" + $ IpV6Host + <$> N.parser + <|> IpV4Host + <$> M.parser + <|> NamedHost + <$> regName -{-# INLINE domainName #-} -domainName :: Parser RegName -domainName = +{-# INLINE regName #-} +regName :: Parser RegName +regName = fmap RegName (E.sepBy1 domainLabel (char '.')) -{-| -Domain label with Punycode decoding applied. --} +-- | +-- Domain label with Punycode decoding applied. {-# INLINE domainLabel #-} domainLabel :: Parser DomainLabel domainLabel = - labeled "Domain label" $ - DomainLabel <$> takeWhile1 (C.unencodedRegName . ord) + labeled "Domain label" + $ DomainLabel + <$> takeWhile1 (C.unencodedRegName . ord) {-# INLINE port #-} port :: Parser Word16 @@ -137,25 +149,36 @@ else return (Path segments) where segmentsAreEmpty segments = - S.length segments == 1 && - (case S.unsafeHead segments of PathSegment headSegmentText -> T.null headSegmentText) + S.length segments + == 1 + && (case S.unsafeHead segments of PathSegment headSegment -> K.null headSegment) {-# INLINE pathSegment #-} pathSegment :: Parser PathSegment pathSegment = fmap PathSegment (urlEncodedComponent (C.unencodedPathSegment . ord)) -{-# INLINABLE urlEncodedComponent #-} -urlEncodedComponent :: (Char -> Bool) -> Parser Text +{-# INLINEABLE urlEncodedComponent #-} +urlEncodedComponent :: (Char -> Bool) -> Parser ByteString urlEncodedComponent unencodedCharPredicate = - labeled "URL-encoded component" $ - fmap J.run $ - R.foldl mappend mempty $ - (J.text <$> takeWhile1 unencodedCharPredicate) <|> urlEncodedSequence + labeled "URL-encoded component" + $ fmap ByteString.poking + $ R.fold + $ (Poking.bytes . B.encodeUtf8 <$> takeWhile1 unencodedCharPredicate) + <|> (Poking.word8 <$> urlEncodedByte) -{-# INLINABLE urlEncodedSequence #-} -urlEncodedSequence :: Parser J.Builder -urlEncodedSequence = +{-# INLINEABLE urlEncodedComponentText #-} +urlEncodedComponentText :: (Char -> Bool) -> Parser Text +urlEncodedComponentText unencodedCharPredicate = + labeled "URL-encoded component" + $ fmap J.toText + $ R.foldl mappend mempty + $ (J.text <$> takeWhile1 unencodedCharPredicate) + <|> urlEncodedSequenceTextBuilder + +{-# INLINEABLE urlEncodedSequenceTextBuilder #-} +urlEncodedSequenceTextBuilder :: Parser J.TextBuilder +urlEncodedSequenceTextBuilder = labeled "URL-encoded sequence" $ do start <- progress (mempty, mempty, B.streamDecodeUtf8) =<< urlEncodedByte R.foldlM progress (start) urlEncodedByte >>= finish @@ -166,6 +189,8 @@ return (builder <> J.text decodedChunk, undecodedBytes, newDecode) Left (L.DecodeError error _) -> fail (showString "UTF8 decoding: " error) + Left _ -> + fail "Unexpected decoding error" finish (builder, undecodedBytes, _) = if K.null undecodedBytes then return builder @@ -175,7 +200,7 @@ urlEncodedByte :: Parser Word8 urlEncodedByte = do - char '%' + _ <- char '%' digit1 <- fromIntegral <$> hexadecimalDigit digit2 <- fromIntegral <$> hexadecimalDigit return (shiftL digit1 4 .|. digit2) @@ -188,29 +213,31 @@ 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) + else + if x >= 65 && x < 71 + then return (x - 55) + else + if x >= 97 && x < 103 + then return (x - 87) + else fail ("Not a hexadecimal digit: " <> show c) -{-# INLINABLE query #-} +{-# INLINEABLE query #-} query :: Parser Query query = - labeled "Query" $ - (char '?' *> queryBody) <|> pure (Query mempty) + labeled "Query" + $ (char '?' *> queryBody) + <|> pure (Query mempty) -{-| -The stuff after the question mark. --} -{-# INLINABLE queryBody #-} +-- | +-- The stuff after the question mark. +{-# INLINEABLE queryBody #-} queryBody :: Parser Query queryBody = fmap Query (urlEncodedComponent (C.unencodedQuery . ord)) -{-# INLINABLE fragment #-} +{-# INLINEABLE fragment #-} fragment :: Parser Fragment fragment = - labeled "Fragment" $ - (char '#' *> (Fragment <$> urlEncodedComponent (C.unencodedFragment . ord))) <|> - pure (Fragment mempty) + labeled "Fragment" + $ (char '#' *> (Fragment <$> urlEncodedComponent (C.unencodedFragment . ord))) + <|> pure (Fragment mempty) diff --git a/library/Iri/Parsing/ByteString.hs b/library/Iri/Parsing/ByteString.hs --- a/library/Iri/Parsing/ByteString.hs +++ b/library/Iri/Parsing/ByteString.hs @@ -1,29 +1,55 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + module Iri.Parsing.ByteString -( - uri, - httpUri, -) + ( uri, + httpUri, + regName, + uriQuery, + ) where -import Iri.Prelude +import qualified Data.Attoparsec.ByteString as B +import qualified Data.ByteString as ByteString import Iri.Data import qualified Iri.Parsing.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString as B +import Iri.Prelude +parser :: B.Parser a -> ByteString -> Either Text a +parser parser = + either (Left . fromString) Right + . B.parseOnly (parser <* B.endOfInput) -{-| -Parser of a well-formed URI conforming to the RFC3986 standard into IRI. -Performs URL- and Punycode-decoding. --} +-- | +-- 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) + parser A.uri -{-| -Same as 'uri', but optimized specifially for the case of HTTP URIs. --} +-- | +-- 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) + parser A.httpUri + +-- | +-- Domain name parser. +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 -> Either Text Query +uriQuery x = + case ByteString.break (== 63) x of + (_, questionAndAfterQuestion) -> case ByteString.uncons questionAndAfterQuestion of + Just (_, afterQuestion) -> case ByteString.break (== 35) afterQuestion of + (beforeHash, _) -> Right (Query beforeHash) + Nothing -> + Left "Does not start with a question mark" + +-- | +-- 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 diff --git a/library/Iri/Parsing/Text.hs b/library/Iri/Parsing/Text.hs --- a/library/Iri/Parsing/Text.hs +++ b/library/Iri/Parsing/Text.hs @@ -1,29 +1,66 @@ module Iri.Parsing.Text -( - iri, - httpIri, -) + ( iri, + httpIri, + hierarchy, + scheme, + host, + regName, + domainLabel, + port, + path, + pathSegment, + query, + fragment, + ) where -import Iri.Prelude +import qualified Data.Attoparsec.Text as B import Iri.Data import qualified Iri.Parsing.Attoparsec.Text as A -import qualified Data.Attoparsec.Text as B +import Iri.Prelude +fromParser :: B.Parser a -> Text -> Either Text a +fromParser parser = + either (Left . fromString) Right + . B.parseOnly (parser <* B.endOfInput) -{-| -Parser of a well-formed IRI conforming to the RFC3987 standard into IRI. -Performs URL-decoding. --} +-- | +-- 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) +iri = fromParser A.iri -{-| -Same as 'iri', but optimized specifially for the case of HTTP IRIs. --} +-- | +-- 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) +httpIri = fromParser A.httpIri + +hierarchy :: Text -> Either Text Hierarchy +hierarchy = fromParser A.hierarchy + +scheme :: Text -> Either Text Scheme +scheme = fromParser A.scheme + +host :: Text -> Either Text Host +host = fromParser A.host + +regName :: Text -> Either Text RegName +regName = fromParser A.regName + +domainLabel :: Text -> Either Text DomainLabel +domainLabel = fromParser A.domainLabel + +port :: Text -> Either Text Word16 +port = fromParser A.port + +path :: Text -> Either Text Path +path = fromParser A.path + +pathSegment :: Text -> Either Text PathSegment +pathSegment = fromParser A.pathSegment + +query :: Text -> Either Text Query +query = fromParser A.query + +fragment :: Text -> Either Text Fragment +fragment = fromParser A.fragment diff --git a/library/Iri/PercentEncoding.hs b/library/Iri/PercentEncoding.hs --- a/library/Iri/PercentEncoding.hs +++ b/library/Iri/PercentEncoding.hs @@ -2,17 +2,18 @@ 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 + 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 diff --git a/library/Iri/Prelude.hs b/library/Iri/Prelude.hs --- a/library/Iri/Prelude.hs +++ b/library/Iri/Prelude.hs @@ -1,64 +1,82 @@ +{-# OPTIONS_GHC -Wno-dodgy-imports #-} + module Iri.Prelude -( - module Exports, -) + ( 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 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 (forM, forM_, mapM, mapM_, msum, sequence, sequence_) +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +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 hiding (unzip) import Data.Functor.Contravariant as Exports import Data.Functor.Contravariant.Divisible as Exports - --- profunctors -------------------------- -import Data.Profunctor.Unsafe as Exports +import Data.Functor.Identity as Exports +import Data.HashMap.Strict as Exports (HashMap) +import Data.Hashable as Exports +import Data.IORef as Exports +import Data.Int as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (First (..), Last (..)) +import Data.Ord as Exports import Data.Profunctor.Choice as Exports import Data.Profunctor.Strong as Exports - --- semigroups -------------------------- +import Data.Profunctor.Unsafe as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.STRef as Exports import Data.Semigroup as Exports - --- bytestring -------------------------- -import Data.ByteString as Exports (ByteString) - --- text -------------------------- +import Data.String as Exports import Data.Text as Exports (Text) - --- ip -------------------------- +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Vector as Exports (Vector) +import Data.Vector.Instances () +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 (alignment, sizeOf) +import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (groupWith, inline, lazy, sortWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception as Exports +import Instances.TH.Lift () 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 +import Numeric as Exports +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.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) +import Unsafe.Coerce as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) diff --git a/library/Iri/QuasiQuoter.hs b/library/Iri/QuasiQuoter.hs --- a/library/Iri/QuasiQuoter.hs +++ b/library/Iri/QuasiQuoter.hs @@ -1,19 +1,18 @@ module Iri.QuasiQuoter -( - uri, - httpUri, -) + ( uri, + httpUri, + iri, + httpIri, + ) 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.ByteString as A import qualified Iri.Parsing.Attoparsec.Text as D - +import Iri.Prelude hiding (exp) +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax exp :: (String -> Q Exp) -> QuasiQuoter exp exp = @@ -22,42 +21,38 @@ unsupported _ = 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 - Left error -> fail (showString "URI parsing: " error) + exp $ \string -> + case B.parseOnly (A.uri <* B.endOfInput) (fromString string) of + 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 - Left error -> fail (showString "HTTP URI parsing: " error) + exp $ \string -> + case B.parseOnly (A.httpUri <* B.endOfInput) (fromString string) of + 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 = - exp $ \ string -> - case C.parseOnly (D.iri <* C.endOfInput) (fromString string) of - Right iri -> lift iri - Left error -> fail (showString "IRI parsing: " error) + 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' literal from IRI representation. 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) + exp $ \string -> + case C.parseOnly (D.httpIri <* C.endOfInput) (fromString string) of + Right iri -> lift iri + Left error -> fail (showString "HTTP IRI parsing: " error) diff --git a/library/Iri/Rendering/ByteString.hs b/library/Iri/Rendering/ByteString.hs --- a/library/Iri/Rendering/ByteString.hs +++ b/library/Iri/Rendering/ByteString.hs @@ -1,18 +1,16 @@ -module Iri.Rendering.ByteString -where +module Iri.Rendering.ByteString where -import Iri.Prelude import Iri.Data +import Iri.Prelude import qualified Iri.Rendering.Ptr.Poking as A import qualified Ptr.ByteString as F - -{-| Render as URI ASCII bytes -} +-- | Render as URI ASCII bytes uri :: Iri -> ByteString uri = F.poking . A.uri -{-| Render as URI ASCII bytes -} +-- | Render as URI ASCII bytes httpUri :: HttpIri -> ByteString httpUri = F.poking . A.httpUri diff --git a/library/Iri/Rendering/Poke.hs b/library/Iri/Rendering/Poke.hs deleted file mode 100644 --- a/library/Iri/Rendering/Poke.hs +++ /dev/null @@ -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) diff --git a/library/Iri/Rendering/Ptr/Poke.hs b/library/Iri/Rendering/Ptr/Poke.hs new file mode 100644 --- /dev/null +++ b/library/Iri/Rendering/Ptr/Poke.hs @@ -0,0 +1,12 @@ +module Iri.Rendering.Ptr.Poke where + +import Iri.Prelude +import Ptr.Poke + +{-# NOINLINE urlEncodedByte #-} +urlEncodedByte :: Poke Word8 +urlEncodedByte = + divide + (\byte -> ('%', byte)) + asciiChar + (divide (flip divMod 16) asciiHexDigit asciiHexDigit) diff --git a/library/Iri/Rendering/Ptr/Poking.hs b/library/Iri/Rendering/Ptr/Poking.hs --- a/library/Iri/Rendering/Ptr/Poking.hs +++ b/library/Iri/Rendering/Ptr/Poking.hs @@ -1,52 +1,52 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + module Iri.Rendering.Ptr.Poking -( - uri, - httpUri, - scheme, - host, - path, - query, -) + ( uri, + httpUri, + scheme, + host, + path, + query, + ) where -import Iri.Prelude hiding (null, poke) -import Iri.Data -import Ptr.Poking +import qualified Data.ByteString as ByteString +import qualified Data.Text as C 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 Iri.Data +import Iri.Prelude hiding (null, poke) +import qualified Iri.Rendering.Ptr.Poke as L import qualified Iri.Utf8CodePoint as K -import qualified Iri.Rendering.Poke as L - +import qualified Iri.Vector as F +import qualified Net.IPv4 as D +import qualified Net.IPv6 as E +import Ptr.Poking uri :: Iri -> Poking uri (Iri schemeValue hierarchyValue queryValue fragmentValue) = - scheme schemeValue <> - asciiChar ':' <> - hierarchy hierarchyValue <> - (prependIfNotNull - (asciiChar '?') - (query queryValue)) <> - (prependIfNotNull - (asciiChar '#') - (fragment 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) + (if secure then "https://" else "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) = @@ -54,7 +54,7 @@ hierarchy :: Hierarchy -> Poking hierarchy = - \ case + \case AuthorisedHierarchy authorityValue pathValue -> bytes "//" <> authority authorityValue <> prependIfNotNull (asciiChar '/') (path pathValue) AbsoluteHierarchy pathValue -> @@ -64,25 +64,25 @@ authority :: Authority -> Poking authority (Authority userInfoValue hostValue portValue) = - appendIfNotNull (asciiChar '@') (userInfo userInfoValue) <> - host hostValue <> - prependIfNotNull (asciiChar ':') (port portValue) + appendIfNotNull (asciiChar '@') (userInfo userInfoValue) + <> host hostValue + <> prependIfNotNull (asciiChar ':') (port portValue) userInfo :: UserInfo -> Poking userInfo = - \ case + \case PresentUserInfo (User user) password -> case password of PresentPassword password -> userInfoComponent user <> asciiChar ':' <> userInfoComponent password MissingPassword -> userInfoComponent user MissingUserInfo -> mempty -userInfoComponent :: Text -> Poking +userInfoComponent :: ByteString -> Poking userInfoComponent = - urlEncodedText I.unencodedUserInfoComponent + urlEncodedBytes I.unencodedUserInfoComponent host :: Host -> Poking host = - \ case + \case NamedHost value -> domainName value IpV4Host value -> ipV4 value IpV6Host value -> ipV6 value @@ -107,7 +107,7 @@ port :: Port -> Poking port = - \ case + \case PresentPort value -> asciiIntegral value MissingPort -> mempty @@ -117,28 +117,38 @@ 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 -{-| Apply URL-encoding to text -} +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 urlEncodedText unencodedPredicate = - C.foldl' (\ poking -> mappend poking . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty + 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) + 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 = diff --git a/library/Iri/Rendering/Text.hs b/library/Iri/Rendering/Text.hs --- a/library/Iri/Rendering/Text.hs +++ b/library/Iri/Rendering/Text.hs @@ -1,8 +1,6 @@ module Iri.Rendering.Text -( - module Iri.Rendering.Text.Internal, -) + ( module Iri.Rendering.Text.Internal, + ) where import Iri.Rendering.Text.Internal -import Iri.Data diff --git a/library/Iri/Rendering/Text/Internal.hs b/library/Iri/Rendering/Text/Internal.hs --- a/library/Iri/Rendering/Text/Internal.hs +++ b/library/Iri/Rendering/Text/Internal.hs @@ -1,18 +1,56 @@ -module Iri.Rendering.Text.Internal -where +module Iri.Rendering.Text.Internal where -import Iri.Prelude import Iri.Data.Types +import Iri.Prelude import qualified Iri.Rendering.TextBuilder.Internal as A -import qualified Text.Builder as B - +import qualified TextBuilder as B -{-| Render as a Unicode IRI text -} +-- | Render as a Unicode IRI text iri :: Iri -> Text -iri = - B.run . A.iri +iri = B.toText . A.iri -{-| Render as a Unicode IRI text -} +-- | Render as a Unicode IRI text httpIri :: HttpIri -> Text -httpIri = - B.run . A.httpIri +httpIri = B.toText . A.httpIri + +scheme :: Scheme -> Text +scheme = B.toText . A.scheme + +hierarchy :: Hierarchy -> Text +hierarchy = B.toText . A.hierarchy + +authority :: Authority -> Text +authority = B.toText . A.authority + +userInfo :: UserInfo -> Text +userInfo = B.toText . A.userInfo + +host :: Host -> Text +host = B.toText . A.host + +regName :: RegName -> Text +regName = B.toText . A.regName + +domainLabel :: DomainLabel -> Text +domainLabel = B.toText . A.domainLabel + +ipV4 :: IPv4 -> Text +ipV4 = B.toText . A.ipV4 + +ipV6 :: IPv6 -> Text +ipV6 = B.toText . A.ipV6 + +port :: Port -> Text +port = B.toText . A.port + +path :: Path -> Text +path = B.toText . A.path + +pathSegment :: PathSegment -> Text +pathSegment = B.toText . A.pathSegment + +query :: Query -> Text +query = B.toText . A.query + +fragment :: Fragment -> Text +fragment = B.toText . A.fragment diff --git a/library/Iri/Rendering/TextBuilder.hs b/library/Iri/Rendering/TextBuilder.hs --- a/library/Iri/Rendering/TextBuilder.hs +++ b/library/Iri/Rendering/TextBuilder.hs @@ -1,8 +1,6 @@ module Iri.Rendering.TextBuilder -( - module Iri.Rendering.TextBuilder.Internal, -) + ( module Iri.Rendering.TextBuilder.Internal, + ) where import Iri.Rendering.TextBuilder.Internal -import Iri.Data.Types diff --git a/library/Iri/Rendering/TextBuilder/Internal.hs b/library/Iri/Rendering/TextBuilder/Internal.hs --- a/library/Iri/Rendering/TextBuilder/Internal.hs +++ b/library/Iri/Rendering/TextBuilder/Internal.hs @@ -1,55 +1,68 @@ module Iri.Rendering.TextBuilder.Internal -( - iri, - httpIri, -) + ( iri, + httpIri, + scheme, + hierarchy, + authority, + userInfo, + host, + regName, + domainLabel, + ipV4, + ipV6, + port, + path, + pathSegment, + query, + fragment, + ) where -import Iri.Prelude hiding (null) -import Iri.Data.Types -import Text.Builder +import qualified Data.ByteString as ByteString +import qualified Data.Text as C 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 Iri.CodePointPredicates.Core as CorePredicates +import qualified Iri.CodePointPredicates.Rfc3986 as Rfc3986Predicates +import qualified Iri.CodePointPredicates.Rfc3987 as Rfc3987Predicates +import Iri.Data.Types +import Iri.Prelude hiding (null) +import qualified Iri.Utf8CodePoint as K +import qualified Iri.Vector as F 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 - +import TextBuilder -iri :: Iri -> Builder +iri :: Iri -> TextBuilder iri (Iri schemeValue hierarchyValue queryValue fragmentValue) = - scheme schemeValue <> - char ':' <> - hierarchy hierarchyValue <> - (prependIfNotNull - (char '?') - (query queryValue)) <> - (prependIfNotNull - (char '#') - (fragment fragmentValue)) + scheme schemeValue + <> char ':' + <> hierarchy hierarchyValue + <> ( prependIfNotNull + (char '?') + (query queryValue) + ) + <> ( prependIfNotNull + (char '#') + (fragment fragmentValue) + ) -httpIri :: HttpIri -> Builder +httpIri :: HttpIri -> TextBuilder 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) + (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 -> TextBuilder scheme (Scheme bytes) = text (A.decodeUtf8With A.lenientDecode bytes) -hierarchy :: Hierarchy -> Builder +hierarchy :: Hierarchy -> TextBuilder hierarchy = - \ case + \case AuthorisedHierarchy authorityValue pathValue -> string "//" <> authority authorityValue <> prependIfNotNull (char '/') (path pathValue) AbsoluteHierarchy pathValue -> @@ -57,99 +70,115 @@ RelativeHierarchy pathValue -> path pathValue -authority :: Authority -> Builder +authority :: Authority -> TextBuilder authority (Authority userInfoValue hostValue portValue) = - appendIfNotNull (char '@') (userInfo userInfoValue) <> - host hostValue <> - prependIfNotNull (char ':') (port portValue) + appendIfNotNull (char '@') (userInfo userInfoValue) + <> host hostValue + <> prependIfNotNull (char ':') (port portValue) -userInfo :: UserInfo -> Builder +userInfo :: UserInfo -> TextBuilder userInfo = - \ case + \case PresentUserInfo (User user) password -> case password of - PresentPassword password -> userInfoComponent user <> char ':' <> userInfoComponent password + PresentPassword password -> userInfoComponent user <> char ':' <> userInfoComponent password MissingPassword -> userInfoComponent user MissingUserInfo -> mempty -userInfoComponent :: Text -> Builder +userInfoComponent :: ByteString -> TextBuilder userInfoComponent = - urlEncodedText I.unencodedUserInfoComponent + urlEncodedBytesOrText Rfc3987Predicates.unencodedUserInfoComponent Rfc3986Predicates.unencodedUserInfoComponent -host :: Host -> Builder +host :: Host -> TextBuilder host = - \ case - NamedHost value -> domainName value + \case + NamedHost value -> regName value IpV4Host value -> ipV4 value IpV6Host value -> ipV6 value -domainName :: RegName -> Builder -domainName (RegName vector) = +regName :: RegName -> TextBuilder +regName (RegName vector) = F.intercalate domainLabel (char '.') vector -domainLabel :: DomainLabel -> Builder -domainLabel (DomainLabel value) = - text value +domainLabel :: DomainLabel -> TextBuilder +domainLabel (DomainLabel x) = + text x -ipV4 :: IPv4 -> Builder +ipV4 :: IPv4 -> TextBuilder ipV4 = text . D.encode -ipV6 :: IPv6 -> Builder +ipV6 :: IPv6 -> TextBuilder ipV6 = text . E.encode -port :: Port -> Builder +port :: Port -> TextBuilder port = - \ case - PresentPort value -> unsignedDecimal value + \case + PresentPort value -> decimal value MissingPort -> mempty -path :: Path -> Builder +path :: Path -> TextBuilder path (Path pathSegmentVector) = F.intercalate pathSegment (char '/') pathSegmentVector -pathSegment :: PathSegment -> Builder +pathSegment :: PathSegment -> TextBuilder pathSegment (PathSegment value) = - urlEncodedText I.unencodedPathSegment value + urlEncodedBytesOrText Rfc3987Predicates.unencodedPathSegment Rfc3986Predicates.unencodedPathSegment value -query :: Query -> Builder +query :: Query -> TextBuilder query (Query value) = - urlEncodedText I.unencodedQuery value + urlEncodedBytesOrText Rfc3987Predicates.unencodedQuery Rfc3986Predicates.unencodedQuery value -fragment :: Fragment -> Builder +fragment :: Fragment -> TextBuilder fragment (Fragment value) = - urlEncodedText I.unencodedFragment value + urlEncodedBytesOrText Rfc3987Predicates.unencodedFragment Rfc3986Predicates.unencodedFragment value -{-| Apply URL-encoding to text -} -urlEncodedText :: I.Predicate -> Text -> Builder +urlEncodedBytesOrText :: CorePredicates.Predicate -> CorePredicates.Predicate -> ByteString -> TextBuilder +urlEncodedBytesOrText unencodedPredicate1 unencodedPredicate2 bytes = + case A.decodeUtf8' bytes of + Right text -> urlEncodedText unencodedPredicate1 text + Left _ -> urlEncodedBytes unencodedPredicate2 bytes + +-- | Apply URL-encoding to text +urlEncodedBytes :: CorePredicates.Predicate -> ByteString -> TextBuilder +urlEncodedBytes unencodedPredicate = + ByteString.foldl' + ( \builder -> + mappend builder . \byte -> + if unencodedPredicate (fromIntegral byte) + then unicodeCodepoint (fromIntegral byte) + else urlEncodedByte byte + ) + mempty + +-- | Apply URL-encoding to text +urlEncodedText :: CorePredicates.Predicate -> Text -> TextBuilder urlEncodedText unencodedPredicate = - C.foldl' (\ builder -> mappend builder . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty + C.foldl' (\builder -> mappend builder . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty -urlEncodedUnicodeCodePoint :: I.Predicate -> Int -> Builder +urlEncodedUnicodeCodePoint :: CorePredicates.Predicate -> Int -> TextBuilder urlEncodedUnicodeCodePoint unencodedPredicate codePoint = if unencodedPredicate codePoint - then - unicodeCodePoint 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) + 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 +urlEncodedByte :: Word8 -> TextBuilder +urlEncodedByte x = char '%' <> hexadecimal x -prependIfNotNull :: Builder -> Builder -> Builder +prependIfNotNull :: TextBuilder -> TextBuilder -> TextBuilder prependIfNotNull prepended it = - if null it + if isEmpty it then mempty else prepended <> it -appendIfNotNull :: Builder -> Builder -> Builder +appendIfNotNull :: TextBuilder -> TextBuilder -> TextBuilder appendIfNotNull appended it = - if null it + if isEmpty it then mempty else it <> appended diff --git a/library/Iri/Utf8CodePoint.hs b/library/Iri/Utf8CodePoint.hs --- a/library/Iri/Utf8CodePoint.hs +++ b/library/Iri/Utf8CodePoint.hs @@ -1,14 +1,11 @@ -{- | -Utilities for the UTF-8 encoding. --} +-- | +-- Utilities for the UTF-8 encoding. module Iri.Utf8CodePoint where import Iri.Prelude - -{-| -Church encoding of a UTF8-encoded character. --} +-- | +-- Church encoding of a UTF8-encoded character. type Utf8CodePoint = forall a. (Word8 -> a) -> @@ -19,31 +16,30 @@ {-# INLINE char #-} char :: Char -> Utf8CodePoint -char = - unicodeCodePoint . ord +char a = + unicodeCodePoint (ord a) {-# INLINE unicodeCodePoint #-} unicodeCodePoint :: Int -> Utf8CodePoint unicodeCodePoint x f1 f2 f3 f4 = if x <= 0x7F - then - f1 (fromIntegral x) - else + then f1 (fromIntegral x) + else if x <= 0x07FF then f2 - (fromIntegral ((x `shiftR` 6) + 0xC0)) - (fromIntegral ((x .&. 0x3F) + 0x80)) + (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) + (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) + (fromIntegral (x `shiftR` 18) + 0xF0) + (fromIntegral ((x `shiftR` 12) .&. 0x3F) + 0x80) + (fromIntegral ((x `shiftR` 6) .&. 0x3F) + 0x80) + (fromIntegral (x .&. 0x3F) + 0x80) diff --git a/library/Iri/Vector.hs b/library/Iri/Vector.hs --- a/library/Iri/Vector.hs +++ b/library/Iri/Vector.hs @@ -1,12 +1,10 @@ -module Iri.Vector -where +module Iri.Vector where -import Iri.Prelude hiding (null, length) import Data.Vector - +import Iri.Prelude hiding (length, null) {-# INLINE intercalate #-} -intercalate :: (Semigroup monoid, Monoid monoid) => (element -> monoid) -> monoid -> Vector element -> monoid +intercalate :: (Monoid monoid) => (element -> monoid) -> monoid -> Vector element -> monoid intercalate project separator vector = if null vector then mempty diff --git a/punycode/Data/Text/Punycode.hs b/punycode/Data/Text/Punycode.hs new file mode 100644 --- /dev/null +++ b/punycode/Data/Text/Punycode.hs @@ -0,0 +1,4 @@ +module Data.Text.Punycode (encode, PunycodeDecodeException (..), decode) where + +import Data.Text.Punycode.Decode (PunycodeDecodeException (..), decode) +import Data.Text.Punycode.Encode (encode) diff --git a/punycode/Data/Text/Punycode/Decode.hs b/punycode/Data/Text/Punycode/Decode.hs new file mode 100644 --- /dev/null +++ b/punycode/Data/Text/Punycode/Decode.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.Text.Punycode.Decode (PunycodeDecodeException (..), decode) where + +import Control.Exception.Base +import qualified Data.ByteString as BS +import Data.Char +import Data.Serialize hiding (decode) +import qualified Data.Text as T +import Data.Text.Punycode.Shared +import Data.Typeable +import Data.Word + +data PunycodeDecodeException + = GenericDecodeException + | InternalStringTooShort + | InputTooShort + | RightOfHyphenShouldBeAlphanumeric + | LeftOfHyphenShouldBeBasic + | CantStartWithDash + | InvalidCodePoint + deriving (Eq, Show, Typeable) + +instance Exception PunycodeDecodeException + +-- | Decode a string into its unicode form +decode :: BS.ByteString -> Either PunycodeDecodeException T.Text +decode input + | input == BS.pack [45, 45] = Right $ T.pack "-" + | not (BS.null input) && BS.length (BS.filter (== 45) input) == 1 && BS.head input == 45 = Left CantStartWithDash + | T.any (not . isExtendedBasic) before = Left LeftOfHyphenShouldBeBasic + | otherwise = case runGet (inner2 initial_n 0 initial_bias before) after of + Right out -> out + Left _ -> Left InputTooShort + where + (before, after) + | BS.any f input = (T.pack $ map (chr . fromIntegral) $ BS.unpack $ BS.init b1, a1) + | otherwise = (T.empty, input) + f = (== (fromIntegral $ ord '-')) + (b1, a1) = BS.breakEnd f input + +inner2 :: Int -> Int -> Int -> T.Text -> Get (Either PunycodeDecodeException T.Text) +inner2 n oldi bias output = do + b <- isEmpty + helper b + where + helper False = do + i <- inner base 1 oldi bias + helper' i + where + helper' Nothing = return $ Left RightOfHyphenShouldBeAlphanumeric + helper' (Just i) = case output' of + Right output'' -> inner2 n' (i' + 1) bias' output'' + Left err -> return $ Left err + where + bias' = adapt (i - oldi) (T.length output + 1) (oldi == 0) + n' = n + i `div` (T.length output + 1) + i' = i `mod` (T.length output + 1) + output' = insertInto output n' i' + helper True = return $ Right output + +inner :: Int -> Int -> Int -> Int -> Get (Maybe Int) +inner k w i bias = do + word8 <- getWord8 + helper $ word8ToDigit word8 + where + helper Nothing = return Nothing + helper (Just digit) + | digit < t = return $ Just i' + | otherwise = inner (k + base) w' i' bias + where + w' = w * (base - t) + i' = i + digit * w + t + | k <= bias + tmin = tmin + | k >= bias + tmax = tmax + | otherwise = k - bias + +insertInto :: T.Text -> Int -> Int -> Either PunycodeDecodeException T.Text +insertInto input n i + | T.length input < i = Left InternalStringTooShort + | otherwise = case n' of + Just n'' -> Right $ T.concat [T.take i input, T.singleton n'', T.drop i input] + Nothing -> Left InvalidCodePoint + where + n' = safeChr n + +safeChr :: Int -> Maybe Char +safeChr x + | x >= 0 && x <= fromEnum (maxBound :: Char) = Just $ chr x + | otherwise = Nothing + +word8ToDigit :: Word8 -> Maybe Int +word8ToDigit = helper . fromIntegral + where + helper word8 + | word8 >= ord 'a' && word8 <= ord 'z' = Just $ word8 - (ord 'a') + | word8 >= ord 'A' && word8 <= ord 'Z' = Just $ word8 - (ord 'A') + | word8 >= ord '0' && word8 <= ord '9' = Just $ 26 + word8 - (ord '0') + | otherwise = Nothing + +isExtendedBasic :: Char -> Bool +isExtendedBasic x + | isBasic x = True + | ord x == 128 = True + | otherwise = False diff --git a/punycode/Data/Text/Punycode/Encode.hs b/punycode/Data/Text/Punycode/Encode.hs new file mode 100644 --- /dev/null +++ b/punycode/Data/Text/Punycode/Encode.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Data.Text.Punycode.Encode (encode) where + +import Control.Monad +import Control.Monad.State hiding (state) +import Control.Monad.Writer +import qualified Data.ByteString as BS +import Data.Char +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Text.Punycode.Shared +import Data.Word + +data PunycodeState = PunycodeState + { n :: Int, + delta :: Int, + bias :: Int, + h :: Int + } + +-- | Encode a string into its ascii form +encode :: T.Text -> BS.ByteString +encode = execWriter . initialWriter + +initialWriter :: (MonadWriter BS.ByteString m) => T.Text -> m () +initialWriter input = do + tell basics + when (b > 0) $ tell $ BS.singleton $ fromIntegral $ ord '-' + evalStateT (inner3 (map ord $ T.unpack input) b) $ + PunycodeState + { n = initial_n, + delta = 0, + bias = initial_bias, + h = b + } + where + basics = TE.encodeUtf8 $ T.filter isBasic input + b = BS.length basics + +inner3 :: (MonadState PunycodeState m, MonadWriter BS.ByteString m) => [Int] -> Int -> m () +inner3 input b = do + state <- get + helper state + where + helper state + | h' < length input = do + put $ state {n = m, delta = delta'} + mapM_ (inner2 b) input + state' <- get + put $ state' {delta = (delta state') + 1, n = (n state') + 1} + inner3 input b + | otherwise = return () + where + m = minimum $ filter (>= n') input + n' = n state + h' = h state + delta' = (delta state) + (m - n') * (h' + 1) + +inner2 :: (MonadState PunycodeState m, MonadWriter BS.ByteString m) => Int -> Int -> m () +inner2 b c = do + state <- get + helper state + where + helper state + | c == n' = do + q <- inner delta' base bias' + tell $ BS.singleton $ baseToAscii q + put $ state {bias = adapt delta' (h' + 1) (h' == b), delta = 0, h = (h state) + 1} + | otherwise = put $ state {delta = delta'} + where + delta' = (delta state) + d + where + d + | c < n' = 1 + | otherwise = 0 + n' = n state + bias' = bias state + h' = h state + +inner :: (MonadWriter BS.ByteString m) => Int -> Int -> Int -> m Int +inner q k bias' + | q < t = return q + | otherwise = do + tell $ BS.singleton $ baseToAscii $ t + ((q - t) `mod` (base - t)) + inner ((q - t) `div` (base - t)) (k + base) bias' + where + t + | k <= bias' + tmin = tmin + | k >= bias' + tmax = tmax + | otherwise = k - bias' + +baseToAscii :: Int -> Word8 +baseToAscii i + | i < 26 = fromIntegral $ i + (ord 'a') + | otherwise = fromIntegral $ (i - 26) + (ord '0') diff --git a/punycode/Data/Text/Punycode/Shared.hs b/punycode/Data/Text/Punycode/Shared.hs new file mode 100644 --- /dev/null +++ b/punycode/Data/Text/Punycode/Shared.hs @@ -0,0 +1,39 @@ +module Data.Text.Punycode.Shared where + +import Data.Char (ord) + +base :: Int +base = 36 + +tmin :: Int +tmin = 1 + +tmax :: Int +tmax = 26 + +skew :: Int +skew = 38 + +damp :: Int +damp = 700 + +initial_bias :: Int +initial_bias = 72 + +initial_n :: Int +initial_n = 128 + +adapt :: Int -> Int -> Bool -> Int +adapt delta numpoints firsttime = helper + where + helper = loop 0 $ delta' + (delta' `div` numpoints) + where + delta' + | firsttime = delta `div` damp + | otherwise = delta `div` 2 + loop k delta' + | delta' > ((base - tmin) * tmax) `div` 2 = loop (k + base) $ delta' `div` (base - tmin) + | otherwise = k + (((base - tmin + 1) * delta') `div` (delta' + skew)) + +isBasic :: Char -> Bool +isBasic = (< initial_n) . ord diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,124 @@ +module Main where + +import qualified Data.Text as T +import qualified Iri.Parsing.ByteString as D +import qualified Iri.Parsing.Text as F +import Iri.QuasiQuoter +import qualified Iri.Rendering.ByteString as E +import qualified Iri.Rendering.Text as C +import Test.Tasty +import Test.Tasty.HUnit +import Prelude + +main :: IO () +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 -> + assertEqual "" (Right input) (fmap E.uri (D.uri input)), + 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|]), + testCase "Messed up URIs" + $ let testUri uri = + assertEqual "Original and parsed URIs are not equal" (Right uri) (fmap E.uri (D.uri uri)) + in traverse_ + testUri + [ "http://m.ru.hellomagazine.com/krasota-i-zdorove/ukhod-za-kozhey-i-volosami/11373-5-prichesok-kotorye-sdelayut-vas-molozhe.html?utm_medium=teaser&utm_campaign=gnezdo1&utm_term=15376&utm_content=[TID", + "https://m.tsargrad.tv/news/komediju_113156?%90\"%20" + ], + testCase "User Info" + $ assertEqual "" (Right "http://user:password@localhost:993") (fmap E.uri (D.uri "http://user:password@localhost:993")), + 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/" + ], + testCase "Hex digit parsing bug reproduction - lowercase hex digits" + $ do + -- Bug: lowercase hex digits 'a'-'f' were calculated as (ascii - 97) instead of (ascii - 87) + -- This caused %6a (should be ASCII 106 = 'j') to be parsed incorrectly + -- %6a = 6*16 + 10 = 106 = 'j', but with bug: 6*16 + 0 = 96 = '`' + let result = F.iri "https://example.com/test%6a" -- should be 'j' + case result of + Left err -> assertFailure $ "Should parse successfully: " ++ T.unpack err + Right iri -> + let rendered = C.iri iri -- Use text rendering to see decoded content + in assertBool "Should contain 'j' when correctly parsed" ('j' `T.elem` rendered), + testCase "Lowercase hex digits a-f UTF-8 parsing" + $ do + -- Test that %c3%a9 (UTF-8 for é) parses correctly with lowercase hex + -- This tests the fix for hex digits 'c' and 'a' which were affected by the bug + let result = F.iri "https://example.com/caf%c3%a9" + case result of + Left _ -> assertFailure "Should parse UTF-8 encoded URL successfully" + Right iri -> + let rendered = C.iri iri -- Use text rendering to see the decoded UTF-8 + in assertBool "Should contain é character when correctly decoded" ('é' `T.elem` rendered), + 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")), + 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")) + ] + ] + ] diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,93 +0,0 @@ -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")) - ] - ]