damnpacket 0.1.2 → 0.2.0
raw patch · 5 files changed
+64/−61 lines, 5 filesdep +bytestringdep +trifectadep +utf8-stringdep −attoparsecdep −text
Dependencies added: bytestring, trifecta, utf8-string
Dependencies removed: attoparsec, text
Files
- benchmarks/parse.hs +13/−13
- damnpacket.cabal +10/−10
- src/Text/Damn/Packet/Internal.hs +8/−8
- src/Text/Damn/Packet/Parser.hs +29/−27
- tests/render.hs +4/−3
benchmarks/parse.hs view
@@ -2,26 +2,24 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Exception (evaluate) import Criterion.Main import Text.Damn.Packet-import Data.Map (fromList) import Data.Maybe (fromJust) import Data.Monoid-import Data.Text (Text)+import Data.ByteString (ByteString) main :: IO () main = defaultMain [ bgroup "Parsing" [- bench "phony" $ nf parse ""- , bench "cmd" $ nf parse cmd- , bench "cmdParam" $ nf parse cmdParam- , bench "cmdArgs" $ nf parse cmdArgs- , bench "cmdParamArgs" $ nf parse cmdParamArgs- , bench "cmdBody" $ nf parse cmdBody- , bench "cmdParamBody" $ nf parse cmdParamBody- , bench "cmdArgsBody" $ nf parse cmdArgsBody- , bench "cmdParamArgsBody" $ nf parse cmdParamArgsBody ]+ bench "phony" $ nf parse' ""+ , bench "cmd" $ nf parse' cmd+ , bench "cmdParam" $ nf parse' cmdParam+ , bench "cmdArgs" $ nf parse' cmdArgs+ , bench "cmdParamArgs" $ nf parse' cmdParamArgs+ , bench "cmdBody" $ nf parse' cmdBody+ , bench "cmdParamBody" $ nf parse' cmdParamBody+ , bench "cmdArgsBody" $ nf parse' cmdArgsBody+ , bench "cmdParamArgsBody" $ nf parse' cmdParamArgsBody ] , bgroup "Rendering" [ bench "cmd" $ nf render cmdPkt , bench "cmdParam" $ nf render cmdParamPkt@@ -34,7 +32,7 @@ ] cmd, cmdParam, cmdArgs, cmdParamArgs,- cmdBody, cmdParamBody, cmdArgsBody, cmdParamArgsBody :: Text+ cmdBody, cmdParamBody, cmdArgsBody, cmdParamArgsBody :: ByteString cmd = "ping" cmdParam = "ping foobar" cmdArgs = "ping\nfoo=bar\nbaz=qux"@@ -44,6 +42,8 @@ cmdArgsBody = cmdArgs <> "\n\nfoobar" cmdParamArgsBody = cmdParamArgs <> "\n\nfoobar" +cmdPkt, cmdParamPkt, cmdArgsPkt, cmdParamArgsPkt, cmdBodyPkt,+ cmdParamBodyPkt, cmdArgsBodyPkt, cmdParamArgsBodyPkt :: Packet cmdPkt = fromJust $! parse' cmd cmdParamPkt = fromJust $! parse' cmdParam cmdArgsPkt = fromJust $! parse' cmdArgs
damnpacket.cabal view
@@ -1,8 +1,5 @@--- Initial damnpacket.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/- name: damnpacket-version: 0.1.2+version: 0.2.0 synopsis: Parsing dAmn packets license: MIT license-file: LICENSE@@ -18,10 +15,11 @@ other-modules: Text.Damn.Packet.Internal Text.Damn.Packet.Parser build-depends: base >= 4.4 && < 4.8- , attoparsec >= 0.10.4+ , bytestring >= 0.10 , containers >= 0.4 , deepseq >= 1.3- , text >= 0.11+ , trifecta+ , utf8-string hs-source-dirs: src default-language: Haskell2010 @@ -31,10 +29,11 @@ ghc-options: -w -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests build-depends: base- , damnpacket+ , bytestring >= 0.10 , containers >= 0.5+ , damnpacket , QuickCheck >= 2.6- , text >= 0.11+ default-language: Haskell2010 benchmark parse type: exitcode-stdio-1.0@@ -42,7 +41,8 @@ ghc-options: -Wall -O2 -threaded hs-source-dirs: benchmarks build-depends: base- , damnpacket+ , bytestring >= 0.10 , containers >= 0.5 , criterion >= 0.8- , text >= 0.11+ , damnpacket+ default-language: Haskell2010
src/Text/Damn/Packet/Internal.hs view
@@ -14,12 +14,12 @@ import Control.Applicative import Control.DeepSeq+import Data.ByteString (ByteString) import Data.Data import Data.Map (Map)-import Data.Text (Text) -- | A type synonym--because pressing spacebar is pretty irritating.-type Arguments = Map Text Text+type Arguments = Map ByteString ByteString lens :: Functor f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t lens sa sbt afb s = sbt s <$> afb (sa s)@@ -52,10 +52,10 @@ -- , 'pktBody' = 'Just' \"value of property\" -- } -- @-data Packet = Packet { pktCommand :: Text- , pktParameter :: Maybe Text+data Packet = Packet { pktCommand :: ByteString+ , pktParameter :: Maybe ByteString , pktArgs :: Arguments- , pktBody :: Maybe Text+ , pktBody :: Maybe ByteString } deriving (Eq, Data, Show, Typeable) instance NFData Packet where@@ -67,14 +67,14 @@ -- | A lens on 'pktCommand'. pktCommandL :: Functor f- => (Text -> f Text)+ => (ByteString -> f ByteString) -> Packet -> f Packet pktCommandL = lens pktCommand (\pk b -> pk { pktCommand = b }) {-# INLINE pktCommandL #-} -- | A lens on 'pktParameter'. pktParameterL :: Functor f- => (Maybe Text -> f (Maybe Text))+ => (Maybe ByteString -> f (Maybe ByteString)) -> Packet -> f Packet pktParameterL = lens pktParameter (\pk b -> pk { pktParameter = b }) {-# INLINE pktParameterL #-}@@ -88,7 +88,7 @@ -- | A lens on 'pktBody'. pktBodyL :: Functor f- => (Maybe Text -> f (Maybe Text))+ => (Maybe ByteString -> f (Maybe ByteString)) -> Packet -> f Packet pktBodyL = lens pktBody (\pk b -> pk { pktBody = b }) {-# INLINE pktBodyL #-}
src/Text/Damn/Packet/Parser.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} -- | Parsing Packets. module Text.Damn.Packet.Parser (@@ -16,13 +15,14 @@ import Prelude hiding (null) import Control.Applicative ((<$>), (*>), liftA3, pure) import Control.Arrow (second)-import Data.Attoparsec.Text hiding (parse) import Data.Char import qualified Data.Map as M import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T+import qualified Data.ByteString as B+import Data.ByteString.UTF8 (ByteString)+import qualified Data.ByteString.UTF8 as B hiding (length, drop) import Text.Damn.Packet.Internal+import Text.Trifecta hiding (render) -- | A lens on 'pktSubpacket''. pktSubpacketL :: Functor f => (Maybe Packet -> f (Maybe Packet)) -> Packet -> f Packet@@ -34,23 +34,23 @@ -- | Due to the way dAmn packets are designed, it's not possible to -- unambiguously determine whether a packet has a subpacket or just a body. -- Thus you will need to request a subpacket yourself.-pktSubpacket :: Packet -> Either String Packet+pktSubpacket :: Packet -> Result Packet pktSubpacket Packet { pktBody = b } =- case b of Nothing -> Left "Parent packet has no body!"+ case b of Nothing -> Failure "Parent packet has no body!" Just pk -> parse pk {-# INLINE pktSubpacket #-} -- | Use when you don't care about the reason for parse failure. pktSubpacket' :: Packet -> Maybe Packet pktSubpacket' p = case pktSubpacket p of- Left _ -> Nothing- Right pk -> Just pk+ Success pk -> Just pk+ _ -> Nothing {-# INLINE pktSubpacket' #-} -- | 'render' converts a packet back into the dAmn text format. -- This is used by 'pktSubpacketL' to fulfill the lens laws, but you might -- find it useful if you want to write packets to dAmn.-render :: Packet -> Text+render :: Packet -> ByteString render (Packet cmd prm args b) = cmd <> maybe "" (" " <>) prm@@ -59,37 +59,37 @@ {-# INLINE render #-} -- | Parse some text, providing a packet or the reason for parse failure.-parse :: Text -> Either String Packet-parse str = if T.null body+parse :: ByteString -> Result Packet+parse str = if B.null body then packet else addBody packet where adjustedStr = accountForLoginSpace str- (header, body) = second (T.drop 2) $ T.breakOn "\n\n" adjustedStr- packet = parseOnly headP header- addBody (Right s) = Right $ s { pktBody = Just body }- addBody l@Left{..} = l+ (header, body) = second (B.drop 2) $ B.breakSubstring "\n\n" adjustedStr+ packet = parseByteString headP mempty header+ addBody (Success s) = Success $ s { pktBody = Just body }+ addBody l = l -- | Parse some text, discarding any failure message.-parse' :: Text -> Maybe Packet+parse' :: ByteString -> Maybe Packet parse' s = case parse s of- Left _ -> Nothing- Right pk -> Just pk+ Success pk -> Just pk+ _ -> Nothing {-# INLINE parse' #-} headP :: Parser Packet headP = do- cmd <- takeWhile1 (not . isSpace)+ cmd <- some (satisfy (not . isSpace)) prm <- option Nothing paramP args <- argsP- return $ Packet cmd prm args Nothing+ return $ Packet (B.fromString cmd) (fmap B.fromString prm) args Nothing where- paramP = fmap Just (char ' ' *> takeWhile1 (not . isSpace)) <?> "parameter"+ paramP = fmap Just (char ' ' *> some (satisfy (not . isSpace))) <?> "parameter" argsP = do- ch <- peekChar+ ch <- optional (char '\n') case ch of Just '\n' -> liftA3 M.insert- (char '\n' >> takeTill (=='='))- (char '=' >> takeTill (=='\n'))+ (B.fromString <$> some (notChar '='))+ (char '=' >> fmap B.fromString (some (notChar '\n'))) argsP _ -> pure mempty @@ -106,8 +106,10 @@ -- That is, with an extra space after the \"event\" argument. Since this is -- unintuitive behavior and no other packet behaves this way, the parser has -- a special case for login packets where it will eliminate the extra newline.-accountForLoginSpace :: Text -> Text-accountForLoginSpace s = if "login " `T.isPrefixOf` s- then T.replace "\n\n" "\n" s+accountForLoginSpace :: ByteString -> ByteString+accountForLoginSpace s = if "login " `B.isPrefixOf` s+ then replace "\n\n" "\n" s else s+ where replace find rep ss = case B.breakSubstring find ss of+ (a, b) -> a <> rep <> replace find rep (B.drop (B.length find) b) {-# INLINE accountForLoginSpace #-}
tests/render.hs view
@@ -1,17 +1,18 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} import Control.Applicative ((<*>), (<$>)) import Control.Monad (unless) import Data.Map (fromList, toList)-import Data.Text (Text, pack, unpack)+import Data.ByteString (ByteString, pack, unpack) import System.Exit import Test.QuickCheck import Test.QuickCheck.Test (isSuccess) import Text.Damn.Packet -instance Arbitrary Text where- arbitrary = pack <$> vectorOf 10 (elements ['a'..'z'])+instance Arbitrary ByteString where+ arbitrary = pack <$> vectorOf 10 (elements [97..122]) shrink m = pack <$> shrink (unpack m) instance Arbitrary Packet where