damnpacket 0.5.0 → 0.6.0
raw patch · 5 files changed
+40/−53 lines, 5 filesdep +attoparsecdep −trifectadep ~text
Dependencies added: attoparsec
Dependencies removed: trifecta
Dependency ranges changed: text
Files
- benchmarks/parse.hs +2/−2
- damnpacket.cabal +5/−6
- src/Text/Damn/Packet/Internal.hs +3/−4
- src/Text/Damn/Packet/Parser.hs +26/−32
- tests/render.hs +4/−9
benchmarks/parse.hs view
@@ -6,7 +6,7 @@ import Text.Damn.Packet import Data.Maybe (fromJust) import Data.Monoid-import Data.ByteString (ByteString)+import Data.Text (Text) main :: IO () main = defaultMain [@@ -32,7 +32,7 @@ ] cmd, cmdParam, cmdArgs, cmdParamArgs,- cmdBody, cmdParamBody, cmdArgsBody, cmdParamArgsBody :: ByteString+ cmdBody, cmdParamBody, cmdArgsBody, cmdParamArgsBody :: Text cmd = "ping" cmdParam = "ping foobar" cmdArgs = "ping\nfoo=bar\nbaz=qux"
damnpacket.cabal view
@@ -1,5 +1,5 @@ name: damnpacket-version: 0.5.0+version: 0.6.0 synopsis: Parsing dAmn packets license: MIT license-file: LICENSE@@ -15,11 +15,11 @@ other-modules: Text.Damn.Packet.Internal Text.Damn.Packet.Parser build-depends: base >= 4.4 && < 4.8+ , attoparsec >= 0.11 , bytestring >= 0.10 , containers >= 0.4 , deepseq >= 1.3- , text- , trifecta+ , text >= 1.1 hs-source-dirs: src default-language: Haskell2010 @@ -29,11 +29,10 @@ ghc-options: -w -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests build-depends: base- , bytestring >= 0.10 , containers >= 0.5 , damnpacket , QuickCheck >= 2.6- , text+ , text >= 1.1 default-language: Haskell2010 benchmark parse@@ -42,8 +41,8 @@ ghc-options: -Wall -O2 -threaded hs-source-dirs: benchmarks build-depends: base- , bytestring >= 0.10 , containers >= 0.5 , criterion >= 0.8 , damnpacket+ , text >= 1.1 default-language: Haskell2010
src/Text/Damn/Packet/Internal.hs view
@@ -14,10 +14,9 @@ import Control.Applicative import Control.DeepSeq-import Data.ByteString import Data.Data import Data.Map (Map)-import Data.Text+import Data.Text (Text) -- | A type synonym--because pressing spacebar is pretty irritating. type Arguments = Map Text Text@@ -56,7 +55,7 @@ data Packet = Packet { pktCommand :: Text , pktParameter :: Maybe Text , pktArgs :: Arguments- , pktBody :: Maybe ByteString+ , pktBody :: Maybe Text } deriving (Eq, Data, Show, Typeable) instance NFData Packet where@@ -89,7 +88,7 @@ -- | A lens on 'pktBody'. pktBodyL :: Functor f- => (Maybe ByteString -> f (Maybe ByteString))+ => (Maybe Text -> f (Maybe Text)) -> Packet -> f Packet pktBodyL = lens pktBody (\pk b -> pk { pktBody = b }) {-# INLINE pktBodyL #-}
src/Text/Damn/Packet/Parser.hs view
@@ -15,15 +15,12 @@ import Prelude hiding (null) import Control.Applicative ((<$>), (*>), liftA3, pure) import Control.Arrow (second)+import qualified Data.Attoparsec.Text as A import Data.Char import qualified Data.Map as M import Data.Monoid-import qualified Data.ByteString as B-import Data.ByteString (ByteString) import qualified Data.Text as T-import qualified Data.Text.Encoding as T 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@@ -35,63 +32,63 @@ -- | 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 -> Result Packet+pktSubpacket :: Packet -> Either String Packet pktSubpacket Packet { pktBody = b } =- case b of Nothing -> Failure "Parent packet has no body!"+ case b of Nothing -> Left "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- Success pk -> Just pk+ Right 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 -> ByteString+render :: Packet -> T.Text render (Packet cmd prm args b) =- T.encodeUtf8 cmd- <> maybe "" ((" " <>) . T.encodeUtf8) prm+ cmd+ <> maybe "" (" " <>) prm <> M.foldrWithKey- (\k v m -> "\n" <> T.encodeUtf8 k <> "=" <> T.encodeUtf8 v <> m) "" args+ (\k v m -> "\n" <> k <> "=" <> v <> m) "" args <> maybe "" ("\n\n" <>) b {-# INLINE render #-} -- | Parse some text, providing a packet or the reason for parse failure.-parse :: ByteString -> Result Packet-parse str = if B.null body+parse :: T.Text -> Either String Packet+parse str = if T.null body then packet else addBody packet where adjustedStr = accountForLoginSpace str- (header, body) = second (B.drop 2) $ B.breakSubstring "\n\n" adjustedStr- packet = parseByteString headP mempty header- addBody (Success s) = Success $ s { pktBody = Just body }+ (header, body) = second (T.drop 2) $ T.breakOn "\n\n" adjustedStr+ packet = A.parseOnly headP header+ addBody (Right s) = Right $ s { pktBody = Just body } addBody l = l -- | Parse some text, discarding any failure message.-parse' :: ByteString -> Maybe Packet+parse' :: T.Text -> Maybe Packet parse' s = case parse s of- Success pk -> Just pk+ Right pk -> Just pk _ -> Nothing {-# INLINE parse' #-} -headP :: Parser Packet+headP :: A.Parser Packet headP = do- cmd <- some (satisfy (not . isSpace))- prm <- option Nothing paramP+ cmd <- A.takeWhile1 (not . isSpace)+ prm <- A.option Nothing paramP args <- argsP- return $ Packet (T.pack cmd) (fmap T.pack prm) args Nothing+ return $ Packet cmd prm args Nothing where- paramP = fmap Just (char ' ' *> some (satisfy (not . isSpace))) <?> "parameter"+ paramP = fmap Just (A.char ' ' *> A.takeWhile1 (not . isSpace)) A.<?> "parameter" argsP = do- ch <- optional (char '\n')+ ch <- A.option Nothing (Just <$> A.char '\n') case ch of Just '\n' -> liftA3 M.insert- (T.pack <$> some (notChar '='))- (char '=' *> fmap T.pack (many (notChar '\n')))+ (A.takeWhile1 (/= '='))+ (A.char '=' >> A.takeWhile (/= '\n')) argsP _ -> pure mempty @@ -108,11 +105,8 @@ -- 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 :: ByteString -> ByteString-accountForLoginSpace s = if "login " `B.isPrefixOf` s- then replace "\n\n" "\n" s+accountForLoginSpace :: T.Text -> T.Text+accountForLoginSpace s = if "login " `T.isPrefixOf` s+ then T.replace "\n\n" "\n" s else s- where replace find rep ss = case B.breakSubstring find ss of- (n, b) | B.null b -> n- (a, b) -> a <> rep <> replace find rep (B.drop (B.length find) b) {-# INLINE accountForLoginSpace #-}
tests/render.hs view
@@ -4,21 +4,16 @@ import Control.Applicative ((<*>), (<$>)) import Control.Monad (unless)-import qualified Data.ByteString as B import Data.Map (fromList, toList)-import qualified Data.Text as T+import Data.Text (Text, pack, unpack) import System.Exit import Test.QuickCheck import Test.QuickCheck.Test (isSuccess) import Text.Damn.Packet -instance Arbitrary B.ByteString where- arbitrary = B.pack <$> vectorOf 10 (elements [97..122])- shrink m = B.pack <$> shrink (B.unpack m)--instance Arbitrary T.Text where- arbitrary = T.pack <$> vectorOf 10 (elements ['a'..'z'])- shrink m = T.pack <$> shrink (T.unpack m)+instance Arbitrary Text where+ arbitrary = pack <$> vectorOf 10 (elements ['a'..'Z'])+ shrink m = pack <$> shrink (unpack m) instance Arbitrary Packet where arbitrary = do