Headers is now instances of collections-api's type classes.

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
index 064a97ebd8671232b9053a6382d93c85927df318..7b69fb53ae95460d6e6d970b47db4094689cbee2 100644 (file)
--- a/Network/HTTP/Lucu/Abortion.hs
+++ b/Network/HTTP/Lucu/Abortion.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    UnicodeSyntax
+    FlexibleContexts
+  , UnicodeSyntax

   #-}
 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
 -- in any 'Prelude.IO' monads or arrows.
   #-}
 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
 -- in any 'Prelude.IO' monads or arrows.


@@ -14,21 +15,25 @@ module Network.HTTP.Lucu.Abortion
 import Control.Exception
 import Control.Monad.Trans
 import Data.Ascii (Ascii, CIAscii)
 import Control.Exception
 import Control.Monad.Trans
 import Data.Ascii (Ascii, CIAscii)

+import Data.Collections

 import Data.Monoid.Unicode
 import Data.Text (Text)
 import Network.HTTP.Lucu.Abortion.Internal
 import Data.Monoid.Unicode
 import Data.Text (Text)
 import Network.HTTP.Lucu.Abortion.Internal

-import Network.HTTP.Lucu.Headers

 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 
 -- |Construct an 'Abortion' with additional headers and an optional
 -- message text.
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 
 -- |Construct an 'Abortion' with additional headers and an optional
 -- message text.

-mkAbortion ∷ StatusCode sc ⇒ sc → [(CIAscii, Ascii)] → Maybe Text → Abortion
+mkAbortion ∷ (StatusCode sc, Foldable f (CIAscii, Ascii))
+           ⇒ sc
+           → f
+           → Maybe Text
+           → Abortion

 {-# INLINE mkAbortion #-}
 {-# INLINE mkAbortion #-}

-mkAbortion sc hdr msg
+mkAbortion sc hdrs msg

     = Abortion {
         aboStatus  = fromStatusCode sc
     = Abortion {
         aboStatus  = fromStatusCode sc

-      , aboHeaders = toHeaders hdr
+      , aboHeaders = fromFoldable hdrs

       , aboMessage = msg
       }
 
       , aboMessage = msg
       }
 

diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs
index 6142c23ec6b97f783c906348c40f6ff9f43e0bf8..93fb8da44a70d87375d79bf47cb763385ba75450 100644 (file)
--- a/Network/HTTP/Lucu/Abortion/Internal.hs
+++ b/Network/HTTP/Lucu/Abortion/Internal.hs
@@ -12,6 +12,7 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
 import Control.Exception
 import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
 import Control.Exception

+import Data.Collections

 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Typeable
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Typeable


@@ -20,7 +21,6 @@ import Network.HTTP.Lucu.DefaultPage
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response

-import Prelude.Unicode

 import Text.XML.HXT.Arrow.WriteDocument
 import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
 import Text.XML.HXT.Arrow.WriteDocument
 import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState


@@ -67,8 +67,9 @@ abortPage conf reqM res abo
               in
                 BB.fromString html
         Nothing
               in
                 BB.fromString html
         Nothing

-            → let res'  = res { resStatus = aboStatus abo }
-                  res'' = foldl (∘) id [setHeader name value
-                                            | (name, value) ← fromHeaders $ aboHeaders abo] res'
+            → let res' = res {
+                            resStatus  = aboStatus abo
+                          , resHeaders = insertMany (aboHeaders abo) (resHeaders res)
+                          }

                in
                in

-                 getDefaultPage conf reqM res''
+                 getDefaultPage conf reqM res'

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 80b9b1339501d95a08c80511645e3603a5b1d9ea..8219624df47b052df0be224e37dbda10957927bc 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    GeneralizedNewtypeDeriving
+    FlexibleInstances
+  , GeneralizedNewtypeDeriving
+  , MultiParamTypeClasses
+  , TypeSynonymInstances

   , OverloadedStrings
   , UnicodeSyntax
   #-}
   , OverloadedStrings
   , UnicodeSyntax
   #-}


@@ -8,103 +11,125 @@ module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
 
     ( Headers
     , HasHeaders(..)
 

-    , singleton
-
-    , toHeaders
-    , fromHeaders
-

     , headers
     , printHeaders
     )
     where
 import Control.Applicative
     , headers
     , printHeaders
     )
     where
 import Control.Applicative

+import Control.Applicative.Unicode hiding ((∅))
+import Control.Arrow

 import Control.Monad
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import Control.Monad
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P

-import qualified Data.ByteString as BS
-import Data.List
-import Data.Map (Map)
+import Data.List (intersperse)

 import qualified Data.Map as M
 import qualified Data.Map as M

