Many bugfixes

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

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
new file mode 100644 (file)
index 0000000..6b935c8
--- /dev/null
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE
+    BangPatterns
+  , ScopedTypeVariables
+  , UnicodeSyntax
+  #-}
+-- |This is an auxiliary parser utilities. You usually don't have to
+-- use this module directly.
+module Network.HTTP.Lucu.Parser
+    ( atMost
+    , manyOctetsTill
+    )
+    where
+import Blaze.ByteString.Builder (Builder, Write)
+import qualified Blaze.ByteString.Builder as BB
+import qualified Blaze.ByteString.Builder.Internal as BI
+import Control.Applicative
+import Control.Applicative.Unicode hiding ((∅))
+import Control.Monad.Unicode
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LS
+import Data.Monoid
+import Data.Monoid.Unicode
+import Data.Word
+import Prelude.Unicode
+
+-- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ 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 []
+
+data OctetAccumState
+    = OctetAccumState {
+        casChunks    ∷ !Builder
+      , casLastChunk ∷ !Write
+      }
+
+instance Monoid OctetAccumState where
+    {-# INLINE mempty #-}
+    mempty
+        = OctetAccumState {
+            casChunks    = (∅)
+          , casLastChunk = (∅)
+          }
+    {-# INLINEABLE mappend #-}
+    mappend !a !b
+        = b {
+            casChunks = casChunks a ⊕ lastChunk a ⊕ casChunks b
+          }
+
+lastChunk ∷ OctetAccumState → Builder
+{-# INLINEABLE lastChunk #-}
+lastChunk !s = case toChunk s of
+                 c → BB.insertByteString c
+    where
+      toChunk ∷ OctetAccumState → BS.ByteString
+      {-# INLINE toChunk #-}
+      toChunk = BB.toByteString ∘ BB.fromWrite ∘ casLastChunk
+
+snoc ∷ OctetAccumState → Word8 → OctetAccumState
+{-# INLINEABLE snoc #-}
+snoc !s !o
+    | BI.getBound (casLastChunk s) ≥ BI.defaultBufferSize
+        = s {
+            casChunks    = casChunks s ⊕ lastChunk s
+          , casLastChunk = BB.writeWord8 o
+          }
+    | otherwise
+        = s {
+            casLastChunk = casLastChunk s ⊕ BB.writeWord8 o
+          }
+
+finish ∷ OctetAccumState → LS.ByteString
+{-# INLINEABLE finish #-}
+finish = BB.toLazyByteString ∘ toChunks
+    where
+      toChunks ∷ OctetAccumState → Builder
+      {-# INLINE toChunks #-}
+      toChunks !s = casChunks s ⊕ lastChunk s
+
+-- |@'manyOctetsTill' p end@ takes as many octets untill @p@ succeeds.
+manyOctetsTill ∷ ∀m b. (Monad m, Alternative m)
+              ⇒ m Word8
+              → m b
+              → m LS.ByteString
+{-# INLINEABLE manyOctetsTill #-}
+manyOctetsTill p end = scan (∅)
+    where
+      scan ∷ OctetAccumState → m LS.ByteString
+      {-# INLINE scan #-}
+      scan !s
+          = (end *> pure (finish s))
+            <|>
+            (scan =≪ (snoc s <$> p))