X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FHeaders.hs;h=5391743d1163833a1b47b8f10e14ef4edf91e369;hp=b26ddddfc17a0a0fa81eec7bcd5ae0bfba2b4d1d;hb=90fca0675b1694e69b8e431c989343855cbd125d;hpb=83db536d11e8efb26848318ad4514b825f412460 diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index b26dddd..5391743 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -1,146 +1,131 @@ +{-# LANGUAGE + FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , TemplateHaskell + , TypeSynonymInstances + , OverloadedStrings + , UnicodeSyntax + #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +-- |An internal module for HTTP headers. module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) - - , noCaseCmp - , noCaseEq - - , emptyHeaders - , toHeaders - , fromHeaders - - , headersP - , hPutHeaders ) where - -import Data.ByteString.Base (ByteString, toForeignPtr, w2c, inlinePerformIO) -import qualified Data.ByteString.Char8 as C8 -import Data.Char -import Data.List -import Data.Map (Map) -import qualified Data.Map as M -import Data.Word -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils -import System.IO - -type Headers = Map NCBS ByteString -newtype NCBS = NCBS ByteString - -toNCBS :: ByteString -> NCBS -toNCBS = NCBS -{-# INLINE toNCBS #-} - -fromNCBS :: NCBS -> ByteString -fromNCBS (NCBS x) = x -{-# INLINE fromNCBS #-} - -instance Eq NCBS where - (NCBS a) == (NCBS b) = a == b - -instance Ord NCBS where - (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b - -instance Show NCBS where - show (NCBS x) = show x - -noCaseCmp :: ByteString -> ByteString -> Ordering -noCaseCmp a b = a `seq` b `seq` - toForeignPtr a `cmp` toForeignPtr b - where - cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering - cmp (x1, s1, l1) (x2, s2, l2) - | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined - | l1 == 0 && l2 == 0 = EQ - | x1 == x2 && s1 == s2 && l1 == l2 = EQ - | otherwise - = inlinePerformIO $ - withForeignPtr x1 $ \ p1 -> - withForeignPtr x2 $ \ p2 -> - noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2 - - --- もし先頭の文字列が等しければ、短い方が小さい。 -noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering -noCaseCmp' p1 l1 p2 l2 - | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined - | l1 == 0 && l2 == 0 = return EQ - | l1 == 0 && l1 /= 0 = return LT - | l1 /= 0 && l2 == 0 = return GT - | otherwise - = do c1 <- peek p1 - c2 <- peek p2 - case toLower (w2c c1) `compare` toLower (w2c c2) of - EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1) - x -> return x - - -noCaseEq :: ByteString -> ByteString -> Bool -noCaseEq a b = a `seq` b `seq` - toForeignPtr a `cmp` toForeignPtr b - where - cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool - cmp (x1, s1, l1) (x2, s2, l2) - | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined - | l1 /= l2 = False - | l1 == 0 && l2 == 0 = True - | x1 == x2 && s1 == s2 && l1 == l2 = True - | otherwise - = inlinePerformIO $ - withForeignPtr x1 $ \ p1 -> - withForeignPtr x2 $ \ p2 -> - noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1 - - -noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool -noCaseEq' p1 p2 l - | p1 `seq` p2 `seq` l `seq` False = undefined - | l == 0 = return True - | otherwise - = do c1 <- peek p1 - c2 <- peek p2 - if toLower (w2c c1) == toLower (w2c c2) then - noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1) - else - return False - +import Control.Applicative hiding (empty) +import Control.Applicative.Unicode hiding ((∅)) +import Control.Monad +import Data.Ascii (Ascii, AsciiBuilder, CIAscii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 +import qualified Data.Collections.Newtype.TH as C +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils +import Data.Default +import Data.List (intersperse) +import qualified Data.Map as M (Map) +import Data.Collections +import Data.Collections.BaseInstances () +import Data.Monoid +import Data.Monoid.Unicode +import Network.HTTP.Lucu.Parser.Http +import Prelude hiding (lookup, null) +import Prelude.Unicode + +newtype Headers + = Headers (M.Map CIAscii Ascii) + deriving (Eq, Show) class HasHeaders a where - getHeaders :: a -> Headers - setHeaders :: a -> Headers -> a - - getHeader :: ByteString -> a -> Maybe ByteString - getHeader key a - = key `seq` a `seq` - M.lookup (toNCBS key) (getHeaders a) - - deleteHeader :: ByteString -> a -> a - deleteHeader key a - = key `seq` a `seq` - setHeaders a $ M.delete (toNCBS key) (getHeaders a) - - setHeader :: ByteString -> ByteString -> a -> a - setHeader key val a - = key `seq` val `seq` a `seq` - setHeaders a $ M.insert (toNCBS key) val (getHeaders a) - - -emptyHeaders :: Headers -emptyHeaders = M.empty - - -toHeaders :: [(ByteString, ByteString)] -> Headers -toHeaders xs = M.fromList [(toNCBS a, b) | (a, b) <- xs] - - -fromHeaders :: Headers -> [(ByteString, ByteString)] -fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] - + getHeaders ∷ a → Headers + setHeaders ∷ a → Headers → a + + modifyHeaders ∷ (Headers → Headers) → a → a + {-# INLINE modifyHeaders #-} + modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders) + + getHeader ∷ CIAscii → a → Maybe Ascii + {-# INLINE getHeader #-} + getHeader = (∘ getHeaders) ∘ lookup + + hasHeader ∷ CIAscii → a → Bool + {-# INLINE hasHeader #-} + hasHeader = (∘ getHeaders) ∘ member + + getCIHeader ∷ CIAscii → a → Maybe CIAscii + {-# INLINE getCIHeader #-} + getCIHeader = ((cs <$>) ∘) ∘ getHeader + + deleteHeader ∷ CIAscii → a → a + {-# INLINE deleteHeader #-} + deleteHeader = modifyHeaders ∘ delete + + setHeader ∷ CIAscii → Ascii → a → a + {-# INLINE setHeader #-} + setHeader = (modifyHeaders ∘) ∘ insertWith const + +instance HasHeaders Headers where + getHeaders = id + setHeaders _ = id + +C.derive [d| instance Foldable Headers (CIAscii, Ascii) + instance Collection Headers (CIAscii, Ascii) + instance Indexed Headers CIAscii Ascii + instance Map Headers CIAscii Ascii + instance SortingCollection Headers (CIAscii, Ascii) + |] + +-- |@'insert' (key, val)@ merges @val@ with an existing one if any. +instance Unfoldable Headers (CIAscii, Ascii) where + {-# INLINE insert #-} + insert (key, val) (Headers m) + = Headers $ insertWith merge key val m + {-# INLINE empty #-} + empty = Headers empty + {-# INLINE singleton #-} + singleton = Headers ∘ singleton + +instance Monoid Headers where + {-# INLINE mempty #-} + mempty = empty + {-# INLINE mappend #-} + mappend = insertMany + +merge ∷ Ascii → Ascii → Ascii +{-# INLINE merge #-} +merge a b + | nullA a ∧ nullA b = (∅) + | nullA a = b + | nullA b = a + | otherwise = a ⊕ ", " ⊕ b + where + nullA ∷ Ascii → Bool + {-# INLINE nullA #-} + nullA = null ∘ A.toByteString + +instance ConvertSuccess Headers Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess Headers AsciiBuilder where + {-# INLINEABLE convertSuccess #-} + convertSuccess (Headers m) + = mconcat (header <$> fromFoldable m) ⊕ cs ("\x0D\x0A" ∷ Ascii) + where + header ∷ (CIAscii, Ascii) → AsciiBuilder + {-# INLINE header #-} + header (name, value) + = cs name ⊕ + cs (": " ∷ Ascii) ⊕ + cs value ⊕ + cs ("\x0D\x0A" ∷ Ascii) + +deriveAttempts [ ([t| Headers |], [t| Ascii |]) + , ([t| Headers |], [t| AsciiBuilder |]) + ] {- message-header = field-name ":" [ field-value ] @@ -153,49 +138,31 @@ fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] field-value の先頭および末尾にある LWS は全て削除され、それ以外の LWS は單一の SP に變換される。 -} -headersP :: Parser Headers -headersP = do xs <- many header - crlf - return (M.fromList xs) - where - header :: Parser (NCBS, ByteString) - header = do name <- token - char ':' - -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 - -- の記述はひどく曖昧であり、この動作が本當に間違って - -- ゐるのかどうかも良く分からない。例へば - -- quoted-string の内部にある空白は纏めていいのか惡い - -- のか？直勸的には駄目さうに思へるが、そんな記述は見 - -- 付からない。 - contents <- many (lws <|> many1 text) - crlf - let value = foldr (++) "" contents - norm = normalize value - return (toNCBS $ C8.pack name, C8.pack norm) - - normalize :: String -> String - normalize = trimBody . trim isWhiteSpace - - trimBody = foldr (++) [] - . map (\ s -> if head s == ' ' then - " " - else - s) - . group - . map (\ c -> if isWhiteSpace c - then ' ' - else c) - - -hPutHeaders :: Handle -> Headers -> IO () -hPutHeaders h hds - = h `seq` hds `seq` - mapM_ putH (M.toList hds) >> hPutStr h "\r\n" - where - putH :: (NCBS, ByteString) -> IO () - putH (name, value) - = name `seq` value `seq` - do C8.hPutStr h (fromNCBS name) - C8.hPutStr h (C8.pack ": ") - C8.hPutStr h value - C8.hPutStr h (C8.pack "\r\n") +instance Default (Parser Headers) where + {-# INLINEABLE def #-} + def = do xs ← many header + crlf + return $ fromFoldable xs + where + header ∷ Parser (CIAscii, Ascii) + {-# INLINEABLE header #-} + header = do name ← cs <$> token + void $ char ':' + skipMany lws + values ← content `sepBy` try lws + skipMany (try lws) + crlf + return (name, joinValues values) + + content ∷ Parser Ascii + {-# INLINEABLE content #-} + content = A.unsafeFromByteString + <$> + takeWhile1 (\c → isText c ∧ c ≢ '\x20') + + joinValues ∷ [Ascii] → Ascii + {-# INLINEABLE joinValues #-} + joinValues = cs + ∘ mconcat + ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder) + ∘ (cs <$>)