|
Packit |
fc2124 |
{-# LANGUAGE Rank2Types #-}
|
|
Packit |
fc2124 |
{-# LANGUAGE BangPatterns #-}
|
|
Packit |
fc2124 |
{-# LANGUAGE OverloadedStrings #-}
|
|
Packit |
fc2124 |
-- |
|
|
Packit |
fc2124 |
-- Module : Network.Socks5.Parse
|
|
Packit |
fc2124 |
-- License : BSD-style
|
|
Packit |
fc2124 |
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
Packit |
fc2124 |
-- Stability : experimental
|
|
Packit |
fc2124 |
-- Portability : portable
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- A very simple bytestring parser related to Parsec and Attoparsec
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- Simple example:
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- > > parse ((,) <$> take 2 <*> byte 0x20 <*> (bytes "abc" *> anyByte)) "xx abctest"
|
|
Packit |
fc2124 |
-- > ParseOK "est" ("xx", 116)
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
module Network.Socks5.Parse
|
|
Packit |
fc2124 |
( Parser
|
|
Packit |
fc2124 |
, Result(..)
|
|
Packit |
fc2124 |
-- * run the Parser
|
|
Packit |
fc2124 |
, parse
|
|
Packit |
fc2124 |
, parseFeed
|
|
Packit |
fc2124 |
-- * Parser methods
|
|
Packit |
fc2124 |
, byte
|
|
Packit |
fc2124 |
, anyByte
|
|
Packit |
fc2124 |
, bytes
|
|
Packit |
fc2124 |
, take
|
|
Packit |
fc2124 |
, takeWhile
|
|
Packit |
fc2124 |
, takeAll
|
|
Packit |
fc2124 |
, skip
|
|
Packit |
fc2124 |
, skipWhile
|
|
Packit |
fc2124 |
, skipAll
|
|
Packit |
fc2124 |
, takeStorable
|
|
Packit |
fc2124 |
) where
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
import Control.Applicative
|
|
Packit |
fc2124 |
import Control.Monad
|
|
Packit |
fc2124 |
import Data.ByteString (ByteString)
|
|
Packit |
fc2124 |
import qualified Data.ByteString as B
|
|
Packit |
fc2124 |
import qualified Data.ByteString.Internal as B (toForeignPtr)
|
|
Packit |
fc2124 |
import Data.Word
|
|
Packit |
fc2124 |
import Foreign.Storable (Storable, peekByteOff, sizeOf)
|
|
Packit |
fc2124 |
import Foreign.ForeignPtr (withForeignPtr)
|
|
Packit |
fc2124 |
import Prelude hiding (take, takeWhile)
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
import System.IO.Unsafe (unsafePerformIO)
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Simple parsing result, that represent respectively:
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- * failure: with the error message
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- * continuation: that need for more input data
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- * success: the remaining unparsed data and the parser value
|
|
Packit |
fc2124 |
data Result a =
|
|
Packit |
fc2124 |
ParseFail String
|
|
Packit |
fc2124 |
| ParseMore (ByteString -> Result a)
|
|
Packit |
fc2124 |
| ParseOK ByteString a
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
instance Show a => Show (Result a) where
|
|
Packit |
fc2124 |
show (ParseFail err) = "ParseFailure: " ++ err
|
|
Packit |
fc2124 |
show (ParseMore _) = "ParseMore _"
|
|
Packit |
fc2124 |
show (ParseOK b a) = "ParseOK " ++ show a ++ " " ++ show b
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
type Failure r = ByteString -> String -> Result r
|
|
Packit |
fc2124 |
type Success a r = ByteString -> a -> Result r
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Simple ByteString parser structure
|
|
Packit |
fc2124 |
newtype Parser a = Parser
|
|
Packit |
fc2124 |
{ runParser :: forall r . ByteString -> Failure r -> Success a r -> Result r }
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
instance Monad Parser where
|
|
Packit |
fc2124 |
fail errorMsg = Parser $ \buf err _ -> err buf ("failed: " ++ errorMsg)
|
|
Packit |
fc2124 |
return v = Parser $ \buf _ ok -> ok buf v
|
|
Packit |
fc2124 |
m >>= k = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
runParser m buf err (\buf' a -> runParser (k a) buf' err ok)
|
|
Packit |
fc2124 |
instance MonadPlus Parser where
|
|
Packit |
fc2124 |
mzero = fail "Parser.MonadPlus.mzero"
|
|
Packit |
fc2124 |
mplus f g = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
-- rewrite the err callback of @f to call @g
|
|
Packit |
fc2124 |
runParser f buf (\_ _ -> runParser g buf err ok) ok
|
|
Packit |
fc2124 |
instance Functor Parser where
|
|
Packit |
fc2124 |
fmap f p = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
runParser p buf err (\b a -> ok b (f a))
|
|
Packit |
fc2124 |
instance Applicative Parser where
|
|
Packit |
fc2124 |
pure = return
|
|
Packit |
fc2124 |
(<*>) d e = d >>= \b -> e >>= \a -> return (b a)
|
|
Packit |
fc2124 |
instance Alternative Parser where
|
|
Packit |
fc2124 |
empty = fail "Parser.Alternative.empty"
|
|
Packit |
fc2124 |
(<|>) = mplus
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Run a parser on an @initial ByteString.
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- If the Parser need more data than available, the @feeder function
|
|
Packit |
fc2124 |
-- is automatically called and fed to the More continuation.
|
|
Packit |
fc2124 |
parseFeed :: Monad m => m B.ByteString -> Parser a -> B.ByteString -> m (Result a)
|
|
Packit |
fc2124 |
parseFeed feeder p initial = loop $ parse p initial
|
|
Packit |
fc2124 |
where loop (ParseMore k) = feeder >>= (loop . k)
|
|
Packit |
fc2124 |
loop r = return r
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Run a Parser on a ByteString and return a 'Result'
|
|
Packit |
fc2124 |
parse :: Parser a -> ByteString -> Result a
|
|
Packit |
fc2124 |
parse p s = runParser p s (\_ msg -> ParseFail msg) (\b a -> ParseOK b a)
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
------------------------------------------------------------
|
|
Packit |
fc2124 |
getMore :: Parser ()
|
|
Packit |
fc2124 |
getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
|
|
Packit |
fc2124 |
if B.null nextChunk
|
|
Packit |
fc2124 |
then err buf "EOL: need more data"
|
|
Packit |
fc2124 |
else ok (B.append buf nextChunk) ()
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
getAll :: Parser ()
|
|
Packit |
fc2124 |
getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
|
|
Packit |
fc2124 |
if B.null nextChunk
|
|
Packit |
fc2124 |
then ok buf ()
|
|
Packit |
fc2124 |
else runParser getAll (B.append buf nextChunk) err ok
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
flushAll :: Parser ()
|
|
Packit |
fc2124 |
flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->
|
|
Packit |
fc2124 |
if B.null nextChunk
|
|
Packit |
fc2124 |
then ok buf ()
|
|
Packit |
fc2124 |
else runParser getAll B.empty err ok
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
------------------------------------------------------------
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Get the next byte from the parser
|
|
Packit |
fc2124 |
anyByte :: Parser Word8
|
|
Packit |
fc2124 |
anyByte = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
case B.uncons buf of
|
|
Packit |
fc2124 |
Nothing -> runParser (getMore >> anyByte) buf err ok
|
|
Packit |
fc2124 |
Just (c1,b2) -> ok b2 c1
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Parse a specific byte at current position
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- if the byte is different than the expected on,
|
|
Packit |
fc2124 |
-- this parser will raise a failure.
|
|
Packit |
fc2124 |
byte :: Word8 -> Parser ()
|
|
Packit |
fc2124 |
byte w = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
case B.uncons buf of
|
|
Packit |
fc2124 |
Nothing -> runParser (getMore >> byte w) buf err ok
|
|
Packit |
fc2124 |
Just (c1,b2) | c1 == w -> ok b2 ()
|
|
Packit |
fc2124 |
| otherwise -> err buf ("byte " ++ show w ++ " : failed")
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Parse a sequence of bytes from current position
|
|
Packit |
fc2124 |
--
|
|
Packit |
fc2124 |
-- if the following bytes don't match the expected
|
|
Packit |
fc2124 |
-- bytestring completely, the parser will raise a failure
|
|
Packit |
fc2124 |
bytes :: ByteString -> Parser ()
|
|
Packit |
fc2124 |
bytes allExpected = consumeEq allExpected
|
|
Packit |
fc2124 |
where errMsg = "bytes " ++ show allExpected ++ " : failed"
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- partially consume as much as possible or raise an error.
|
|
Packit |
fc2124 |
consumeEq expected = Parser $ \actual err ok ->
|
|
Packit |
fc2124 |
let eLen = B.length expected in
|
|
Packit |
fc2124 |
if B.length actual >= eLen
|
|
Packit |
fc2124 |
then -- enough data for doing a full match
|
|
Packit |
fc2124 |
let (aMatch,aRem) = B.splitAt eLen actual
|
|
Packit |
fc2124 |
in if aMatch == expected
|
|
Packit |
fc2124 |
then ok aRem ()
|
|
Packit |
fc2124 |
else err actual errMsg
|
|
Packit |
fc2124 |
else -- not enough data, match as much as we have, and then recurse.
|
|
Packit |
fc2124 |
let (eMatch, eRem) = B.splitAt (B.length actual) expected
|
|
Packit |
fc2124 |
in if actual == eMatch
|
|
Packit |
fc2124 |
then runParser (getMore >> consumeEq eRem) B.empty err ok
|
|
Packit |
fc2124 |
else err actual errMsg
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
------------------------------------------------------------
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Take a storable from the current position in the stream
|
|
Packit |
fc2124 |
takeStorable :: Storable d
|
|
Packit |
fc2124 |
=> Parser d
|
|
Packit |
fc2124 |
takeStorable = anyStorable undefined
|
|
Packit |
fc2124 |
where
|
|
Packit |
fc2124 |
anyStorable :: Storable d => d -> Parser d
|
|
Packit |
fc2124 |
anyStorable a = do
|
|
Packit |
fc2124 |
(fptr, off, _) <- B.toForeignPtr <$> take (sizeOf a)
|
|
Packit |
fc2124 |
return $ unsafePerformIO $ withForeignPtr fptr $ \ptr -> peekByteOff ptr off
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Take @n bytes from the current position in the stream
|
|
Packit |
fc2124 |
take :: Int -> Parser ByteString
|
|
Packit |
fc2124 |
take n = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
if B.length buf >= n
|
|
Packit |
fc2124 |
then let (b1,b2) = B.splitAt n buf in ok b2 b1
|
|
Packit |
fc2124 |
else runParser (getMore >> take n) buf err ok
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Take bytes while the @predicate hold from the current position in the stream
|
|
Packit |
fc2124 |
takeWhile :: (Word8 -> Bool) -> Parser ByteString
|
|
Packit |
fc2124 |
takeWhile predicate = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
case B.span predicate buf of
|
|
Packit |
fc2124 |
(_, b2) | B.null b2 -> runParser (getMore >> takeWhile predicate) buf err ok
|
|
Packit |
fc2124 |
(b1, b2) -> ok b2 b1
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Take the remaining bytes from the current position in the stream
|
|
Packit |
fc2124 |
takeAll :: Parser ByteString
|
|
Packit |
fc2124 |
takeAll = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
runParser (getAll >> returnBuffer) buf err ok
|
|
Packit |
fc2124 |
where
|
|
Packit |
fc2124 |
returnBuffer = Parser $ \buf _ ok -> ok B.empty buf
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Skip @n bytes from the current position in the stream
|
|
Packit |
fc2124 |
skip :: Int -> Parser ()
|
|
Packit |
fc2124 |
skip n = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
if B.length buf >= n
|
|
Packit |
fc2124 |
then ok (B.drop n buf) ()
|
|
Packit |
fc2124 |
else runParser (getMore >> skip (n - B.length buf)) B.empty err ok
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Skip bytes while the @predicate hold from the current position in the stream
|
|
Packit |
fc2124 |
skipWhile :: (Word8 -> Bool) -> Parser ()
|
|
Packit |
fc2124 |
skipWhile p = Parser $ \buf err ok ->
|
|
Packit |
fc2124 |
case B.span p buf of
|
|
Packit |
fc2124 |
(_, b2) | B.null b2 -> runParser (getMore >> skipWhile p) B.empty err ok
|
|
Packit |
fc2124 |
(_, b2) -> ok b2 ()
|
|
Packit |
fc2124 |
|
|
Packit |
fc2124 |
-- | Skip all the remaining bytes from the current position in the stream
|
|
Packit |
fc2124 |
skipAll :: Parser ()
|
|
Packit |
fc2124 |
skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok
|