uri-bytestring-0.3.2.1/bench/0000755000000000000000000000000013317713050014107 5ustar0000000000000000uri-bytestring-0.3.2.1/licenses/0000755000000000000000000000000013317713050014635 5ustar0000000000000000uri-bytestring-0.3.2.1/licenses/http-types/0000755000000000000000000000000013317713050016756 5ustar0000000000000000uri-bytestring-0.3.2.1/src/0000755000000000000000000000000013317713050013617 5ustar0000000000000000uri-bytestring-0.3.2.1/src/URI/0000755000000000000000000000000013317713050014256 5ustar0000000000000000uri-bytestring-0.3.2.1/src/URI/ByteString/0000755000000000000000000000000013317713050016350 5ustar0000000000000000uri-bytestring-0.3.2.1/test/0000755000000000000000000000000013317713050014007 5ustar0000000000000000uri-bytestring-0.3.2.1/test/URI/0000755000000000000000000000000013317713050014446 5ustar0000000000000000uri-bytestring-0.3.2.1/test/URI/ByteString/0000755000000000000000000000000013317713050016540 5ustar0000000000000000uri-bytestring-0.3.2.1/src/URI/ByteString.hs0000644000000000000000000000560713317713050016714 0ustar0000000000000000{-| Module : URI.ByteString Description : ByteString URI Parser and Serializer Copyright : (c) Soostone Inc., 2014-2015 Michael Xavier, 2014-2015 License : BSD3 Maintainer : michael.xavier@soostone.com Stability : experimental URI.ByteString aims to be an RFC3986 compliant URI parser that uses efficient ByteStrings for parsing and representing the data. This module provides a URI datatype as well as a parser and serializer. Note that this library is an early release and may have issues. It is currently being used in production and no issues have been encountered, however. Please report any issues encountered to the issue tracker. This module also provides analogs to Lens over the various types in this library. These are written in a generic way to avoid a dependency on any particular lens library. You should be able to use these with a number of packages including lens and lens-family-core. -} module URI.ByteString (-- * URI-related types Scheme(..) , Host(..) , Port(..) , Authority(..) , UserInfo(..) , Query(..) , URIRef(..) , Absolute , Relative , SchemaError(..) , URIParseError(..) , URIParserOptions(..) , strictURIParserOptions , laxURIParserOptions , URINormalizationOptions(..) , noNormalization , rfc3986Normalization , httpNormalization , aggressiveNormalization , httpDefaultPorts -- * Operations , toAbsolute -- * Parsing , parseURI , parseRelativeRef , uriParser , relativeRefParser -- * Serializing , serializeURIRef , serializeURIRef' -- ** Normalized Serialization , normalizeURIRef , normalizeURIRef' -- * Low level utility functions , urlDecode , urlDecodeQuery , urlEncodeQuery , urlEncodePath , urlEncode -- * Lenses -- ** Lenses over 'Scheme' , schemeBSL -- ** Lenses over 'Host' , hostBSL -- ** Lenses over 'Port' , portNumberL -- ** Lenses over 'Authority' , authorityUserInfoL , authorityHostL , authorityPortL -- ** Lenses over 'UserInfo' , uiUsernameL , uiPasswordL -- ** Lenses over 'Query' , queryPairsL -- ** Lenses over 'URIRef' , uriSchemeL , authorityL , pathL , queryL , fragmentL -- ** Lenses over 'URIParserOptions' , upoValidQueryCharL -- ** Deprecated , URI , RelativeRef , serializeURI , serializeURI' , serializeRelativeRef , serializeRelativeRef' , uriAuthorityL , uriPathL , uriQueryL , uriFragmentL , rrAuthorityL , rrPathL , rrQueryL , rrFragmentL ) where ------------------------------------------------------------------------------- import URI.ByteString.Internal import URI.ByteString.Lens import URI.ByteString.Types ------------------------------------------------------------------------------- uri-bytestring-0.3.2.1/src/URI/ByteString/QQ.hs0000644000000000000000000000321413317713050017225 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} module URI.ByteString.QQ ( uri , relativeRef ) where import Language.Haskell.TH.Quote import URI.ByteString import Data.ByteString.Char8 import Instances.TH.Lift() -- | Allows uri literals via QuasiQuotes language extension. -- -- >>> {-# LANGUAGE QuasiQuotes #-} -- >>> stackage :: URI -- >>> stackage = [uri|http://stackage.org|] uri :: QuasiQuoter uri = QuasiQuoter { quoteExp = \s -> let parsedURI = either (\err -> error $ show err) id (parseURI laxURIParserOptions (pack s)) in [| parsedURI |], quotePat = error "Not implemented.", quoteType = error "Not implemented.", quoteDec = error "Not implemented." } ------------------------------------------------------------------------------- -- | Allows relative ref literals via QuasiQuotes language extension. -- -- >>> {-# LANGUAGE QuasiQuotes #-} -- >>> ref :: RelativeRef -- >>> ref = [relativeRef|/foo?bar=baz#quux|] relativeRef :: QuasiQuoter relativeRef = QuasiQuoter { quoteExp = \s -> let parsedURI = either (\err -> error $ show err) id (parseRelativeRef laxURIParserOptions (pack s)) in [| parsedURI |], quotePat = error "Not implemented.", quoteType = error "Not implemented.", quoteDec = error "Not implemented." } uri-bytestring-0.3.2.1/src/URI/ByteString/Lens.hs0000644000000000000000000001671313317713050017615 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module URI.ByteString.Lens where ------------------------------------------------------------------------------- import Control.Applicative import Data.ByteString (ByteString) import Data.Word ------------------------------------------------------------------------------- import Prelude ------------------------------------------------------------------------------- import URI.ByteString.Types ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- schemeBSL :: Lens' Scheme ByteString schemeBSL = lens schemeBS (\a b -> a { schemeBS = b}) {-# INLINE schemeBSL #-} ------------------------------------------------------------------------------- hostBSL :: Lens' Host ByteString hostBSL = lens hostBS (\a b -> a { hostBS = b}) {-# INLINE hostBSL #-} ------------------------------------------------------------------------------- portNumberL :: Lens' Port Int portNumberL = lens portNumber (\a b -> a { portNumber = b}) {-# INLINE portNumberL #-} ------------------------------------------------------------------------------- authorityUserInfoL :: Lens' Authority (Maybe UserInfo) authorityUserInfoL = lens authorityUserInfo (\a b -> a { authorityUserInfo = b}) {-# INLINE authorityUserInfoL #-} ------------------------------------------------------------------------------- authorityHostL :: Lens' Authority Host authorityHostL = lens authorityHost (\a b -> a { authorityHost = b}) {-# INLINE authorityHostL #-} ------------------------------------------------------------------------------- authorityPortL :: Lens' Authority (Maybe Port) authorityPortL = lens authorityPort (\a b -> a { authorityPort = b}) {-# INLINE authorityPortL #-} ------------------------------------------------------------------------------- uiUsernameL :: Lens' UserInfo ByteString uiUsernameL = lens uiUsername (\a b -> a { uiUsername = b}) {-# INLINE uiUsernameL #-} ------------------------------------------------------------------------------- uiPasswordL :: Lens' UserInfo ByteString uiPasswordL = lens uiPassword (\a b -> a { uiPassword = b}) {-# INLINE uiPasswordL #-} ------------------------------------------------------------------------------- queryPairsL :: Lens' Query [(ByteString, ByteString)] queryPairsL = lens queryPairs (\a b -> a { queryPairs = b}) {-# INLINE queryPairsL #-} ------------------------------------------------------------------------------- uriAuthorityL :: Lens' URI (Maybe Authority) uriAuthorityL = lens uriAuthority (\a b -> a { uriAuthority = b}) {-# INLINE uriAuthorityL #-} {-# DEPRECATED uriAuthorityL "Use 'authorityL' instead" #-} ------------------------------------------------------------------------------- uriPathL :: Lens' URI ByteString uriPathL = lens uriPath (\a b -> a { uriPath = b}) {-# INLINE uriPathL #-} {-# DEPRECATED uriPathL "Use 'pathL' instead" #-} ------------------------------------------------------------------------------- uriQueryL :: Lens' URI Query uriQueryL = lens uriQuery (\a b -> a { uriQuery = b}) {-# INLINE uriQueryL #-} {-# DEPRECATED uriQueryL "Use 'queryL' instead" #-} ------------------------------------------------------------------------------- uriFragmentL :: Lens' URI (Maybe ByteString) uriFragmentL = lens uriFragment (\a b -> a { uriFragment = b}) {-# INLINE uriFragmentL #-} {-# DEPRECATED uriFragmentL "Use 'fragmentL' instead" #-} ------------------------------------------------------------------------------- rrAuthorityL :: Lens' RelativeRef (Maybe Authority) rrAuthorityL = lens rrAuthority (\a b -> a { rrAuthority = b}) {-# INLINE rrAuthorityL #-} {-# DEPRECATED rrAuthorityL "Use 'authorityL' instead" #-} ------------------------------------------------------------------------------- rrPathL :: Lens' RelativeRef ByteString rrPathL = lens rrPath (\a b -> a { rrPath = b}) {-# INLINE rrPathL #-} {-# DEPRECATED rrPathL "Use 'pathL' instead" #-} ------------------------------------------------------------------------------- rrQueryL :: Lens' RelativeRef Query rrQueryL = lens rrQuery (\a b -> a { rrQuery = b}) {-# INLINE rrQueryL #-} {-# DEPRECATED rrQueryL "Use 'queryL' instead" #-} ------------------------------------------------------------------------------- rrFragmentL :: Lens' RelativeRef (Maybe ByteString) rrFragmentL = lens rrFragment (\a b -> a { rrFragment = b}) {-# INLINE rrFragmentL #-} {-# DEPRECATED rrFragmentL "Use 'fragmentL' instead" #-} ------------------------------------------------------------------------------- uriSchemeL :: Lens' (URIRef Absolute) Scheme uriSchemeL = lens uriScheme setter where setter :: URIRef Absolute -> Scheme -> URIRef Absolute setter (URI _ b c d e) a' = URI a' b c d e {-# INLINE uriSchemeL #-} ------------------------------------------------------------------------------- authorityL :: Lens' (URIRef a) (Maybe Authority) authorityL = lens getter setter where getter :: URIRef a -> Maybe Authority getter (URI {..}) = uriAuthority getter (RelativeRef {..}) = rrAuthority setter :: URIRef a -> Maybe Authority -> URIRef a setter (URI a _ c d e) b' = URI a b' c d e setter (RelativeRef _ c d e) b' = RelativeRef b' c d e {-# INLINE authorityL #-} ------------------------------------------------------------------------------- pathL :: Lens' (URIRef a) ByteString pathL = lens getter setter where getter :: URIRef a -> ByteString getter (URI {..}) = uriPath getter (RelativeRef {..}) = rrPath setter :: URIRef a -> ByteString -> URIRef a setter (URI a b _ d e) c' = URI a b c' d e setter (RelativeRef b _ d e) c' = RelativeRef b c' d e {-# INLINE pathL #-} ------------------------------------------------------------------------------- queryL :: Lens' (URIRef a) Query queryL = lens getter setter where getter :: URIRef a -> Query getter (URI {..}) = uriQuery getter (RelativeRef {..}) = rrQuery setter :: URIRef a -> Query -> URIRef a setter (URI a b c _ e) d' = URI a b c d' e setter (RelativeRef b c _ e) d' = RelativeRef b c d' e {-# INLINE queryL #-} ------------------------------------------------------------------------------- fragmentL :: Lens' (URIRef a) (Maybe ByteString) fragmentL = lens getter setter where getter :: URIRef a -> Maybe ByteString getter (URI {..}) = uriFragment getter (RelativeRef {..}) = rrFragment setter :: URIRef a -> Maybe ByteString -> URIRef a setter (URI a b c d _) e' = URI a b c d e' setter (RelativeRef b c d _) e' = RelativeRef b c d e' {-# INLINE fragmentL #-} ------------------------------------------------------------------------------- upoValidQueryCharL :: Lens' URIParserOptions (Word8 -> Bool) upoValidQueryCharL = lens upoValidQueryChar (\a b -> a { upoValidQueryChar = b}) {-# INLINE upoValidQueryCharL #-} ------------------------------------------------------------------------------- -- Lens machinery ------------------------------------------------------------------------------- -- Unexported type aliases to clean up the documentation 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 ------------------------------------------------------------------------------- lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) {-# INLINE lens #-} uri-bytestring-0.3.2.1/src/URI/ByteString/Types.hs0000644000000000000000000001520013317713050020006 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} #ifdef LIFT_COMPAT {-# LANGUAGE TemplateHaskell #-} #else {-# LANGUAGE DeriveLift #-} #endif module URI.ByteString.Types where ------------------------------------------------------------------------------- import Data.ByteString (ByteString) import qualified Data.Map.Strict as M import Data.Monoid import Data.Semigroup (Semigroup) import Data.Typeable import Data.Word import GHC.Generics import Instances.TH.Lift() ------------------------------------------------------------------------------- import Prelude ------------------------------------------------------------------------------- #ifdef LIFT_COMPAT import Language.Haskell.TH.Syntax() import Language.Haskell.TH.Lift #else import Language.Haskell.TH.Syntax #endif -- | Required first component to referring to a specification for the -- remainder of the URI's components, e.g. "http" or "https" newtype Scheme = Scheme { schemeBS :: ByteString } deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''Scheme #else deriving instance Lift Scheme #endif ------------------------------------------------------------------------------- newtype Host = Host { hostBS :: ByteString } deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''Host #else deriving instance Lift Host #endif ------------------------------------------------------------------------------- -- | While some libraries have chosen to limit this to a Word16, the -- spec only specifies that the string be comprised of digits. newtype Port = Port { portNumber :: Int } deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''Port #else deriving instance Lift Port #endif ------------------------------------------------------------------------------- data UserInfo = UserInfo { uiUsername :: ByteString , uiPassword :: ByteString } deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''UserInfo #else deriving instance Lift UserInfo #endif ------------------------------------------------------------------------------- data Authority = Authority { authorityUserInfo :: Maybe UserInfo , authorityHost :: Host , authorityPort :: Maybe Port } deriving (Show, Eq, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''Authority #else deriving instance Lift Authority #endif ------------------------------------------------------------------------------- newtype Query = Query { queryPairs :: [(ByteString, ByteString)] } deriving (Show, Eq, Semigroup, Monoid, Generic, Typeable, Ord) #ifdef LIFT_COMPAT deriveLift ''Query #else deriving instance Lift Query #endif ------------------------------------------------------------------------------- data Absolute deriving(Typeable) #ifdef LIFT_COMPAT deriveLift ''Absolute #else deriving instance Lift Absolute #endif ------------------------------------------------------------------------------- data Relative deriving(Typeable) #ifdef LIFT_COMPAT deriveLift ''Relative #else deriving instance Lift Relative #endif ------------------------------------------------------------------------------- -- | Note: URI fragment does not include the # data URIRef a where URI :: { uriScheme :: Scheme , uriAuthority :: Maybe Authority , uriPath :: ByteString , uriQuery :: Query , uriFragment :: Maybe ByteString } -> URIRef Absolute RelativeRef :: { rrAuthority :: Maybe Authority , rrPath :: ByteString , rrQuery :: Query , rrFragment :: Maybe ByteString } -> URIRef Relative deriving instance Show (URIRef a) deriving instance Eq (URIRef a) -- deriving instance Generic (URIRef a) deriving instance Ord (URIRef a) #ifdef LIFT_COMPAT deriveLift ''URIRef #else deriving instance Lift (URIRef a) #endif #ifdef WITH_TYPEABLE deriving instance Typeable URIRef #endif ------------------------------------------------------------------------------- type URI = URIRef Absolute ------------------------------------------------------------------------------- type RelativeRef = URIRef Relative ------------------------------------------------------------------------------- -- | Options for the parser. You will probably want to use either -- "strictURIParserOptions" or "laxURIParserOptions" data URIParserOptions = URIParserOptions { upoValidQueryChar :: Word8 -> Bool } ------------------------------------------------------------------------------- data URINormalizationOptions = URINormalizationOptions { unoDowncaseScheme :: Bool -- ^ hTtP -> http , unoDowncaseHost :: Bool -- ^ eXaMpLe.org -> example.org , unoDropDefPort :: Bool -- ^ If the scheme is known and the port is the default (e.g. 80 for http) it is removed. , unoSlashEmptyPath :: Bool -- ^ If the path is empty, set it to \/ , unoDropExtraSlashes :: Bool -- ^ Rewrite path from \/foo\/\/bar\/\/\/baz to \/foo\/bar\/baz , unoSortParameters :: Bool -- ^ Sorts parameters by parameter name , unoRemoveDotSegments :: Bool -- ^ Remove dot segments as per , unoDefaultPorts :: M.Map Scheme Port -- ^ Map of known schemes to their default ports. Used when 'unoDropDefPort' is enabled. } deriving (Show, Eq) ------------------------------------------------------------------------------- -- | URI Parser Types ------------------------------------------------------------------------------- data SchemaError = NonAlphaLeading -- ^ Scheme must start with an alphabet character | InvalidChars -- ^ Subsequent characters in the schema were invalid | MissingColon -- ^ Schemas must be followed by a colon deriving (Show, Eq, Read, Generic, Typeable) ------------------------------------------------------------------------------- data URIParseError = MalformedScheme SchemaError | MalformedUserInfo | MalformedQuery | MalformedFragment | MalformedHost | MalformedPort | MalformedPath | OtherError String -- ^ Catchall for unpredictable errors deriving (Show, Eq, Generic, Read, Typeable) uri-bytestring-0.3.2.1/src/URI/ByteString/Internal.hs0000644000000000000000000011476413317713050020475 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module URI.ByteString.Internal where ------------------------------------------------------------------------------- import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as BB import qualified Blaze.ByteString.Builder.Char.Utf8 as BB import Control.Applicative import Control.Monad import qualified Control.Monad.Fail as F import Data.Attoparsec.ByteString import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Char8 as A (decimal) import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Char (ord, toLower) import Data.Ix import Data.List (delete, intersperse, sortBy, stripPrefix, (\\)) import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid as Monoid import Data.Ord (comparing) import Data.Semigroup (Semigroup) import Data.Word import Text.Read (readMaybe) ------------------------------------------------------------------------------- import URI.ByteString.Types ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- | Strict URI Parser config. Follows RFC3986 as-specified. Use this -- if you can be certain that your URIs are properly encoded or if you -- want parsing to fail if they deviate from the spec at all. strictURIParserOptions :: URIParserOptions strictURIParserOptions = URIParserOptions { upoValidQueryChar = validForQuery } ------------------------------------------------------------------------------- -- | Lax URI Parser config. Use this if you you want to handle common -- deviations from the spec gracefully. -- -- * Allows non-encoded [ and ] in query string laxURIParserOptions :: URIParserOptions laxURIParserOptions = URIParserOptions { upoValidQueryChar = validForQueryLax } ------------------------------------------------------------------------------- -- | All normalization options disabled noNormalization :: URINormalizationOptions noNormalization = URINormalizationOptions False False False False False False False httpDefaultPorts ------------------------------------------------------------------------------- -- | The set of known default ports to schemes. Currently only -- contains http\/80 and https\/443. Feel free to extend it if needed -- with 'unoDefaultPorts'. httpDefaultPorts :: M.Map Scheme Port httpDefaultPorts = M.fromList [ (Scheme "http", Port 80) , (Scheme "https", Port 443) ] ------------------------------------------------------------------------------- -- | Only normalizations deemed appropriate for all protocols by -- RFC3986 enabled, namely: -- -- * Downcase Scheme -- * Downcase Host -- * Remove Dot Segments rfc3986Normalization :: URINormalizationOptions rfc3986Normalization = noNormalization { unoDowncaseScheme = True , unoDowncaseHost = True , unoRemoveDotSegments = True } ------------------------------------------------------------------------------- -- | The same as 'rfc3986Normalization' but with additional enabled -- features if you're working with HTTP URIs: -- -- * Drop Default Port (with 'httpDefaultPorts') -- * Drop Extra Slashes httpNormalization :: URINormalizationOptions httpNormalization = rfc3986Normalization { unoDropDefPort = True , unoSlashEmptyPath = True } ------------------------------------------------------------------------------- -- | All options enabled aggressiveNormalization :: URINormalizationOptions aggressiveNormalization = URINormalizationOptions True True True True True True True httpDefaultPorts ------------------------------------------------------------------------------- -- | @toAbsolute scheme ref@ converts @ref@ to an absolute URI. -- If @ref@ is already absolute, then it is unchanged. toAbsolute :: Scheme -> URIRef a -> URIRef Absolute toAbsolute scheme (RelativeRef {..}) = URI scheme rrAuthority rrPath rrQuery rrFragment toAbsolute _ uri@(URI {..}) = uri ------------------------------------------------------------------------------- -- | URI Serializer ------------------------------------------------------------------------------- -- | Serialize a URI reference into a 'Builder'. -- -- Example of serializing + converting to a lazy "Data.ByteString.Lazy.ByteString": -- -- >>> BB.toLazyByteString $ serializeURIRef $ URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar","baz")]}, uriFragment = Just "quux"} -- "http://www.example.org/foo?bar=baz#quux" serializeURIRef :: URIRef a -> Builder serializeURIRef = normalizeURIRef noNormalization ------------------------------------------------------------------------------- -- | Like 'serializeURIRef', with conversion into a strict 'ByteString'. serializeURIRef' :: URIRef a -> ByteString serializeURIRef' = BB.toByteString . serializeURIRef ------------------------------------------------------------------------------- -- | Serialize a URI into a Builder. serializeURI :: URIRef Absolute -> Builder serializeURI = normalizeURIRef noNormalization {-# DEPRECATED serializeURI "Use 'serializeURIRef' instead" #-} ------------------------------------------------------------------------------- -- | Similar to 'serializeURIRef' but performs configurable degrees of -- URI normalization. If your goal is the fastest serialization speed -- possible, 'serializeURIRef' will be fine. If you intend on -- comparing URIs (say for caching purposes), you'll want to use this. normalizeURIRef :: URINormalizationOptions -> URIRef a -> Builder normalizeURIRef o uri@(URI {..}) = normalizeURI o uri normalizeURIRef o uri@(RelativeRef {}) = normalizeRelativeRef o Nothing uri ------------------------------------------------------------------------------- normalizeURIRef' :: URINormalizationOptions -> URIRef a -> ByteString normalizeURIRef' o = BB.toByteString . normalizeURIRef o ------------------------------------------------------------------------------- normalizeURI :: URINormalizationOptions -> URIRef Absolute -> Builder normalizeURI o@URINormalizationOptions {..} URI {..} = scheme <> BB.fromString ":" <> normalizeRelativeRef o (Just uriScheme) rr where scheme = bs (sCase (schemeBS uriScheme)) sCase | unoDowncaseScheme = downcaseBS | otherwise = id rr = RelativeRef uriAuthority uriPath uriQuery uriFragment ------------------------------------------------------------------------------- normalizeRelativeRef :: URINormalizationOptions -> Maybe Scheme -> URIRef Relative -> Builder normalizeRelativeRef o@URINormalizationOptions {..} mScheme RelativeRef {..} = authority <> path <> query <> fragment where path | unoSlashEmptyPath && BS.null rrPath = BB.fromByteString "/" | segs == [""] = BB.fromByteString "/" | otherwise = mconcat (intersperse (c8 '/') (map urlEncodePath segs)) segs = dropSegs (BS.split slash (pathRewrite rrPath)) pathRewrite | unoRemoveDotSegments = removeDotSegments | otherwise = id dropSegs [] = [] dropSegs (h:t) | unoDropExtraSlashes = h:(filter (not . BS.null) t) | otherwise = h:t authority = maybe Monoid.mempty (serializeAuthority o mScheme) rrAuthority query = serializeQuery o rrQuery fragment = maybe mempty (\s -> c8 '#' <> bs s) rrFragment ------------------------------------------------------------------------------- --TODO: this is probably ripe for benchmarking -- | Algorithm described in -- , reproduced -- artlessly. removeDotSegments :: ByteString -> ByteString removeDotSegments path = mconcat (rl2L (go path (RL []))) where go inBuf outBuf -- A. If the input buffer begins with prefix of ../ or ./ then -- remove the prefix from the input buffer | BS8.isPrefixOf "../" inBuf = go (BS8.drop 3 inBuf) outBuf | BS8.isPrefixOf "./" inBuf = go (BS8.drop 2 inBuf) outBuf -- B. If the input buffer begins with a prefix of "/./" or "/.", -- where "." is a complete path segment, then replace that -- prefix with "/" in the input buffer. TODO: I think "a -- complete path segment" means its the whole thing? | BS.isPrefixOf "/./" inBuf = go (BS8.drop 2 inBuf) outBuf | inBuf == "/." = go "/" outBuf -- C. If the input buffer begins with a prefix of "/../" or -- "/..", where ".." is a complete path segment, then replace -- that prefix with "/" in the input buffer and remove the last -- segment and its preceding "/" (if any) from the output buffer | BS.isPrefixOf "/../" inBuf = go (BS8.drop 3 inBuf) (unsnoc (unsnoc outBuf)) | inBuf == "/.." = go "/" (unsnoc (unsnoc outBuf)) -- D. If the input buffer consists only of "." or "..", then -- remove that from the input buffer | inBuf == "." = go mempty outBuf | inBuf == ".." = go mempty outBuf -- E. Move the first path segment in the input buffer to the end -- of the output buffer, including the initial "/" character (if -- any) and any subsequent characters up to, but not including, -- the next "/" character or the end of the input buffer. | otherwise = case BS8.uncons inBuf of Just ('/', rest) -> let (thisSeg, inBuf') = BS8.span (/= '/') rest in go inBuf' (outBuf |> "/" |> thisSeg) Just (_, _) -> let (thisSeg, inBuf') = BS8.span (/= '/') inBuf in go inBuf' (outBuf |> thisSeg) Nothing -> outBuf ------------------------------------------------------------------------------- -- | Like 'serializeURI', with conversion into a strict 'ByteString'. serializeURI' :: URIRef Absolute -> ByteString serializeURI' = BB.toByteString . serializeURI {-# DEPRECATED serializeURI' "Use 'serializeURIRef'' instead" #-} ------------------------------------------------------------------------------- -- | Like 'serializeURI', but do not render scheme. serializeRelativeRef :: URIRef Relative -> Builder serializeRelativeRef = normalizeRelativeRef noNormalization Nothing {-# DEPRECATED serializeRelativeRef "Use 'serializeURIRef' instead" #-} ------------------------------------------------------------------------------- -- | Like 'serializeRelativeRef', with conversion into a strict 'ByteString'. serializeRelativeRef' :: URIRef Relative -> ByteString serializeRelativeRef' = BB.toByteString . serializeRelativeRef {-# DEPRECATED serializeRelativeRef' "Use 'serializeURIRef'' instead" #-} ------------------------------------------------------------------------------- serializeQuery :: URINormalizationOptions -> Query -> Builder serializeQuery _ (Query []) = mempty serializeQuery URINormalizationOptions {..} (Query ps) = c8 '?' <> mconcat (intersperse (c8 '&') (map serializePair ps')) where serializePair (k, v) = urlEncodeQuery k <> c8 '=' <> urlEncodeQuery v ps' | unoSortParameters = sortBy (comparing fst) ps | otherwise = ps ------------------------------------------------------------------------------- serializeAuthority :: URINormalizationOptions -> Maybe Scheme -> Authority -> Builder serializeAuthority URINormalizationOptions {..} mScheme Authority {..} = BB.fromString "//" <> userinfo <> bs host <> port where userinfo = maybe mempty serializeUserInfo authorityUserInfo host = hCase (hostBS authorityHost) hCase | unoDowncaseHost = downcaseBS | otherwise = id port = maybe mempty packPort effectivePort effectivePort = do p <- authorityPort dropPort mScheme p packPort (Port p) = c8 ':' <> BB.fromString (show p) dropPort Nothing = Just dropPort (Just scheme) | unoDropDefPort = dropPort' scheme | otherwise = Just dropPort' s p | M.lookup s unoDefaultPorts == Just p = Nothing | otherwise = Just p ------------------------------------------------------------------------------- serializeUserInfo :: UserInfo -> Builder serializeUserInfo UserInfo {..} = bs uiUsername <> c8 ':' <> bs uiPassword <> c8 '@' ------------------------------------------------------------------------------- bs :: ByteString -> Builder bs = BB.fromByteString ------------------------------------------------------------------------------- c8 :: Char -> Builder c8 = BB.fromChar ------------------------------------------------------------------------------- -- | Parse a strict ByteString into a URI or an error. -- -- Example: -- -- >>> parseURI strictURIParserOptions "http://www.example.org/foo?bar=baz#quux" -- Right (URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar","baz")]}, uriFragment = Just "quux"}) -- -- >>> parseURI strictURIParserOptions "$$$$://badurl.example.org" -- Left (MalformedScheme NonAlphaLeading) -- -- There are some urls that you'll encounter which defy the spec, such -- as those with square brackets in the query string. If you must be -- able to parse those, you can use "laxURIParserOptions" or specify your own -- -- >>> parseURI strictURIParserOptions "http://www.example.org/foo?bar[]=baz" -- Left MalformedQuery -- -- >>> parseURI laxURIParserOptions "http://www.example.org/foo?bar[]=baz" -- Right (URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar[]","baz")]}, uriFragment = Nothing}) -- -- >>> let myLaxOptions = URIParserOptions { upoValidQueryChar = liftA2 (||) (upoValidQueryChar strictURIParserOptions) (inClass "[]")} -- >>> parseURI myLaxOptions "http://www.example.org/foo?bar[]=baz" -- Right (URI {uriScheme = Scheme {schemeBS = "http"}, uriAuthority = Just (Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.example.org"}, authorityPort = Nothing}), uriPath = "/foo", uriQuery = Query {queryPairs = [("bar[]","baz")]}, uriFragment = Nothing}) parseURI :: URIParserOptions -> ByteString -> Either URIParseError (URIRef Absolute) parseURI opts = parseOnly' OtherError (uriParser' opts) -- | Like 'parseURI', but do not parse scheme. parseRelativeRef :: URIParserOptions -> ByteString -> Either URIParseError (URIRef Relative) parseRelativeRef opts = parseOnly' OtherError (relativeRefParser' opts) ------------------------------------------------------------------------------- -- | Convenience alias for a parser that can return URIParseError type URIParser = Parser' URIParseError ------------------------------------------------------------------------------- -- | Underlying attoparsec parser. Useful for composing with your own parsers. uriParser :: URIParserOptions -> Parser (URIRef Absolute) uriParser = unParser' . uriParser' ------------------------------------------------------------------------------- -- | Toplevel parser for URIs uriParser' :: URIParserOptions -> URIParser (URIRef Absolute) uriParser' opts = do scheme <- schemeParser void $ word8 colon `orFailWith` MalformedScheme MissingColon RelativeRef authority path query fragment <- relativeRefParser' opts return $ URI scheme authority path query fragment ------------------------------------------------------------------------------- -- | Underlying attoparsec parser. Useful for composing with your own parsers. relativeRefParser :: URIParserOptions -> Parser (URIRef Relative) relativeRefParser = unParser' . relativeRefParser' ------------------------------------------------------------------------------- -- | Toplevel parser for relative refs relativeRefParser' :: URIParserOptions -> URIParser (URIRef Relative) relativeRefParser' opts = do (authority, path) <- hierPartParser <|> rrPathParser query <- queryParser opts frag <- mFragmentParser case frag of Just _ -> endOfInput `orFailWith` MalformedFragment Nothing -> endOfInput `orFailWith` MalformedQuery return $ RelativeRef authority path query frag ------------------------------------------------------------------------------- -- | Parser for scheme, e.g. "http", "https", etc. schemeParser :: URIParser Scheme schemeParser = do c <- satisfy isAlpha `orFailWith` MalformedScheme NonAlphaLeading rest <- A.takeWhile isSchemeValid `orFailWith` MalformedScheme InvalidChars return $ Scheme $ c `BS.cons` rest where isSchemeValid = inClass $ "-+." ++ alphaNum ------------------------------------------------------------------------------- -- | Hier part immediately follows the schema and encompasses the -- authority and path sections. hierPartParser :: URIParser (Maybe Authority, ByteString) hierPartParser = authWithPathParser <|> pathAbsoluteParser <|> pathRootlessParser <|> pathEmptyParser ------------------------------------------------------------------------------- -- | Relative references have awkward corner cases. See -- 'firstRelRefSegmentParser'. rrPathParser :: URIParser (Maybe Authority, ByteString) rrPathParser = (Nothing,) <$> ((<>) <$> firstRelRefSegmentParser <*> pathParser) ------------------------------------------------------------------------------- -- | See the "authority path-abempty" grammar in the RFC authWithPathParser :: URIParser (Maybe Authority, ByteString) authWithPathParser = string' "//" *> ((,) <$> mAuthorityParser <*> pathParser) ------------------------------------------------------------------------------- -- | See the "path-absolute" grammar in the RFC. Essentially a special -- case of rootless. pathAbsoluteParser :: URIParser (Maybe Authority, ByteString) pathAbsoluteParser = string' "/" *> pathRootlessParser ------------------------------------------------------------------------------- -- | See the "path-rootless" grammar in the RFC. pathRootlessParser :: URIParser (Maybe Authority, ByteString) pathRootlessParser = (,) <$> pure Nothing <*> pathParser1 ------------------------------------------------------------------------------- -- | See the "path-empty" grammar in the RFC. Must not be followed -- with a path-valid char. pathEmptyParser :: URIParser (Maybe Authority, ByteString) pathEmptyParser = do nextChar <- peekWord8 `orFailWith` OtherError "impossible peekWord8 error" case nextChar of Just c -> guard (notInClass pchar c) >> return emptyCase _ -> return emptyCase where emptyCase = (Nothing, mempty) ------------------------------------------------------------------------------- -- | Parser whe mAuthorityParser :: URIParser (Maybe Authority) mAuthorityParser = mParse authorityParser ------------------------------------------------------------------------------- -- | Parses the user info section of a URL (i.e. for HTTP Basic -- Authentication). Note that this will decode any percent-encoded -- data. userInfoParser :: URIParser UserInfo userInfoParser = (uiTokenParser <* word8 atSym) `orFailWith` MalformedUserInfo where atSym = 64 uiTokenParser = do ui <- A.takeWhile1 validForUserInfo let (user, passWithColon) = BS.break (== colon) $ urlDecode' ui let pass = BS.drop 1 passWithColon return $ UserInfo user pass validForUserInfo = inClass $ pctEncoded ++ subDelims ++ (':' : unreserved) ------------------------------------------------------------------------------- -- | Authority consists of host and port authorityParser :: URIParser Authority authorityParser = Authority <$> mParse userInfoParser <*> hostParser <*> mPortParser ------------------------------------------------------------------------------- -- | Parser that can handle IPV6/Future literals, IPV4, and domain names. hostParser :: URIParser Host hostParser = (Host <$> parsers) `orFailWith` MalformedHost where parsers = ipLiteralParser <|> ipV4Parser <|> regNameParser ipLiteralParser = word8 oBracket *> (ipVFutureParser <|> ipV6Parser) <* word8 cBracket ------------------------------------------------------------------------------- -- | Parses IPV6 addresses. See relevant section in RFC. ipV6Parser :: Parser ByteString ipV6Parser = do leading <- h16s elided <- maybe [] (const [""]) <$> optional (string "::") trailing <- many (A.takeWhile (/= colon) <* word8 colon) (finalChunkLen, final) <- finalChunk let len = length (leading ++ trailing) + finalChunkLen when (len > 8) $ fail "Too many digits in IPv6 address" return $ rejoin $ [rejoin leading] ++ elided ++ trailing ++ maybeToList final where finalChunk = fromMaybe (0, Nothing) <$> optional (finalIpV4 <|> finalH16) finalH16 = (1, ) . Just <$> h16 finalIpV4 = (2, ) . Just <$> ipV4Parser rejoin = BS.intercalate ":" h16s = h16 `sepBy` word8 colon h16 = mconcat <$> parseBetween 1 4 (A.takeWhile1 hexDigit) ------------------------------------------------------------------------------- -- | Parses IPVFuture addresses. See relevant section in RFC. ipVFutureParser :: Parser ByteString ipVFutureParser = do _ <- word8 lowercaseV ds <- A.takeWhile1 hexDigit _ <- word8 period rest <- A.takeWhile1 $ inClass $ subDelims ++ ":" ++ unreserved return $ "v" <> ds <> "." <> rest where lowercaseV = 118 ------------------------------------------------------------------------------- -- | Parses a valid IPV4 address ipV4Parser :: Parser ByteString ipV4Parser = mconcat <$> sequence [ decOctet , dot , decOctet , dot , decOctet , dot , decOctet] where decOctet :: Parser ByteString decOctet = do (s,num) <- A.match A.decimal let len = BS.length s guard $ len <= 3 guard $ num >= (1 :: Int) && num <= 255 return s dot = string "." ------------------------------------------------------------------------------- -- | This corresponds to the hostname, e.g. www.example.org regNameParser :: Parser ByteString regNameParser = urlDecode' <$> A.takeWhile1 (inClass validForRegName) where validForRegName = pctEncoded ++ subDelims ++ unreserved ------------------------------------------------------------------------------- -- | Only parse a port if the colon signifier is there. mPortParser :: URIParser (Maybe Port) mPortParser = word8' colon `thenJust` portParser ------------------------------------------------------------------------------- -- | Parses port number from the hostname. Colon separator must be -- handled elsewhere. portParser :: URIParser Port portParser = (Port <$> A.decimal) `orFailWith` MalformedPort ------------------------------------------------------------------------------- -- | Path with any number of segments pathParser :: URIParser ByteString pathParser = pathParser' A.many' ------------------------------------------------------------------------------- -- | Path with at least 1 segment pathParser1 :: URIParser ByteString pathParser1 = pathParser' A.many1' ------------------------------------------------------------------------------- -- | Parses the path section of a url. Note that while this can take -- percent-encoded characters, it does not itself decode them while parsing. pathParser' :: (Parser ByteString -> Parser [ByteString]) -> URIParser ByteString pathParser' repeatParser = (urlDecodeQuery . mconcat <$> repeatParser segmentParser) `orFailWith` MalformedPath where segmentParser = mconcat <$> sequence [string "/", A.takeWhile (inClass pchar)] ------------------------------------------------------------------------------- -- | Parses the first segment of a path section of a relative-path -- reference. See RFC 3986, Section 4.2. -- firstRelRefSegmentParser :: URIParser ByteString firstRelRefSegmentParser :: URIParser ByteString firstRelRefSegmentParser = A.takeWhile (inClass (pchar \\ ":")) `orFailWith` MalformedPath ------------------------------------------------------------------------------- -- | This parser is being a bit pragmatic. The query section in the -- spec does not identify the key/value format used in URIs, but that -- is what most users are expecting to see. One alternative could be -- to just expose the query string as a string and offer functions on -- URI to parse a query string to a Query. queryParser :: URIParserOptions -> URIParser Query queryParser opts = do mc <- peekWord8 `orFailWith` OtherError "impossible peekWord8 error" case mc of Just c | c == question -> skip' 1 *> itemsParser | c == hash -> pure mempty | otherwise -> fail' MalformedPath _ -> pure mempty where itemsParser = Query . filter neQuery <$> A.sepBy' (queryItemParser opts) (word8' ampersand) neQuery (k, _) = not (BS.null k) ------------------------------------------------------------------------------- -- | When parsing a single query item string like "foo=bar", turns it -- into a key/value pair as per convention, with the value being -- optional. & separators need to be handled further up. queryItemParser :: URIParserOptions -> URIParser (ByteString, ByteString) queryItemParser opts = do s <- A.takeWhile (upoValidQueryChar opts) `orFailWith` MalformedQuery if BS.null s then return (mempty, mempty) else do let (k, vWithEquals) = BS.break (== equals) s let v = BS.drop 1 vWithEquals return (urlDecodeQuery k, urlDecodeQuery v) ------------------------------------------------------------------------------- validForQuery :: Word8 -> Bool validForQuery = inClass ('?':'/':delete '&' pchar) ------------------------------------------------------------------------------- validForQueryLax :: Word8 -> Bool validForQueryLax = notInClass "&#" ------------------------------------------------------------------------------- -- | Only parses a fragment if the # signifiier is there mFragmentParser :: URIParser (Maybe ByteString) mFragmentParser = mParse $ word8' hash *> fragmentParser ------------------------------------------------------------------------------- -- | The final piece of a uri, e.g. #fragment, minus the #. fragmentParser :: URIParser ByteString fragmentParser = Parser' $ A.takeWhile validFragmentWord where validFragmentWord = inClass ('?':'/':pchar) ------------------------------------------------------------------------------- -- | Grammar Components ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- hexDigit :: Word8 -> Bool hexDigit = inClass "0-9a-fA-F" ------------------------------------------------------------------------------- isAlpha :: Word8 -> Bool isAlpha = inClass alpha ------------------------------------------------------------------------------- isDigit :: Word8 -> Bool isDigit = inClass digit ------------------------------------------------------------------------------- pchar :: String pchar = pctEncoded ++ subDelims ++ ":@" ++ unreserved ------------------------------------------------------------------------------- -- Very important! When concatenating this to other strings to make larger -- character classes, you must put this at the end because the '-' character -- is treated as a range unless it's at the beginning or end. unreserved :: String unreserved = alphaNum ++ "~._-" ------------------------------------------------------------------------------- unreserved8 :: [Word8] unreserved8 = map ord8 unreserved ------------------------------------------------------------------------------- unreservedPath8 :: [Word8] unreservedPath8 = unreserved8 ++ map ord8 ":@&=+$," ------------------------------------------------------------------------------- ord8 :: Char -> Word8 ord8 = fromIntegral . ord ------------------------------------------------------------------------------- -- | pc-encoded technically is % HEXDIG HEXDIG but that's handled by -- the previous alphaNum constraint. May need to double back with a -- parser to ensure pct-encoded never exceeds 2 hexdigs after pctEncoded :: String pctEncoded = "%" ------------------------------------------------------------------------------- subDelims :: String subDelims = "!$&'()*+,;=" ------------------------------------------------------------------------------- alphaNum :: String alphaNum = alpha ++ digit ------------------------------------------------------------------------------- alpha :: String alpha = "a-zA-Z" ------------------------------------------------------------------------------- digit :: String digit = "0-9" ------------------------------------------------------------------------------- colon :: Word8 colon = 58 ------------------------------------------------------------------------------- oBracket :: Word8 oBracket = 91 ------------------------------------------------------------------------------- cBracket :: Word8 cBracket = 93 ------------------------------------------------------------------------------- equals :: Word8 equals = 61 ------------------------------------------------------------------------------- question :: Word8 question = 63 ------------------------------------------------------------------------------- ampersand :: Word8 ampersand = 38 ------------------------------------------------------------------------------- hash :: Word8 hash = 35 ------------------------------------------------------------------------------- period :: Word8 period = 46 ------------------------------------------------------------------------------- slash :: Word8 slash = 47 ------------------------------------------------------------------------------- -- | ByteString Utilities ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- | Decoding specifically for the query string, which decodes + as -- space. Shorthand for @urlDecode True@ urlDecodeQuery :: ByteString -> ByteString urlDecodeQuery = urlDecode plusToSpace where plusToSpace = True ------------------------------------------------------------------------------- -- | Decode any part of the URL besides the query, which decodes + as -- space. urlDecode' :: ByteString -> ByteString urlDecode' = urlDecode plusToSpace where plusToSpace = False ------------------------------------------------------------------------------- -- | Parsing with Strongly-Typed Errors ------------------------------------------------------------------------------- -- | A parser with a specific error type. Attoparsec unfortunately -- throws all errors into strings, which cannot be handled well -- programmatically without doing something silly like parsing error -- messages. This wrapper attempts to concentrate these errors into -- one type. newtype Parser' e a = Parser' { unParser' :: Parser a} deriving ( Functor , Applicative , Alternative , Monad , MonadPlus , Semigroup , Monoid) instance F.MonadFail (Parser' e) where #if MIN_VERSION_attoparsec(0,13,1) fail e = Parser' (F.fail e) #else fail e = Parser' (fail e) #endif ------------------------------------------------------------------------------- -- | Use with caution. Catch a parser failing and return Nothing. mParse :: Parser' e a -> Parser' e (Maybe a) mParse p = option Nothing (Just <$> p) ------------------------------------------------------------------------------- -- | If the first parser succeeds, discard the result and use the -- second parser (which may fail). If the first parser fails, return -- Nothing. This is used to check a benign precondition that indicates -- the presence of a parsible token, i.e. ? preceding a query. thenJust :: Parser' e a -> Parser' e b -> Parser' e (Maybe b) thenJust p1 p2 = p1 *> (Just <$> p2) <|> pure Nothing ------------------------------------------------------------------------------- -- | Lift a word8 Parser into a strongly error typed parser. This will -- generate a "stringy" error message if it fails, so you should -- probably be prepared to exit with a nicer error further up. word8' :: Word8 -> Parser' e Word8 word8' = Parser' . word8 ------------------------------------------------------------------------------- -- | Skip exactly 1 character. Fails if the character isn't -- there. Generates a "stringy" error. skip' :: Int -> Parser' e () skip' = Parser' . void . A.take ------------------------------------------------------------------------------- -- | Lifted version of the string token parser. Same caveats about -- "stringy" errors apply. string' :: ByteString -> Parser' e ByteString string' = Parser' . string ------------------------------------------------------------------------------- -- | Combinator for tunnelling more specific error types through the -- attoparsec machinery using read/show. orFailWith :: (Show e) => Parser a -> e -> Parser' e a orFailWith p e = Parser' p <|> fail' e ------------------------------------------------------------------------------- -- | Should be preferred to fail' fail' :: (Show e) => e -> Parser' e a fail' = fail . show ------------------------------------------------------------------------------- parseBetween :: (Alternative m, Monad m) => Int -> Int -> m a -> m [a] parseBetween a b f = choice parsers where parsers = map (`count` f) $ reverse $ range (a, b) ------------------------------------------------------------------------------- -- | Stronger-typed variation of parseOnly'. Consumes all input. parseOnly' :: (Read e) => (String -> e) -- ^ Fallback if we can't parse a failure message for the sake of totality. -> Parser' e a -> ByteString -> Either e a parseOnly' noParse (Parser' p) = fmapL readWithFallback . parseOnly p where readWithFallback s = fromMaybe (noParse s) (readMaybe . stripAttoparsecGarbage $ s) ------------------------------------------------------------------------------- -- | Our pal Control.Monad.fail is how attoparsec propagates -- errors. If you throw an error string with fail (your only choice), -- it will *always* prepend it with "Failed reading: ". At least in -- this version. That may change to something else and break this workaround. stripAttoparsecGarbage :: String -> String stripAttoparsecGarbage = stripPrefix' "Failed reading: " ------------------------------------------------------------------------------- -- | stripPrefix where it is a noop if the prefix doesn't exist. stripPrefix' :: Eq a => [a] -> [a] -> [a] stripPrefix' pfx s = fromMaybe s $ stripPrefix pfx s ------------------------------------------------------------------------------- fmapL :: (a -> b) -> Either a r -> Either b r fmapL f = either (Left . f) Right ------------------------------------------------------------------------------- -- | This function was extracted from the @http-types@ package. The -- license can be found in licenses/http-types/LICENSE urlDecode :: Bool -- ^ Whether to decode '+' to ' ' -> BS.ByteString -> BS.ByteString urlDecode replacePlus z = fst $ BS.unfoldrN (BS.length z) go z where go bs' = case BS.uncons bs' of Nothing -> Nothing Just (43, ws) | replacePlus -> Just (32, ws) -- plus to space Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent (x, xs) <- BS.uncons ws x' <- hexVal x (y, ys) <- BS.uncons xs y' <- hexVal y Just (combine x' y', ys) Just (w, ws) -> Just (w, ws) hexVal w | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9 | 65 <= w && w <= 70 = Just $ w - 55 -- A - F | 97 <= w && w <= 102 = Just $ w - 87 -- a - f | otherwise = Nothing combine :: Word8 -> Word8 -> Word8 combine a b = shiftL a 4 .|. b ------------------------------------------------------------------------------- --TODO: keep an eye on perf here. seems like a good use case for a DList. the word8 list could be a set/hashset -- | Percent-encoding for URLs. Specify a list of additional -- unreserved characters to permit. urlEncode :: [Word8] -> ByteString -> Builder urlEncode extraUnreserved = mconcat . map encodeChar . BS.unpack where encodeChar ch | unreserved' ch = BB.fromWord8 ch | otherwise = h2 ch unreserved' ch | ch >= 65 && ch <= 90 = True -- A-Z | ch >= 97 && ch <= 122 = True -- a-z | ch >= 48 && ch <= 57 = True -- 0-9 unreserved' c = c `elem` extraUnreserved h2 v = let (a, b) = v `divMod` 16 in bs $ BS.pack [37, h a, h b] -- percent (%) h i | i < 10 = 48 + i -- zero (0) | otherwise = 65 + i - 10 -- 65: A ------------------------------------------------------------------------------- -- | Encode a ByteString for use in the query section of a URL urlEncodeQuery :: ByteString -> Builder urlEncodeQuery = urlEncode unreserved8 ------------------------------------------------------------------------------- -- | Encode a ByteString for use in the path section of a URL urlEncodePath :: ByteString -> Builder urlEncodePath = urlEncode unreservedPath8 ------------------------------------------------------------------------------- downcaseBS :: ByteString -> ByteString downcaseBS = BS8.map toLower ------------------------------------------------------------------------------- -- | Simple data structure to get O(1) prepends on a list and defers the O(n) newtype RL a = RL [a] deriving (Show) (|>) :: RL a -> a -> RL a RL as |> a = RL (a:as) rl2L :: RL a -> [a] rl2L (RL as) = reverse as unsnoc :: RL a -> RL a unsnoc (RL []) = RL [] unsnoc (RL (_:xs)) = RL xs uri-bytestring-0.3.2.1/test/Main.hs0000644000000000000000000000104313317713050015225 0ustar0000000000000000module Main (main) where ------------------------------------------------------------------------------- import Test.Tasty ------------------------------------------------------------------------------- import qualified URI.ByteStringTests import qualified URI.ByteStringQQTests ------------------------------------------------------------------------------- main :: IO () main = defaultMain testSuite testSuite :: TestTree testSuite = testGroup "uri-bytestring" [ URI.ByteStringTests.tests , URI.ByteStringQQTests.tests ] uri-bytestring-0.3.2.1/test/URI/ByteString/Arbitrary.hs0000644000000000000000000000632613317713050021042 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module URI.ByteString.Arbitrary where ------------------------------------------------------------------------------- import Control.Applicative import Data.Proxy (Proxy (..)) import qualified Generics.SOP as SOP import qualified Generics.SOP.Constraint as SOP import qualified Generics.SOP.GGP as SOP import GHC.Generics (Generic) import Test.QuickCheck import Test.QuickCheck.Instances () ------------------------------------------------------------------------------- import Prelude ------------------------------------------------------------------------------- import URI.ByteString ------------------------------------------------------------------------------- -- this workaround can go away when -- is merged. sopArbitrary :: ( SOP.SListI (SOP.GCode b) , Generic b , SOP.GTo b , SOP.AllF SOP.SListI (SOP.GCode b) , SOP.AllF (SOP.All Arbitrary) (SOP.GCode b) ) => Gen b sopArbitrary = fmap SOP.gto sopArbitrary' sopArbitrary' :: (SOP.SListI xs, SOP.AllF (SOP.All Arbitrary) xs, SOP.AllF SOP.SListI xs) => Gen (SOP.SOP SOP.I xs) sopArbitrary' = oneof (map SOP.hsequence $ SOP.apInjs_POP $ SOP.hcpure p arbitrary) where p :: Proxy Arbitrary p = Proxy instance Arbitrary UserInfo where arbitrary = UserInfo <$> arbitrary <*> arbitrary instance Arbitrary Authority where arbitrary = Authority <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary Host where arbitrary = Host <$> arbitrary instance Arbitrary Port where arbitrary = Port <$> arbitrary instance Arbitrary (URIRef Absolute) where arbitrary = URI <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary (URIRef Relative) where arbitrary = RelativeRef <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary Scheme where arbitrary = Scheme <$> arbitrary instance Arbitrary Query where arbitrary = Query <$> arbitrary instance Arbitrary URIParserOptions where arbitrary = URIParserOptions <$> arbitrary instance Arbitrary URINormalizationOptions where arbitrary = URINormalizationOptions <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary SchemaError where arbitrary = sopArbitrary shrink = genericShrink instance Arbitrary URIParseError where arbitrary = sopArbitrary shrink = genericShrink uri-bytestring-0.3.2.1/test/URI/ByteStringTests.hs0000644000000000000000000004302313317713050020121 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module URI.ByteStringTests (tests) where ------------------------------------------------------------------------------- import Control.Applicative (Const (..)) import qualified Blaze.ByteString.Builder as BB import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 import Data.Either import Data.Function.Compat ((&)) import Data.Functor.Identity (Identity (..)) import qualified Data.Map.Strict as M import Data.Monoid import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck ------------------------------------------------------------------------------- import Prelude ------------------------------------------------------------------------------- import URI.ByteString import URI.ByteString.Arbitrary () ------------------------------------------------------------------------------- import URI.ByteStringQQTests () infixr 4 .~ (.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t (.~) l b s = runIdentity (l (const (Identity b)) s) infixl ^. (^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a s ^. l = getConst (l Const s) tests :: TestTree tests = testGroup "URI.Bytestring" [ parseUriTests , uriParseErrorInstancesTests , lensTests , serializeURITests , normalizeURITests ] ------------------------------------------------------------------------------- parseUriTests :: TestTree parseUriTests = testGroup "parseUri" [ testParses "http://www.example.org/" $ URI (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "/" mempty Nothing , testParseHost "http://www.example.org" "www.example.org" -- IPV4 , testParseHost "http://192.168.1.1" "192.168.1.1" -- IPV6 , testParseHost "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]" "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210" , testParseHost "http://[1080:0:0:0:8:800:200C:417A]" "1080:0:0:0:8:800:200C:417A" , testParseHost "http://[3ffe:2a00:100:7031::1]" "3ffe:2a00:100:7031::1" , testParseHost "http://[::192.9.5.5]" "::192.9.5.5" , testParseHost "http://[::FFFF:129.144.52.38]" "::FFFF:129.144.52.38" , testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179" , testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179" -- IPVFuture , testParseHost "http://[v1.fe80::a+en1]" "v1.fe80::a+en1" , testParses "https://user:pass:wo%20rd@www.example.org?foo=bar&foo=baz+quux#frag" $ URI (Scheme "https") (Just (Authority (Just (UserInfo "user" "pass:wo rd")) (Host "www.example.org") Nothing)) "" (Query [("foo", "bar"), ("foo", "baz quux")]) (Just "frag") -- trailing & , testParses "http://www.example.org?foo=bar&" $ URI (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [("foo", "bar")]) Nothing , testParses "http://www.google.com:80/aclk?sa=l&ai=CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw&sig=AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ&rct=j&q=&ved=0CCUQ0Qw&adurl=http://www.aruba.com/where-to-stay/hotels-and-resorts%3Ftid%3D122" URI { uriScheme = Scheme {schemeBS = "http"} , uriAuthority = Just Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.google.com"}, authorityPort = Just (Port 80)} , uriPath = "/aclk" , uriQuery = Query {queryPairs = [("sa", "l") ,("ai", "CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw") ,("sig", "AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ") ,("rct", "j") ,("q", "") ,("ved", "0CCUQ0Qw") ,("adurl", "http://www.aruba.com/where-to-stay/hotels-and-resorts?tid=122") ]} , uriFragment = Nothing } , testParseFailure "$$$$://www.example.org/" (MalformedScheme NonAlphaLeading) , testParses "http://www.example.org/foo#bar" $ URI (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "/foo" mempty (Just "bar") , testParses "http://www.example.org/foo#" $ URI (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "/foo" mempty (Just "") , testParseFailure "http://www.example.org/foo#bar#baz" MalformedFragment , testParseFailure "https://www.example.org?listParam[]=foo,bar" MalformedQuery , testParsesLax "https://www.example.org?listParam[]=foo,bar" $ URI (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [("listParam[]", "foo,bar")]) Nothing , testParses "https://www.example.org?listParam%5B%5D=foo,bar" $ URI (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query [("listParam[]", "foo,bar")]) Nothing , testParses "https://www.example.org#only-fragment" $ URI (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "" (Query []) (Just "only-fragment") , testParses "https://www.example.org/weird%20path" $ URI (Scheme "https") (Just (Authority Nothing (Host "www.example.org") Nothing)) "/weird path" (Query []) Nothing , parseTestURI strictURIParserOptions "http://www.example.org/." $ Right $ URI (Scheme "http") (Just (Authority Nothing (Host "www.example.org") Nothing)) "/." (Query []) Nothing , parseTestURI strictURIParserOptions "http:/." $ Right $ URI (Scheme "http") Nothing "/." (Query []) Nothing , roundtripTestURI strictURIParserOptions "ftp://ftp.is.co.za/rfc/rfc1808.txt" , roundtripTestURI strictURIParserOptions "http://www.ietf.org/rfc/rfc2396.txt" , roundtripTestURI strictURIParserOptions "mailto:John.Doe@example.com" , roundtripTestURI strictURIParserOptions "news:comp.infosystems.www.servers.unix" , roundtripTestURI strictURIParserOptions "tel:+1-816-555-1212" , roundtripTestURI strictURIParserOptions "telnet://192.0.2.16:80/" -- RFC 3986, Section 4.2 , parseTestRelativeRef strictURIParserOptions "verysimple" $ Right $ RelativeRef Nothing "verysimple" (Query []) Nothing , parseTestRelativeRef strictURIParserOptions "this:that/thap/sub?1=2" $ Left $ MalformedPath , parseTestRelativeRef strictURIParserOptions "./this:that/thap/sub?1=2" $ Right $ RelativeRef Nothing "./this:that/thap/sub" (Query [("1", "2")]) Nothing ] ------------------------------------------------------------------------------- uriParseErrorInstancesTests :: TestTree uriParseErrorInstancesTests = testGroup "URIParseError instances" [ testProperty "roundtrips between Show and Read" $ \(e :: URIParseError) -> read (show e) == e ] ------------------------------------------------------------------------------- lensTests :: TestTree lensTests = testGroup "lenses" [ testProperty "schemeBSL Lens" $ \bs bs' -> let wrapped = Scheme bs in (wrapped ^. schemeBSL) === schemeBS wrapped .&&. (wrapped & schemeBSL .~ bs') === wrapped { schemeBS = bs'} , testProperty "hostBSL Lens" $ \bs bs' -> let wrapped = Host bs in (wrapped ^. hostBSL) === hostBS wrapped .&&. (wrapped & hostBSL .~ bs') === wrapped { hostBS = bs'} , testProperty "portNumberL Lens" $ \n n' -> let wrapped = Port n in (wrapped ^. portNumberL) === portNumber wrapped .&&. (wrapped & portNumberL .~ n') === wrapped { portNumber = n'} , testProperty "queryPairsL Lens" $ \ps ps' -> let wrapped = Query ps in wrapped ^. queryPairsL === queryPairs wrapped .&&. (wrapped & queryPairsL .~ ps') === wrapped { queryPairs = ps'} , testProperty "authorityUserInfoL Lens" $ \a ui -> (a ^. authorityUserInfoL === authorityUserInfo a) .&&. ((a & authorityUserInfoL .~ ui) === a { authorityUserInfo = ui }) , testProperty "authorityHostL Lens" $ \a host -> (a ^. authorityHostL === authorityHost a) .&&. ((a & authorityHostL .~ host) === a { authorityHost = host }) , testProperty "authorityPortL Lens" $ \a port -> (a ^. authorityPortL === authorityPort a) .&&. ((a & authorityPortL .~ port) === a { authorityPort = port }) , testProperty "uiUsernameL Lens" $ \ui bs -> (ui ^. uiUsernameL === uiUsername ui) .&&. ((ui & uiUsernameL .~ bs) === ui { uiUsername = bs }) , testProperty "uiPasswordL Lens" $ \ui bs -> (ui ^. uiPasswordL === uiPassword ui) .&&. ((ui & uiPasswordL .~ bs) === ui { uiPassword = bs }) , testProperty "uriSchemeL Lens" $ \uri x -> (uri ^. uriSchemeL === uriScheme uri) .&&. ((uri & uriSchemeL .~ x) === uri { uriScheme = x }) , testProperty "authorityL Lens on URI" $ \uri x -> (uri ^. authorityL === uriAuthority uri) .&&. ((uri & authorityL .~ x) === uri { uriAuthority = x }) , testProperty "pathL Lens on URI" $ \uri x -> (uri ^. pathL === uriPath uri) .&&. ((uri & pathL .~ x) === uri { uriPath = x }) , testProperty "queryL Lens on URI" $ \uri x -> (uri ^. queryL === uriQuery uri) .&&. ((uri & queryL .~ x) === uri { uriQuery = x }) , testProperty "fragmentL Lens on URI" $ \uri x -> (uri ^. fragmentL === uriFragment uri) .&&. ((uri & fragmentL .~ x) === uri { uriFragment = x }) , testProperty "authorityL Lens on relative ref" $ \rr x -> (rr ^. authorityL === rrAuthority rr) .&&. ((rr & authorityL .~ x) === rr { rrAuthority = x }) , testProperty "pathL Lens on relative ref" $ \rr x -> (rr ^. pathL === rrPath rr) .&&. ((rr & pathL .~ x) === rr { rrPath = x }) , testProperty "queryL Lens on relative ref" $ \rr x -> (rr ^. queryL === rrQuery rr) .&&. ((rr & queryL .~ x) === rr { rrQuery = x }) , testProperty "fragmentL Lens on relative ref" $ \rr x -> (rr ^. fragmentL === rrFragment rr) .&&. ((rr & fragmentL .~ x) === rr { rrFragment = x }) ] ------------------------------------------------------------------------------- testParses :: ByteString -> URI -> TestTree testParses = testParses' strictURIParserOptions ------------------------------------------------------------------------------- testParseHost :: ByteString -> ByteString -> TestTree testParseHost uri expectedHost = testParses uri $ URI (Scheme "http") (Just (Authority Nothing (Host expectedHost) Nothing)) mempty mempty Nothing ------------------------------------------------------------------------------- testParsesLax :: ByteString -> URI -> TestTree testParsesLax = testParses' laxURIParserOptions ------------------------------------------------------------------------------- testParses' :: URIParserOptions -> ByteString -> URI -> TestTree testParses' opts s u = testGroup "testParses'" [ parseTestURI opts s $ Right u , parseTestRelativeRef opts (makeRelativeRefBS s) $ Right (makeRelativeRefTyped u) ] ------------------------------------------------------------------------------- makeRelativeRefTyped :: URI -> RelativeRef makeRelativeRefTyped (URI _ a p q f) = RelativeRef a p q f ------------------------------------------------------------------------------- makeRelativeRefBS :: ByteString -> ByteString makeRelativeRefBS s = B8.tail x where (_, x) = B8.break (==':') s ------------------------------------------------------------------------------- testParseFailure :: ByteString -> URIParseError -> TestTree testParseFailure s = parseTestURI strictURIParserOptions s . Left ------------------------------------------------------------------------------- parseTestURI :: URIParserOptions -> ByteString -> Either URIParseError URI -> TestTree parseTestURI opts s r = testCase (B8.unpack s) $ parseURI opts s @?= r ------------------------------------------------------------------------------- roundtripTestURI :: URIParserOptions -> ByteString -> TestTree roundtripTestURI opts s = testCase (B8.unpack s) $ (parseURI opts s >>= return . serializeURIRef') @?= Right s ------------------------------------------------------------------------------- parseTestRelativeRef :: URIParserOptions -> ByteString -> Either URIParseError RelativeRef -> TestTree parseTestRelativeRef opts s r = testCase (B8.unpack s) $ parseRelativeRef opts s @?= r ------------------------------------------------------------------------------- serializeURITests :: TestTree serializeURITests = testGroup "serializeURIRef" [ testCase "renders userinfo correctly" $ do let ui = UserInfo "user" "pass" let uri = URI (Scheme "http") (Just (Authority (Just ui) (Host "www.example.org") (Just port))) "/" (Query [("foo", "bar")]) (Just "somefragment") let res = BB.toLazyByteString (serializeURIRef uri) res @?= "http://user:pass@www.example.org:123/?foo=bar#somefragment" , testCase "encodes decoded paths" $ do let uri = URI (Scheme "http") (Just (Authority Nothing (Host "www.example.org") (Just port))) "/weird path" (Query []) Nothing let res = BB.toLazyByteString (serializeURIRef uri) res @?= "http://www.example.org:123/weird%20path" , testCase "encodes relative refs" $ do let ui = UserInfo "user" "pass" let uri = RelativeRef (Just (Authority (Just ui) (Host "www.example.org") (Just port))) "/" (Query [("foo", "bar")]) (Just "somefragment") let res = BB.toLazyByteString (serializeURIRef uri) res @?= "//user:pass@www.example.org:123/?foo=bar#somefragment" ] where port = Port 123 ------------------------------------------------------------------------------- normalizeURITests :: TestTree normalizeURITests = testGroup "normalization" [ testCase "downcase schema" $ do normalizeURIBS o { unoDowncaseScheme = True } "hTtP://example.org" @?= "http://example.org" , testCase "downcase host" $ do normalizeURIBS o { unoDowncaseHost = True } "http://ExAmPlE.org" @?= "http://example.org" , testCase "drop default port http" $ do normalizeURIBS o { unoDropDefPort = True } "http://example.org:80" @?= "http://example.org" , testCase "drop default port https" $ do normalizeURIBS o { unoDropDefPort = True } "https://example.org:443" @?= "https://example.org" , testCase "drop default port no port" $ do normalizeURIBS o { unoDropDefPort = True } "http://example.org" @?= "http://example.org" , testCase "drop default port nondefault" $ do normalizeURIBS o { unoDropDefPort = True } "http://example.org:8000" @?= "http://example.org:8000" , testCase "drop default unknown schema" $ do normalizeURIBS o { unoDropDefPort = True } "bogus://example.org:9999" @?= "bogus://example.org:9999" , testCase "user-extensable port defaulting hit" $ do normalizeURIBS o { unoDropDefPort = True , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } "ftp://example.org:21" @?= "ftp://example.org" , testCase "user-extensable port defaulting off" $ do normalizeURIBS o { unoDropDefPort = False , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } "ftp://example.org:21" @?= "ftp://example.org:21" , testCase "user-extensable port defaulting miss" $ do normalizeURIBS o { unoDropDefPort = True , unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21) } "http://example.org:80" @?= "http://example.org:80" , testCase "slash empty path" $ do normalizeURIBS o { unoSlashEmptyPath = True } "http://example.org" @?= "http://example.org/" , testCase "slash empty path with nonempty path" $ do normalizeURIBS o { unoSlashEmptyPath = True } "http://example.org/foo/bar" @?= "http://example.org/foo/bar" , testCase "drop redundant slashes" $ do normalizeURIBS o { unoDropExtraSlashes = True } "http://example.org/foo//bar///baz" @?= "http://example.org/foo/bar/baz" , testCase "sort params" $ do normalizeURIBS o { unoSortParameters = True } "http://example.org/foo?zulu=1&charlie=&alpha=1" @?= "http://example.org/foo?alpha=1&charlie=&zulu=1" , testCase "remove dot segments" $ do normalizeURIBS o { unoRemoveDotSegments = True } "http://example.org/a/b/c/./../../g" @?= "http://example.org/a/g" , testCase "percent encoding is upcased automatically" $ do normalizeURIBS o "http://example.org/a?foo%3abar=baz" @?= "http://example.org/a?foo%3Abar=baz" , testCase "aggressive normalization retains slashes (issue 41)" $ do normalizeURIBS aggressiveNormalization "http://example.org/" @?= "http://example.org/" ] where o = noNormalization normalizeURIBS opts bs = let Right x = parseURI laxURIParserOptions bs in normalizeURIRef' opts x uri-bytestring-0.3.2.1/test/URI/ByteStringQQTests.hs0000644000000000000000000000206213317713050020361 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module URI.ByteStringQQTests (tests) where ------------------------------------------------------------------------------- import Test.Tasty import Test.Tasty.HUnit ------------------------------------------------------------------------------- import URI.ByteString import URI.ByteString.QQ ------------------------------------------------------------------------------- quasiTest :: URI quasiTest = [uri|https://stackage.org/foo?bar=baz#quux|] quasiRelTest :: RelativeRef quasiRelTest = [relativeRef|/foo?bar=baz#quux|] tests :: TestTree tests = testGroup "URI.ByteString.QQ" [ testCase "uri quasi quoter produces expected RelativeRef" $ do quasiTest @?= URI (Scheme "https") (Just (Authority Nothing (Host "stackage.org") Nothing)) "/foo" (Query [("bar", "baz")]) (Just "quux") , testCase "relativeRef quasi quoter produces expected RelativeRef" $ do quasiRelTest @?= RelativeRef Nothing "/foo" (Query [("bar", "baz")]) (Just "quux") ] uri-bytestring-0.3.2.1/bench/Main.hs0000644000000000000000000000547513317713050015342 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where ------------------------------------------------------------------------------- import Blaze.ByteString.Builder import Control.DeepSeq import Criterion.Main import Data.String import qualified Network.URI as NU ------------------------------------------------------------------------------- import URI.ByteString ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- instance NFData Authority instance NFData Host instance NFData UserInfo instance NFData SchemaError instance NFData URIParseError instance NFData Scheme instance NFData Port instance NFData Query instance NFData (URIRef a) where rnf (URI a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e rnf (RelativeRef b c d e) = rnf b `seq` rnf c `seq` rnf d `seq` rnf e ------------------------------------------------------------------------------- main :: IO () main = defaultMain [ bgroup "parsing" [ bench "Network.URI.parseURI" $ nf NU.parseURI exampleURIS , bench "URI.ByteString.parseURI strict" $ nf (parseURI strictURIParserOptions) exampleURIS , bench "URI.ByteString.parseURI lax" $ nf (parseURI laxURIParserOptions) exampleURIS , bench "URI.ByteString.parseRelativeRef strict" $ nf (parseRelativeRef strictURIParserOptions) exampleRelativeRefS , bench "URI.ByteString.parseRelativeRef lax" $ nf (parseRelativeRef laxURIParserOptions) exampleRelativeRefS ] , bgroup "serializing" [ bench "URI.ByteString.serializeURIRef on URI" $ nf (toLazyByteString . serializeURIRef) exampleURI , bench "URI.ByteString.serializeURIRef on relative ref" $ nf (toLazyByteString . serializeURIRef) exampleRelativeRef ] ] exampleURIS :: IsString s => s exampleURIS = "http://google.com/example?params=youbetcha" exampleRelativeRefS :: IsString s => s exampleRelativeRefS = "/example?params=youbetcha#17u" exampleURI :: URI exampleURI = URI { uriScheme = Scheme "http" , uriAuthority = Just Authority { authorityUserInfo = Nothing , authorityHost = Host "google.com" , authorityPort = Nothing } , uriPath = "/example" , uriQuery = Query [("params", "youbetcha")] , uriFragment = Nothing } exampleRelativeRef :: RelativeRef exampleRelativeRef = RelativeRef { rrAuthority = Just Authority { authorityUserInfo = Nothing , authorityHost = Host "google.com" , authorityPort = Nothing } , rrPath = "/example" , rrQuery = Query [("params", "youbetcha")] , rrFragment = Nothing } uri-bytestring-0.3.2.1/LICENSE0000644000000000000000000000272113317713050014037 0ustar0000000000000000Copyright (c) 2014, Soostone Inc All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the {organization} nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. uri-bytestring-0.3.2.1/licenses/http-types/LICENSE0000644000000000000000000000304213317713050017762 0ustar0000000000000000Copyright (c) 2011, Aristid Breitkreuz Copyright (c) 2011, Michael Snoyman All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Aristid Breitkreuz nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. uri-bytestring-0.3.2.1/Setup.hs0000644000000000000000000000005613317713050014465 0ustar0000000000000000import Distribution.Simple main = defaultMain uri-bytestring-0.3.2.1/uri-bytestring.cabal0000644000000000000000000000544013357741160017015 0ustar0000000000000000name: uri-bytestring version: 0.3.2.1 synopsis: Haskell URI parsing as ByteStrings description: uri-bytestring aims to be an RFC3986 compliant URI parser that uses efficient ByteStrings for parsing and representing the URI data. license: BSD3 license-files: LICENSE , licenses/http-types/LICENSE author: Doug Beardsley, Michael Xavier maintainer: Michael Xavier copyright: Soostone Inc. category: Web build-type: Simple cabal-version: >=1.16 homepage: https://github.com/Soostone/uri-bytestring bug-reports: https://github.com/Soostone/uri-bytestring/issues Tested-With: GHC == 7.8.4 , GHC == 7.10.1 , GHC == 8.0.2 , GHC == 8.2.1 , GHC == 8.4.1 extra-source-files: README.md CONTRIBUTING.md changelog.md bench/*.hs flag lib-Werror default: False manual: True library exposed-modules: URI.ByteString URI.ByteString.QQ other-modules: URI.ByteString.Lens URI.ByteString.Types URI.ByteString.Internal build-depends: attoparsec >= 0.13.1.0 && < 0.14 , base >= 4.6 && < 5 , bytestring >= 0.9.1 && < 0.11 , blaze-builder >= 0.3.0.0 && < 0.5 , template-haskell >= 2.9 && < 2.15 , th-lift-instances >= 0.1.8 && < 0.2 , containers hs-source-dirs: src default-language: Haskell2010 if impl(ghc >= 7.8) cpp-options: -DWITH_TYPEABLE if !impl(ghc >= 8) cpp-options: -DLIFT_COMPAT build-depends: fail >= 4.9 && < 5, th-lift >= 0.7.5 && < 0.8, semigroups >= 0.16.2.2 && <0.19 if flag(lib-Werror) ghc-options: -Werror ghc-options: -Wall test-suite test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: URI.ByteString.Arbitrary URI.ByteStringTests URI.ByteStringQQTests hs-source-dirs: test build-depends: uri-bytestring , HUnit , QuickCheck , tasty , tasty-hunit , tasty-quickcheck , attoparsec , base , base-compat >= 0.7.0 , blaze-builder , bytestring , quickcheck-instances , semigroups , transformers , containers , generics-sop >= 0.2 default-language: Haskell2010 if flag(lib-Werror) ghc-options: -Werror ghc-options: -Wall benchmark bench type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench default-language: Haskell2010 build-depends: base , uri-bytestring , criterion , deepseq , deepseq-generics , network-uri >= 2.6.0.3 , bytestring , blaze-builder source-repository head type: git location: git://github.com/Soostone/uri-bytestring.git uri-bytestring-0.3.2.1/README.md0000644000000000000000000000153513317713050014313 0ustar0000000000000000# uri-bytestring [![Build Status](https://travis-ci.org/Soostone/uri-bytestring.svg?branch=master)](https://travis-ci.org/Soostone/uri-bytestring) [![Hackage](https://img.shields.io/hackage/v/uri-bytestring.svg?style=flat)](https://hackage.haskell.org/package/uri-bytestring) Haskell URI parsing as ByteStrings ## Contributors * [Michael Xavier](http://github.com/MichaelXavier) * [Doug Beardsley](http://github.com/mightybyte) * [Ozgun Ataman](http://github.com/ozataman) * [fisx](http://github.com/fisx) * [Timo von Holtz](http://github.com/tvh) * [Brendan Hay](http://github.com/brendanhay) * [k0ral](https://github.com/k0ral) * [Michael Hatfield](https://github.com/mikehat) * [reactormonk](https://github.com/reactormonk) * [Oleg Grenrus](https://github.com/phadej) * [Edward Betts](https://github.com/EdwardBetts) * [clinty](https://github.com/clinty) uri-bytestring-0.3.2.1/CONTRIBUTING.md0000644000000000000000000000131213317713050015256 0ustar0000000000000000# Contribution Guidelines 1. Configure your project with `--enable-tests -flib-Werror`. This will make sure tests get built and will treat all warnings as errors. We are shooting for 0 warnings in this project. 2. If you are considering some major functionality, please run it by us in an issue first so you don't have to do a bunch of work that will get rejected. This project is shooting for very minimal dependencies and compliance with the RFC3986 spec, so we can't include every feature under the sun. 3. Please try to write a test if applicable. 4. Please try to write a benchmark if applicable. 5. If we forget to add you to the Contributors section of the README, please let us know! uri-bytestring-0.3.2.1/changelog.md0000644000000000000000000000371313357741174015321 0ustar00000000000000000.3.2.1 * Loosen upper bounds on template-haskell 0.3.2.0 * Only depend on the fail package when it is needed due to GHC version. 0.3.0.2 * Avoid using OverloadedStrings for Builder. 0.3.0.1 * Fix normalization bug where certain combination of options would fail to add a trailing slash. 0.3.0.0 * Add MonadFail instance. * Correct haddock spelling mistake. 0.2.3.3 * Make buildable on GHC 8.2.1. 0.2.3.2 * Broaden dep on base. 0.2.3.1 * Add `relativeRef` quasi-quoter. 0.2.3.0 * Add `URI.ByteString.QQ` and the `uri` quasiquoter to be able to express statically known to be valid URIs, e.g. `example = [uri|http://www.example.com|]`. Thanks to [reactormonk](https://github.com/reactormonk). 0.2.2.1 * Drop dependency on derive in tests. 0.2.2.0 * Internally use attoparsec's numeric parser. Raise lower bounds on attoparsec. * Allow blank fragments. 0.2.1.2 * Fixed bug introduced at 0.2.1.1 where RelativeRefs would fail to serialize their port numbers. 0.2.1.1 * Add URI normalization features. 0.2.1.0 * Widen dependency on base. 0.2.0.0 * Introduce URIRef, a GADT representation of absolute and relative URIs. 0.1.9.2 * Fix bug wher trailing ampersand in the query section would not parse. 0.1.9 * Fix type bug in serializeRelativeRef' 0.1.8 * Fix bug where uri-encoded paths would not decode when parsed. 0.1.7 * Add bytestring serialization functions. This is a common use case and exporting these prevents the user from directly depending on blaze-builder and re-implementing these functions in every application. 0.1.6 * Add Ord instances 0.1.5 * Fix serialization bug where userinfo was not including the @ separator. 0.1.4 * Bump attoparsec bounds 0.1.3 * Include test modules in distribution 0.1.2 * Add support for GHC 7.10 0.1.1 * Switch to blaze-bytestring for less contentious dependencies 0.1 * Add generic lenses (breaking field name changes). * Add support for relative refs. * Make Query instance of Generic, Typeable. 0.0.1 * Initial release.