module Strelka.RequestBodyParsing.Parser
where
import Strelka.Prelude hiding (fail)
import qualified Data.Attoparsec.ByteString
import qualified Data.Attoparsec.Text
import qualified Data.Attoparsec.Types
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Lazy.Internal
import qualified Data.ByteString.Builder
import qualified Data.Text
import qualified Data.Text.Encoding
import qualified Data.Text.Encoding.Error
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Encoding
import qualified Data.Text.Lazy.Builder
import qualified Data.Text.Internal.Lazy
import qualified Data.HashMap.Strict as C
import qualified Strelka.ParamsParsing.Params as A
import qualified URLDecoders as B
import qualified Text.Builder as D
import qualified ByteString.TreeBuilder as E
newtype Parser a =
Parser (IO ByteString -> IO (Either Text a))
deriving (Functor)
instance Applicative Parser where
pure =
return
(<*>) =
ap
instance Monad Parser where
return x =
Parser (\_ -> pure (Right x))
(>>=) (Parser def1) cont2 =
Parser def
where
def input =
def1 input >>= \case
Right result -> case cont2 result of Parser def2 -> def2 input
Left failure -> return (Left failure)
data Folded a =
Unfinished !a |
Finished !a |
Failed Text
deriving (Functor)
fail :: Text -> Parser a
fail message =
Parser (\_ -> return (Left message))
foldBytes :: (a -> ByteString -> Folded a) -> a -> Parser a
foldBytes step init =
Parser consumer
where
consumer getChunk =
recur init
where
recur !state =
getChunk >>= onChunk
where
onChunk chunk =
if Data.ByteString.null chunk
then return (Right state)
else case step state chunk of
Unfinished newState -> recur newState
Finished newState -> return (Right newState)
Failed failure -> return (Left failure)
foldText :: (a -> Text -> Folded a) -> a -> Parser a
foldText step init =
Parser consumer
where
consumer getChunk =
recur Data.Text.Encoding.streamDecodeUtf8 init
where
recur !decode !accumulator =
do
chunk <- getChunk
if Data.ByteString.null chunk
then return (Right accumulator)
else catch (decodeChunk chunk) fail
where
decodeChunk chunk =
case decode chunk of
Data.Text.Encoding.Some textChunk leftovers newDecode ->
if Data.Text.null textChunk
then recur newDecode accumulator
else case step accumulator textChunk of
Unfinished newAccumulator -> recur newDecode newAccumulator
Finished newAccumulator -> return (Right accumulator)
Failed failure -> return (Left failure)
fail (Data.Text.Encoding.Error.DecodeError message byte) =
return (Left ("UTF8 decoding failure: " <> fromString message))
buildFromBytes :: Monoid a => (ByteString -> a) -> Parser a
buildFromBytes proj =
foldBytes (\l r -> Unfinished (mappend l (proj r))) mempty
buildFromText :: Monoid a => (Text -> a) -> Parser a
buildFromText proj =
foldText (\l r -> Unfinished (mappend l (proj r))) mempty
bytes :: Parser ByteString
bytes =
fmap E.toByteString bytesBuilder
bytesBuilder :: Parser E.Builder
bytesBuilder =
buildFromBytes E.byteString
lazyBytes :: Parser Data.ByteString.Lazy.ByteString
lazyBytes =
fmap fromAccumulator (buildFromBytes toAccumulator)
where
toAccumulator chunk =
Endo (Data.ByteString.Lazy.Internal.Chunk chunk)
fromAccumulator (Endo fn) =
fn Data.ByteString.Lazy.Internal.Empty
lazyBytesBuilder :: Parser Data.ByteString.Builder.Builder
lazyBytesBuilder =
buildFromBytes Data.ByteString.Builder.byteString
text :: Parser Text
text =
fmap D.run textBuilder
textBuilder :: Parser D.Builder
textBuilder =
buildFromText D.text
lazyText :: Parser Data.Text.Lazy.Text
lazyText =
fmap fromAccumulator (buildFromText toAccumulator)
where
toAccumulator chunk =
Endo (Data.Text.Internal.Lazy.Chunk chunk)
fromAccumulator (Endo fn) =
fn Data.Text.Internal.Lazy.Empty
lazyTextBuilder :: Parser Data.Text.Lazy.Builder.Builder
lazyTextBuilder =
buildFromText Data.Text.Lazy.Builder.fromText
parseBytes :: Data.Attoparsec.ByteString.Parser a -> Parser a
parseBytes parser =
processParserResult foldBytes (Data.Attoparsec.ByteString.Partial (Data.Attoparsec.ByteString.parse parser))
parseText :: Data.Attoparsec.Text.Parser a -> Parser a
parseText parser =
processParserResult foldText (Data.Attoparsec.Text.Partial (Data.Attoparsec.Text.parse parser))
processParserResult :: Monoid chunk => (forall a. (a -> chunk -> Folded a) -> a -> Parser a) -> Data.Attoparsec.Types.IResult chunk a -> Parser a
processParserResult fold result =
fold step result >>= finalise
where
step result chunk =
case result of
Data.Attoparsec.Types.Partial chunkToResult ->
Unfinished (chunkToResult chunk)
_ ->
Finished result
finalise =
\case
Data.Attoparsec.Types.Done leftovers resultValue ->
Parser (\_ -> return (Right resultValue))
Data.Attoparsec.Types.Fail leftovers contexts message ->
Parser (\_ -> return (Left (fromString (intercalate " > " contexts <> ": " <> message))))
Data.Attoparsec.Types.Partial chunkToResult ->
finalise (chunkToResult mempty)
parseParams :: A.Params a -> Parser a
parseParams parser =
do
queryBytes <- bytes
case B.utf8Query queryBytes of
Right query -> case A.run parser (flip C.lookup query) of
Right result -> return result
Left message -> fail ("Query params parsing error: " <> message)
Left message -> fail ("Query parsing error: " <> message)