packages feed

dormouse-uri (empty) → 0.1.0.0

raw patch · 22 files changed

+1689/−0 lines, 22 filesdep +attoparsecdep +basedep +bytestring

Dependencies added: attoparsec, base, bytestring, case-insensitive, containers, hedgehog, hspec, hspec-discover, hspec-hedgehog, http-types, safe-exceptions, scientific, template-haskell, text, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for dormouse++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Phil Curzon (c) 2020-2021++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 Phil Curzon 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.
+ README.md view
@@ -0,0 +1,75 @@+# Dormouse-Uri++Dormouse-Uri provides type safe handling of `Uri`s and `Url`s.++`Uri` sytax is well defined according to [RFC 3986](https://tools.ietf.org/html/rfc3986), Dormouse-Uri parses and encodes `Uri`s according to the syntax defined in this document.++We define `Url` as an absolute URI associated with web resources, the current version of Dormouse-Uri restricts `Url`s to the `http` and `https` schemes.++Dormouse-Uri has the following features:++ - The `Uri`/`Url` data types use `Data.Text` internally, this allows you to freely include percent-decoded characters which will be properly rendered when the `Url`/`Uri` is encoded.+ - Quasiquoters to allow safe construction of `Uri`/`Url`s from string literals.+ - `DataKinds` allow `Url`s to be restricted to the `http` or `https` schemes are the type level.+ - A UrlBuilder syntax to allow type-safe construction/concatenation of `Url`s from their components, e.g. path and query parameters.++ ## Constructing Uris++ ```haskell+{-# LANGUAGE QuasiQuotes #-}++import Dormouse.Uri+import Dormouse.Uri.QQ++telUri :: Uri+telUri = [uri|tel:+1-816-555-1212|]++mailtoUri :: Uri+mailtoUri = [uri|mailto:John.Doe@example.com|]++httpUri :: Uri+httpUri = [uri|http://haskell.org|]+ ```++ ## Constructing Urls++You can construct Urls using the helper QuasiQuoters:++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}++import Dormouse.Url+import Dormouse.Url.QQ++githubHttpsUrl :: Url "https"+githubHttpsUrl = [https|https://github.com|]++githubHttpUrl :: Url "http"+githubHttpUrl = [http|http://github.com|]++githubAnyUrl :: AnyUrl+githubAnyUrl = [url|http://github.com|]+```++You can use the Url Builder syntax to modify an existing Url safely to include paths, adding the import:++```haskell+import Dormouse.Url.Builder+```++To allow:++```haskell+dormouseHttpsUrl :: Url "https"+dormouseHttpsUrl = githubHttpsUrl </> "TheInnerLight" </> "dormouse"+```++The Url will be constructed safely so that any characters that wouldn't normally be allowed in a Url path are percent-encoded before the url is resolved by Dormouse.++You can also handle query parameters using similar syntax:++```haskell+searchUrl :: Url "https"+searchUrl = [https|https://google.com|] </> "search" ? "q" =: ("haskell" :: String)+```
+ dormouse-uri.cabal view
@@ -0,0 +1,121 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 7c88a7285ad48f5d51d430c58efcedff76ebd29951e6a7cb06ab16b8b38b1909++name:           dormouse-uri+version:        0.1.0.0+synopsis:       Library for type-safe representations of Uri/Urls+description:    Dormouse-Uri provides type safe handling of `Uri`s and `Url`s.+                .+                `Uri` sytax is well defined according to [RFC 3986](https://tools.ietf.org/html/rfc3986), Dormouse-Uri parses and encodes `Uri`s according to the syntax defined in this document.+                .+                We define `Url` as an absolute URI associated with web resources, the current version of Dormouse-Uri restricts `Url`s to the `http` and `https` schemes.+                .+                Dormouse-Uri has the following features:+                .+                  - The `Uri` and `Url` data types use `Data.Text` internally, this allows you to freely include percent-decoded characters which will be properly rendered when the `Url`/`Uri` is encoded.+                  - Quasiquoters to allow safe construction of `Uri`/`Url`s from string literals.+                  - `DataKinds` allow `Url`s to be restricted to the `http` or `https` schemes are the type level.+                  - A UrlBuilder syntax to allow type-safe construction/concatenation of `Url`s from their components, e.g. path and query parameters.+                .+                Please see https://dormouse.io for full documentation.+category:       Web+homepage:       https://dormouse.io/uri.html+bug-reports:    https://github.com/theinnerlight/dormouse/issues+author:         Phil Curzon+maintainer:     phil@novelfs.org+copyright:      2020-2021 Phil Curzon+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md+extra-doc-files:+    README.md++source-repository head+  type: git+  location: https://github.com/theinnerlight/dormouse++library+  exposed-modules:+      Dormouse.Uri.RFC3986+      Dormouse.Uri.Encode+      Dormouse.Uri.Exception+      Dormouse.Url.Builder+      Dormouse.Url.Exception+      Dormouse.Uri.QQ+      Dormouse.Url.QQ+      Dormouse.Uri+      Dormouse.Url+  other-modules:+      Dormouse.Uri.Parser+      Dormouse.Uri.Types+      Dormouse.Url.Class+      Dormouse.Url.Types+      Paths_dormouse_uri+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings MultiParamTypeClasses ScopedTypeVariables FlexibleContexts+  ghc-options: -Wall+  build-depends:+      attoparsec >=0.13.2.4 && <0.14+    , base >=4.7 && <5+    , bytestring >=0.10.8 && <0.11.0+    , case-insensitive >=1.2.1.0 && <2.0.0+    , containers >=0.6.2.1 && <0.7+    , http-types >=0.12.3 && <0.13+    , safe-exceptions >=0.1.7 && <0.2.0+    , template-haskell >=2.15.0 && <3.0.0+    , text >=1.2.3 && <2.0.0+  default-language: Haskell2010++test-suite dormouse-uri-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Dormouse.Uri+      Dormouse.Uri.Encode+      Dormouse.Uri.Exception+      Dormouse.Uri.Parser+      Dormouse.Uri.QQ+      Dormouse.Uri.RFC3986+      Dormouse.Uri.Types+      Dormouse.Url+      Dormouse.Url.Builder+      Dormouse.Url.Class+      Dormouse.Url.Exception+      Dormouse.Url.QQ+      Dormouse.Url.Types+      Dormouse.Generators.UriComponents+      Dormouse.Uri.ParserSpec+      Dormouse.Uri.QQSpec+      Dormouse.Uri.QuerySpec+      Paths_dormouse_uri+  hs-source-dirs:+      src+      test+  default-extensions: OverloadedStrings MultiParamTypeClasses ScopedTypeVariables FlexibleContexts+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      attoparsec >=0.13.2.4 && <0.14+    , base >=4.7 && <5+    , bytestring >=0.10.8 && <0.11.0+    , case-insensitive >=1.2.1.0 && <2.0.0+    , containers >=0.6.2.1 && <0.7+    , hedgehog >=1.0.1 && <2+    , hspec >=2.0.0 && <3+    , hspec-discover >=2.0.0 && <3+    , hspec-hedgehog >=0.0.1.2 && <0.1+    , http-types >=0.12.3 && <0.13+    , safe-exceptions >=0.1.7 && <0.2.0+    , scientific >=0.3.6.2 && <0.4+    , template-haskell >=2.15.0 && <3.0.0+    , text >=1.2.3 && <2.0.0+    , vector >=0.12.0.3 && <0.13+  default-language: Haskell2010
+ src/Dormouse/Uri.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module Dormouse.Uri+  ( module Dormouse.Uri.Types+  , parseUri+  ) where++import Control.Exception.Safe (MonadThrow, throw)+import qualified Data.ByteString as SB+import Data.Attoparsec.ByteString.Char8 (parseOnly)+import qualified Data.Text as T+import Dormouse.Uri.Exception (UriException(..))+import Dormouse.Uri.Parser+import Dormouse.Uri.Types++-- | Parse an ascii 'ByteString' as an absolute uri, throwing a 'UriException' in @m@ if this fails+parseUri :: MonadThrow m => SB.ByteString -> m Uri+parseUri bs = either (throw . UriException . T.pack) return $ parseOnly pUri bs
+ src/Dormouse/Uri/Encode.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}++module Dormouse.Uri.Encode+  ( encodeQuery+  , encodePath+  , encodeUnless+  ) where++import Data.Char (chr)+import Data.Word (Word8)+import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import Dormouse.Uri.Types+import Dormouse.Uri.RFC3986++-- | Percent encode a word8 as an ascii 'Bytestring'+percentEncode :: Word8 -> B.ByteString+percentEncode w = +  let h = w `div` 16+      l = w `mod` 16 in+  B.pack [37, hex h, hex l]+  where +    hex x+     | x < 10    = 48+x+     | otherwise = 55+x++-- | Percent encode all chars in the supplied text except for those which satsify the supplied predicate+encodeUnless :: (Char -> Bool)  -> T.Text -> B.ByteString+encodeUnless isAllowedChar = B.concatMap pEncodeQuery . E.encodeUtf8+  where+    pEncodeQuery :: Word8 -> B.ByteString+    pEncodeQuery c+      | isAllowedChar (chr $ fromEnum c) = B.singleton c+      | otherwise                         = percentEncode c++-- | Generate an ascii `Bytestring` from a supplied Query by percent encoding all of the invalid octets+encodeQuery :: Query -> B.ByteString+encodeQuery = B.append "?" . encodeUnless isQueryChar . unQuery++-- | Generate an ascii `Bytestring` from a supplied Path by percent encoding all of the invalid octets+encodePath :: Path 'Absolute -> B.ByteString+encodePath =  B.append "/" . B.intercalate "/" . fmap (encodeUnless isPathChar . unPathSegment) . unPath
+ src/Dormouse/Uri/Exception.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ExistentialQuantification #-}++module Dormouse.Uri.Exception+  ( UriException(..)+  ) where++import Control.Exception.Safe (Exception(..))+import qualified Data.Text as T++-- | 'UriException' is used to indicate an error parsing a URI+newtype UriException = UriException  { uriExceptionMessage :: T.Text }++instance Show UriException where+  show UriException { uriExceptionMessage = msg } = "Failed to parse uri: " <> T.unpack msg++instance Exception UriException
+ src/Dormouse/Uri/Parser.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}++module Dormouse.Uri.Parser+  ( pUri+  , pAbsoluteUri+  , pRelativeUri+  , pScheme+  , pUsername+  , pPassword+  , pUserInfo+  , pIPv4+  , pRegName+  , pHost+  , pPort+  , pAuthority+  , pPathAbsAuth+  , pPathAbsNoAuth+  , pPathRel+  , pQuery+  , pFragment+  ) where++import Control.Applicative ((<|>))+import Data.Attoparsec.ByteString.Char8 as A+import Data.Char as C+import Data.Bits (Bits, shiftL, (.|.))+import Data.Maybe (isJust)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Dormouse.Uri.Types+import Dormouse.Uri.RFC3986+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8++repack :: String -> T.Text+repack = TE.decodeUtf8 . B8.pack++pMaybe :: Parser a -> Parser (Maybe a)+pMaybe p = option Nothing (Just <$> p)++pAsciiAlpha :: Parser Char+pAsciiAlpha = satisfy isAsciiAlpha++pAsciiAlphaNumeric :: Parser Char+pAsciiAlphaNumeric = satisfy isAsciiAlphaNumeric++pSubDelim :: Parser Char+pSubDelim = satisfy isSubDelim++pUnreserved :: Parser Char+pUnreserved = satisfy isUnreserved++pSizedHexadecimal :: (Integral a, Bits a) => Int -> Parser a+pSizedHexadecimal n = do+    bytes <- A.take n+    if B.all isHexDigit' bytes then return $ B.foldl' step 0 $ bytes else fail "pSizedHexadecimal"+  where +    isHexDigit' w = (w >= 48 && w <= 57) ||  (w >= 97 && w <= 102) ||(w >= 65 && w <= 70)+    step a w | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)+             | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)+             | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55)++pPercentEnc :: Parser Char+pPercentEnc = do+  _ <- char '%'+  hexdig1 <- pSizedHexadecimal 1+  hexdig2 <- pSizedHexadecimal 1+  return . chr $ hexdig1 * 16 + hexdig2++pUsername :: Parser Username+pUsername = do+  xs <- many1' (satisfy isUsernameChar <|> pPercentEnc)+  return $ Username (repack xs)++pPassword :: Parser Password+pPassword = do+  xs <- many1' (satisfy isPasswordChar <|> pPercentEnc)+  return $ Password (repack xs)++pRegName :: Parser T.Text+pRegName = do+  xs <- many1' (satisfy isRegNameChar <|> pPercentEnc)+  return . repack $ xs++pIPv4 :: Parser T.Text+pIPv4 = do+  oct1 <- pOctet+  _ <- char '.'+  oct2 <- pOctet+  _ <- char '.'+  oct3 <- pOctet+  _ <- char '.'+  oct4 <- pOctet+  return . T.pack $ show oct1 <> "." <> show oct2 <> "." <> show oct3 <> "." <> show oct4+  where+    pOctet :: Parser Int+    pOctet = decimal >>= \case+      i | i > 255 -> fail "IPv4 Octects must be in range 0-255"+      i           -> return i++pHost :: Parser Host+pHost = do+  hostText <- pIPv4 <|> pRegName+  return . Host  $ hostText++pUserInfo :: Parser UserInfo+pUserInfo = do+  username <- pUsername+  password <- pMaybe (char ':' *> pPassword)+  _ <- char '@'+  return $ UserInfo { userInfoUsername = username, userInfoPassword = password }++pPort :: Parser Int+pPort = +  (char ':' *> decimal) >>= \case+    i | i > 65535 -> fail "Port must be in the range 0-65535"+    i             -> return i++pAuthority :: Parser Authority+pAuthority = do+  _ <- string "//"+  authUserInfo <- pMaybe pUserInfo+  authHost <- pHost+  authPort <- pMaybe pPort+  _ <- peekChar >>= \case+    Nothing                                   -> return ()+    Just c | c == '/' || c == '?' || c == '#' -> return ()+    _                                         -> fail "Invalid authority termination character, must be /, ?, # or end of input"+  return Authority { authorityUserInfo = authUserInfo, authorityHost = authHost, authorityPort = authPort}++pPathChar :: Parser Char +pPathChar = satisfy isPathChar <|> pPercentEnc++pPathCharNc :: Parser Char +pPathCharNc = satisfy isPathCharNoColon <|> pPercentEnc++pSegmentNz :: Parser PathSegment +pSegmentNz = PathSegment . repack <$> many1' pPathChar++pSegmentNzNc :: Parser PathSegment +pSegmentNzNc = PathSegment . repack <$> many1' pPathCharNc++pSegment :: Parser PathSegment+pSegment = PathSegment . repack <$> many' pPathChar++pPathsAbEmpty :: Parser [PathSegment]+pPathsAbEmpty = many1' (char '/' *> pSegment)++pPathsAbsolute :: Parser [PathSegment]+pPathsAbsolute = do+  _ <- char '/'+  seg <- pSegmentNz+  comps <- many' (char '/' *> pSegment)+  return $ seg : comps++pPathsNoScheme :: Parser [PathSegment]+pPathsNoScheme = do+  seg <- pSegmentNzNc+  comps <- many' (char '/' *> pSegment)+  return $ seg : comps++pPathsRootless :: Parser [PathSegment]+pPathsRootless = do+  seg <- pSegmentNz+  comps <- many' (char '/' *> pSegment)+  return $ seg : comps++pPathsEmpty :: Parser [PathSegment]+pPathsEmpty = return []++pPathAbsAuth :: Parser (Path 'Absolute)+pPathAbsAuth = fmap Path (pPathsAbEmpty <|> pPathsAbsolute <|> pPathsEmpty)++pPathAbsNoAuth :: Parser (Path 'Absolute)+pPathAbsNoAuth = fmap Path (pPathsAbsolute <|> pPathsRootless <|> pPathsEmpty)++pPathRel :: Parser (Path 'Relative)+pPathRel = fmap Path (pPathsAbsolute <|> pPathsNoScheme <|> pPathsEmpty)++pQuery :: Parser Query+pQuery = do+  queryText <- (char '?' *> (many1' (satisfy isQueryChar <|> pPercentEnc)))+  _ <- peekChar >>= \case+    Nothing           -> return ()+    Just c | c == '#' -> return ()+    c                 -> fail $ "Invalid query termination character: " <> show c <> ", must be # or end of input"+  return . Query . repack $ queryText++pFragment :: Parser Fragment+pFragment = do+  fragmentText <- (char '#' *> (many1' (satisfy isFragmentChar <|> pPercentEnc)))+  _ <- peekChar >>= \case+    Nothing           -> return ()+    c                 -> fail $ "Invalid fragment termination character: " <> show c <> ", must be end of input"+  return . Fragment . repack $ fragmentText++pScheme :: Parser Scheme+pScheme = do+  x <- pAsciiAlpha+  xs <- many' (pAsciiAlphaNumeric <|> char '+' <|> char '.' <|> char '-' )+  _ <- char ':'+  return $ Scheme (T.toLower . repack $ x:xs)++pAbsolutePart :: Parser (Scheme, Maybe Authority)+pAbsolutePart = do+  scheme <- pScheme+  authority <- pMaybe pAuthority+  return (scheme, authority)++pRelativeUri :: Parser Uri+pRelativeUri = do+  path <- pPathRel+  query <- pMaybe pQuery+  fragment <- pMaybe pFragment+  _ <- endOfInput+  return $ RelativeUri $ RelUri { uriPath = path, uriQuery = query, uriFragment = fragment }++pAbsoluteUri :: Parser Uri+pAbsoluteUri = do+  (scheme, authority) <- pAbsolutePart+  path <- if isJust authority then pPathAbsAuth else pPathAbsNoAuth+  query <- pMaybe pQuery+  fragment <- pMaybe pFragment+  _ <- endOfInput+  return $ AbsoluteUri $ AbsUri {uriScheme = scheme, uriAuthority = authority, uriPath = path, uriQuery = query, uriFragment = fragment }++pUri :: Parser Uri+pUri = pAbsoluteUri <|> pRelativeUri
+ src/Dormouse/Uri/QQ.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}++module Dormouse.Uri.QQ+  ( uri+  ) where+  +import Data.ByteString.Char8 (pack)+import Dormouse.Uri+import Language.Haskell.TH.Quote +import Language.Haskell.TH ++uri :: QuasiQuoter+uri = QuasiQuoter +  { quoteExp = \s -> +      let res = parseUri $ pack s in+      case res of+        Left err -> fail $ show err+        Right x -> [| x :: Uri |]+  , quotePat = \s ->+      case parseUri (pack s) of+        Left err -> fail $ show err+        Right x  -> appE [|(==)|] [| (x :: Uri) |] `viewP` [p|True|]+  , quoteType = error "Not supported"+  , quoteDec =error "Not supported"+  }
+ src/Dormouse/Uri/RFC3986.hs view
@@ -0,0 +1,74 @@+module Dormouse.Uri.RFC3986+  ( isGenDelim+  , isSubDelim+  , isReserved+  , isAsciiAlpha+  , isAsciiAlphaNumeric+  , isUnreserved+  , isSchemeChar+  , isUsernameChar+  , isPasswordChar+  , isRegNameChar+  , isPathChar+  , isPathCharNoColon+  , isQueryChar+  , isFragmentChar+  ) where++import Data.Char as C++-- | Checks whether a char belongs to the gen-delims in RFC3986 +isGenDelim :: Char -> Bool+isGenDelim c = c == ':' || c == '/' || c == '?' || c == '#' || c == '[' || c == ']' || c == '@'++-- | Checks whether a char belongs to the sub-delims in RFC3986 +isSubDelim :: Char -> Bool+isSubDelim c = c == '!' || c == '$' || c == '&' || c == '\'' || c == '(' || c == ')' || c == '*' || c == '+' || c == ',' || c == ';' || c == '='++-- | Checks whether a char belongs to the sub-delims in RFC3986 +isReserved :: Char -> Bool+isReserved c = isGenDelim c || isSubDelim c++-- | Checks whether a char is ascii & alpha+isAsciiAlpha :: Char -> Bool+isAsciiAlpha c = C.isAlpha c && C.isAscii c++-- | Checks whether a char is ascii & alphanumeric+isAsciiAlphaNumeric :: Char -> Bool+isAsciiAlphaNumeric c = C.isAlphaNum c && C.isAscii c++-- | Checks whether a char belongs to the unreserved group in RFC3986 +isUnreserved :: Char -> Bool+isUnreserved c = isAsciiAlphaNumeric c || c == '-' || c == '.' || c == '_' || c == '~'++-- | Checks whether a char is a valid scheme char in RFC3986+isSchemeChar :: Char -> Bool+isSchemeChar c = isAsciiAlphaNumeric c || c == '+' || c == '.' || c == '-'++-- | Checks whether a char is a valid username char in RFC3986+isUsernameChar :: Char -> Bool+isUsernameChar c = isUnreserved c || isSubDelim c++-- | Checks whether a char is a valid password char in RFC3986+isPasswordChar :: Char -> Bool+isPasswordChar c = isUnreserved c || isSubDelim c || c == ':'++-- | Checks whether a char is a valid reg-name char in RFC3986+isRegNameChar :: Char -> Bool+isRegNameChar c = isUnreserved c || isSubDelim c++-- | Checks whether a char is a valid path char in RFC3986+isPathChar :: Char -> Bool+isPathChar c = isUnreserved c || isSubDelim c || c == ':' || c == '@'++-- | Checks whether a char is a valid path char (excluding colons) in RFC3986+isPathCharNoColon :: Char -> Bool+isPathCharNoColon c = isUnreserved c || isSubDelim c || c == '@'++-- | Checks whether a char is a valid query char in RFC3986+isQueryChar :: Char -> Bool+isQueryChar c = isPathChar c || c == '?' || c == '/'++-- | Checks whether a char is a valid fragment char in RFC3986+isFragmentChar :: Char -> Bool+isFragmentChar c = isPathChar c || c == '?' || c == '/'
+ src/Dormouse/Uri/Types.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveLift #-}++module Dormouse.Uri.Types+  ( UriReference(..)+  , Authority(..)+  , Fragment(..)+  , Host(..)+  , Path(..)+  , PathSegment(..)+  , Query(..)+  , Scheme(..)+  , Username(..)+  , Password(..)+  , UserInfo(..)+  , Uri(..)+  , AbsUri(..)+  , RelUri(..)+  ) where++import Data.String (IsString(..))+import qualified Data.List as L+import Data.Text (Text, unpack, pack)+import Language.Haskell.TH.Syntax (Lift(..))++-- | The Username subcomponent of a URI UserInfo+newtype Username = Username { unUsername :: Text } deriving (Eq, Lift)++instance Show Username where+  show username = unpack $ unUsername username++instance IsString Username where+  fromString s = Username $ pack s++-- | The Password subcomponent of a URI UserInfo+newtype Password = Password { unPassword :: Text } deriving (Eq, Lift)++instance Show Password where+  show _ = "****"++instance IsString Password where+  fromString s = Password $ pack s++-- | The UserInfo subcomponent of a URI Authority+data UserInfo = UserInfo +  { userInfoUsername :: Username+  , userInfoPassword :: Maybe Password+  } deriving (Eq, Show, Lift)++-- | The Host subcomponent of a URI Authority+newtype Host = Host { unHost :: Text } deriving (Eq, Lift)++instance IsString Host where+  fromString s = Host $ pack s++instance Show Host where+  show host = unpack $ unHost host++-- | The Authority component of a URI+data Authority = Authority +  { authorityUserInfo :: Maybe UserInfo+  , authorityHost :: Host+  , authorityPort :: Maybe Int+  } deriving (Eq, Show, Lift)++-- | The Fragment component of a URI+newtype Fragment = Fragment { unFragment :: Text } deriving (Eq, Lift)++instance IsString Fragment where+  fromString s = Fragment $ pack s++instance Show Fragment where+  show fragment = unpack $ unFragment fragment++data UriReference = Absolute | Relative++-- | The Path component of a URI, including a series of individual Path Segments+newtype Path (ref :: UriReference) = Path { unPath :: [PathSegment]} deriving (Eq, Lift)++instance Show (Path ref) where+  show path = "[" <> L.intercalate "," (fmap show . unPath $ path) <> "]"++-- | An individial Path segment of a URI+newtype PathSegment = PathSegment { unPathSegment :: Text } deriving (Eq, Lift)++instance IsString PathSegment where+  fromString s = PathSegment $ pack s++instance Show PathSegment where+  show seg = unpack $ unPathSegment seg++-- | The Query component of a URI+newtype Query = Query { unQuery :: Text } deriving (Eq, Lift)++instance IsString Query where+  fromString s = Query $ pack s++instance Show Query where+  show query = unpack $ unQuery query++-- | The Scheme component of a URI+newtype Scheme = Scheme { unScheme :: Text } deriving (Eq, Lift)++instance Show Scheme where+  show scheme = unpack . unScheme $ scheme++-- | The data associated with an Absolute URI+data AbsUri = AbsUri+  { uriScheme :: Scheme+  , uriAuthority :: Maybe Authority+  , uriPath :: Path 'Absolute+  , uriQuery :: Maybe Query+  , uriFragment :: Maybe Fragment+  } deriving (Eq, Show, Lift)++-- | The data associated with a Relative URI+data RelUri = RelUri+  { uriPath :: Path 'Relative+  , uriQuery :: Maybe Query+  , uriFragment :: Maybe Fragment+  } deriving (Eq, Show, Lift)++-- | A Uniform Resource Identifier (URI) is a compact sequence of characters that identifies an abstract or physical resource.+-- It is defined according to RFC 3986 (<https://tools.ietf.org/html/rfc3986>).  URIs can be absolute (i.e. defined against a+-- specific scheme) or relative.+data Uri +  = AbsoluteUri AbsUri+  | RelativeUri RelUri+  deriving (Lift, Eq, Show)++
+ src/Dormouse/Url.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module Dormouse.Url+  ( module Dormouse.Url.Types+  , ensureHttp+  , ensureHttps+  , parseUrl+  , parseHttpUrl+  , parseHttpsUrl+  , IsUrl(..)+  ) where++import Control.Exception.Safe (MonadThrow, throw)+import qualified Data.ByteString as SB+import qualified Data.Text as T+import Dormouse.Url.Exception (UrlException(..))+import Dormouse.Uri+import Dormouse.Url.Class+import Dormouse.Url.Types++-- | Ensure that the supplied Url uses the _http_ scheme, throwing a 'UrlException' in @m@ if this is not the case+ensureHttp :: MonadThrow m => AnyUrl -> m (Url "http")+ensureHttp (AnyUrl (HttpUrl u)) = return $ HttpUrl u+ensureHttp (AnyUrl (HttpsUrl _)) = throw $ UrlException "Supplied url was an https url, not an http url"++-- | Ensure that the supplied Url uses the _https_ scheme, throwing a 'UrlException' in @m@ if this is not the case+ensureHttps :: MonadThrow m => AnyUrl -> m (Url "https")+ensureHttps (AnyUrl (HttpsUrl u)) = return $ HttpsUrl u+ensureHttps (AnyUrl (HttpUrl _)) = throw $ UrlException "Supplied url was an http url, not an https url"++-- | Ensure that the supplied Uri is a Url+ensureUrl :: MonadThrow m => Uri -> m AnyUrl+ensureUrl (AbsoluteUri AbsUri {uriScheme = scheme, uriAuthority = maybeAuthority, uriPath = path, uriQuery = query, uriFragment = fragment}) = do+  authority <- maybe (throw $ UrlException "Supplied Url had no authority component") return maybeAuthority+  case unScheme scheme of+    "http"  -> return $ AnyUrl $ HttpUrl UrlComponents { urlAuthority = authority, urlPath = path, urlQuery = query, urlFragment = fragment }+    "https" -> return $ AnyUrl $ HttpsUrl UrlComponents { urlAuthority = authority, urlPath = path, urlQuery = query, urlFragment = fragment }+    s       -> throw $ UrlException ("Supplied Url had a scheme of " <> T.pack (show s) <> " which was not http or https.")+ensureUrl (RelativeUri _) = throw $ UrlException "Supplied Uri was a relative Uri - it must provide a scheme and authority to be considered a valid url"++-- | Parse an ascii 'ByteString' as a url, throwing a 'UriException' in @m@ if this fails+parseUrl :: MonadThrow m => SB.ByteString -> m AnyUrl+parseUrl bs = do+  url <- parseUri bs+  ensureUrl url+  +-- | Parse an ascii 'ByteString' as an http url, throwing a 'UriException' in @m@ if this fails+parseHttpUrl :: MonadThrow m => SB.ByteString -> m (Url "http")+parseHttpUrl text = do +  anyUrl <- parseUrl text+  ensureHttp anyUrl++-- | Parse an ascii 'ByteString' as an https url, throwing a 'UriException' in @m@ if this fails+parseHttpsUrl :: MonadThrow m => SB.ByteString -> m (Url "https")+parseHttpsUrl text = do +  anyUrl <- parseUrl text+  ensureHttps anyUrl
+ src/Dormouse/Url/Builder.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+  +-- | Provides syntax for incrementally building Urls and components of Urls such as Query strings+module Dormouse.Url.Builder +  ( QueryComponent(..)+  , QueryBuilder(..)+  , IsQueryVal(..)+  ,  (</>)+  , (?)+  , (&)+  , (=:)+  ) where++import Data.Foldable  +import Data.Text (Text)+import Dormouse.Uri.Types+import Dormouse.Url.Types++import qualified Data.Text as T+import qualified Data.Sequence as SQ++-- | An individual Query Parameter or Query Flag+data QueryComponent+  = QueryParam T.Text T.Text+  | QueryFlag T.Text+  deriving (Eq, Show)++-- | Stores a series of Query Parameters or Query Flags used for building the Query component of a URI/URL, for example in the format @?param1=2&param2=3&flag1@+newtype QueryBuilder = QueryBuilder { unQueryBuilder :: SQ.Seq QueryComponent }+  deriving (Eq, Show)++instance Semigroup QueryBuilder where+  x1 <> x2 = QueryBuilder $ unQueryBuilder x1 <> unQueryBuilder x2++instance Monoid QueryBuilder where+  mempty = QueryBuilder SQ.empty++-- | Signifies a type that can be rendered as Query Parameter within a URI+class IsQueryVal a where+  toQueryVal :: a -> T.Text++instance IsQueryVal Bool where toQueryVal = T.pack . show+instance IsQueryVal Char where toQueryVal = T.pack . show+instance IsQueryVal Double where toQueryVal = T.pack . show+instance IsQueryVal Float where toQueryVal = T.pack . show+instance IsQueryVal Int where toQueryVal = T.pack . show+instance IsQueryVal Integer where toQueryVal = T.pack . show+instance IsQueryVal String where toQueryVal = T.pack+instance IsQueryVal T.Text where toQueryVal = id++-- | Combine a Url with a new text path component+(</>) :: Url scheme -> Text -> Url scheme+(</>) (HttpUrl UrlComponents {urlPath = path, .. }) text = HttpUrl $ UrlComponents {urlPath = (Path {unPath = unPath path ++ [PathSegment text] }), ..}+(</>) (HttpsUrl UrlComponents {urlPath = path, .. }) text = HttpsUrl $ UrlComponents {urlPath = (Path {unPath = unPath path ++ [PathSegment text] }), ..}++-- | Convenient alias for '<>' which allows for combining query parameters+(&) :: QueryBuilder -> QueryBuilder -> QueryBuilder+(&) = (<>)++-- | Combine a Url with a some supplied query parameters+(?) :: Url scheme -> QueryBuilder -> Url scheme+(?) uri b = +  case uri of +    HttpUrl  UrlComponents { .. } -> HttpUrl $ UrlComponents { urlQuery = Just $ foldl' folder "" $ unQueryBuilder b  , .. }+    HttpsUrl UrlComponents { .. } -> HttpsUrl $ UrlComponents { urlQuery = Just $ foldl' folder "" $ unQueryBuilder b  , .. }+  where +    folder "" (QueryFlag val)       = Query $ val+    folder "" (QueryParam key val)  = Query $ key <> "=" <> val+    folder acc (QueryFlag val)      = Query $ unQuery acc <> "&" <> val+    folder acc (QueryParam key val) = Query $ unQuery acc <> "&" <> key <> "=" <> val++infixl 8 ?++-- | Generate a query paramter of the form @key=value@+(=:) :: IsQueryVal a => Text -> a -> QueryBuilder+(=:) key value = QueryBuilder . SQ.singleton $ QueryParam key (toQueryVal value)
+ src/Dormouse/Url/Class.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE GADTs #-}++module Dormouse.Url.Class +  ( IsUrl(..)+  ) where++import Dormouse.Url.Types++class (Eq url, Show url) => IsUrl url where+  asAnyUrl :: url -> AnyUrl++instance IsUrl (Url scheme) where+  asAnyUrl = AnyUrl++instance IsUrl AnyUrl where+  asAnyUrl (AnyUrl u) = asAnyUrl u
+ src/Dormouse/Url/Exception.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ExistentialQuantification #-}++module Dormouse.Url.Exception+  ( UrlException(..)+  ) where++import Control.Exception.Safe (Exception(..))+import qualified Data.Text as T++-- | 'UrlException' is used to indicate an error in transforming a valid URI into a URL, e.g. the URI refers to a different schema such as @file@+newtype UrlException = UrlException  { urlExceptionMessage :: T.Text }++instance Show UrlException where+  show UrlException { urlExceptionMessage = msg } = "Failed to parse url: " <> T.unpack msg++instance Exception UrlException
+ src/Dormouse/Url/QQ.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}++module Dormouse.Url.QQ+  ( http+  , https+  , url+  ) where++import Data.ByteString.Char8 (pack)+import Dormouse.Url+import Language.Haskell.TH.Quote +import Language.Haskell.TH++http :: QuasiQuoter+http = QuasiQuoter +  { quoteExp = \s -> +      let res = parseHttpUrl $ pack s in+      case res of+        Left err -> fail $ show err+        Right x -> [| x |]+  , quotePat = \s ->+      case parseHttpUrl (pack s) of+        Left err -> fail $ show err+        Right x  -> appE [|(==)|] [| (x :: Url "http") |] `viewP` [p|True|]+  , quoteType = error "Not supported"+  , quoteDec =error "Not supported"+  }++https :: QuasiQuoter+https = QuasiQuoter +  { quoteExp = \s -> +      let res = parseHttpsUrl $ pack s in+      case res of+        Left err -> fail $ show err+        Right x -> [| (x :: Url "https") |]+  , quotePat = \s ->+      case parseHttpsUrl (pack s) of+        Left err -> fail $ show err+        Right x  -> appE [|(==)|] [| (x :: Url "https") |] `viewP` [p|True|]+  , quoteType = error "Not supported"+  , quoteDec =error "Not supported"+  }++url :: QuasiQuoter+url = QuasiQuoter +  { quoteExp = \s -> +      let res = parseUrl $ pack s in+      case res of+        Left err -> fail $ show err+        Right x -> [| (x :: AnyUrl) |]+  , quotePat = \s ->+      case parseUrl (pack s) of+        Left err -> fail $ show err+        Right x  -> appE [|(==)|] [| (x :: AnyUrl) |] `viewP` [p|True|]+  , quoteType = error "Not supported"+  , quoteDec =error "Not supported"+  }
+ src/Dormouse/Url/Types.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE TemplateHaskell #-}++module Dormouse.Url.Types+  ( UrlComponents(..)+  , UrlScheme(..)+  , Url(..)+  , AnyUrl(..)+  ) where++import Dormouse.Uri.Types+import GHC.TypeLits+import Language.Haskell.TH.Syntax (Lift(..))++data UrlComponents = UrlComponents+  { urlAuthority :: Authority+  , urlPath :: Path 'Absolute+  , urlQuery :: Maybe Query+  , urlFragment :: Maybe Fragment+  } deriving (Eq, Show, Lift)++data UrlScheme+  = HttpScheme+  | HttpsScheme++-- | A 'Url' is defined here as an absolute URI in the @http@ or @https@ schemes.  Authority components are requried by the http / https+-- Uri schemes.+data Url (scheme :: Symbol) where+  HttpUrl  :: UrlComponents -> Url "http"+  HttpsUrl :: UrlComponents -> Url "https"++instance Eq (Url scheme) where+  (==) (HttpUrl u1)  (HttpUrl u2)  = show u1 == show u2+  (==) (HttpsUrl u1) (HttpsUrl u2) = show u1 == show u2++instance Show (Url scheme) where+  show (HttpUrl wu)  = "http " <> show wu+  show (HttpsUrl wu) = "https " <> show wu++instance Lift (Url scheme) where+  lift (HttpUrl uc)  = [| HttpUrl uc |]+  lift (HttpsUrl uc) = [| HttpsUrl uc |]++-- | `AnyUrl` is a wrapper aroud `Url` which allows either @http@ or @https@ urls.+data AnyUrl = forall scheme. AnyUrl (Url scheme)++instance Eq AnyUrl where+  (==) (AnyUrl (HttpUrl d1)) (AnyUrl (HttpUrl d2))   = d1 == d2+  (==) (AnyUrl (HttpsUrl d1)) (AnyUrl (HttpsUrl d2)) = d1 == d2+  (==) _  _                                          = False++instance Show AnyUrl where+  show (AnyUrl u) = show u++instance Lift AnyUrl where+  lift (AnyUrl u)  = [| AnyUrl u |]
+ test/Dormouse/Generators/UriComponents.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Dormouse.Generators.UriComponents +  ( genValidScheme+  , genInvalidScheme+  , genValidUsername+  , genInvalidUsername+  , genValidPassword+  , genInvalidPassword+  , genValidUserInfo+  , genInvalidUserInfo+  , genValidIPv4+  , genValidRegName+  , genValidHost+  , genValidPort+  , genValidAuthority+  , genValidPathAbsAuth+  , genValidPathAbsNoAuth+  , genValidPathRel+  , genValidQuery+  , genValidFragment+  , genValidAbsoluteUri+  )+  where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.Char as C+import qualified Data.Text as T+import Dormouse.Uri.Encode+import Dormouse.Uri.RFC3986+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++genPercentEncoded :: Gen B.ByteString+genPercentEncoded = do+  char <- Gen.filter C.isPrint Gen.unicode+  let t = T.pack $ [char]+  let percentEncoded = encodeUnless (const False) t+  return $ percentEncoded++genValidScheme :: Gen B.ByteString+genValidScheme = do+  first <- Gen.filter isAsciiAlpha Gen.ascii+  bs <- Gen.list (Range.constant 0 10) (Gen.filter isSchemeChar Gen.ascii)+  return . B8.pack $ (first : bs ++ [':'])++data SchemeFailureMode +  = NonAsciiFirstChar+  | InvalidSchemeChar+  | NoTrailingSemicolon++schemeFailureMode :: Int -> SchemeFailureMode+schemeFailureMode 1 = NonAsciiFirstChar+schemeFailureMode 2 = InvalidSchemeChar+schemeFailureMode 3 = NoTrailingSemicolon+schemeFailureMode _ = undefined++genInvalidScheme :: Gen B.ByteString+genInvalidScheme = do+  failureMode <- fmap schemeFailureMode $ Gen.element [1..3]+  first <- case failureMode of+    NonAsciiFirstChar -> Gen.filter (not . isAsciiAlpha) Gen.ascii+    _                 -> Gen.filter isAsciiAlpha Gen.ascii+  remainder <- case failureMode of+    InvalidSchemeChar -> do+      let c = Gen.filter (\x -> (not $ isSchemeChar x) && x /= ':') Gen.ascii+      Gen.list (Range.constant 1 10) c+    _ -> do+      let c = Gen.filter isSchemeChar Gen.ascii+      Gen.list (Range.constant 0 10) c+  let finalBs = case failureMode of+        NoTrailingSemicolon -> first : remainder+        _                   -> first : remainder ++ [':']+  return $ B8.pack finalBs++genUsernameChar :: Gen B.ByteString+genUsernameChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isUsernameChar Gen.ascii)]++genValidUsername :: Gen B.ByteString+genValidUsername = do+  list <- Gen.list (Range.constant 1 20) genUsernameChar+  return $ B.intercalate "" list++genInvalidUsername :: Gen B.ByteString+genInvalidUsername = do+  invalids <- Gen.list (Range.constant 1 5) genInvalidUsernameChar+  valids <- Gen.list (Range.constant 0 15) genUsernameChar+  fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids+  where+    genInvalidUsernameChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isUsernameChar x) && x /= '%'  && C.isPrint x) Gen.ascii++genPasswordChar :: Gen B.ByteString+genPasswordChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPasswordChar Gen.ascii)]++genValidPassword :: Gen B.ByteString+genValidPassword = do+  list <- Gen.list (Range.constant 1 20) genPasswordChar+  return $ B.intercalate "" list++genInvalidPassword :: Gen B.ByteString+genInvalidPassword = do+  invalids <- Gen.list (Range.constant 1 5) genInvalidPasswordChar+  valids <- Gen.list (Range.constant 0 15) genPasswordChar+  fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids+  where+    genInvalidPasswordChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isPasswordChar x) && x /= '%' && C.isPrint x) Gen.ascii++genValidUserInfo :: Gen B.ByteString+genValidUserInfo = do+  username <- genValidUsername+  maybePassword <- Gen.maybe genValidPassword+  let passwordSuffix = maybe B.empty (B.cons $ c2w ':') maybePassword+  return $ B.append (B.append username passwordSuffix) "@"++data UserInfoFailureMode +  = InvalidUsername+  | InvalidPassword+  | MissingAtSuffix++userInfoFailureMode :: Int -> UserInfoFailureMode+userInfoFailureMode 1 = InvalidUsername+userInfoFailureMode 2 = InvalidPassword+userInfoFailureMode 3 = MissingAtSuffix+userInfoFailureMode _ = undefined++genInvalidUserInfo :: Gen B.ByteString+genInvalidUserInfo = do+  failureMode <- fmap userInfoFailureMode $ Gen.element [1..3]+  username <- case failureMode of+    InvalidUsername -> Gen.filter (B.all (\x -> w2c x /= ':')) genInvalidUsername -- if the username is supposed to be invalid, ensure that ':' is not present, otherwise the user info could be interpreted as valid if valid chars precede the ':'+    _               -> genValidUsername+  maybePassword <- case failureMode of +    InvalidPassword -> fmap Just genInvalidPassword+    _               -> Gen.maybe $ genValidPassword+  let passwordSuffix = maybe B.empty (B.cons $ c2w ':') maybePassword+  let complete = case failureMode of+        MissingAtSuffix -> B.append (B.append username passwordSuffix) "#"+        _               -> B.append (B.append username passwordSuffix) "@"+  return complete++genValidIPv4 :: Gen B.ByteString+genValidIPv4 = do+  ipChars <- (\a b c d -> show a <> "." <> show b <> "." <> show c <> "." <> show d) <$> genOctet <*> genOctet <*> genOctet <*> genOctet+  return $ B8.pack ipChars+  where+    genOctet = Gen.word8 Range.constantBounded++genValidRegName :: Gen B.ByteString+genValidRegName = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isRegNameChar Gen.ascii)]++genValidHost :: Gen B.ByteString+genValidHost = Gen.choice [genValidIPv4, genValidRegName]++genValidPort :: Gen B.ByteString+genValidPort = fmap (B.append ":" . B8.pack . show) $ Gen.word16 Range.constantBounded++genValidAuthority :: Gen B.ByteString+genValidAuthority = do+  maybeUserInfo <- Gen.maybe genValidUserInfo+  let userInfoPrefix = maybe B.empty id maybeUserInfo+  host <- genValidHost+  maybePort <- Gen.maybe genValidPort+  let portSuffix = maybe B.empty id maybePort+  return . B.append "//" . B.append userInfoPrefix $ B.append host portSuffix++genPathChar :: Gen B.ByteString+genPathChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPathChar Gen.ascii)]++genPathSegment :: Gen B.ByteString+genPathSegment = fmap (B.intercalate "") $ Gen.list (Range.constant 0 20) genPathChar++genPathSegmentNz :: Gen B.ByteString+genPathSegmentNz = fmap (B.intercalate "") $ Gen.list (Range.constant 1 20) genPathChar++genPathCharNc :: Gen B.ByteString+genPathCharNc = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPathCharNoColon Gen.ascii)]++genPathSegmentNzNc :: Gen B.ByteString+genPathSegmentNzNc = fmap (B.intercalate "") $ Gen.list (Range.constant 1 20) genPathCharNc++genPathsAbEmpty :: Gen B.ByteString+genPathsAbEmpty = do+  components <- Gen.list (Range.constant 1 10) genPathSegment+  return . B.append "/" $ B.intercalate "/" components++genPathsAbsolute :: Gen B.ByteString+genPathsAbsolute = do+  first <- genPathSegmentNz+  components <- Gen.list (Range.constant 0 10) genPathSegment+  return . B.append "/" . B.append first $ B.intercalate "/" components++genPathsNoScheme :: Gen B.ByteString+genPathsNoScheme = do+  first <- genPathSegmentNzNc+  components <- Gen.list (Range.constant 0 10) genPathSegment+  return . B.append first . B.append "/" $ B.intercalate "/" components++genPathsRootless :: Gen B.ByteString+genPathsRootless = do+  first <- genPathSegmentNz+  components <- Gen.list (Range.constant 0 10) genPathSegment+  return . B.append first . B.append "/" $ B.intercalate "/" components++genValidPathsEmpty :: Gen B.ByteString+genValidPathsEmpty = return B.empty++genValidPathAbsAuth :: Gen B.ByteString+genValidPathAbsAuth = Gen.choice [genPathsAbEmpty, genPathsAbsolute, genValidPathsEmpty]++genValidPathAbsNoAuth :: Gen B.ByteString+genValidPathAbsNoAuth = Gen.choice [genPathsAbsolute, genPathsRootless, genValidPathsEmpty]++genValidPathRel :: Gen B.ByteString+genValidPathRel = Gen.choice [genPathsAbsolute, genPathsNoScheme, genValidPathsEmpty]++genQueryChar :: Gen B.ByteString+genQueryChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isQueryChar Gen.ascii)]++genValidQuery :: Gen B.ByteString+genValidQuery = do+  list <- Gen.list (Range.constant 1 50) genQueryChar+  return $ B.append "?" $ B.intercalate "" list++genFragmentChar :: Gen B.ByteString+genFragmentChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isFragmentChar Gen.ascii)]++genValidFragment :: Gen B.ByteString+genValidFragment = do+  list <- Gen.list (Range.constant 1 50) genFragmentChar+  return $ B.append "#" $ B.intercalate "" list++genValidAbsoluteUri :: Gen B.ByteString+genValidAbsoluteUri = do+  scheme <- genValidScheme+  authority <- Gen.maybe genValidAuthority+  path <- case authority of+    Just _  -> genValidPathAbsAuth+    Nothing -> genValidPathAbsNoAuth+  query <- Gen.maybe genValidQuery+  fragment <- Gen.maybe genValidFragment+  return . B.intercalate "" $ [scheme, maybe B.empty id authority, path, maybe B.empty id query, maybe B.empty id fragment]++
+ test/Dormouse/Uri/ParserSpec.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ViewPatterns #-}++module Dormouse.Uri.ParserSpec+  ( spec+  ) where++import Test.Hspec+import Test.Hspec.Hedgehog+import Control.Monad.IO.Class+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString as B+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.Char as C+import Data.Either (isLeft, isRight)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Dormouse.Generators.UriComponents +import Dormouse.Uri.Types+import Dormouse.Uri.Parser+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+++uriWithHostAndPath :: Uri+uriWithHostAndPath = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "http"+  , uriAuthority = Just $ Authority {authorityUserInfo = Nothing, authorityHost = Host "google.com", authorityPort = Nothing}+  , uriPath = Path [PathSegment "test1", PathSegment "test2"]+  , uriQuery = Nothing+  , uriFragment = Nothing+  }++uriWithHostUsernameAndPath :: Uri+uriWithHostUsernameAndPath = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "http"+  , uriAuthority = Just $ Authority +    { authorityUserInfo = Just (UserInfo {userInfoUsername = "j.t.kirk", userInfoPassword = Nothing})+    , authorityHost = Host "google.com"+    , authorityPort = Nothing+    }+  , uriPath = Path [PathSegment "test1", PathSegment "test2"]+  , uriQuery = Nothing+  , uriFragment = Nothing+  }++uriWithHostUsernamePasswordAndPath :: Uri+uriWithHostUsernamePasswordAndPath = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "http"+  , uriAuthority = Just $ Authority +    { authorityUserInfo = Just (UserInfo {userInfoUsername = "j.t.kirk", userInfoPassword = Just "11a"})+    , authorityHost = Host "google.com"+    , authorityPort = Nothing+    }+  , uriPath = Path [PathSegment "test1", PathSegment "test2"]+  , uriQuery = Nothing+  , uriFragment = Nothing+  }++uriWithHostPathAndPort :: Uri+uriWithHostPathAndPort = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "https"+  , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Just 123 }+  , uriPath = Path ["forum", "questions", ""]+  , uriQuery = Nothing+  , uriFragment = Nothing+  }++uriWithHostPathQueryAndFragment :: Uri+uriWithHostPathQueryAndFragment = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "https"+  , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }+  , uriPath = Path ["forum", "questions", ""]+  , uriQuery = Just $ Query "tag=networking&order=newest"+  , uriFragment = Just $ Fragment "top"+  }++uriWithUnicodeInQuery :: Uri+uriWithUnicodeInQuery = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "https"+  , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }+  , uriPath = Path ["forum", "questions", ""]+  , uriQuery = Just $ Query "tag=networking&order=newest😀"+  , uriFragment = Nothing+  }++uriWithSpacesInQuery :: Uri+uriWithSpacesInQuery = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "https"+  , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }+  , uriPath = Path ["forum", "questions", ""]+  , uriQuery = Just $ Query "tag=with space"+  , uriFragment = Nothing+  }+++uriWithUnicodeInFragment :: Uri+uriWithUnicodeInFragment = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "https"+  , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "www.example.com", authorityPort = Nothing }+  , uriPath = Path ["forum", "questions", ""]+  , uriQuery = Nothing+  , uriFragment = Just $ "😀😀😀"+  }++ldapUri :: Uri+ldapUri = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "ldap"+  , uriAuthority = Just $ Authority { authorityUserInfo = Nothing, authorityHost = "192.168.0.1", authorityPort = Nothing }+  , uriPath = Path [PathSegment "c=GB"]+  , uriQuery = Just $ Query "objectClass?one"+  , uriFragment = Nothing+  }++telUri :: Uri+telUri = AbsoluteUri $ AbsUri+  { uriScheme = Scheme "tel"+  , uriAuthority = Nothing+  , uriPath = Path ["+1-816-555-1212"]+  , uriQuery = Nothing+  , uriFragment = Nothing+  }++infixr 5 :<++pattern b :< bs <- (B.uncons -> Just (b, bs))+pattern Empty   <- (B.uncons -> Nothing)++percentDecode :: B.ByteString -> B.ByteString+percentDecode Empty = B.empty+percentDecode (x :< Empty) = B.singleton x+percentDecode (x :< y :< Empty) = B.cons x $ B.singleton y+percentDecode (p :< x :< y :< xs) +  | p == c2w '%' = B.cons (fromIntegral $ C.digitToInt (w2c x) * 16 + C.digitToInt (w2c y)) (percentDecode xs)+  | otherwise    = B.cons p $ percentDecode (B.cons x $ B.cons y $ xs)++spec :: Spec+spec = do+  describe "pScheme" $ do+    it "returns the matching scheme for all valid schemes" $ hedgehog $ do+      schemeText <- forAll genValidScheme+      let res = parseOnly (pScheme <* endOfInput) schemeText+      res === (Right . Scheme . T.init . T.toLower $ TE.decodeUtf8 schemeText)+    it "fails for invalid schemes" $ hedgehog $ do+      schemeText <- forAll genInvalidScheme+      let res = parseOnly (pScheme <* endOfInput) schemeText+      isLeft res === True+  describe "pUsername" $ do+    it "returns the matching username for all valid usernames" $ hedgehog $ do+      usernameText <- forAll genValidUsername+      let res = parseOnly (pUsername <* endOfInput) usernameText+      res === (Right . Username . TE.decodeUtf8 . percentDecode $ usernameText)+    it "fails for invalid usernames" $ hedgehog $ do+      usernameText <- forAll genInvalidUsername+      let res = parseOnly (pUsername <* endOfInput) usernameText+      isLeft res === True+  describe "pPassword" $ do+    it "returns the matching password for all valid passwords" $ hedgehog $ do+      passwordText <- forAll genValidPassword+      let res = parseOnly (pPassword <* endOfInput) passwordText+      res === (Right . Password . TE.decodeUtf8 . percentDecode $ passwordText)+    it "fails for invalid passwords" $ hedgehog $ do+      passwordText <- forAll genInvalidPassword+      let res = parseOnly (pPassword <* endOfInput) passwordText+      isLeft res === True+  describe "pUserInfo" $ do+    it "generates a user info for all valid user infos" $ hedgehog $ do+      userInfoText <- forAll genValidUserInfo+      let res = parseOnly (pUserInfo <* endOfInput) userInfoText+      isRight res === True+    it "fails for invalid user infos" $ hedgehog $ do+      userInfoText <- forAll genInvalidUserInfo+      let res = parseOnly (pUserInfo <* endOfInput) userInfoText+      isLeft res === True+  describe "pIPv4" $ do+    it "returns the matching ip address for all valid ip addresses" $ hedgehog $ do+      ipv4Text <- forAll genValidIPv4+      let res = parseOnly (pIPv4 <* endOfInput) ipv4Text+      res === (Right . TE.decodeUtf8 . percentDecode $ ipv4Text)+  describe "pRegName" $ do+    it "returns the matching reg name for all valid reg names" $ hedgehog $ do+      regNameText <- forAll genValidRegName+      let res = parseOnly (pRegName <* endOfInput) regNameText+      res === (Right . TE.decodeUtf8 . percentDecode $ regNameText)+  describe "pHost" $ do+    it "returns the matching host for all valid hosts" $ hedgehog $ do+      hostText <- forAll genValidHost+      let res = parseOnly (pHost <* endOfInput) hostText+      res === (Right . Host . TE.decodeUtf8 . percentDecode $ hostText)+  describe "pPort" $ do+    it "returns the matching host for all valid ports" $ hedgehog $ do+      portText <- forAll genValidPort+      let res = parseOnly (pPort <* endOfInput) portText+      res === (Right . read . T.unpack . T.tail . TE.decodeUtf8 $ portText)+  describe "pAuthority" $ do+    it "generates an authority for all valid authorities" $ hedgehog $ do+      authorityText <- forAll genValidAuthority+      let res = parseOnly (pAuthority <* endOfInput) authorityText+      isRight res === True+  describe "pPathAbsAuth" $ do+    it "generates a path for all valid absolute authority paths" $ hedgehog $ do+      pathText <- forAll genValidPathAbsAuth+      let res = parseOnly (pPathAbsAuth <* endOfInput) pathText+      isRight res === True+  describe "pPathAbsNoAuth" $ do+    it "generates a path for all valid absolute no authority paths" $ hedgehog $ do+      pathText <- forAll genValidPathAbsNoAuth+      let res = parseOnly (pPathAbsNoAuth <* endOfInput) pathText+      isRight res === True+  describe "pPathRel" $ do+    it "generates a path for all valid relative paths" $ hedgehog $ do+      pathText <- forAll genValidPathRel+      let res = parseOnly (pPathRel <* endOfInput) pathText+      isRight res === True+  describe "pQuery" $ do+    it "returns the matching query for all valid queries" $ hedgehog $ do+      queryText <- forAll genValidQuery+      let res = parseOnly (pQuery <* endOfInput) queryText+      res === (Right . Query . T.tail . TE.decodeUtf8 . percentDecode $ queryText)+  describe "pFragment" $ do+    it "returns the matching fragment for all valid fragments" $ hedgehog $ do+      fragmentText <- forAll genValidFragment+      let res = parseOnly (pFragment <* endOfInput) fragmentText+      res === (Right . Fragment . T.tail . TE.decodeUtf8 . percentDecode $ fragmentText)+  describe "pAbsoluteUri" $ do+    it "generates an absolute uri for all valid absolute uris" $ hedgehog $ do+      uriText <- forAll genValidAbsoluteUri+      let res = parseOnly (pAbsoluteUri <* endOfInput) uriText+      isRight res === True+  describe "parseURI" $ do+    it "generates uri components correctly for uri with scheme, host and path" $ do+      let res = parseOnly pUri "http://google.com/test1/test2"+      res `shouldBe` (Right uriWithHostAndPath)+    it "generates uri components correctly for uri with upper case scheme, host and path" $ do+      let res = parseOnly pUri "HTTP://google.com/test1/test2"+      res `shouldBe` (Right uriWithHostAndPath)+    it "generates uri components correctly for uri with host, username and path" $ do+      let res = parseOnly pUri "http://j.t.kirk@google.com/test1/test2"+      res `shouldBe` (Right uriWithHostUsernameAndPath)+    it "generates uri components correctly for uri with host, username and path" $ do+      let res = parseOnly pUri "http://j.t.kirk:11a@google.com/test1/test2"+      res `shouldBe` (Right uriWithHostUsernamePasswordAndPath)+    it "generates uri components correctly for uri with host, username, path and port" $ do+      let res = parseOnly pUri "https://www.example.com:123/forum/questions/"+      res `shouldBe` (Right uriWithHostPathAndPort)+    it "generates uri components correctly for uri with host, username, path, port, query and fragment" $ do+      let res = parseOnly pUri "https://www.example.com/forum/questions/?tag=networking&order=newest#top"+      res `shouldBe` (Right uriWithHostPathQueryAndFragment)+    it "generates uri components correctly when there is percent encoded unicode in the query" $ do+      let res = parseOnly pUri "https://www.example.com/forum/questions/?tag=networking&order=newest%F0%9F%98%80"+      res `shouldBe` (Right uriWithUnicodeInQuery)+    it "generates uri components correctly when there are spaces in the query" $ do+      let res = parseOnly pUri "https://www.example.com/forum/questions/?tag=with%20space"+      res `shouldBe` (Right uriWithSpacesInQuery)+    it "generates uri components correctly when there is percent encoded unicode in the fragment" $ do+      let res = parseOnly pUri "https://www.example.com/forum/questions/#%F0%9F%98%80%F0%9F%98%80%F0%9F%98%80"+      res `shouldBe` (Right uriWithUnicodeInFragment)+    it "generates uri components correctly for ldap uri" $ do+      let res = parseOnly pUri "ldap://192.168.0.1/c=GB?objectClass?one"+      res `shouldBe` (Right ldapUri)+    it "generates uri components correctly for tel uri" $ do+      let res = parseOnly pUri "tel:+1-816-555-1212"+      res `shouldBe` (Right telUri)
+ test/Dormouse/Uri/QQSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ViewPatterns #-}++module Dormouse.Uri.QQSpec +  ( spec+  ) where++import Test.Hspec+import Dormouse.Uri.QQ+import Dormouse.Url.QQ++spec :: Spec+spec = do+  describe "http pattern" $ do+    it "pattern matches correctly against a matching uri" $ do+      let url' = [http|http://google.com|]+      let matched = case url' of+            [http|http://google.com|] -> True+            _ -> False+      matched `shouldBe` True+    it "pattern match doesn't match a different uri" $ do+      let url' = [http|http://google.com|]+      let matched = case url' of+            [http|http://test.com|] -> True+            _ -> False+      matched `shouldBe` False+  describe "https pattern" $ do+    it "pattern matches correctly against a matching uri" $ do+      let url' = [https|https://google.com|]+      let matched = case url' of+            [https|https://google.com|] -> True+            _ -> False+      matched `shouldBe` True+    it "pattern match doesn't match a different uri" $ do+      let url' = [https|https://google.com|]+      let matched = case url' of+            [https|https://test.com|] -> True+            _ -> False+      matched `shouldBe` False+  describe "uri pattern" $ do+    it "pattern matches correctly against a matching uri" $ do+      let uri' = [uri|https://google.com|]+      let matched = case uri' of+            [uri|https://google.com|] -> True+            _ -> False+      matched `shouldBe` True+    it "pattern match doesn't match a different uri" $ do+      let uri' = [uri|https://google.com|]+      let matched = case uri' of+            [uri|https://test.com|] -> True+            _ -> False+      matched `shouldBe` False+  describe "relativeUri pattern" $ do+    it "pattern matches correctly against a matching uri" $ do+      let uri' = [uri|/myPath|]+      let matched = case uri' of+            [uri|/myPath|] -> True+            _ -> False+      matched `shouldBe` True+    it "pattern match doesn't match a different uri" $ do+      let uri' = [uri|/myPath2|]+      let matched = case uri' of+            [uri|/myPath|] -> True+            _ -> False+      matched `shouldBe` False
+ test/Dormouse/Uri/QuerySpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-}++module Dormouse.Uri.QuerySpec+  ( spec+  ) where++import qualified Data.Text as T+import Test.Hspec+import Dormouse.Uri+import Dormouse.Url+import Dormouse.Url.Builder+import Dormouse.Url.QQ++uriWithDestructSequence :: Url "http"+uriWithDestructSequence = HttpUrl $ UrlComponents+  { urlAuthority = Authority {authorityUserInfo = Nothing, authorityHost = Host "enterprise.starfleet.com", authorityPort = Nothing}+  , urlPath = Path ["destruct"]+  , urlQuery = Just $ "code1=11a&code2=11a2b&code3=1b2b3&code4=000destruct-0"+  , urlFragment = Nothing+  }++uriLookingUpTheEnterprise :: Url "http"+uriLookingUpTheEnterprise = HttpUrl $ UrlComponents+  { urlAuthority = Authority {authorityUserInfo = Nothing, authorityHost = Host "starfleet.com", authorityPort = Nothing}+  , urlPath = Path ["ship"]+  , urlQuery = Just $ "registry=1701"+  , urlFragment = Nothing+  }++spec :: Spec+spec = do+  describe "build query" $ do+    it "generates correct uri using the URI builder syntax with text components" $ do+      let actualUri = [http|http://enterprise.starfleet.com|] </> "destruct" ? ("code1" =: ("11a" :: T.Text)) & ("code2" =: ("11a2b" :: T.Text)) & ("code3" =: ("1b2b3":: T.Text)) & ("code4" =: ("000destruct-0" :: T.Text))+      actualUri `shouldBe` uriWithDestructSequence+    it "generates correct uri using the URI builder syntax with int components" $ do+      let actualUri = [http|http://starfleet.com|] </> "ship" ? ("registry" =: (1701 :: Int))+      actualUri `shouldBe` uriLookingUpTheEnterprise++
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}