packages feed

altsvc (empty) → 0.1.0.0

raw patch · 8 files changed

+454/−0 lines, 8 filesdep +altsvcdep +basedep +bytestringsetup-changed

Dependencies added: altsvc, base, bytestring, cereal, tasty, tasty-hunit, tasty-quickcheck

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for altsvc++## 0.1.0.0 - 2019-11-24++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Olivier Chéron (c) 2019++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 Olivier Chéron 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,4 @@+# altsvc++Haskell code to parse and generate the `Alt-Svc` HTTP header field defined in+[RFC 7838](https://tools.ietf.org/html/rfc7838).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ altsvc.cabal view
@@ -0,0 +1,61 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4d0985fc39cc65b37eb24f9d49ac08590807733935a81be60709100900c83b9d++name:           altsvc+version:        0.1.0.0+synopsis:       HTTP Alternative Services+description:    Haskell code to parse and generate the @Alt-Svc@ HTTP header field.+category:       Network, Web+homepage:       https://github.com/ocheron/hs-altsvc#readme+bug-reports:    https://github.com/ocheron/hs-altsvc/issues+author:         Olivier Chéron+maintainer:     olivier.cheron@gmail.com+copyright:      2019 Olivier Chéron+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/ocheron/hs-altsvc++library+  exposed-modules:+      Network.HTTP.AltSvc+  other-modules:+      Network.HTTP.AltSvc.Utils+      Paths_altsvc+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.9 && <5+    , bytestring+    , cereal+  default-language: Haskell2010++test-suite altsvc-test+  type: exitcode-stdio-1.0+  main-is: Tests.hs+  other-modules:+      Paths_altsvc+  hs-source-dirs:+      tests+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      altsvc+    , base >=4.9 && <5+    , bytestring+    , cereal+    , tasty+    , tasty-hunit+    , tasty-quickcheck+  default-language: Haskell2010
+ src/Network/HTTP/AltSvc.hs view
@@ -0,0 +1,162 @@+-- |+-- Module      : Network.HTTP.AltSvc+-- License     : BSD-style+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability   : stable+-- Portability : good+--+-- HTTP Alternative Services,+-- defined in <https://tools.ietf.org/html/rfc7838 RFC 7838>.+{-# LANGUAGE OverloadedStrings #-}+module Network.HTTP.AltSvc+    ( AltSvc(..)+    , AltValue(..)+    ) where++import Control.Applicative+import Control.Monad++import           Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B+import           Data.ByteString.Lazy (toStrict)++import Data.Char (chr)+import Data.Semigroup+import Data.Serialize++import Network.HTTP.AltSvc.Utils++-- | Data type to represent the @Alt-Svc@ header content.  It generally contains+-- one or more values.  An empty list is also possible and allows to invalidate+-- all alternatives, which is different from providing no header at all.+--+-- The content can be encoded to/decoded from bytestring using the 'Serialize'+-- instance.+newtype AltSvc = AltSvc [AltValue] deriving (Show, Eq)++instance Serialize AltSvc where+    get = getAltSvc+    put = putAltSvc++-- | An individual service in the @Alt-Svc@ header.+--+-- The content can be encoded to/decoded from bytestring using the 'Serialize'+-- instance.+data AltValue = AltValue+    { altValueProtocolId :: ByteString+      -- ^ The protocol to use for the alternative service.  Has the syntax of+      -- an ALPN protocol name and cannot be empty.+    , altValueHost       :: ByteString+      -- ^ Host name to connect to the alternative service.  Is optional so may+      -- be empty.+    , altValuePort       :: Int+      -- ^ Port number to connect to the alternative service.  Is mandatory and+      -- cannot be negative.+    , altValueParams     :: [(ByteString, ByteString)]+      -- ^ Additional parameters for the alternative.  The parameter names must+      -- be valid tokens, which means no delimiter character is accepted, and+      -- cannot be empty.  The values may be any bytestring.+    }+    deriving (Show, Eq)++instance Serialize AltValue where+    get = getAltValue+    put = putAltValue++putPercentEncoded :: Putter ByteString+putPercentEncoded bs = mapM_ f (B.unpack bs)+  where+    f 0x25          = putEncodeChar 0x25+    f b | istchar b = putWord8 b+        | otherwise = putEncodeChar b++    putEncodeChar b =+        let (d, r) = b `divMod` 16+            high   = toDigit d+            low    = toDigit r+         in putWord8 0x25 >> putWord8 high >> putWord8 low++    toDigit b | b < 10    = 0x30 + b+              | otherwise = b - 10 + 0x41++getPercentEncoded :: Get ByteString+getPercentEncoded = B.pack <$> parse+  where+    parse = do+        b <- getWord8+        guard (istchar b)+        case b of+            0x25 -> do+                c <- label "percent-encoded byte" $ do+                    d <- getWord8 >>= fromDigit+                    r <- getWord8 >>= fromDigit+                    return $! d * 16 + r+                (c :) <$> parseMore+            _    -> (b :) <$> parseMore++    parseMore = parse <|> return []++    fromDigit b+        | b >= 0x30 && b <= 0x39 = return $! b - 0x30+        | b >= 0x41 && b <= 0x46 = return $! b - 0x41 + 10+        | otherwise              = fail "bad hex digit"++getAltSvc :: Get AltSvc+getAltSvc = AltSvc <$> (getCommaList getAltValue <|> getClear)+  where getClear = getExpected "clear" >> return []++putAltSvc :: Putter AltSvc+putAltSvc (AltSvc [])   = putByteString "clear"+putAltSvc (AltSvc vals) = putCommaList putAltValue vals++getAltValue :: Get AltValue+getAltValue = do+    protocolId <- getPercentEncoded+    label "equals sign" $ skipWord8 0x3d+    authority <- getQuoted+    (host, port) <- either fail return (parseAuth authority)+    params <- getMany getParam+    return AltValue { altValueProtocolId = protocolId+                    , altValueHost       = host+                    , altValuePort       = port+                    , altValueParams     = params+                    }++putAltValue :: Putter AltValue+putAltValue altValue = do+    putPercentEncoded (altValueProtocolId altValue)+    putWord8 0x3d+    putQuoted $ buildAuth (altValueHost altValue) (altValuePort altValue)+    mapM_ putParam (altValueParams altValue)++parseAuth :: ByteString -> Either String (ByteString, Int)+parseAuth authority = case B.elemIndexEnd 0x3a authority of+    Nothing -> Left "invalid authority"+    Just i  ->+        let str = B.drop (i + 1) authority+            p = read (map (chr . fromIntegral) $ B.unpack str)+         in if allDigits str && not (B.null str)+                then Right (B.take i authority, p)+                else Left "invalid authority port"+  where allDigits = B.all $ \b -> b >= 0x30 && b <= 0x39++buildAuth :: ByteString -> Int -> ByteString+buildAuth host port = toStrict $ B.toLazyByteString authority+  where authority = B.byteString host <> B.word8 0x3a <> B.intDec port++getParam :: Get (ByteString, ByteString)+getParam = do+    skipOWP >> label "semi-colon" (skipWord8 0x3b) >> skipOWP+    name <- getToken+    label "equals sign" $ skipWord8 0x3d+    value <- getToken <|> getQuoted+    return (name, value)++putParam :: Putter (ByteString, ByteString)+putParam (name, value) = do+    putByteString "; "+    putToken name+    putWord8 0x3d+    let validTokenValue = not (B.null value) && B.all istchar value+    if validTokenValue then putToken value else putQuoted value
+ src/Network/HTTP/AltSvc/Utils.hs view
@@ -0,0 +1,101 @@+-- |+-- Module      : Network.HTTP.AltSvc.Utils+-- License     : BSD-style+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability   : stable+-- Portability : good+--+{-# LANGUAGE OverloadedStrings #-}+module Network.HTTP.AltSvc.Utils+    ( skipWord8+    , getMany+    , skipOWP+    , istchar+    , getExpected+    , getToken+    , putToken+    , getQuoted+    , putQuoted+    , getCommaList+    , putCommaList+    ) where++import Control.Applicative+import Control.Monad++import           Data.ByteString (ByteString)+import qualified Data.ByteString as B++import Data.Serialize+import Data.Word (Word8)++skipWord8 :: Word8 -> Get ()+skipWord8 b = getWord8 >>= guard . (== b)++skipMany :: Get a -> Get ()+skipMany skipOne = (skipOne >> skipMany skipOne) <|> return ()++getMany :: Get a -> Get [a]+getMany getOne = go <|> return []+  where go = do { a <- getOne; as <- getMany getOne; return (a:as) }++skipWSP :: Get ()+skipWSP = label "whitespace" $ getWord8 >>= guard . flip B.elem " \t"++skipOWP :: Get ()+skipOWP = skipMany skipWSP++getExpected :: ByteString -> Get ()+getExpected expected =+    getBytes (B.length expected) >>= \bs -> guard (bs == expected)++isvchar :: Word8 -> Bool+isvchar b = b > 0x20 && b < 0x80  -- visible (printing) characters++istchar :: Word8 -> Bool+istchar b = isvchar b && B.notElem b "\"(),/:;<=>?@[\\]{}"++getToken :: Get ByteString+getToken = B.pack <$> getTokenBytes+  where+    getTokenBytes = do+        b <- getWord8+        guard (istchar b)+        (b :) <$> (getTokenBytes <|> return [])++putToken :: Putter ByteString+putToken = putByteString++getQuoted :: Get ByteString+getQuoted = label "double quote" (skipWord8 0x22) >> (B.pack <$> getInner)+  where+    getInner = do+        b <- getWord8+        case b of+            0x22 -> return []+            0x5c -> label "quoted byte" getWord8 >>= \c -> (c :) <$> getInner+            _    -> (b :) <$> getInner++putQuoted :: Putter ByteString+putQuoted bs = do+    putWord8 0x22+    mapM_ putQuotedByte (B.unpack bs)+    putWord8 0x22+  where+    putQuotedByte 0x22 = putByteString "\\\""+    putQuotedByte 0x5c = putByteString "\\\\"+    putQuotedByte b    = putWord8 b++getCommaList :: Show a => Get a -> Get [a]+getCommaList getOne = do+    a <- getOne+    skipOWP+    as <- (skipComma >> skipOWP >> getCommaList getOne) <|> return []+    return (a:as)+  where+    skipComma = label "comma" (skipWord8 0x2c)++putCommaList :: Putter a -> Putter [a]+putCommaList _      []     = error "putCommaList: empty list"+putCommaList putOne (a:as) =+    putOne a >> unless (null as) (putByteString ", " >> putCommaList putOne as)
+ tests/Tests.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Serialize++import Network.HTTP.AltSvc++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++arbitraryByteString :: Gen ByteString+arbitraryByteString = B.pack <$> listOf (choose (0,255))++arbitraryToken :: Gen ByteString+arbitraryToken = B.pack <$> listOf1 arbitraryTokenByte+  where+    arbitraryTokenByte = oneof+        [ elements [ 0x21, 0x23, 0x24, 0x25, 0x26, 0x27, 0x2a, 0x2b+                   , 0x2d, 0x2e, 0x5e, 0x5f, 0x60, 0x7c, 0x7e ]+        , choose (0x30, 0x39)  -- 0-9+        , choose (0x41, 0x5a)  -- A-Z+        , choose (0x61, 0x7a)  -- a-z+        ]++arbitraryParam :: Gen (ByteString, ByteString)+arbitraryParam = (,) <$> arbitraryToken <*> arbitraryByteString++arbitraryProtocolId :: Gen ByteString+arbitraryProtocolId = B.pack <$> listOf1 (choose (0,255))++instance Arbitrary AltValue where+    arbitrary = AltValue+        <$> arbitraryProtocolId+        <*> arbitraryByteString+        <*> choose (0,65535)+        <*> listOf arbitraryParam++instance Arbitrary AltSvc where+    arbitrary = fmap AltSvc arbitrary++vectors :: [(AltSvc, ByteString)]+vectors =+    [ ( AltSvc []+      , "clear")+    , ( AltSvc [AltValue "h2" "" 8000 []]+      , "h2=\":8000\"")+    , ( AltSvc [AltValue "h2" "new.example.org" 80 []]+      , "h2=\"new.example.org:80\"")+    , ( AltSvc [AltValue "w=x:y#z" "" 80 []]+      , "w%3Dx%3Ay#z=\":80\"")+    , ( AltSvc [AltValue "x%y" "" 80 []]+      , "x%25y=\":80\"")+    , ( AltSvc [AltValue "h2" "alt.example.com" 8000 [], AltValue "h2" "" 443 []]+      , "h2=\"alt.example.com:8000\", h2=\":443\"")+    , ( AltSvc [AltValue "h2" "" 443 [("ma", "3600")]]+      , "h2=\":443\"; ma=3600")+    , ( AltSvc [AltValue "h2" "" 443 [("ma", "2592000"), ("persist", "1")]]+      , "h2=\":443\"; ma=2592000; persist=1")+    , ( AltSvc [AltValue "clear" "alt.example.com" 8080 []]+      , "clear=\"alt.example.com:8080\"")+    ]++runGetFull :: Get a -> ByteString -> Either String a+runGetFull parse bs = handle (runGetPartial parse bs)+  where+    handle result = case result of+        Fail i _        -> Left i+        Partial f       -> handle (f B.empty)  -- confirm complete+        Done a rb+            | B.null rb -> Right a  -- fully parsed+            | otherwise -> Left ("Remaining bytes: " ++ show rb)++main :: IO ()+main = defaultMain $ testGroup "altsvc"+    [ localOption (QuickCheckMaxSize 10) $ testGroup "properties"+        [ testProperty "AltValue" $ \v ->+            runGetFull get (runPut $ put v) === Right (v :: AltValue)+        , testProperty "AltSvc" $ \v ->+            runGetFull get (runPut $ put v) === Right (v :: AltSvc)+        ]+    , testGroup "vectors" $+        let toCase i (v, bs) = testGroup (show i)+                [ testCase "getting" $ Right v @=? runGetFull get bs+                , testCase "putting" $ bs @=? runPut (put v)+                ]+        in zipWith toCase [(1::Int)..] vectors+    ]