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