packages feed

damnpacket (empty) → 0.1.0.0

raw patch · 8 files changed

+358/−0 lines, 8 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, containers, criterion, damnpacket, deepseq, text

Files

+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2013 Joel Taylor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/parse.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++import Control.Exception (evaluate)+import Criterion.Main+import Text.Damn.Packet+import Data.Map          (fromList)+import Data.Monoid+import Data.Text         (Text)++main :: IO ()+main = do+    let mypkt = samplePacket+    evaluate mypkt+    defaultMain [+          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 "render"           $ nf render mypkt+      ]++cmd, cmdParam, cmdArgs, cmdParamArgs,+    cmdBody, cmdParamBody, cmdArgsBody, cmdParamArgsBody :: Text+cmd = "ping"+cmdParam = "ping foobar"+cmdArgs = "ping\nfoo=bar\nbaz=qux"+cmdParamArgs = "ping foobar\nfoo=bar\nbaz=qux"+cmdBody = cmd <> "\n\nfoobar"+cmdParamBody = cmdParam <> "\n\nfoobar"+cmdArgsBody = cmdArgs <> "\n\nfoobar"+cmdParamArgsBody = cmdParamArgs <> "\n\nfoobar"++samplePacket :: Packet+samplePacket = Packet { pktCommand = "property"+                      , pktParameter = Just "chat:WriteRoom"+                      , pktArgs = fromList [("p", "title"), ("body", "someBody")]+                      , pktBody = Just "this is the property"+                      }
+ damnpacket.cabal view
@@ -0,0 +1,48 @@+-- Initial damnpacket.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                damnpacket+version:             0.1.0.0+synopsis:            Parsing dAmn packets+license:             MIT+license-file:        LICENSE+homepage:            https://github.com/joelteon/damnpacket+author:              Joel Taylor+maintainer:          me@joelt.io+category:            Text+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:  Text.Damn.Packet+  other-modules:    Text.Damn.Packet.Internal+                    Text.Damn.Packet.Parser+  build-depends:    base       >= 4.4  && < 4.7+                  , attoparsec >= 0.10+                  , containers >= 0.5+                  , deepseq    >= 1.3+                  , text       >= 0.11+  hs-source-dirs:   src+  default-language: Haskell2010++test-suite render+  type:           exitcode-stdio-1.0+  main-is:        render.hs+  ghc-options:    -w -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs: tests+  build-depends:  base+                , damnpacket+                , containers >= 0.5+                , QuickCheck >= 2.6+                , text       >= 0.11++benchmark parse+  type:           exitcode-stdio-1.0+  main-is:        parse.hs+  ghc-options:    -Wall -O2 -threaded+  hs-source-dirs: benchmarks+  build-depends:  base+                , damnpacket+                , containers >= 0.5+                , criterion  >= 0.8+                , text       >= 0.11
+ src/Text/Damn/Packet.hs view
@@ -0,0 +1,27 @@+-- | Provides convenience functions for manipulating dAmn packets.+module Text.Damn.Packet (+  -- * The Packet datatype+  Packet(..),+  Arguments,++  -- ** Subpackets+  pktSubpacket,+  pktSubpacket',++  -- ** Packet lenses+  pktCommandL,+  pktParameterL,+  pktArgsL,+  pktBodyL,+  pktSubpacketL,++  -- * Parsing+  parse,+  parse',++  -- * Rendering packets+  render+) where++import Text.Damn.Packet.Parser+import Text.Damn.Packet.Internal
+ src/Text/Damn/Packet/Internal.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Internal functions for Packets.+module Text.Damn.Packet.Internal (+  Packet(..),+  Arguments,+  pktCommandL,+  pktParameterL,+  pktArgsL,+  pktBodyL+) where++import Control.Applicative+import Control.DeepSeq+import Data.Data+import Data.Map            (Map)+import Data.Text           (Text)+import Data.Typeable       (Typeable)++-- | A type synonym--because pressing spacebar is pretty irritating.+type Arguments = Map Text Text++lens :: Functor f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t+lens sa sbt afb s = sbt s <$> afb (sa s)++-- | Represents a dAmn packet.+--+-- Packets are comprised of a command, which is mandatory, and three other+-- optional elements: a \"parameter\", an argument list, and a body. Any+-- combination of the latter three (or none of them) is valid, so the+-- parser is fairly lenient.+--+-- A packet with all four elements will look something like this:+--+-- @+--property chat:SomeChatroom+--p=propertyName+--by=name of setter+--ts=timestamp+--+--value of property+-- @+--+-- Parsing this results in the packet:+--+-- @+--'Packet' { 'pktCommand' = \"property\"+--       , 'pktParameter' = 'Just' \"chat:SomeChatroom\"+--       , 'pktArgs' = 'fromList' [(\"p\",\"propertyName\"),(\"by\",\"name of setter\"),(\"ts\",\"timestamp\")]+--       , 'pktBody' = 'Just' \"value of property\"+--       }+-- @+data Packet = Packet { pktCommand   :: Text+                     , pktParameter :: Maybe Text+                     , pktArgs      :: Arguments+                     , pktBody      :: Maybe Text+                     } deriving (Eq, Data, Show, Typeable)++instance NFData Packet where+   rnf (Packet a b c d) = rnf a `seq`+                          rnf b `seq`+                          rnf c `seq`+                          rnf d `seq`+                          ()++-- | A lens on 'pktCommand'.+pktCommandL :: Functor f+            => (Text -> f Text)+            -> Packet -> f Packet+pktCommandL = lens pktCommand (\pk b -> pk { pktCommand = b })++-- | A lens on 'pktParameter'.+pktParameterL :: Functor f+              => (Maybe Text -> f (Maybe Text))+              -> Packet -> f Packet+pktParameterL = lens pktParameter (\pk b -> pk { pktParameter = b })++-- | A lens on 'pktArgs'.+pktArgsL :: Functor f+         => (Arguments -> f Arguments)+         -> Packet -> f Packet+pktArgsL = lens pktArgs (\pk b -> pk { pktArgs = b })++-- | A lens on 'pktBody'.+pktBodyL :: Functor f+         => (Maybe Text -> f (Maybe Text))+         -> Packet -> f Packet+pktBodyL = lens pktBody (\pk b -> pk { pktBody = b })
+ src/Text/Damn/Packet/Parser.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- | Parsing Packets.+module Text.Damn.Packet.Parser (+  Packet(..),+  parse, parse',+  render,+  pktSubpacket,+  pktSubpacket',+  pktSubpacketL+) where++import           Prelude                   hiding (null)+import           Control.Applicative       ((<$>), (<*>), (*>), many)+import           Control.Arrow             (second)+import           Data.Attoparsec.Text      hiding (parse)+import           Data.Char+import           Data.Map                  (fromList, toList)+import           Data.Monoid+import           Data.Text                 (Text)+import qualified Data.Text as T+import           Text.Damn.Packet.Internal++-- | A lens on 'pktSubpacket''.+pktSubpacketL :: Functor f => (Maybe Packet -> f (Maybe Packet)) -> Packet -> f Packet+pktSubpacketL afb s = setter s <$> afb (getter s)+    where getter p = pktSubpacket' p+          setter pkt m = pkt { pktBody = render <$> m }++-- | 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 { pktBody = b } =+        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+                      Left _   -> Nothing+                      Right pk -> Just pk+{-# 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 cmd prm args b) =+        cmd+     <> maybe "" (" " <>) prm+     <> T.concat (map (\(k,v) -> "\n" <> k <> "=" <> v) (toList args))+     <> maybe "" ("\n\n" <>) b++-- | Parse some text, providing a packet or the reason for parse failure.+parse :: Text -> Either String Packet+parse str = if T.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 (Left l) = Left l++-- | Parse some text, discarding any failure message.+parse' :: Text -> Maybe Packet+parse' s = case parse s of+               Right pk -> Just pk+               Left _ -> Nothing+{-# INLINE parse' #-}++headP :: Parser Packet+headP = do+    cmd <- takeWhile1 (not . isSpace)+    prm <- option Nothing paramP+    args <- fromList <$> argsP+    return $ Packet cmd prm args Nothing+    where+        paramP = fmap Just (char ' ' *> takeWhile1 (not . isSpace)) <?> "parameter"+        argsP = many ((,) <$> (char '\n' >> takeTill (=='='))+                          <*> (char '=' >> takeTill (=='\n')))+                     <?> "arguments"++accountForLoginSpace :: Text -> Text+accountForLoginSpace s = if "login " `T.isPrefixOf` s+                             then T.replace "\n\n" "\n" s+                             else s
+ tests/render.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Applicative  ((<*>), (<$>))+import Control.Monad        (unless)+import Data.Map             (fromList, toList)+import Data.Text            (Text, 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'])+        shrink m = pack <$> shrink (unpack m)++instance Arbitrary Packet where+    arbitrary = do+       cmd <- arbitrary+       prm <- arbitrary+       args <- fromList <$> arbitrary+       b <- arbitrary+       return $ Packet cmd prm args b+    shrink (Packet a b c d) = Packet <$> shrink a+                                     <*> shrink b+                                     <*> (fromList <$> shrink (toList c))+                                     <*> shrink d++quickCheckExit :: Testable prop => prop -> IO ()+quickCheckExit prop = do+    res <- quickCheckResult prop+    unless (isSuccess res) exitFailure++main :: IO ()+main = quickCheckExit (\pk -> parse' (render pk) == Just pk)