attoparsec-uri (empty) → 0.0.0
raw patch · 7 files changed
+372/−0 lines, 7 filesdep +attoparsecdep +basedep +bytedumpsetup-changed
Dependencies added: attoparsec, base, bytedump, n-tuple, strict, text, vector
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- attoparsec-uri.cabal +32/−0
- src/Data/URI.hs +97/−0
- src/Data/URI/Auth.hs +58/−0
- src/Data/URI/Auth/Host.hs +152/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++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 Author name here 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,1 @@+# attoparsec-uri
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ attoparsec-uri.cabal view
@@ -0,0 +1,32 @@+name: attoparsec-uri+version: 0.0.0+synopsis: URI parser / printer using attoparsec+-- description:+homepage: https://github.com/athanclark/attoparsec-uri#readme+license: BSD3+license-file: LICENSE+author: Athan Clark+maintainer: athan.clark@gmail.com+copyright: 2017 Athan Clark+category: Network+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Data.URI+ Data.URI.Auth+ Data.URI.Auth.Host+ build-depends: base >= 4.7 && < 5+ , attoparsec+ , bytedump+ , n-tuple >= 0.0.1.1+ , strict+ , text+ , vector+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/athanclark/attoparsec-uri
+ src/Data/URI.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE+ OverloadedStrings+ , RecordWildCards+ , DeriveGeneric+ , DeriveDataTypeable+ , StandaloneDeriving+ #-}++module Data.URI where++import Data.URI.Auth (URIAuth, parseURIAuth)++import Prelude hiding (Maybe (..))+import Data.Strict.Maybe (Maybe (..), fromMaybe)+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.Attoparsec.Text (Parser, many1, notChar, char, string, sepBy, satisfy, anyChar)+import Data.List (intercalate)+import Control.Applicative ((<|>), many)++import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+++deriving instance (Data a, Data b) => Data (Pair a b)++data URI = URI+ { uriScheme :: !(Maybe Text) -- ^ the scheme without the colon - @https://hackage.haskell.org/@ has a scheme of @https@+ , uriSlashes :: !Bool -- ^ are the slashes present? - @https://hackage.haskell.org/@ is @True@+ , uriAuthority :: !URIAuth+ , uriPath :: !(Vector Text) -- ^ slash-separated list - @https://hackage.haskell.org/foo@ is @["foo"]@+ , uriQuery :: !(Vector (Pair Text (Maybe Text))) -- ^ list of key-value pairs - @https://hackage.haskell.org/?foo=bar&baz&qux=@ is+ -- @[("foo", Just "bar"), ("baz", Nothing), ("qux", Just "")]@+ , uriFragment :: !(Maybe Text) -- ^ uri suffix - @https://hackage.haskell.org/#some-header@ is @Just "some-header"@+ } deriving (Eq, Data, 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++++parseURI :: Parser URI+parseURI =+ URI <$> ((Just <$> parseScheme) <|> pure Nothing)+ <*> parseSlashes+ <*> parseURIAuth+ <*> parsePath+ <*> parseQuery+ <*> ((Just <$> parseFragment) <|> pure Nothing)+ where+ parseScheme = do+ sch <- many1 (satisfy $ \c -> all (c /=) [':','/','@','.'])+ _ <- char ':'+ pure (T.pack sch)+ parseSlashes = do+ mS <- (Just <$> string "//") <|> pure Nothing+ case mS of+ Nothing -> pure False+ Just _ -> pure True+ parsePath =+ ( do _ <- char '/'+ V.fromList <$> (T.pack <$> many (satisfy $ \c -> all (c /=) ['/', '?', '=', '&', '#'])) `sepBy` (char '/')+ ) <|> pure V.empty+ parseQuery :: Parser (Vector (Pair Text (Maybe Text)))+ parseQuery =+ ( do _ <- char '?'+ let parse1 = do+ k <- many (satisfy (\c -> all (c /=) ['=', '&', '#']))+ mV <- ( Just <$> do _ <- char '='+ v <- many (satisfy $ \c -> c /= '&' && c /= '#')+ pure (T.pack v)+ ) <|> ( pure Nothing+ )+ pure (T.pack k :!: mV)+ qs <- parse1 `sepBy` (char '&')+ pure $ V.fromList qs+ ) <|> pure V.empty+ parseFragment = do+ _ <- char '#'+ T.pack <$> many anyChar
+ src/Data/URI/Auth.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE+ RecordWildCards+ , OverloadedStrings+ , DeriveGeneric+ , DeriveDataTypeable+ , StandaloneDeriving+ #-}++module Data.URI.Auth where++import Data.URI.Auth.Host (URIAuthHost, parseURIAuthHost)++import Prelude hiding (Maybe (..))+import Data.Strict.Maybe (Maybe (..), fromMaybe)+import Data.Text (Text)+import Data.Word (Word16)+import qualified Data.Text as T+import Data.Attoparsec.Text (Parser, many1, char, notChar, satisfy, decimal, peekChar)+import Data.Monoid ((<>))+import Control.Applicative ((<|>))+import qualified GHC.Base++import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+++deriving instance Data a => Data (Maybe a)++data URIAuth = URIAuth+ { uriAuthUser :: !(Maybe Text) -- ^ a designated user - @ssh://git\@github.com@ is @git@+ , uriAuthHost :: !URIAuthHost+ , uriAuthPort :: !(Maybe Word16) -- ^ the port, if it exists - @foobar.com:3000@ is @3000@ as a 16-bit unsigned int.+ } deriving (Eq, Data, Typeable, Generic)++instance Show URIAuth where+ show URIAuth{..} =+ fromMaybe "" ((\u -> T.unpack $ u <> "@") <$> uriAuthUser)+ ++ show uriAuthHost+ ++ fromMaybe "" ((\p -> ":" ++ show p) <$> uriAuthPort)+++parseURIAuth :: Parser URIAuth+parseURIAuth =+ URIAuth <$> ((Just <$> parseUser) <|> pure Nothing)+ <*> parseURIAuthHost+ <*> ((Just <$> parsePort) <|> pure Nothing)+ where+ parseUser = do+ u <- many1 $ satisfy $ \c -> all (c /=) ['@','.',':','/','?','&','=']+ mC <- peekChar+ case mC of+ GHC.Base.Nothing -> fail "no user @ thing"+ _ -> do+ _ <- char '@'+ pure $ T.pack u+ parsePort = do+ _ <- char ':'+ decimal
+ src/Data/URI/Auth/Host.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE+ DataKinds+ , DeriveGeneric+ , DeriveDataTypeable+ #-}++module Data.URI.Auth.Host where++import Prelude hiding (Either (..))++import Data.Strict (Either (..))+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Text (Text)+import qualified Data.Text as T+import Data.NTuple (NTuple, _1, _2, _3, _4, _5, _6, _7, _8)+import qualified Data.NTuple as NTuple+import Data.Word (Word8, Word16)+import Data.Attoparsec.Text (Parser, peekChar', decimal, hexadecimal, char, notChar, sepBy1, many1, satisfy)+import Data.Char (isDigit, isHexDigit)+import Data.Bits ((.&.), shiftR)+import Data.List (intercalate)+import Control.Applicative ((<|>))+import Text.Read (readMaybe)+import Text.Bytedump (hexString)++import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+++++type IPv4 = NTuple 4 Word8++parseIPv4 :: Parser IPv4+parseIPv4 = do+ a <- parseOctet+ _ <- char '.'+ b <- parseOctet+ _ <- char '.'+ c <- parseOctet+ _ <- char '.'+ d <- parseOctet+ pure $ NTuple.incl _4 d+ . NTuple.incl _3 c+ . NTuple.incl _2 b+ . NTuple.incl _1 a+ $ NTuple.empty+ where+ parseOctet :: Parser Word8+ parseOctet = decimal++showIPv4 :: IPv4 -> String+showIPv4 xs =+ intercalate "." $ V.toList $ show <$> NTuple.toVector xs+++type IPv6 = NTuple 8 Word16++parseIPv6 :: Parser IPv6+parseIPv6 = do+ a <- parseDiOctet+ _ <- char ':'+ b <- parseDiOctet+ _ <- char ':'+ c <- parseDiOctet+ _ <- char ':'+ d <- parseDiOctet+ _ <- char ':'+ let soFar = NTuple.incl _4 d+ . NTuple.incl _3 c+ . NTuple.incl _2 b+ . NTuple.incl _1 a+ $ NTuple.empty+ q <- peekChar'+ if q == ':'+ then pure $ NTuple.incl _8 0+ . NTuple.incl _7 0+ . NTuple.incl _6 0+ . NTuple.incl _5 0+ $ soFar+ else do+ e <- parseDiOctet+ _ <- char ':'+ f <- parseDiOctet+ _ <- char ':'+ g <- parseDiOctet+ _ <- char ':'+ h <- parseDiOctet+ pure $ NTuple.incl _8 h+ . NTuple.incl _7 g+ . NTuple.incl _6 f+ . NTuple.incl _5 e+ $ soFar+ where+ parseDiOctet :: Parser Word16+ parseDiOctet = hexadecimal+++showIPv6 :: IPv6 -> String+showIPv6 xs =+ let xs'@(a:b:c:d:qs) = V.toList $ NTuple.toVector xs+ in if all (== 0) qs+ then intercalate ":" (showWord16 <$> [a,b,c,d]) ++ "::"+ else intercalate ":" (showWord16 <$> xs')+ where+ showWord16 :: Word16 -> String+ showWord16 x =+ let (l,r) = breakWord16 x+ in hexString l ++ hexString r+ where+ breakWord16 :: Word16 -> (Word8, Word8)+ breakWord16 x = ( fromIntegral $ (x .&. 0xFF00) `shiftR` 8+ , fromIntegral $ x .&. 0xFF+ )++++data URIAuthHost+ = IPv4 !IPv4+ | IPv6 !IPv6+ | -- | @Host ["foo","bar"] "com"@ represents @foo.bar.com@+ Host+ { uriAuthHostName :: !(Vector Text)+ , uriAuthHostSuffix :: !Text+ } deriving (Eq, Data, Typeable, Generic)++instance Show URIAuthHost where+ show (IPv4 l4) = showIPv4 l4+ show (IPv6 r6) = showIPv6 r6+ show (Host ns c) = intercalate "." $ V.toList $ T.unpack <$> ns `V.snoc` c+++parseURIAuthHost :: Parser URIAuthHost+parseURIAuthHost =+ (IPv4 <$> parseIPv4)+ <|> (IPv6 <$> parseIPv6)+ <|> (uncurry Host <$> parseHost)+ where+ parseHost :: Parser (Vector Text, Text)+ parseHost = do+ xss@(x:xs) <- many1 (satisfy $ \c -> all (c /=) ['.',':','/','?']) `sepBy1` char '.'+ if null xs+ then fail "Only one term parsed"+ else let xss' :: Vector Text+ xss' = T.pack <$> V.fromList xss+ unsnoc :: Vector a -> (Vector a, a)+ unsnoc x =+ let (fs,l) = V.splitAt (V.length x - 1) x+ in (fs, l V.! 0)+ (ns,c) = unsnoc xss'+ in pure (unsnoc xss')