diff --git a/attoparsec-uri.cabal b/attoparsec-uri.cabal --- a/attoparsec-uri.cabal +++ b/attoparsec-uri.cabal @@ -1,5 +1,5 @@ name: attoparsec-uri -version: 0.0.3 +version: 0.0.4 synopsis: URI parser / printer using attoparsec -- description: homepage: https://github.com/athanclark/attoparsec-uri#readme diff --git a/src/Data/URI.hs b/src/Data/URI.hs --- a/src/Data/URI.hs +++ b/src/Data/URI.hs @@ -3,23 +3,22 @@ , RecordWildCards , DeriveGeneric , DeriveDataTypeable - , StandaloneDeriving #-} module Data.URI where -import Data.URI.Auth (URIAuth, parseURIAuth) +import Data.URI.Auth (URIAuth, parseURIAuth, printURIAuth) -import Prelude hiding (Maybe (..), takeWhile) +import Prelude hiding (Maybe (..), takeWhile, maybe) import qualified Prelude as P -import Data.Strict.Maybe (Maybe (..), fromMaybe) +import Data.Strict.Maybe (Maybe (..), maybe) import Data.Strict.Tuple (Pair (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Vector (Vector) import qualified Data.Vector as V +import Data.Monoid ((<>)) import Data.Attoparsec.Text (Parser, char, string, sepBy, takeWhile, takeWhile1) -import Data.List (intercalate) import Data.Char (isControl, isSpace) import Control.Monad (void) import Control.Applicative ((<|>), optional) @@ -39,21 +38,28 @@ } deriving (Eq, Typeable, Generic) -instance Show URI where - show URI{..} = - fromMaybe "" ((\s -> T.unpack s ++ ":") <$> uriScheme) - ++ (if uriSlashes then "//" else "") - ++ show uriAuthority - ++ "/" ++ intercalate "/" (V.toList $ T.unpack <$> uriPath) - ++ ( if null uriQuery - then "" - else "?" ++ intercalate "&" (V.toList $ (\(k :!: mV) -> T.unpack k ++ ( case mV of - Nothing -> "" - Just v -> "=" ++ T.unpack v)) <$> uriQuery) - ) - ++ case uriFragment of - Nothing -> "" - Just f -> "#" ++ T.unpack f +printURI :: URI -> Text +printURI URI{..} = + maybe "" (<> ":") uriScheme + <> (if uriSlashes then "//" else "") + <> printURIAuth uriAuthority + <> "/" <> T.intercalate "/" (V.toList uriPath) + <> ( if null uriQuery + then "" + else "?" + <> T.intercalate "&" + ( V.toList $ + (\(k :!: mV) -> + let v' = case mV of + Nothing -> "" + Just v -> "=" <> v + in k <> v' + ) <$> uriQuery + ) + ) + <> case uriFragment of + Nothing -> "" + Just f -> "#" <> f @@ -67,7 +73,7 @@ <*> (toStrictMaybe <$> optional parseFragment) where parseScheme = do - sch <- takeWhile1 (\c -> all (c /=) [':','/','@','.']) + sch <- takeWhile1 (\c -> c `notElem` [':','/','@','.']) _ <- char ':' pure sch parseSlashes = do @@ -86,8 +92,7 @@ k <- parseChunkWithout ['=','&','#'] mV <- ( Just <$> do void $ char '=' parseChunkWithout ['&','#'] - ) <|> ( pure Nothing - ) + ) <|> pure Nothing pure (k :!: mV) qs <- parse1 `sepBy` char '&' pure $ V.fromList qs @@ -97,7 +102,7 @@ parseChunkWithout [] parseChunkWithout :: [Char] -> Parser Text parseChunkWithout xs = - takeWhile (\c -> not (isControl c || isSpace c) && all (c /=) xs) + takeWhile (\c -> not (isControl c || isSpace c) && c `notElem` xs) toStrictMaybe P.Nothing = Nothing toStrictMaybe (P.Just x) = Just x diff --git a/src/Data/URI/Auth.hs b/src/Data/URI/Auth.hs --- a/src/Data/URI/Auth.hs +++ b/src/Data/URI/Auth.hs @@ -3,16 +3,15 @@ , OverloadedStrings , DeriveGeneric , DeriveDataTypeable - , StandaloneDeriving #-} module Data.URI.Auth where -import Data.URI.Auth.Host (URIAuthHost, parseURIAuthHost) +import Data.URI.Auth.Host (URIAuthHost, parseURIAuthHost, printURIAuthHost) -import Prelude hiding (Maybe (..)) +import Prelude hiding (Maybe (..), maybe) import qualified Prelude as P -import Data.Strict.Maybe (Maybe (..), fromMaybe) +import Data.Strict.Maybe (Maybe (..), maybe) import Data.Text (Text) import Data.Word (Word16) import qualified Data.Text as T @@ -31,11 +30,11 @@ , uriAuthPort :: !(Maybe Word16) -- ^ the port, if it exists - @foobar.com:3000@ is @3000@ as a 16-bit unsigned int. } deriving (Eq, Typeable, Generic) -instance Show URIAuth where - show URIAuth{..} = - fromMaybe "" ((\u -> T.unpack $ u <> "@") <$> uriAuthUser) - ++ show uriAuthHost - ++ fromMaybe "" ((\p -> ":" ++ show p) <$> uriAuthPort) +printURIAuth :: URIAuth -> Text +printURIAuth URIAuth{..} = + maybe "" (<> "@") uriAuthUser + <> printURIAuthHost uriAuthHost + <> maybe "" (\p -> ":" <> T.pack (show p)) uriAuthPort parseURIAuth :: Parser URIAuth @@ -45,7 +44,7 @@ <*> (toStrictMaybe <$> optional parsePort) where parseUser = do - u <- takeWhile1 (\c -> all (c /=) ['@','.',':','/','?','&','=']) + u <- takeWhile1 (\c -> c `notElem` ['@','.',':','/','?','&','=']) mC <- peekChar case mC of P.Nothing -> fail "no user @ thing" diff --git a/src/Data/URI/Auth/Host.hs b/src/Data/URI/Auth/Host.hs --- a/src/Data/URI/Auth/Host.hs +++ b/src/Data/URI/Auth/Host.hs @@ -11,11 +11,10 @@ import Data.Vector (Vector) import qualified Data.Vector as V -import Data.Text (Text, unpack) +import Data.Text (Text) import qualified Data.Text as T import Data.Attoparsec.Text (Parser, char, sepBy1, takeWhile1) import Data.Attoparsec.IP (ipv4, ipv6) -import Data.List (intercalate) import Control.Applicative ((<|>)) import Net.Types (IPv4, IPv6) import qualified Net.IPv4 as IPv4 @@ -37,11 +36,12 @@ , uriAuthHostSuffix :: !Text } deriving (Eq, Typeable, Generic) -instance Show URIAuthHost where - show (IPv4 l4) = unpack (IPv4.encode l4) - show (IPv6 r6) = unpack (IPv6.encode r6) - show Localhost = "localhost" - show (Host ns c) = intercalate "." $ V.toList $ T.unpack <$> ns `V.snoc` c +printURIAuthHost :: URIAuthHost -> Text +printURIAuthHost x = case x of + IPv4 l4 -> IPv4.encode l4 + IPv6 r6 -> IPv6.encode r6 + Localhost -> "localhost" + Host ns c -> T.intercalate "." (V.toList (ns `V.snoc` c)) parseURIAuthHost :: Parser URIAuthHost @@ -52,7 +52,7 @@ where parseHost :: Parser URIAuthHost parseHost = do - xss@(x:xs) <- takeWhile1 (\c -> all (c /=) ['.',':','/','?']) `sepBy1` char '.' + xss@(x:xs) <- takeWhile1 (\c -> c `notElem` ['.',':','/','?']) `sepBy1` char '.' if null xs then if x == "localhost" then pure Localhost @@ -60,8 +60,8 @@ else let xss' :: Vector Text xss' = V.fromList xss unsnoc :: Vector a -> (Vector a, a) - unsnoc x = - let (fs,l) = V.splitAt (V.length x - 1) x + unsnoc x' = + let (fs,l) = V.splitAt (V.length x' - 1) x' in (fs, l V.! 0) (ns,c) = unsnoc xss' in pure (Host ns c)