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,96 +1,189 @@ -name: iri -version: 0.4 -category: URI, URL, IRI, Network -synopsis: RFC-based resource identifier library +cabal-version: 3.0 +name: iri +version: 0.5 +category: URI, URL, IRI, Network +synopsis: RFC-based resource identifier library description: 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. -homepage: https://github.com/nikita-volkov/iri -bug-reports: https://github.com/nikita-volkov/iri/issues -author: Nikita Volkov -maintainer: Metrix.AI Tech Team -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 + type: git location: git://github.com/nikita-volkov/iri.git library - hs-source-dirs: library - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 + hs-source-dirs: library + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + Arrows + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeFamilies + TypeOperators + UnboxedTuples + 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.Lift - Iri.Data.Instances.Show Iri.Data.Instances.Eq + Iri.Data.Instances.Generic Iri.Data.Instances.Hashable + Iri.Data.Instances.Lift Iri.Data.Instances.Ord - Iri.Data.Instances.Generic - Iri.Prelude - Iri.Utf8CodePoint - Iri.Vector + Iri.Data.Instances.Show + Iri.Data.Types Iri.MonadPlus - Iri.CodePointPredicates.Core - Iri.CodePointPredicates.Rfc3986 - Iri.CodePointPredicates.Rfc3987 - Iri.Rendering.Ptr.Poke - Iri.PercentEncoding 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 + build-depends: - attoparsec >=0.13 && <0.14, - base >=4.9 && <5, - bytestring >=0.10 && <0.11, - contravariant >=1.4 && <2, - hashable >=1.2 && <2, - ip >=1.1 && <2, - profunctors >=5.2 && <6, - ptr >=0.16.1 && <0.17, - punycode >=2 && <3, - semigroups >=0.18 && <0.20, - template-haskell >=2.9 && <3, - text ==1.*, - text-builder >=0.6.5 && <0.7, - th-lift >=0.7.7 && <0.8, - th-lift-instances >=0.1.11 && <0.2, - unordered-containers >=0.2 && <0.3, - vector >=0.10 && <0.13, - vector-builder >=0.3.4 && <0.4, - vector-instances >=3.4 && <4 + , 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 + , template-haskell >=2.17 && <3 + , text >=2 && <3 + , text-builder >=0.6.7.2 && <0.7 + , 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 + , vector-instances >=3.4 && <4 + , wide-word >=0.1.6 && <2 -test-suite test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples +library punycode + hs-source-dirs: punycode default-language: Haskell2010 build-depends: - iri, - QuickCheck >=2.8.1 && <3, - quickcheck-instances >=0.3.11 && <0.4, - rerebase <2, - tasty >=0.12 && <2, - tasty-hunit >=0.9 && <0.11, - tasty-quickcheck >=0.9 && <0.11 + , base >=4.15 && <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 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + Arrows + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeFamilies + TypeOperators + UnboxedTuples + + build-depends: + , iri + , 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.Unboxed as A +module Iri.CodePointPredicates.Core where +import Data.Vector.Unboxed qualified 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,104 +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 - -{-| -Reference: +import Iri.Prelude hiding (Predicate, inRange, (&&&), (|||)) -@ -unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" -@ --} +-- | +-- Reference: +-- +-- @ +-- unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +-- @ unreserved :: Predicate unreserved = asciiAlphanumeric ||| oneOfChars "-._~" @@ -110,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 / ":" / "@" @@ -125,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 = @@ -151,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.CodePointPredicates.Rfc3986 qualified 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,22 +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.Ord -import Iri.Data.Instances.Hashable -import Iri.Data.Instances.Generic - +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 @@ -19,7 +17,7 @@ PresentUserInfo (User 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 --- a/library/Iri/Data/Instances/Generic.hs +++ b/library/Iri/Data/Instances/Generic.hs @@ -1,9 +1,9 @@ -module Iri.Data.Instances.Generic -where +{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude -import Iri.Data.Types +module Iri.Data.Instances.Generic where +import Iri.Data.Types +import Iri.Prelude deriving instance Generic Iri diff --git a/library/Iri/Data/Instances/Hashable.hs b/library/Iri/Data/Instances/Hashable.hs --- a/library/Iri/Data/Instances/Hashable.hs +++ b/library/Iri/Data/Instances/Hashable.hs @@ -1,11 +1,11 @@ -module Iri.Data.Instances.Hashable -where +{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude -import Iri.Data.Types -import Iri.Data.Instances.Generic -import qualified Net.IPv6 as B +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 @@ -21,13 +21,7 @@ instance Hashable Password -instance Hashable Host where - hashWithSalt salt host = - hashWithSalt salt $ - case host of - NamedHost regName -> hashWithSalt 0 regName - IpV4Host ip -> hashWithSalt 1 ip - IpV6Host (B.IPv6 a b) -> (hashWithSalt (hashWithSalt 2 a) b) +instance Hashable Host instance Hashable RegName 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 Data.WideWord.Word128 qualified 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 Net.IPv6 qualified -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 --- a/library/Iri/Data/Instances/Ord.hs +++ b/library/Iri/Data/Instances/Ord.hs @@ -1,10 +1,10 @@ -module Iri.Data.Instances.Ord -where +{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude -import Iri.Data.Types -import Iri.Data.Instances.Eq +module Iri.Data.Instances.Ord where +import Iri.Data.Instances.Eq () +import Iri.Data.Types +import Iri.Prelude deriving instance Ord Iri 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 -import Iri.Data.Types -import qualified Iri.Rendering.Text.Internal as A -import qualified Data.Text as B +module Iri.Data.Instances.Show where +import Data.Text qualified as B +import Iri.Data.Types +import Iri.Prelude +import Iri.Rendering.Text.Internal qualified as A 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,98 +1,83 @@ -{-| -References: - -* -* --} {-# OPTIONS_GHC -funbox-strict-fields #-} -module Iri.Data.Types -where -import Iri.Prelude +-- | +-- References: +-- +-- * +-- * +module Iri.Data.Types where +import Iri.Prelude -{-| -Thorough structure of IRI or URI. --} -data Iri = - Iri !Scheme !Hierarchy !Query !Fragment +-- | +-- Thorough structure of IRI or URI. +data Iri = Iri !Scheme !Hierarchy !Query !Fragment -newtype Scheme = - Scheme ByteString +newtype Scheme = Scheme ByteString -data Hierarchy = - AuthorisedHierarchy !Authority !Path | - AbsoluteHierarchy !Path | - RelativeHierarchy !Path +data Hierarchy + = AuthorisedHierarchy !Authority !Path + | AbsoluteHierarchy !Path + | RelativeHierarchy !Path -data Authority = - Authority !UserInfo !Host !Port +data Authority = Authority !UserInfo !Host !Port -data UserInfo = - PresentUserInfo !User !Password | - MissingUserInfo +data UserInfo + = PresentUserInfo !User !Password + | MissingUserInfo -newtype User = - User ByteString +newtype User = User ByteString -data Password = - PresentPassword !ByteString | - MissingPassword +data Password + = PresentPassword !ByteString + | MissingPassword -data Host = - NamedHost !RegName | - IpV4Host !IPv4 | - IpV6Host !IPv6 +data Host + = NamedHost !RegName + | IpV4Host !IPv4 + | IpV6Host !IPv6 -newtype RegName = - RegName (Vector DomainLabel) +newtype RegName = RegName (Vector DomainLabel) data DomainLabel = DomainLabel Text -data Port = - PresentPort !Word16 | - MissingPort - -newtype Path = - Path (Vector PathSegment) - -newtype PathSegment = - PathSegment ByteString +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 percent-decoded bytes. +newtype Path = Path (Vector PathSegment) -See . --} -newtype Query = - Query ByteString +newtype PathSegment = PathSegment ByteString -newtype Fragment = - Fragment ByteString +-- | +-- Since the exact structure of the query string is not standardised and +-- methods used to parse the query string may differ between websites, +-- we simply represent it as 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 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 +-- | +-- 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,41 +1,42 @@ -module Iri.MonadPlus -where +module Iri.MonadPlus where import Iri.Prelude hiding (foldl) -import qualified Ptr.ByteString as ByteString -import qualified Ptr.Poking as Poking - +import Ptr.ByteString qualified as ByteString +import Ptr.Poking qualified 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 :: (MonadPlus m) => m ByteString -> m ByteString foldByteString = - fmap ByteString.poking . - foldl (\ poking -> mappend poking . Poking.bytes) mempty + fmap ByteString.poking + . foldl (\poking -> mappend poking . Poking.bytes) mempty {-# INLINE fold #-} fold :: (MonadPlus m, Monoid a) => m a -> m a diff --git a/library/Iri/Optics.hs b/library/Iri/Optics.hs --- a/library/Iri/Optics.hs +++ b/library/Iri/Optics.hs @@ -1,14 +1,12 @@ -{-| -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 -( - module Basics, - module Defs, -) + ( module Basics, + module Defs, + ) where import Iri.Optics.Basics as Basics (Lens, Lens', Prism, Prism', Traversal, Traversal') diff --git a/library/Iri/Optics/Basics.hs b/library/Iri/Optics/Basics.hs --- a/library/Iri/Optics/Basics.hs +++ b/library/Iri/Optics/Basics.hs @@ -1,10 +1,8 @@ -module Iri.Optics.Basics -where +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 t a b = forall f. (Functor f) => (a -> f b) -> s -> f t type Lens' s a = Lens s s a a @@ -12,7 +10,7 @@ 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 t a b = forall f. (Applicative f) => (a -> f b) -> s -> f t type Traversal' s a = Traversal s s a a diff --git a/library/Iri/Optics/Defs.hs b/library/Iri/Optics/Defs.hs --- a/library/Iri/Optics/Defs.hs +++ b/library/Iri/Optics/Defs.hs @@ -1,36 +1,37 @@ -module Iri.Optics.Defs -where +module Iri.Optics.Defs where -import Iri.Prelude +import Data.Text.Encoding qualified as Text import Iri.Data import Iri.Optics.Basics -import qualified Iri.Rendering.ByteString as A -import qualified Iri.Parsing.ByteString as B -import qualified Iri.Rendering.Text as C -import qualified Iri.Parsing.Text as D -import qualified Data.Text.Encoding as Text - +import Iri.Parsing.ByteString qualified as B +import Iri.Parsing.Text qualified as D +import Iri.Prelude +import Iri.Rendering.ByteString qualified as A +import Iri.Rendering.Text qualified as C -- * Definitions by source + ------------------------- -- ** Text + ------------------------- textIriIri :: Prism' Text Iri textIriIri = - prism C.iri (\ text -> either (const (Left text)) Right (D.iri text)) + 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)) + prism A.uri (\bytes -> either (const (Left bytes)) Right (B.uri bytes)) byteStringHttpIri :: Prism' ByteString HttpIri byteStringHttpIri = @@ -40,31 +41,34 @@ 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) +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) +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) +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) +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) +schemeByteString = lens (\(Scheme x) -> x) (const Scheme) -- ** Fragment + ------------------------- fragmentByteString :: Lens' Fragment ByteString -fragmentByteString = lens (\ (Fragment x) -> x) (const Fragment) +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,34 +1,28 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + module Iri.Parsing.Attoparsec.ByteString -( - uri, - httpUri, - regName, -) + ( 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.Vector as S -import qualified VectorBuilder.Builder as P -import qualified VectorBuilder.Vector as Q -import qualified VectorBuilder.MonadPlus as E -import qualified Iri.PercentEncoding as I -import qualified Iri.CodePointPredicates.Rfc3986 as C -import qualified Iri.MonadPlus as R -import qualified Ptr.Poking as G -import qualified Ptr.ByteString as H -import qualified Text.Builder as J -import qualified Net.IPv4 as M -import qualified Net.IPv6 as N - +import Data.Attoparsec.ByteString.Char8 qualified as F +import Data.ByteString qualified as K +import Data.Text.Encoding qualified as B +import Data.Text.Encoding.Error qualified as L +import Data.Text.Punycode qualified as A +import Data.Vector qualified as S +import Iri.CodePointPredicates.Rfc3986 qualified as C +import Iri.Data +import Iri.MonadPlus qualified as R +import Iri.PercentEncoding qualified as I +import Iri.Prelude hiding (foldl, hash) +import Net.IPv4 qualified as M +import Net.IPv6 qualified as N +import Text.Builder qualified as J +import VectorBuilder.MonadPlus qualified as E {-# INLINE percent #-} percent :: Parser Word8 @@ -85,11 +79,10 @@ labeled label parser = parser label -{-| -Parser of a well-formed URI conforming to the RFC3986 or RFC3987 standards. -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 @@ -100,18 +93,17 @@ 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 + 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 @@ -146,31 +138,33 @@ {-# 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 <$> regName + labeled "Host" + $ asum + [ IpV6Host <$> ipV6, + IpV4Host <$> M.parserUtf8, + NamedHost <$> regName + ] -{-# INLINABLE ipV6 #-} +{-# INLINEABLE ipV6 #-} ipV6 :: Parser IPv6 ipV6 = do @@ -183,27 +177,28 @@ d <- F.hexadecimal colon mplus - (do - e <- F.hexadecimal - colon - f <- F.hexadecimal - colon - g <- F.hexadecimal - colon - h <- F.hexadecimal - return (N.fromWord16s a b c d e f g h)) - (do - colon - return (N.fromWord16s a b c d 0 0 0 0)) + ( 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 regName #-} regName :: Parser RegName regName = fmap RegName (E.sepBy1 domainLabel (word8 46)) -{-| -Domain label with Punycode decoding applied if need be. --} +-- | +-- Domain label with Punycode decoding applied if need be. {-# INLINE domainLabel #-} domainLabel :: Parser DomainLabel domainLabel = @@ -231,19 +226,21 @@ else return (Path segments) where segmentsAreEmpty segments = - S.length segments == 1 && - (case S.unsafeHead segments of PathSegment headSegment -> K.null headSegment) + 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 @@ -251,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) else fail (showString "UTF8 decoding: Bytes remaining: " (show undecodedBytes)) -{-# INLINABLE urlEncodedString #-} +{-# INLINEABLE urlEncodedString #-} urlEncodedString :: (Word8 -> Bool) -> Parser ByteString urlEncodedString unencodedBytesPredicate = - labeled "URL-encoded string" $ - R.foldByteString $ - takeWhile1 unencodedBytesPredicate <|> encoded + labeled "URL-encoded string" + $ R.foldByteString + $ takeWhile1 unencodedBytesPredicate + <|> encoded where encoded = K.singleton <$> percentEncodedByte @@ -270,7 +270,7 @@ percentEncodedByte :: Parser Word8 percentEncodedByte = labeled "Percent-encoded byte" $ do - percent + percent byte1 <- anyWord8 byte2 <- anyWord8 I.matchPercentEncodedBytes (fail "Broken percent encoding") return byte1 byte2 @@ -278,22 +278,25 @@ {-# INLINE query #-} query :: Parser Query query = - labeled "Query" $ - (question *> (Query <$> queryOrFragmentBody)) <|> pure (Query mempty) + labeled "Query" + $ (question *> (Query <$> queryOrFragmentBody)) + <|> pure (Query mempty) {-# 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 #-} +-- | +-- The stuff after the question or the hash mark. +{-# INLINEABLE queryOrFragmentBody #-} queryOrFragmentBody :: Parser ByteString queryOrFragmentBody = - R.foldByteString $ - 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,38 +1,46 @@ +{-# 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 qualified Iri.MonadPlus as R -import qualified Text.Builder as J -import qualified Net.IPv4 as M -import qualified Net.IPv6 as N -import qualified Ptr.ByteString as ByteString -import qualified Ptr.Poking as Poking - +import Data.ByteString qualified as K +import Data.Text.Encoding qualified as B +import Data.Text.Encoding.Error qualified as L +import Data.Vector qualified as S +import Iri.CodePointPredicates.Rfc3987 qualified as C +import Iri.Data +import Iri.MonadPlus qualified as R +import Iri.Prelude +import Net.IPv4 qualified as M +import Net.IPv6 qualified as N +import Ptr.ByteString qualified as ByteString +import Ptr.Poking qualified as Poking +import Text.Builder qualified as J +import VectorBuilder.MonadPlus qualified 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 @@ -43,15 +51,14 @@ 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 + secure <- satisfy (\x -> x == 's' || x == 'S') $> True <|> pure False string "://" parsedHost <- host parsedPort <- PresentPort <$> (char ':' *> port) <|> pure MissingPort @@ -86,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 @@ -139,31 +149,34 @@ else return (Path segments) where segmentsAreEmpty segments = - S.length segments == 1 && - (case S.unsafeHead segments of PathSegment headSegment -> K.null headSegment) + 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 #-} +{-# INLINEABLE urlEncodedComponent #-} urlEncodedComponent :: (Char -> Bool) -> Parser ByteString urlEncodedComponent unencodedCharPredicate = - labeled "URL-encoded component" $ - fmap ByteString.poking $ - R.fold $ - (Poking.bytes . B.encodeUtf8 <$> takeWhile1 unencodedCharPredicate) <|> (Poking.word8 <$> urlEncodedByte) + labeled "URL-encoded component" + $ fmap ByteString.poking + $ R.fold + $ (Poking.bytes . B.encodeUtf8 <$> takeWhile1 unencodedCharPredicate) + <|> (Poking.word8 <$> urlEncodedByte) -{-# INLINABLE urlEncodedComponentText #-} +{-# INLINEABLE urlEncodedComponentText #-} urlEncodedComponentText :: (Char -> Bool) -> Parser Text urlEncodedComponentText unencodedCharPredicate = - labeled "URL-encoded component" $ - fmap J.run $ - R.foldl mappend mempty $ - (J.text <$> takeWhile1 unencodedCharPredicate) <|> urlEncodedSequenceTextBuilder + labeled "URL-encoded component" + $ fmap J.run + $ R.foldl mappend mempty + $ (J.text <$> takeWhile1 unencodedCharPredicate) + <|> urlEncodedSequenceTextBuilder -{-# INLINABLE urlEncodedSequenceTextBuilder #-} +{-# INLINEABLE urlEncodedSequenceTextBuilder #-} urlEncodedSequenceTextBuilder :: Parser J.Builder urlEncodedSequenceTextBuilder = labeled "URL-encoded sequence" $ do @@ -176,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 @@ -185,7 +200,7 @@ urlEncodedByte :: Parser Word8 urlEncodedByte = do - char '%' + char '%' digit1 <- fromIntegral <$> hexadecimalDigit digit2 <- fromIntegral <$> hexadecimalDigit return (shiftL digit1 4 .|. digit2) @@ -198,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 - 97) + 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,57 +1,55 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + module Iri.Parsing.ByteString -( - uri, - httpUri, - regName, - uriQuery, -) + ( uri, + httpUri, + regName, + uriQuery, + ) where -import Iri.Prelude +import Data.Attoparsec.ByteString qualified as B +import Data.ByteString qualified as ByteString import Iri.Data -import qualified Iri.Parsing.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString as B -import qualified Data.ByteString as ByteString - +import Iri.Parsing.Attoparsec.ByteString qualified as A +import Iri.Prelude +parser :: B.Parser a -> ByteString -> Either Text a parser parser = - either (Left . fromString) Right . - B.parseOnly (parser <* B.endOfInput) + 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 = 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 = parser A.httpUri -{-| -Domain name parser. --} +-- | +-- 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 -> Query +-- | +-- 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 (beforeQuestion, questionAndAfterQuestion) -> case ByteString.uncons questionAndAfterQuestion of Just (_, afterQuestion) -> case ByteString.break (== 35) afterQuestion of - (beforeHash, hashAndAfterHash) -> Query beforeHash + (beforeHash, hashAndAfterHash) -> 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. --} +-- | +-- 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 Data.Attoparsec.Text qualified as B import Iri.Data -import qualified Iri.Parsing.Attoparsec.Text as A -import qualified Data.Attoparsec.Text as B +import Iri.Parsing.Attoparsec.Text qualified as A +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,23 +1,22 @@ +{-# OPTIONS_GHC -Wno-dodgy-imports #-} + module Iri.Prelude -( - module Exports, -) + ( module Exports, + ) where - --- base -------------------------- import Control.Applicative as Exports import Control.Arrow as Exports import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports -import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) -import Control.Monad.IO.Class as Exports +import Control.Monad 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 @@ -27,35 +26,48 @@ import Data.Fixed as Exports import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports import Data.Functor.Identity as Exports -import Data.Int 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 (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +import Data.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 (Last(..), First(..)) +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 +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 import Data.String as Exports +import Data.Text as Exports (Text) 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 (sizeOf, alignment) -import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) -import GHC.Exts as Exports (lazy, inline, sortWith, groupWith) +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) import Numeric as Exports -import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports @@ -64,62 +76,7 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports -import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) -import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) -import Text.Printf as Exports (printf, hPrintf) -import Text.Read as Exports (Read(..), readMaybe, readEither) +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports - --- contravariant -------------------------- -import Data.Functor.Contravariant as Exports -import Data.Functor.Contravariant.Divisible as Exports - --- profunctors -------------------------- -import Data.Profunctor.Unsafe as Exports -import Data.Profunctor.Choice as Exports -import Data.Profunctor.Strong as Exports - --- semigroups -------------------------- -import Data.Semigroup as Exports - --- hashable -------------------------- -import Data.Hashable as Exports - --- vector-instances -------------------------- -import Data.Vector.Instances () - --- bytestring -------------------------- -import Data.ByteString as Exports (ByteString) - --- text -------------------------- -import Data.Text as Exports (Text) - --- ip -------------------------- -import Net.IPv4 as Exports (IPv4) -import Net.IPv6 as Exports (IPv6) - --- vector -------------------------- -import Data.Vector as Exports (Vector) - --- unordered-containers -------------------------- -import Data.HashMap.Strict as Exports (HashMap) - --- th-lift-instances -------------------------- -import Instances.TH.Lift as Exports - --------------------------------------------------------------------------------- - -import qualified Language.Haskell.TH.Lift as A -A.deriveLift ''IPv4 -A.deriveLift ''IPv6 +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,21 +1,18 @@ module Iri.QuasiQuoter -( - uri, - httpUri, - iri, - httpIri, -) + ( uri, + httpUri, + iri, + httpIri, + ) where +import Data.Attoparsec.ByteString qualified as B +import Data.Attoparsec.Text qualified as C +import Iri.Parsing.Attoparsec.ByteString qualified as A +import Iri.Parsing.Attoparsec.Text qualified as D import Iri.Prelude hiding (exp) -import Iri.Data -import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote -import qualified Iri.Parsing.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString as B -import qualified Data.Attoparsec.Text as C -import qualified Iri.Parsing.Attoparsec.Text as D - +import Language.Haskell.TH.Syntax exp :: (String -> Q Exp) -> QuasiQuoter exp exp = @@ -24,42 +21,38 @@ unsupported _ = fail "Not supported" -{-| -'Iri' literal from ASCII representation. --} +-- | +-- 'Iri' literal from ASCII representation. uri :: QuasiQuoter uri = - exp $ \ string -> - case B.parseOnly (A.uri <* B.endOfInput) (fromString string) of - Right uri -> lift uri - 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) -{-| -'HttpIri' literal from ASCII representation. --} +-- | +-- 'HttpIri' literal from ASCII representation. httpUri :: QuasiQuoter httpUri = - exp $ \ string -> - case B.parseOnly (A.httpUri <* B.endOfInput) (fromString string) of - Right uri -> lift uri - 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 from IRI representation. --} +-- | +-- '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) -{-| -'HttpIri' literal from IRI representation. --} +-- | +-- '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 qualified Iri.Rendering.Ptr.Poking as A -import qualified Ptr.ByteString as F - +import Iri.Prelude +import Iri.Rendering.Ptr.Poking qualified as A +import Ptr.ByteString qualified 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/Ptr/Poke.hs b/library/Iri/Rendering/Ptr/Poke.hs --- a/library/Iri/Rendering/Ptr/Poke.hs +++ b/library/Iri/Rendering/Ptr/Poke.hs @@ -1,14 +1,12 @@ -module Iri.Rendering.Ptr.Poke -where +module Iri.Rendering.Ptr.Poke where import Iri.Prelude -import Iri.Data import Ptr.Poke - {-# NOINLINE urlEncodedByte #-} urlEncodedByte :: Poke Word8 urlEncodedByte = - divide (\byte -> ('%', byte)) + 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,53 +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 Data.ByteString qualified as ByteString +import Data.Text qualified as C +import Data.Text.Encoding qualified as A +import Data.Text.Punycode qualified as B +import Iri.CodePointPredicates.Core qualified as I +import Iri.CodePointPredicates.Rfc3986 qualified as I import Iri.Data +import Iri.Prelude hiding (null, poke) +import Iri.Rendering.Ptr.Poke qualified as L +import Iri.Utf8CodePoint qualified as K +import Iri.Vector qualified as F +import Net.IPv4 qualified as D +import Net.IPv6 qualified as E import Ptr.Poking -import qualified Data.Text.Encoding as A -import qualified Data.Text.Encoding.Error as A -import qualified Data.Text.Punycode as B -import qualified Data.Text as C -import qualified Data.ByteString as ByteString -import qualified Data.HashMap.Strict as G -import qualified Data.Vector as H -import qualified Net.IPv4 as D -import qualified Net.IPv6 as E -import qualified Iri.Vector as F -import qualified Iri.CodePointPredicates.Core as I -import qualified Iri.CodePointPredicates.Rfc3986 as I -import qualified Iri.Utf8CodePoint as K -import qualified Iri.Rendering.Ptr.Poke as L - uri :: Iri -> Poking uri (Iri schemeValue hierarchyValue queryValue fragmentValue) = - scheme schemeValue <> - asciiChar ':' <> - hierarchy hierarchyValue <> - (prependIfNotNull - (asciiChar '?') - (query queryValue)) <> - (prependIfNotNull - (asciiChar '#') - (fragment fragmentValue)) + 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 "https://" else "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) = @@ -55,7 +54,7 @@ hierarchy :: Hierarchy -> Poking hierarchy = - \ case + \case AuthorisedHierarchy authorityValue pathValue -> bytes "//" <> authority authorityValue <> prependIfNotNull (asciiChar '/') (path pathValue) AbsoluteHierarchy pathValue -> @@ -65,13 +64,13 @@ 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 @@ -83,7 +82,7 @@ host :: Host -> Poking host = - \ case + \case NamedHost value -> domainName value IpV4Host value -> ipV4 value IpV6Host value -> ipV6 value @@ -108,7 +107,7 @@ port :: Port -> Poking port = - \ case + \case PresentPort value -> asciiIntegral value MissingPort -> mempty @@ -130,25 +129,26 @@ urlEncodedBytes :: I.Predicate -> ByteString -> Poking urlEncodedBytes unencodedPredicate = - ByteString.foldl' (\ poking -> mappend poking . byte) mempty + 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 -} +-- | 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,16 @@ -module Iri.Rendering.Text.Internal -where +module Iri.Rendering.Text.Internal where -import Iri.Prelude import Iri.Data.Types -import qualified Iri.Rendering.TextBuilder.Internal as A -import qualified Text.Builder as B - +import Iri.Prelude +import Iri.Rendering.TextBuilder.Internal qualified as A +import Text.Builder qualified as B -{-| Render as a Unicode IRI text -} +-- | Render as a Unicode IRI text iri :: Iri -> Text iri = B.run . A.iri -{-| Render as a Unicode IRI text -} +-- | Render as a Unicode IRI text httpIri :: HttpIri -> Text httpIri = B.run . A.httpIri 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,49 +1,46 @@ module Iri.Rendering.TextBuilder.Internal -( - iri, - httpIri, -) + ( iri, + httpIri, + ) where -import Iri.Prelude hiding (null) +import Data.ByteString qualified as ByteString +import Data.Text qualified as C +import Data.Text.Encoding qualified as A +import Data.Text.Encoding.Error qualified as A +import Iri.CodePointPredicates.Core qualified as CorePredicates +import Iri.CodePointPredicates.Rfc3986 qualified as Rfc3986Predicates +import Iri.CodePointPredicates.Rfc3987 qualified as Rfc3987Predicates import Iri.Data.Types +import Iri.Prelude hiding (null) +import Iri.Utf8CodePoint qualified as K +import Iri.Vector qualified as F +import Net.IPv4 qualified as D +import Net.IPv6 qualified as E import Text.Builder -import qualified Data.Text.Encoding as A -import qualified Data.Text.Encoding.Error as A -import qualified Data.Text.Punycode as B -import qualified Data.Text as C -import qualified Data.HashMap.Strict as G -import qualified Data.Vector as H -import qualified Net.IPv4 as D -import qualified Net.IPv6 as E -import qualified Iri.Vector as F -import qualified Iri.CodePointPredicates.Core as CorePredicates -import qualified Iri.CodePointPredicates.Rfc3987 as Rfc3987Predicates -import qualified Iri.CodePointPredicates.Rfc3986 as Rfc3986Predicates -import qualified Iri.Utf8CodePoint as K -import qualified Data.ByteString as ByteString - iri :: Iri -> Builder 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 (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 bytes) = @@ -51,7 +48,7 @@ hierarchy :: Hierarchy -> Builder hierarchy = - \ case + \case AuthorisedHierarchy authorityValue pathValue -> string "//" <> authority authorityValue <> prependIfNotNull (char '/') (path pathValue) AbsoluteHierarchy pathValue -> @@ -61,15 +58,15 @@ authority :: Authority -> Builder 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 = - \ 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 @@ -79,7 +76,7 @@ host :: Host -> Builder host = - \ case + \case NamedHost value -> domainName value IpV4Host value -> ipV4 value IpV6Host value -> ipV6 value @@ -102,7 +99,7 @@ port :: Port -> Builder port = - \ case + \case PresentPort value -> unsignedDecimal value MissingPort -> mempty @@ -128,31 +125,34 @@ Right text -> urlEncodedText unencodedPredicate1 text Left _ -> urlEncodedBytes unencodedPredicate2 bytes -{-| Apply URL-encoding to text -} +-- | Apply URL-encoding to text urlEncodedBytes :: CorePredicates.Predicate -> ByteString -> Builder urlEncodedBytes unencodedPredicate = ByteString.foldl' - (\ builder -> mappend builder . \ byte -> if unencodedPredicate (fromIntegral byte) - then utf8CodeUnits1 byte - else urlEncodedByte byte) + ( \builder -> + mappend builder . \byte -> + if unencodedPredicate (fromIntegral byte) + then utf8CodeUnits1 byte + else urlEncodedByte byte + ) mempty -{-| Apply URL-encoding to text -} +-- | Apply URL-encoding to text urlEncodedText :: CorePredicates.Predicate -> Text -> Builder urlEncodedText unencodedPredicate = - C.foldl' (\ builder -> mappend builder . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty + C.foldl' (\builder -> mappend builder . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty urlEncodedUnicodeCodePoint :: CorePredicates.Predicate -> Int -> Builder 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 = 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 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,119 +1,102 @@ module Main where -import Prelude -import Test.QuickCheck.Instances +import Iri.Parsing.ByteString qualified as D +import Iri.Parsing.Text qualified as F +import Iri.QuasiQuoter +import Iri.Rendering.ByteString qualified as E +import Iri.Rendering.Text qualified as C 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 - +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 -> - 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|]) - , - 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 + 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/Баренцбург" - "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3" - , - testUriIri - "https://www.w3.org/International/articles/idn-and-iri/JP納豆/引き割り納豆.html" - "https://www.w3.org/International/articles/idn-and-iri/JP%E7%B4%8D%E8%B1%86/%E5%BC%95%E3%81%8D%E5%89%B2%E3%82%8A%E7%B4%8D%E8%B1%86.html" - , - testUriIri - "http://点心和烤鸭.w3.mag.keio.ac.jp" - "http://xn--0trv4xfvn8el34t.w3.mag.keio.ac.jp/" - ] - , - testGroup "Mess" $ - [ - 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")) + (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/" + ], + 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")) + ] + ] ] - ] - ]