MultipartForm

[Lucu.git] / Network / HTTP / Lucu / Parser / Http.hs

diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index 65ba8b27ccb1ff66f52d6bd83a6b2af86f3980be..4ac11a4686624c3d66da14d4a034d29116b85640 100644 (file)
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     BangPatterns
   , OverloadedStrings
+  , ScopedTypeVariables
   , UnicodeSyntax
   #-}
 -- |This is an auxiliary parser utilities for parsing things related
@@ -27,16 +28,24 @@ module Network.HTTP.Lucu.Parser.Http
     , qvalue
 
     , atMost
+    , manyCharsTill
     )
     where
 import Control.Applicative
-import Control.Applicative.Unicode
+import Control.Applicative.Unicode hiding ((∅))
 import Control.Monad.Unicode
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8 as P hiding (scan)
 import qualified Data.Attoparsec.FastSet as FS
 import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as LS
+import qualified Data.ByteString.Lazy.Internal as LS
+import qualified Data.Foldable as F
+import Data.Monoid
+import Data.Monoid.Unicode
+import qualified Data.Sequence as S
+import Data.Sequence.Unicode hiding ((∅))
 import Prelude.Unicode
 
 -- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@.
@@ -162,3 +171,60 @@ atMost 0 _ = pure []
 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
              <|>
              pure []
+
+
+data CharAccumState
+    = CharAccumState {
+        casChunks    ∷ !(S.Seq BS.ByteString)
+      , casLastChunk ∷ !(S.Seq Char)
+      }
+
+instance Monoid CharAccumState where
+    mempty
+        = CharAccumState {
+            casChunks    = (∅)
+          , casLastChunk = (∅)
+          }
+    mappend a b
+        = b {
+            casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
+          }
+
+lastChunk ∷ CharAccumState → BS.ByteString
+{-# INLINE lastChunk #-}
+lastChunk = BS.pack ∘ F.toList ∘ casLastChunk
+
+snoc ∷ CharAccumState → Char → CharAccumState
+{-# INLINEABLE snoc #-}
+snoc cas c
+    | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
+        = cas {
+            casChunks    = casChunks cas ⊳ lastChunk cas
+          , casLastChunk = S.singleton c
+          }
+    | otherwise
+        = cas {
+            casLastChunk = casLastChunk cas ⊳ c
+          }
+
+finish ∷ CharAccumState → LS.ByteString
+{-# INLINEABLE finish #-}
+finish cas
+    = let chunks = F.toList $ casChunks cas ⊳ lastChunk cas
+          str    = LS.fromChunks chunks
+      in
+        str
+
+manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
+              ⇒ m Char
+              → m b
+              → m LS.ByteString
+{-# INLINEABLE manyCharsTill #-}
+manyCharsTill p end = scan (∅)
+    where
+      scan ∷ CharAccumState → m LS.ByteString
+      {-# INLINE scan #-}
+      scan s
+          = (end *> pure (finish s))
+            <|>
+            (scan =≪ (snoc s <$> p))