diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for altsvc + +## 0.1.0.0 - 2019-11-24 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/altsvc.cabal b/altsvc.cabal new file mode 100644 --- /dev/null +++ b/altsvc.cabal @@ -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 diff --git a/src/Network/HTTP/AltSvc.hs b/src/Network/HTTP/AltSvc.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/AltSvc.hs @@ -0,0 +1,162 @@ +-- | +-- Module : Network.HTTP.AltSvc +-- License : BSD-style +-- Maintainer : Olivier Chéron +-- Stability : stable +-- Portability : good +-- +-- HTTP Alternative Services, +-- defined in . +{-# 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 diff --git a/src/Network/HTTP/AltSvc/Utils.hs b/src/Network/HTTP/AltSvc/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/AltSvc/Utils.hs @@ -0,0 +1,101 @@ +-- | +-- Module : Network.HTTP.AltSvc.Utils +-- License : BSD-style +-- Maintainer : Olivier Chéron +-- 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) diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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 + ]