-import qualified Data.Map.Unicode as M
+import Data.Collections
+import Data.Collections.BaseInstances ()

 import Data.Monoid
 import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http
 import Data.Monoid
 import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http

+import Prelude hiding (filter, lookup, null)

 import Prelude.Unicode
 
 newtype Headers
 import Prelude.Unicode
 
 newtype Headers

-    = Headers (Map CIAscii Ascii)
-      deriving (Eq, Show, Monoid)
+    = Headers (M.Map CIAscii Ascii)
+      deriving (Eq, Monoid, Show)

 
 class HasHeaders a where
     getHeaders ∷ a → Headers
     setHeaders ∷ a → Headers → a
 
 
 class HasHeaders a where
     getHeaders ∷ a → Headers
     setHeaders ∷ a → Headers → a
 

+    modifyHeaders ∷ (Headers → Headers) → a → a
+    {-# INLINE modifyHeaders #-}
+    modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)
+

     getHeader ∷ CIAscii → a → Maybe Ascii
     getHeader ∷ CIAscii → a → Maybe Ascii

-    getHeader key a
-        = case getHeaders a of
-            Headers m → M.lookup key m
+    {-# INLINE getHeader #-}
+    getHeader = (∘ getHeaders) ∘ lookup

 
     hasHeader ∷ CIAscii → a → Bool
     {-# INLINE hasHeader #-}
 
     hasHeader ∷ CIAscii → a → Bool
     {-# INLINE hasHeader #-}

-    hasHeader key a
-        = case getHeaders a of
-            Headers m → key M.∈ m
+    hasHeader = (∘ getHeaders) ∘ member

 
     getCIHeader ∷ CIAscii → a → Maybe CIAscii
     {-# INLINE getCIHeader #-}
 
     getCIHeader ∷ CIAscii → a → Maybe CIAscii
     {-# INLINE getCIHeader #-}

-    getCIHeader key a
-        = A.toCIAscii <$> getHeader key a
+    getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader

 
     deleteHeader ∷ CIAscii → a → a
     {-# INLINE deleteHeader #-}
 
     deleteHeader ∷ CIAscii → a → a
     {-# INLINE deleteHeader #-}

-    deleteHeader key a
-        = case getHeaders a of
-            Headers m
-              → setHeaders a $ Headers $ M.delete key m
+    deleteHeader = modifyHeaders ∘ delete

 
     setHeader ∷ CIAscii → Ascii → a → a
     {-# INLINE setHeader #-}
 
     setHeader ∷ CIAscii → Ascii → a → a
     {-# INLINE setHeader #-}

-    setHeader key val a
-        = case getHeaders a of
-            Headers m
-              → setHeaders a $ Headers $ M.insert key val m
+    setHeader = (modifyHeaders ∘) ∘ insertWith const

 
 instance HasHeaders Headers where
     getHeaders   = id
     setHeaders _ = id
 
 
 instance HasHeaders Headers where
     getHeaders   = id
     setHeaders _ = id
 

-singleton ∷ CIAscii → Ascii → Headers
-{-# INLINE singleton #-}
-singleton key val
-    = Headers $ M.singleton key val
-
-toHeaders ∷ [(CIAscii, Ascii)] → Headers
-{-# INLINE toHeaders #-}
-toHeaders = flip mkHeaders (∅)
-
-mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers
-mkHeaders []              (Headers m) = Headers m
-mkHeaders ((key, val):xs) (Headers m)
-    = mkHeaders xs $ Headers $
-      case M.lookup key m of
-        Nothing  → M.insert key val m
-        Just old → M.insert key (merge old val) m
+-- |@'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
+
+instance Foldable Headers (CIAscii, Ascii) where
+    {-# INLINE foldMap #-}
+    foldMap f (Headers m) = foldMap f m
+
+instance Collection Headers (CIAscii, Ascii) where
+    {-# INLINE filter #-}
+    filter f (Headers m) = Headers $ filter f m
+
+instance Indexed Headers CIAscii Ascii where
+    {-# INLINE index #-}
+    index k (Headers m) = index k m
+    {-# INLINE adjust #-}
+    adjust f k (Headers m) = Headers $ adjust f k m
+    {-# INLINE inDomain #-}
+    inDomain k (Headers m) = inDomain k m
+
+instance Map Headers CIAscii Ascii where
+    {-# INLINE lookup #-}
+    lookup k (Headers m) = lookup k m
+    {-# INLINE insertWith #-}
+    insertWith f k v (Headers m)
+        = Headers $ insertWith f k v m
+    {-# INLINE mapWithKey #-}
+    mapWithKey f (Headers m)
+        = Headers $ mapWithKey f m
+    {-# INLINE unionWith #-}
+    unionWith f (Headers α) (Headers β)
+        = Headers $ unionWith f α β
+    {-# INLINE intersectionWith #-}
+    intersectionWith f (Headers α) (Headers β)
+        = Headers $ intersectionWith f α β
+    {-# INLINE differenceWith #-}
+    differenceWith f (Headers α) (Headers β)
+        = Headers $ differenceWith f α β
+    {-# INLINE isSubmapBy #-}
+    isSubmapBy f (Headers α) (Headers β)
+        = isSubmapBy f α β
+    {-# INLINE isProperSubmapBy #-}
+    isProperSubmapBy f (Headers α) (Headers β)
+        = isProperSubmapBy f α β
+
+instance SortingCollection Headers (CIAscii, Ascii) where
+    {-# INLINE minView #-}
+    minView (Headers m) = second Headers <$> minView m
+
+merge ∷ Ascii → Ascii → Ascii
+{-# INLINE merge #-}
+merge a b
+    | nullA a ∧ nullA b = (∅)
+    | nullA a           = b
+    |           nullA b = a
+    | otherwise         = a ⊕ ", " ⊕ b

     where
     where

-      merge ∷ Ascii → Ascii → Ascii
-      {-# INLINE merge #-}
-      merge a b
-          | nullA a ∧ nullA b = (∅)
-          | nullA a           = b
-          |           nullA b = a
-          | otherwise         = a ⊕ ", " ⊕ b
-

       nullA ∷ Ascii → Bool
       {-# INLINE nullA #-}
       nullA ∷ Ascii → Bool
       {-# INLINE nullA #-}

-      nullA = BS.null ∘ A.toByteString
-
-fromHeaders ∷ Headers → [(CIAscii, Ascii)]
-fromHeaders (Headers m) = M.toList m
+      nullA = null ∘ A.toByteString

 
 {-
   message-header = field-name ":" [ field-value ]
 
 {-
   message-header = field-name ":" [ field-value ]


@@ -121,7 +146,7 @@ headers ∷ Parser Headers
 {-# INLINEABLE headers #-}
 headers = do xs ← P.many header
              crlf
 {-# INLINEABLE headers #-}
 headers = do xs ← P.many header
              crlf

-             return $ toHeaders xs
+             return $ fromFoldable xs

     where
       header ∷ Parser (CIAscii, Ascii)
       header = do name ← A.toCIAscii <$> token
     where
       header ∷ Parser (CIAscii, Ascii)
       header = do name ← A.toCIAscii <$> token


@@ -147,7 +172,7 @@ headers = do xs ← P.many header
 
 printHeaders ∷ Headers → AsciiBuilder
 printHeaders (Headers m)
 
 printHeaders ∷ Headers → AsciiBuilder
 printHeaders (Headers m)

-    = mconcat (map printHeader (M.toList m)) ⊕
+    = mconcat (map printHeader (fromFoldable m)) ⊕

       A.toAsciiBuilder "\x0D\x0A"
     where
       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
       A.toAsciiBuilder "\x0D\x0A"
     where
       printHeader ∷ (CIAscii, Ascii) → AsciiBuilder

diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index 54be5f3934f5755c24a152850e6a8227f5a72146..b5fad5952f8463b16adbdcf27e98a91cbcfed909 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -36,13 +36,15 @@ import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception

+import Control.Monad hiding (mapM_)

 import Control.Monad.IO.Class
 import Control.Monad.IO.Class

-import Control.Monad.Reader
+import Control.Monad.Reader (ReaderT, runReaderT, ask)

 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString as Strict
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString as Strict

-import Data.List
+import Data.Collections
+import Data.List (intersperse, nub)

 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode


@@ -60,7 +62,7 @@ import Network.Socket
 #if defined(HAVE_SSL)
 import OpenSSL.X509
 #endif
 #if defined(HAVE_SSL)
 import OpenSSL.X509
 #endif

-import Prelude hiding (catch)
+import Prelude hiding (catch, concat, mapM_, tail)

 import Prelude.Unicode
 import System.IO
 
 import Prelude.Unicode
 import System.IO
 


@@ -207,7 +209,7 @@ spawnResource (ResourceDef {..}) ni@(NI {..})
                    -- in the response. Hooray!
                    flip runResource ni $
                        do setStatus $ aboStatus abo
                    -- in the response. Hooray!
                    flip runResource ni $
                        do setStatus $ aboStatus abo

-                          mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
+                          mapM_ (uncurry setHeader) (aboHeaders abo)

                           setHeader "Content-Type" defaultPageContentType
                           deleteHeader "Content-Encoding"
                           putBuilder $ abortPage niConfig (Just niRequest) res abo
                           setHeader "Content-Type" defaultPageContentType
                           deleteHeader "Content-Encoding"
                           putBuilder $ abortPage niConfig (Just niRequest) res abo