From: PHO <pho@cielonegro.org>
Date: Sat, 30 Jul 2011 11:16:18 +0000 (+0900)
Subject: The attoparsec branch. It doesn't even compile for now.
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=9bb89434103e9a22f100d6ecb7e65a5d461e0454;p=Lucu.git

The attoparsec branch. It doesn't even compile for now.
---

diff --git a/Lucu.cabal b/Lucu.cabal
index a5ea793..36e1cd2 100644
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -24,6 +24,7 @@ Extra-Source-Files:
     ImplantFile.hs
     NEWS
     data/CompileMimeTypes.hs
+    data/Makefile
     data/mime.types
     examples/HelloWorld.hs
     examples/Implanted.hs
@@ -45,6 +46,8 @@ Flag build-lucu-implant-file
 Library
     Build-Depends:
         HsOpenSSL            == 0.10.*,
+        ascii                == 0.0.*,
+        attoparsec           == 0.9.*,
         base                 == 4.3.*,
         base-unicode-symbols == 0.2.*,
         base64-bytestring    == 0.1.*,
@@ -73,7 +76,6 @@ Library
         Network.HTTP.Lucu.MIMEType
         Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
         Network.HTTP.Lucu.MIMEType.Guess
-        Network.HTTP.Lucu.Parser
         Network.HTTP.Lucu.Parser.Http
         Network.HTTP.Lucu.Request
         Network.HTTP.Lucu.Resource
diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs
index 6b0e1c2..d085234 100644
--- a/Network/HTTP/Lucu/Authorization.hs
+++ b/Network/HTTP/Lucu/Authorization.hs
@@ -14,9 +14,10 @@ module Network.HTTP.Lucu.Authorization
     , authCredentialP -- private
     )
     where
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as C8
-import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
 import Prelude.Unicode
@@ -29,7 +30,7 @@ data AuthChallenge
       deriving (Eq)
 
 -- |'Realm' is just a string which must not contain any non-ASCII letters.
-type Realm = String
+type Realm = Ascii
 
 -- |Authorization credential to be sent by client with
 -- \"Authorization\" header. See
@@ -40,12 +41,13 @@ data AuthCredential
 
 -- |'UserID' is just a string which must not contain colon and any
 -- non-ASCII letters.
-type UserID   = String
+type UserID   = Ascii
 
 -- |'Password' is just a string which must not contain any non-ASCII
 -- letters.
-type Password = String
+type Password = Ascii
 
+-- FIXME: Don't use String for network output.
 instance Show AuthChallenge where
     show (BasicAuthChallenge realm)
         = "Basic realm=" ⧺ quoteStr realm
diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs
index 27deb74..a419464 100644
--- a/Network/HTTP/Lucu/Chunk.hs
+++ b/Network/HTTP/Lucu/Chunk.hs
@@ -1,38 +1,35 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.Chunk
     ( chunkHeaderP  -- Num a => Parser a
     , chunkFooterP  -- Parser ()
     , chunkTrailerP -- Parser Headers
     )
     where
-
-import           Network.HTTP.Lucu.Headers
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
-import           Numeric
-
-
-chunkHeaderP :: Num a => Parser a
-chunkHeaderP = do hexLen <- many1 hexDigit
-                  _      <- extension
-                  _      <- crlf
-
-                  let [(len, _)] = readHex hexLen
+import Control.Applicative
+import Data.Attoparsec.Char8
+import Data.Bits
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Parser.Http
+
+chunkHeaderP ∷ (Integral a, Bits a) ⇒ Parser a
+{-# INLINEABLE chunkHeaderP #-}
+chunkHeaderP = do len ← hexadecimal
+                  extension
+                  crlf
                   return len
     where
-      extension :: Parser ()
-      extension = many ( char ';' >>
-                         token    >>
-                         char '=' >>
-                         ( token <|> quotedStr )
-                       )
-                  >>
-                  return ()
-{-# SPECIALIZE chunkHeaderP :: Parser Int #-}
-
-
-chunkFooterP :: Parser ()
-chunkFooterP = crlf >> return ()
-
-
-chunkTrailerP :: Parser Headers
+      extension ∷ Parser ()
+      extension = skipMany $
+                  do _ ← char ';'
+                     _ ← token
+                     _ ← char '='
+                     _ ← token <|> quotedStr
+                     return ()
+
+chunkFooterP ∷ Parser ()
+chunkFooterP = crlf
+
+chunkTrailerP ∷ Parser Headers
 chunkTrailerP = headersP
diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs
index 27a8941..7a0918a 100644
--- a/Network/HTTP/Lucu/ContentCoding.hs
+++ b/Network/HTTP/Lucu/ContentCoding.hs
@@ -1,48 +1,63 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.ContentCoding
-    ( acceptEncodingListP
+    ( AcceptEncoding(..)
+
+    , acceptEncodingListP
     , normalizeCoding
     , unnormalizeCoding
-    , orderAcceptEncodings
     )
     where
-
-import           Data.Char
-import           Data.Ord
-import           Data.Maybe
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
-
-
-acceptEncodingListP :: Parser [(String, Maybe Double)]
-acceptEncodingListP = allowEOF $! listOf accEncP
-
-      
-accEncP :: Parser (String, Maybe Double)
-accEncP = do coding <- token
-             qVal   <- option Nothing
-                       $ do _ <- string ";q="
-                            q <- qvalue
-                            return $ Just q
+import Control.Applicative
+import Data.Ascii (CIAscii, toCIAscii)
+import Data.Attoparsec.Char8
+import Data.Ord
+import Data.Maybe
+import Network.HTTP.Lucu.Parser.Http
+import Prelude.Unicode
+
+data AcceptEncoding
+    = AcceptEncoding !CIAscii !(Maybe Double)
+      deriving (Eq, Show)
+
+instance Ord AcceptEncoding where
+    (AcceptEncoding c1 q1) `compare` (AcceptEncoding c2 q2)
+        | q1' > q1' = GT
+        | q1' < q2' = LT
+        | otherwise = compare c1 c2
+        where
+          q1' = fromMaybe 0 q1
+          q2' = fromMaybe 0 q2
+
+acceptEncodingListP ∷ Parser [(CIAscii, Maybe Double)]
+acceptEncodingListP = listOf accEncP
+
+accEncP ∷ Parser (CIAscii, Maybe Double)
+accEncP = do coding ← toCIAscii <$> token
+             qVal   ← option Nothing
+                      $ do _ ← string ";q="
+                           q ← qvalue
+                           return $ Just q
              return (normalizeCoding coding, qVal)
 
-
-normalizeCoding :: String -> String
+normalizeCoding ∷ CIAscii → CIAscii
 normalizeCoding coding
-    = case map toLower coding of
-        "x-gzip"     -> "gzip"
-        "x-compress" -> "compress"
-        other        -> other
-
-
-unnormalizeCoding :: String -> String
+    = if coding ≡ "x-gzip" then
+          "gzip"
+      else
+          if coding ≡ "x-compress" then
+              "compress"
+          else
+              coding
+
+unnormalizeCoding ∷ CIAscii → CIAscii
 unnormalizeCoding coding
-    = case map toLower coding of
-        "gzip"     -> "x-gzip"
-        "compress" -> "x-compress"
-        other        -> other
-
-
-orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering
-orderAcceptEncodings (_, q1) (_, q2)
-    = comparing (fromMaybe 0) q1 q2
-
+    = if coding ≡ "gzip" then
+          "x-gzip"
+      else
+          if coding ≡ "compress" then
+              "x-compress"
+          else
+              coding
diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
index d607ad1..41e99f8 100644
--- a/Network/HTTP/Lucu/ETag.hs
+++ b/Network/HTTP/Lucu/ETag.hs
@@ -9,11 +9,9 @@ module Network.HTTP.Lucu.ETag
     , eTagListP
     )
     where
-
-import           Control.Monad
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http hiding (token)
-import           Network.HTTP.Lucu.Utils
+import Control.Monad
+import Network.HTTP.Lucu.Parser.Http hiding (token)
+import Network.HTTP.Lucu.Utils
 
 -- |An entity tag is made of a weakness flag and a opaque string.
 data ETag = ETag {
diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 87d858c..2378ebc 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -1,11 +1,13 @@
+{-# LANGUAGE
+    BangPatterns
+  , GeneralizedNewtypeDeriving
+  , OverloadedStrings
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.Headers
     ( Headers
     , HasHeaders(..)
 
-    , noCaseCmp
-    , noCaseEq
-
-    , emptyHeaders
     , toHeaders
     , fromHeaders
 
@@ -13,153 +15,74 @@ module Network.HTTP.Lucu.Headers
     , hPutHeaders
     )
     where
-
-import qualified Data.ByteString as Strict (ByteString)
-import           Data.ByteString.Internal (toForeignPtr, w2c, inlinePerformIO)
-import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
-import           Data.Char
-import           Data.List
-import           Data.Map (Map)
+import Control.Applicative
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P
+import qualified Data.ByteString as BS
+import Data.Map (Map)
 import qualified Data.Map as M
-import           Data.Ord
-import           Data.Word
-import           Foreign.ForeignPtr
-import           Foreign.Ptr
-import           Foreign.Storable
-import           Network.HTTP.Lucu.HandleLike
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
-import           Network.HTTP.Lucu.Utils
-
-type Headers = Map NCBS Strict.ByteString
-newtype NCBS = NCBS Strict.ByteString
-
-toNCBS :: Strict.ByteString -> NCBS
-toNCBS = NCBS
-{-# INLINE toNCBS #-}
-
-fromNCBS :: NCBS -> Strict.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 :: Strict.ByteString -> Strict.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            = return LT
-    |            l2 == 0 = return GT
-    | otherwise
-        = do c1 <- peek p1
-             c2 <- peek p2
-             case comparing (toLower . w2c) c1 c2 of
-               EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
-               x  -> return x
-
-
-noCaseEq :: Strict.ByteString -> Strict.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 Data.Monoid
+import Data.Monoid.Unicode
+import Network.HTTP.Lucu.HandleLike
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
 
+newtype Headers
+    = Headers (Map CIAscii Ascii)
+      deriving (Eq, Show, Monoid)
 
 class HasHeaders a where
-    getHeaders :: a -> Headers
-    setHeaders :: a -> Headers -> a
-
-    getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString
-    getHeader key a
-        = key `seq` a `seq`
-          M.lookup (toNCBS key) (getHeaders a)
-
-    deleteHeader :: Strict.ByteString -> a -> a
-    deleteHeader key a
-        = key `seq` a `seq`
-          setHeaders a $ M.delete (toNCBS key) (getHeaders a)
-
-    setHeader :: Strict.ByteString -> Strict.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 :: [(Strict.ByteString, Strict.ByteString)] -> Headers
-toHeaders xs = mkHeaders xs M.empty
-
-
-mkHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -> Headers
-mkHeaders []              m = m
-mkHeaders ((key, val):xs) m = mkHeaders xs $
-                              case M.lookup (toNCBS key) m of
-                                Nothing  -> M.insert (toNCBS key) val m
-                                Just old -> M.insert (toNCBS key) (merge old val) m
+    getHeaders ∷ a → Headers
+    setHeaders ∷ a → Headers → a
+
+    getHeader ∷ CIAscii → a → Maybe Ascii
+    {-# INLINE getHeader #-}
+    getHeader !key !a
+        = case getHeaders a of
+            Headers m → M.lookup key m
+
+    deleteHeader ∷ CIAscii → a → a
+    {-# INLINE deleteHeader #-}
+    deleteHeader !key !a
+        = case getHeaders a of
+            Headers m
+              → setHeaders a $ Headers $ M.delete key m
+
+    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
+
+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
     where
-      merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString
-      -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない
-      -- ヘッダは複數個あってはならない事になってゐる。
+      merge ∷ Ascii → Ascii → Ascii
+      {-# INLINE merge #-}
       merge a b
-          | C8.null a && C8.null b = C8.empty
-          | C8.null a              = b
-          |              C8.null b = a
-          | otherwise              = C8.concat [a, C8.pack ", ", b]
-
+          | nullA a ∧ nullA b = (∅)
+          | nullA a           = b
+          |           nullA b = a
+          | otherwise         = a ⊕ ", " ⊕ b
 
-fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)]
-fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
+      nullA ∷ Ascii → Bool
+      {-# INLINE nullA #-}
+      nullA = BS.null ∘ A.toByteString
 
+fromHeaders ∷ Headers → [(CIAscii, Ascii)]
+fromHeaders (Headers m) = M.toList m
 
 {-
   message-header = field-name ":" [ field-value ]
@@ -172,49 +95,39 @@ 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 $! toHeaders xs
+headersP ∷ Parser Headers
+{-# INLINEABLE headersP #-}
+headersP = do xs ← P.many header
+              crlf
+              return $ toHeaders xs
     where
-      header :: Parser (Strict.ByteString, Strict.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 (C8.pack name, C8.pack norm)
-
-      normalize :: String -> String
-      normalize = trimBody . trim isWhiteSpace
-
-      trimBody = concat
-                 . map (\ s -> if head s == ' ' then
-                                   " "
-                               else
-                                   s)
-                 . group
-                 . map (\ c -> if isWhiteSpace c
-                               then ' '
-                               else c)
-
-
-hPutHeaders :: HandleLike h => h -> Headers -> IO ()
-hPutHeaders h hds
-    = h `seq` hds `seq`
-      mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n")
+      header ∷ Parser (CIAscii, Ascii)
+      header = try $
+               do name ← A.toCIAscii <$> token
+                  _    ← char ':'
+                  skipMany lws
+                  values ← sepBy content lws
+                  skipMany lws
+                  crlf
+                  return (name, joinValues values)
+
+      content ∷ Parser Ascii
+      {-# INLINE content #-}
+      content = A.unsafeFromByteString
+                <$>
+                takeWhile1 (\c → ((¬) (isSPHT c)) ∧ isText c)
+
+      joinValues ∷ [Ascii] → Ascii
+      {-# INLINE joinValues #-}
+      joinValues = A.fromAsciiBuilder ∘ joinWith "\x20"
+
+hPutHeaders ∷ HandleLike h => h → Headers → IO ()
+hPutHeaders !h !(Headers m)
+    = mapM_ putH (M.toList m) >> hPutBS h "\r\n"
     where
-      putH :: (NCBS, Strict.ByteString) -> IO ()
-      putH (name, value)
-          = name `seq` value `seq`
-            do hPutBS h (fromNCBS name)
-               hPutBS h (C8.pack ": ")
-               hPutBS h value
-               hPutBS h (C8.pack "\r\n")
+      putH ∷ (CIAscii, Ascii) → IO ()
+      putH (!name, !value)
+          = do hPutBS h (A.ciToByteString name)
+               hPutBS h ": "
+               hPutBS h (A.toByteString value)
+               hPutBS h "\r\n"
diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs
index d48f6ec..4531c83 100644
--- a/Network/HTTP/Lucu/HttpVersion.hs
+++ b/Network/HTTP/Lucu/HttpVersion.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
     BangPatterns
+  , OverloadedStrings
   , UnicodeSyntax
   #-}
 {-# OPTIONS_HADDOCK prune #-}
@@ -11,18 +12,15 @@ module Network.HTTP.Lucu.HttpVersion
     , hPutHttpVersion
     )
     where
-
-import qualified Data.ByteString.Char8 as C8
-import           Network.HTTP.Lucu.HandleLike
-import           Network.HTTP.Lucu.Parser
-import           Prelude hiding (min)
+import Control.Monad.Unicode
+import Data.Attoparsec.Char8
+import Network.HTTP.Lucu.HandleLike
+import Prelude hiding (min)
 
 -- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\".
-data HttpVersion = HttpVersion !Int !Int
-                   deriving (Eq)
-
-instance Show HttpVersion where
-    show (HttpVersion maj min) = "HTTP/" ++ show maj ++ "." ++ show min
+data HttpVersion
+    = HttpVersion !Int !Int
+      deriving (Eq, Show)
 
 instance Ord HttpVersion where
     (HttpVersion majA minA) `compare` (HttpVersion majB minB)
@@ -32,30 +30,26 @@ instance Ord HttpVersion where
         | minA < minB = LT
         | otherwise   = EQ
 
-
-httpVersionP :: Parser HttpVersion
+httpVersionP ∷ Parser HttpVersion
 httpVersionP = string "HTTP/"
-               >>
-               -- 頻出するので高速化
-               choice [ string "1.0" >> return (HttpVersion 1 0)
-                      , string "1.1" >> return (HttpVersion 1 1)
-                        -- 一般の場合
-                      , do major <- many1 digit
-                           _     <- char '.'
-                           minor <- many1 digit
-                           return $ HttpVersion (read major) (read minor)
+               ≫
+               choice [ string "1.1" ≫ return (HttpVersion 1 1)
+                      , string "1.0" ≫ return (HttpVersion 1 0)
+                      , do major ← decimal
+                           _     ← char '.'
+                           minor ← decimal
+                           return $ HttpVersion major minor
                       ]
 
-
-hPutHttpVersion :: HandleLike h => h -> HttpVersion -> IO ()
+hPutHttpVersion ∷ HandleLike h ⇒ h → HttpVersion → IO ()
 hPutHttpVersion !h !v
     = case v of
         -- 頻出するので高速化
-        HttpVersion 1 0 -> hPutBS h (C8.pack "HTTP/1.0")
-        HttpVersion 1 1 -> hPutBS h (C8.pack "HTTP/1.1")
+        HttpVersion 1 0 → hPutBS h "HTTP/1.0"
+        HttpVersion 1 1 → hPutBS h "HTTP/1.1"
         -- 一般の場合
         HttpVersion !maj !min
-            -> do hPutBS   h (C8.pack "HTTP/")
-                  hPutStr  h (show maj)
-                  hPutChar h '.'
-                  hPutStr  h (show min)
+            → do hPutBS   h "HTTP/"
+                 hPutStr  h (show maj)
+                 hPutChar h '.'
+                 hPutStr  h (show min)
diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
index a3f3fc5..88a2eef 100644
--- a/Network/HTTP/Lucu/MIMEType.hs
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -8,44 +8,49 @@
 module Network.HTTP.Lucu.MIMEType
     ( MIMEType(..)
     , parseMIMEType
+    , printMIMEType
+
     , mimeTypeP
     , mimeTypeListP
     )
     where
-
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
 import qualified Data.ByteString.Lazy as B
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
-import           Network.HTTP.Lucu.Utils
-import           Prelude hiding (min)
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+import Prelude hiding (min)
 
 -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
 -- represents \"major\/minor; name=value\".
 data MIMEType = MIMEType {
-      mtMajor  :: !String
-    , mtMinor  :: !String
-    , mtParams :: ![ (String, String) ]
-    } deriving (Eq)
-
+      mtMajor  :: !CIAscii
+    , mtMinor  :: !CIAscii
+    , mtParams :: ![ (CIAscii, Ascii) ]
+    } deriving (Eq, Show)
 
-instance Show MIMEType where
-    show (MIMEType maj min params)
-        = maj ++ "/" ++ min ++
-          if null params then
-              ""
-          else
-              "; " ++ joinWith "; " (map showPair params)
-        where
-          showPair :: (String, String) -> String
-          showPair (name, value)
-              = name ++ "=" ++ if any (not . isToken) value then
-                                   quoteStr value
-                               else
-                                   value
-
-
-instance Read MIMEType where
-    readsPrec _ s = [(parseMIMEType s, "")]
+-- |Convert a 'MIMEType' to 'Ascii'.
+printMIMEType ∷ MIMEType → Ascii
+printMIMEType (MIMEType maj min params)
+    = A.fromAsciiBuilder $
+      ( A.toAsciiBuilder maj ⊕
+        A.toAsciiBuilder "/" ⊕
+        A.toAsciiBuilder min ⊕
+        if null params then
+            (∅)
+        else
+            A.toAsciiBuilder "; " ⊕
+            joinWith "; " (map printPair params)
+      )
+    where
+      printPair ∷ (CIAscii, Ascii) → A.AsciiBuilder
+      printPair (name, value)
+          = A.toAsciiBuilder (A.fromCIAscii name) ⊕
+            A.toAsciiBuilder "=" ⊕
+            if any ((¬) ∘ isToken) value then
+                quoteStr value
+            else
+                A.toAsciiBuilder value
 
 -- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an
 -- exception for parse error.
diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 39de37e..5a10bb6 100644
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -14,17 +14,15 @@ module Network.HTTP.Lucu.MIMEType.Guess
     , serializeExtMap
     )
     where
-
 import qualified Data.ByteString.Lazy.Char8 as B
 import qualified Data.Map as M
-import           Data.Map (Map)
-import           Data.Maybe
-import           Language.Haskell.Pretty
-import           Language.Haskell.Syntax
-import           Network.HTTP.Lucu.MIMEType
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
-import           Network.HTTP.Lucu.Utils
+import Data.Map (Map)
+import Data.Maybe
+import Language.Haskell.Pretty
+import Language.Haskell.Syntax
+import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
 
 -- |'Data.Map.Map' from extension to MIME Type.
 type ExtMap = Map String MIMEType
diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index c463130..741427f 100644
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -7,19 +7,16 @@ module Network.HTTP.Lucu.MultipartForm
     , multipartFormP
     )
     where
-
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy.Char8 as L8
 import           Data.Char
 import           Data.List
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Headers
-import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Parser.Http
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.Utils
 
-
 data Part = Part Headers L8.ByteString
 
 -- |This data type represents a form value and possibly an uploaded
diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
deleted file mode 100644
index 7809f53..0000000
--- a/Network/HTTP/Lucu/Parser.hs
+++ /dev/null
@@ -1,339 +0,0 @@
-{-# LANGUAGE
-    BangPatterns
-  , ScopedTypeVariables
-  , UnboxedTuples
-  , UnicodeSyntax
-  #-}
--- |Yet another parser combinator. This is mostly a subset of
--- "Text.ParserCombinators.Parsec" but there are some differences:
---
--- * This parser works on 'Data.ByteString.Base.LazyByteString'
---   instead of 'Prelude.String'.
---
--- * Backtracking is the only possible behavior so there is no \"try\"
---   action.
---
--- * On success, the remaining string is returned as well as the
---   parser result.
---
--- * You can choose whether to treat reaching EOF (trying to eat one
---   more letter at the end of string) a fatal error or to treat it a
---   normal failure. If a fatal error occurs, the entire parsing
---   process immediately fails without trying any backtracks. The
---   default behavior is to treat EOF fatal.
---
--- In general, you don't have to use this module directly.
-module Network.HTTP.Lucu.Parser
-    ( Parser
-    , ParserResult(..)
-
-    , failP
-
-    , parse
-    , parseStr
-
-    , anyChar
-    , eof
-    , allowEOF
-    , satisfy
-    , char
-    , string
-    , (<|>)
-    , choice
-    , oneOf
-    , digit
-    , hexDigit
-    , notFollowedBy
-    , many
-    , manyChar
-    , many1
-    , count
-    , option
-    , sepBy
-    , sepBy1
-
-    , sp
-    , ht
-    , crlf
-    )
-    where
-
-import           Control.Monad.State.Strict hiding (state)
-import qualified Data.ByteString.Lazy as Lazy (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)
-import qualified Data.Foldable as Fold
-import           Data.Int
-import qualified Data.Sequence as Seq
-import           Data.Sequence (Seq, (|>))
-
--- |@'Parser' a@ is obviously a parser which parses and returns @a@.
-newtype Parser a = Parser {
-      runParser :: State ParserState (ParserResult a)
-    }
-
-
-data ParserState
-    = PST {
-        pstInput      :: Lazy.ByteString
-      , pstIsEOFFatal :: !Bool
-      }
-    deriving (Eq, Show)
-
-
-data ParserResult a = Success !a
-                    | IllegalInput -- 受理出來ない入力があった
-                    | ReachedEOF   -- 限界を越えて讀まうとした
-                      deriving (Eq, Show)
-
-
---  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
-instance Monad Parser where
-    p >>= f = Parser $! do saved <- get -- 失敗した時の爲に状態を保存
-                           result <- runParser p
-                           case result of
-                             Success a    -> runParser (f a)
-                             IllegalInput -> do put saved -- 状態を復歸
-                                                return IllegalInput
-                             ReachedEOF   -> do put saved -- 状態を復歸
-                                                return ReachedEOF
-    return !x = Parser $! return $! Success x
-    fail _    = Parser $! return $! IllegalInput
-
-instance Functor Parser where
-    fmap f p = p >>= return . f
-
--- |@'failP'@ is just a synonym for @'Prelude.fail'
--- 'Prelude.undefined'@.
-failP :: Parser a
-failP = fail undefined
-
--- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result,
--- remaining #)@.
-parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #)
-parse !p input -- input は lazy である必要有り。
-    = let (!result, state') = runState (runParser p) (PST input True)
-      in
-        (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。
-
--- |@'parseStr' p str@ packs @str@ and parses it.
-parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #)
-parseStr !p input -- input は lazy である必要有り。
-    = parse p (B.pack input)
-
-
-anyChar :: Parser Char
-anyChar = Parser $!
-          do state@(PST input _) <- get
-             if B.null input then
-                 return ReachedEOF
-               else
-                 do put $! state { pstInput = B.tail input }
-                    return (Success $! B.head input)
-
-
-eof :: Parser ()
-eof = Parser $!
-      do PST input _ <- get
-         if B.null input then
-             return $! Success ()
-           else
-             return IllegalInput
-
--- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure.
-allowEOF :: Parser a -> Parser a
-allowEOF !f
-    = Parser $! do saved@(PST _ isEOFFatal) <- get
-                   put $! saved { pstIsEOFFatal = False }
-
-                   result <- runParser f
-                         
-                   state <- get
-                   put $! state { pstIsEOFFatal = isEOFFatal }
-
-                   return result
-
-
-satisfy :: (Char -> Bool) -> Parser Char
-satisfy !f
-    = do c <- anyChar
-         if f c then
-             return c
-           else
-             failP
-
-
-char :: Char -> Parser Char
-char !c = satisfy (== c)
-
-
-string :: String -> Parser String
-string !str
-    = let bs  = B.pack str
-          len = B.length bs
-      in
-        Parser $!
-        do st <- get
-           let (bs', rest) = B.splitAt len $ pstInput st
-               st'         = st { pstInput = rest }
-           if B.length bs' < len then
-               return ReachedEOF
-             else
-               if bs == bs' then
-                   do put st'
-                      return $ Success str
-               else
-                   return IllegalInput
-
-
-infixr 0 <|>
-
--- |This is the backtracking alternation. There is no non-backtracking
--- equivalent.
-(<|>) :: Parser a -> Parser a -> Parser a
-(!f) <|> (!g)
-    = Parser $! do saved  <- get -- 状態を保存
-                   result <- runParser f
-                   case result of
-                     Success a    -> return $! Success a
-                     IllegalInput -> do put saved -- 状態を復歸
-                                        runParser g
-                     ReachedEOF   -> if pstIsEOFFatal saved then
-                                         do put saved
-                                            return ReachedEOF
-                                     else
-                                         do put saved
-                                            runParser g
-
-
-choice :: [Parser a] -> Parser a
-choice = foldl (<|>) failP
-
-
-oneOf :: [Char] -> Parser Char
-oneOf = foldl (<|>) failP . map char
-
-
-notFollowedBy :: Parser a -> Parser ()
-notFollowedBy !p
-    = Parser $! do saved  <- get -- 状態を保存
-                   result <- runParser p
-                   case result of
-                     Success _    -> do put saved -- 状態を復歸
-                                        return IllegalInput
-                     IllegalInput -> do put saved -- 状態を復歸
-                                        return $! Success ()
-                     ReachedEOF   -> do put saved -- 状態を復歸
-                                        return $! Success ()
-
-
-digit :: Parser Char
-digit = do c <- anyChar
-           if c >= '0' && c <= '9' then
-               return c
-             else
-               failP
-
-
-hexDigit :: Parser Char
-hexDigit = do c <- anyChar
-              if (c >= '0' && c <= '9') ||
-                 (c >= 'a' && c <= 'f') ||
-                 (c >= 'A' && c <= 'F') then
-                  return c
-                else
-                  failP
-
-
-many :: forall a. Parser a -> Parser [a]
-many !p = Parser $!
-          do state <- get
-             let (# result, state' #) = many' state Seq.empty
-             put state'
-             return result
-    where
-      many' :: ParserState -> Seq a -> (# ParserResult [a], ParserState #)
-      many' !st !soFar
-          = case runState (runParser p) st of
-              (Success a,  st') -> many' st' (soFar |> a)
-              (IllegalInput, _) -> (# Success (Fold.toList soFar), st #)
-              (ReachedEOF  , _) -> if pstIsEOFFatal st then
-                                       (# ReachedEOF, st #)
-                                   else
-                                       (# Success (Fold.toList soFar), st #)
-
-manyChar :: Parser Char -> Parser Lazy.ByteString
-manyChar !p = Parser $!
-              do state <- get
-                 case scan' state 0 of
-                   Success len
-                       -> do let (bs, rest) = B.splitAt len (pstInput state)
-                                 state'     = state { pstInput = rest }
-                             put state'
-                             return $ Success bs
-                   ReachedEOF
-                       -> if pstIsEOFFatal state then
-                              return ReachedEOF
-                          else
-                              error "internal error"
-                   _   -> error "internal error"
-    where
-      scan' :: ParserState -> Int64 -> ParserResult Int64
-      scan' !st !soFar
-          = case runState (runParser p) st of
-              (Success _   , st') -> scan' st' (soFar + 1)
-              (IllegalInput, _  ) -> Success soFar
-              (ReachedEOF  , _  ) -> if pstIsEOFFatal st then
-                                         ReachedEOF
-                                     else
-                                         Success soFar
-
-
-many1 :: Parser a -> Parser [a]
-many1 !p = do x  <- p
-              xs <- many p
-              return (x:xs)
-
-
-count :: Int -> Parser a -> Parser [a]
-count !n !p = Parser $! count' n p Seq.empty
-
--- This implementation is rather ugly but we need to make it
--- tail-recursive to avoid stack overflow.
-count' :: Int -> Parser a -> Seq a -> State ParserState (ParserResult [a])
-count' 0  _  !soFar = return $! Success $! Fold.toList soFar
-count' !n !p !soFar = do saved  <- get
-                         result <- runParser p
-                         case result of
-                           Success a    -> count' (n-1) p (soFar |> a)
-                           IllegalInput -> do put saved
-                                              return IllegalInput
-                           ReachedEOF   -> do put saved
-                                              return ReachedEOF
-
-
--- def may be a _|_
-option :: a -> Parser a -> Parser a
-option def !p = p <|> return def
-
-
-sepBy :: Parser a -> Parser sep -> Parser [a]
-sepBy !p !sep = sepBy1 p sep <|> return []
-
-
-sepBy1 :: Parser a -> Parser sep -> Parser [a]
-sepBy1 !p !sep
-    = do x  <- p
-         xs <- many $! sep >> p
-         return (x:xs)
-
-
-sp :: Parser Char
-sp = char ' '
-
-
-ht :: Parser Char
-ht = char '\t'
-
-
-crlf :: Parser String
-crlf = string "\x0d\x0a"
diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index fe54bde..65ba8b2 100644
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
     BangPatterns
+  , OverloadedStrings
   , UnicodeSyntax
   #-}
 -- |This is an auxiliary parser utilities for parsing things related
@@ -8,120 +9,156 @@
 -- In general you don't have to use this module directly.
 module Network.HTTP.Lucu.Parser.Http
     ( isCtl
+    , isText
     , isSeparator
     , isChar
     , isToken
+    , isSPHT
+
     , listOf
-    , token
+
+    , crlf
+    , sp
     , lws
-    , text
-    , separator
+
+    , token
+    , separators
     , quotedStr
     , qvalue
+
+    , atMost
     )
     where
+import Control.Applicative
+import Control.Applicative.Unicode
+import Control.Monad.Unicode
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P
+import qualified Data.Attoparsec.FastSet as FS
+import qualified Data.ByteString.Char8 as BS
+import Prelude.Unicode
 
-import           Network.HTTP.Lucu.Parser
-
--- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@.
-isCtl :: Char -> Bool
+-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@.
+isCtl ∷ Char → Bool
+{-# INLINE isCtl #-}
 isCtl c
-    | c <  '\x1f' = True
-    | c >= '\x7f' = True
-    | otherwise   = False
+    | c ≤ '\x1f' = True
+    | c > '\x7f' = True
+    | otherwise  = False
+
+-- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@
+isText ∷ Char → Bool
+{-# INLINE isText #-}
+isText = (¬) ∘ isCtl
 
 -- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
 -- separators.
-isSeparator :: Char -> Bool
-isSeparator '('  = True
-isSeparator ')'  = True
-isSeparator '<'  = True
-isSeparator '>'  = True
-isSeparator '@'  = True
-isSeparator ','  = True
-isSeparator ';'  = True
-isSeparator ':'  = True
-isSeparator '\\' = True
-isSeparator '"'  = True
-isSeparator '/'  = True
-isSeparator '['  = True
-isSeparator ']'  = True
-isSeparator '?'  = True
-isSeparator '='  = True
-isSeparator '{'  = True
-isSeparator '}'  = True
-isSeparator ' '  = True
-isSeparator '\t' = True
-isSeparator _    = False
+isSeparator ∷ Char → Bool
+{-# INLINE isSeparator #-}
+isSeparator = flip FS.memberChar set
+    where
+      {-# NOINLINE set #-}
+      set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09"
 
 -- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
-isChar :: Char -> Bool
-isChar c
-    | c <= '\x7f' = True
-    | otherwise   = False
+isChar ∷ Char → Bool
+{-# INLINE isChar #-}
+isChar = (≤ '\x7F')
 
 -- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
 -- c)@
-isToken :: Char -> Bool
-isToken c = c `seq`
-            not (isCtl c || isSeparator c)
-
--- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p
--- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any
--- occurrences of LWS before and after each tokens.
-listOf :: Parser a -> Parser [a]
-listOf !p = do _ <- many lws
-               sepBy p $! do _ <- many lws
-                             _ <- char ','
-                             many lws
-
--- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
--- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
-token :: Parser String
-token = many1 $! satisfy isToken
-
--- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
--- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
-lws :: Parser String
-lws = do s  <- option "" crlf
-         xs <- many1 (sp <|> ht)
-         return (s ++ xs)
-
--- |'text' accepts one character which doesn't satisfy 'isCtl'.
-text :: Parser Char
-text = satisfy (not . isCtl)
-
--- |'separator' accepts one character which satisfies 'isSeparator'.
-separator :: Parser Char
-separator = satisfy isSeparator
+isToken ∷ Char → Bool
+{-# INLINE isToken #-}
+isToken !c
+    = (¬) (isCtl c ∨ isSeparator c)
+
+-- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it
+-- allows any occurrences of 'lws' before and after each tokens.
+listOf ∷ Parser a → Parser [a]
+{-# INLINEABLE listOf #-}
+listOf p
+    = try $
+      do skipMany lws
+         sepBy p $ do skipMany lws
+                      _ <- char ','
+                      skipMany lws
+
+-- |'token' is similar to @'takeWhile1' 'isToken'@
+token ∷ Parser Ascii
+{-# INLINE token #-}
+token = A.unsafeFromByteString <$> takeWhile1 isToken
+
+-- |The CRLF: 0x0D 0x0A.
+crlf ∷ Parser ()
+{-# INLINE crlf #-}
+crlf = string "\x0D\x0A" ≫ return ()
+
+-- |The SP: 0x20.
+sp ∷ Parser ()
+{-# INLINE sp #-}
+sp = char '\x20' ≫ return ()
+
+-- |HTTP LWS: crlf? (sp | ht)+
+lws ∷ Parser ()
+{-# INLINEABLE lws #-}
+lws = try $
+      do option () crlf
+         _ ← satisfy isSPHT
+         skipWhile isSPHT
+
+-- |Returns 'True' for SP and HT.
+isSPHT ∷ Char → Bool
+{-# INLINE isSPHT #-}
+isSPHT '\x20' = True
+isSPHT '\x09' = True
+isSPHT _      = False
+
+-- |@'separators'@ is similar to @'takeWhile1' 'isSeparator'@.
+separators ∷ Parser Ascii
+{-# INLINE separators #-}
+separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
 
 -- |'quotedStr' accepts a string surrounded by double quotation
 -- marks. Quotes can be escaped by backslashes.
-quotedStr :: Parser String
-quotedStr = do _  <- char '"'
-               xs <- many (qdtext <|> quotedPair)
-               _  <- char '"'
-               return $ foldr (++) "" xs
+quotedStr ∷ Parser Ascii
+{-# INLINEABLE quotedStr #-}
+quotedStr = try $
+            do _  ← char '"'
+               xs ← P.many (qdtext <|> quotedPair)
+               _  ← char '"'
+               return $ A.unsafeFromByteString $ BS.pack xs
     where
-      qdtext = do c <- satisfy (/= '"')
-                  return [c]
+      qdtext ∷ Parser Char
+      {-# INLINE qdtext #-}
+      qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
 
-      quotedPair = do _ <- char '\\'
-                      c <- satisfy isChar
-                      return [c]
+      quotedPair ∷ Parser Char
+      {-# INLINE quotedPair #-}
+      quotedPair = char '\\' ≫ satisfy isChar
 
 -- |'qvalue' accepts a so-called qvalue.
-qvalue :: Parser Double
-qvalue = do x  <- char '0'
-            xs <- option ""
-                  $ do y  <- char '.'
-                       ys <- many digit -- 本當は三文字までに制限
-                       return (y:ys)
+qvalue ∷ Parser Double
+{-# INLINEABLE qvalue #-}
+qvalue = do x  ← char '0'
+            xs ← option "" $
+                 do y  ← char '.'
+                    ys ← atMost 3 digit
+                    return (y:ys)
             return $ read (x:xs)
          <|>
-         do x  <- char '1'
-            xs <- option ""
-                  $ do y  <- char '.'
-                       ys <- many (char '0') -- 本當は三文字までに制限
-                       return (y:ys)
+         do x  ← char '1'
+            xs ← option "" $
+                 do y  ← char '.'
+                    ys ← atMost 3 (char '0')
+                    return (y:ys)
             return $ read (x:xs)
+
+-- |@'atMost' n v@ is like @'P.many' v@ but applies the given action
+-- at most @n@ times.
+atMost ∷ Alternative f ⇒ Int → f a → f [a]
+{-# INLINE atMost #-}
+atMost 0 _ = pure []
+atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
+             <|>
+             pure []
diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index 712a610..8b516cc 100644
--- a/Network/HTTP/Lucu/Request.hs
+++ b/Network/HTTP/Lucu/Request.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , UnicodeSyntax
+  #-}
 {-# OPTIONS_HADDOCK prune #-}
 
 -- |Definition of things related on HTTP request.
@@ -9,12 +13,16 @@ module Network.HTTP.Lucu.Request
     , requestP
     )
     where
-
-import           Network.HTTP.Lucu.Headers
-import           Network.HTTP.Lucu.HttpVersion
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
-import           Network.URI
+import Control.Applicative
+import Control.Monad.Unicode
+import Data.Ascii (Ascii)
+import Data.Attoparsec.Char8
+import qualified Data.ByteString.Char8 as C8
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Parser.Http
+import Network.URI
+import Prelude.Unicode
 
 -- |This is the definition of HTTP request methods, which shouldn't
 -- require any description.
@@ -26,28 +34,27 @@ data Method = OPTIONS
             | DELETE
             | TRACE
             | CONNECT
-            | ExtensionMethod !String
+            | ExtensionMethod !Ascii
               deriving (Eq, Show)
 
 -- |This is the definition of HTTP reqest.
 data Request
     = Request {
-        reqMethod  :: !Method
-      , reqURI     :: !URI
-      , reqVersion :: !HttpVersion
-      , reqHeaders :: !Headers
+        reqMethod  ∷ !Method
+      , reqURI     ∷ !URI
+      , reqVersion ∷ !HttpVersion
+      , reqHeaders ∷ !Headers
       }
-    deriving (Show, Eq)
+    deriving (Eq, Show)
 
 instance HasHeaders Request where
     getHeaders = reqHeaders
     setHeaders req hdr = req { reqHeaders = hdr }
 
-
-requestP :: Parser Request
-requestP = do _                      <- many crlf
-              (method, uri, version) <- requestLineP
-              headers                <- headersP
+requestP ∷ Parser Request
+requestP = do skipMany crlf
+              (method, uri, version) ← requestLineP
+              headers                ← headersP
               return Request {
                            reqMethod  = method
                          , reqURI     = uri
@@ -55,35 +62,32 @@ requestP = do _                      <- many crlf
                          , reqHeaders = headers
                          }
 
-
-requestLineP :: Parser (Method, URI, HttpVersion)
-requestLineP = do method <- methodP
-                  _      <- sp
-                  uri    <- uriP
-                  _      <- sp
-                  ver    <- httpVersionP
-                  _      <- crlf
+requestLineP ∷ Parser (Method, URI, HttpVersion)
+requestLineP = do method ← methodP
+                  sp
+                  uri    ← uriP
+                  sp
+                  ver    ← httpVersionP
+                  crlf
                   return (method, uri, ver)
 
+methodP ∷ Parser Method
+methodP = choice
+          [ string "OPTIONS" ≫ return OPTIONS
+          , string "GET"     ≫ return GET
+          , string "HEAD"    ≫ return HEAD
+          , string "POST"    ≫ return POST
+          , string "PUT"     ≫ return PUT
+          , string "DELETE"  ≫ return DELETE
+          , string "TRACE"   ≫ return TRACE
+          , string "CONNECT" ≫ return CONNECT
+          , ExtensionMethod <$> token
+          ]
 
-methodP :: Parser Method
-methodP = ( let methods = [ ("OPTIONS", OPTIONS)
-                          , ("GET"    , GET    )
-                          , ("HEAD"   , HEAD   )
-                          , ("POST"   , POST   )
-                          , ("PUT"    , PUT    )
-                          , ("DELETE" , DELETE )
-                          , ("TRACE"  , TRACE  )
-                          , ("CONNECT", CONNECT)
-                          ]
-            in choice $ map (\ (str, mth)
-                                 -> string str >> return mth) methods )
-          <|>
-          fmap ExtensionMethod token
-
-
-uriP :: Parser URI
-uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' '))
+uriP ∷ Parser URI
+uriP = try $
+       do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
+          let str = C8.unpack bs
           case parseURIReference str of
-            Nothing  -> failP
-            Just uri -> return uri
\ No newline at end of file
+            Nothing  -> fail ("Unparsable URI: " ⧺ str)
+            Just uri -> return uri
diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index d3b8daa..ab8e5c7 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -7,7 +7,6 @@ module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
     where
-
 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad
@@ -23,7 +22,6 @@ import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage
 import           Network.HTTP.Lucu.HandleLike
 import           Network.HTTP.Lucu.Interaction
-import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
 import           Network.HTTP.Lucu.Preprocess
 import           Network.HTTP.Lucu.Request
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index fa08fa5..3bc7524 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -139,7 +139,6 @@ module Network.HTTP.Lucu.Resource
     , driftTo
     )
     where
-
 import           Control.Concurrent.STM
 import           Control.Monad.Reader
 import qualified Data.ByteString as Strict (ByteString)
@@ -161,7 +160,6 @@ import qualified Network.HTTP.Lucu.Headers as H
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.MultipartForm
-import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index c85c9a7..387cca2 100644
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
     BangPatterns
+  , OverloadedStrings
   , UnicodeSyntax
   #-}
 -- |Utility functions used internally in the Lucu httpd. These
@@ -7,71 +8,72 @@
 module Network.HTTP.Lucu.Utils
     ( splitBy
     , joinWith
-    , trim
-    , isWhiteSpace
     , quoteStr
     , parseWWWFormURLEncoded
     )
     where
-
 import Control.Monad
-import Data.List     hiding (last)
+import Data.Ascii (Ascii, AsciiBuilder)
+import qualified Data.Ascii as A
+import qualified Data.ByteString.Char8 as BS
+import Data.List hiding (last)
+import Data.Monoid.Unicode
 import Network.URI
-import Prelude       hiding (last)
+import Prelude hiding (last)
+import Prelude.Unicode
 
 -- |> splitBy (== ':') "ab:c:def"
 --  > ==> ["ab", "c", "def"]
-splitBy :: (a -> Bool) -> [a] -> [[a]]
+splitBy ∷ (a → Bool) → [a] → [[a]]
 splitBy isSep src
     = case break isSep src
-      of (last , []       ) -> [last]
-         (first, _sep:rest) -> first : splitBy isSep rest
+      of (last , []       ) → [last]
+         (first, _sep:rest) → first : splitBy isSep rest
 
 -- |> joinWith ":" ["ab", "c", "def"]
 --  > ==> "ab:c:def"
-joinWith :: [a] -> [[a]] -> [a]
-joinWith = (join .) . intersperse
-
--- |> trim (== '_') "__ab_c__def___"
---  > ==> "ab_c__def"
-trim :: (a -> Bool) -> [a] -> [a]
-trim !p = trimTail . trimHead
+joinWith ∷ Ascii → [Ascii] → AsciiBuilder
+{-# INLINEABLE joinWith #-}
+joinWith sep = flip go (∅)
     where
-      trimHead = dropWhile p
-      trimTail = reverse . trimHead . reverse
-
--- |@'isWhiteSpace' c@ is 'Prelude.True' iff c is one of SP, HT, CR
--- and LF.
-isWhiteSpace :: Char -> Bool
-isWhiteSpace ' '  = True
-isWhiteSpace '\t' = True
-isWhiteSpace '\r' = True
-isWhiteSpace '\n' = True
-isWhiteSpace _    = False
-{-# INLINE isWhiteSpace #-}
+      go ∷ [Ascii] → A.AsciiBuilder → A.AsciiBuilder
+      {-# INLINE go #-}
+      go []     ab = ab
+      go (x:[]) ab = ab ⊕ A.toAsciiBuilder x
+      go (x:xs) ab = go xs ( ab ⊕
+                             A.toAsciiBuilder sep ⊕
+                             A.toAsciiBuilder x )
 
 -- |> quoteStr "abc"
 --  > ==> "\"abc\""
 --
 --  > quoteStr "ab\"c"
 --  > ==> "\"ab\\\"c\""
-quoteStr :: String -> String
-quoteStr !str = concat (["\""] ++ map quote str ++ ["\""])
+quoteStr ∷ Ascii → AsciiBuilder
+quoteStr str = A.toAsciiBuilder "\"" ⊕
+               go (A.toByteString str) (∅) ⊕
+               A.toAsciiBuilder "\""
     where
-      quote :: Char -> String
-      quote '"' = "\\\""
-      quote c   = [c]
+      go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
+      go bs ab
+          = case BS.break (≡ '"') bs of
+              (x, y)
+                  | BS.null y → ab ⊕ b2ab x
+                  | otherwise → go (BS.tail y) (ab ⊕ b2ab x
+                                                   ⊕ A.toAsciiBuilder "\\\"")
 
+      b2ab ∷ BS.ByteString → AsciiBuilder
+      b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
 
 -- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
 --  > ==> [("aaa", "bbb"), ("ccc", "ddd")]
-parseWWWFormURLEncoded :: String -> [(String, String)]
+parseWWWFormURLEncoded ∷ String → [(String, String)]
 parseWWWFormURLEncoded src
     | src == "" = []
-    | otherwise = do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
+    | otherwise = do pairStr <- splitBy (\ c → c == ';' || c == '&') src
                      let (key, value) = break (== '=') pairStr
                      return ( unEscapeString key
                             , unEscapeString $ case value of
-                                                 ('=':val) -> val
-                                                 val       -> val
+                                                 ('=':val) → val
+                                                 val       → val
                             )