packages feed

damnpacket 0.6.0 → 1.0.0

raw patch · 16 files changed

+648/−380 lines, 16 filesdep +HUnitdep +faildep +hspecdep −containersdep −criteriondep −deepseqdep ~QuickCheckdep ~attoparsecdep ~basenew-uploader

Dependencies added: HUnit, fail, hspec, html-entities, template-haskell

Dependencies removed: containers, criterion, deepseq

Dependency ranges changed: QuickCheck, attoparsec, base, bytestring, text

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for damn++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
LICENSE view
@@ -1,21 +1,20 @@-The MIT License (MIT)--Copyright (c) 2013 Joel Taylor+Copyright (c) 2016 Jude 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:+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 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.+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.
− benchmarks/parse.hs 
@@ -1,54 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# LANGUAGE OverloadedStrings #-}--import Criterion.Main-import Text.Damn.Packet-import Data.Maybe        (fromJust)-import Data.Monoid-import Data.Text         (Text)--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 ]-      , bgroup "Rendering" [-            bench "cmd"              $ nf render cmdPkt-          , bench "cmdParam"         $ nf render cmdParamPkt-          , bench "cmdArgs"          $ nf render cmdArgsPkt-          , bench "cmdParamArgs"     $ nf render cmdParamArgsPkt-          , bench "cmdBody"          $ nf render cmdBodyPkt-          , bench "cmdParamBody"     $ nf render cmdParamBodyPkt-          , bench "cmdArgsBody"      $ nf render cmdArgsBodyPkt-          , bench "cmdParamArgsBody" $ nf render cmdParamArgsBodyPkt ]-      ]--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"--cmdPkt, cmdParamPkt, cmdArgsPkt, cmdParamArgsPkt, cmdBodyPkt,-    cmdParamBodyPkt, cmdArgsBodyPkt, cmdParamArgsBodyPkt :: Packet-cmdPkt = fromJust $! parse' cmd-cmdParamPkt = fromJust $! parse' cmdParam-cmdArgsPkt = fromJust $! parse' cmdArgs-cmdParamArgsPkt = fromJust $! parse' cmdParamArgs-cmdBodyPkt = fromJust $! parse' cmdBody-cmdParamBodyPkt = fromJust $! parse' cmdParamBody-cmdArgsBodyPkt = fromJust $! parse' cmdArgsBody-cmdParamArgsBodyPkt = fromJust $! parse' cmdParamArgsBody
damnpacket.cabal view
@@ -1,48 +1,43 @@ name:                damnpacket-version:             0.6.0-synopsis:            Parsing dAmn packets+version:             1.0.0+synopsis:            Parsing dAmn messages+description:         This module provides a datatype and convenience functions for parsing, manipulating, and rendering deviantART Message Network messages. license:             MIT license-file:        LICENSE-homepage:            https://github.com/joelteon/damnpacket-author:              Joel Taylor-maintainer:          me@joelt.io-category:            Text+author:              Jude Taylor+maintainer:          me@jude.bio+-- copyright:           +category:            Network build-type:          Simple+extra-source-files:  ChangeLog.md 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.8-                  , attoparsec >= 0.11-                  , bytestring >= 0.10-                  , containers >= 0.4-                  , deepseq    >= 1.3-                  , text       >= 1.1-  hs-source-dirs:   src-  default-language: Haskell2010+  exposed-modules:     Network.Damn+                       Network.Damn.Format.IRC+                       Network.Damn.Format.Damn+  other-modules:       Network.Damn.Tablumps+                       Network.Damn.Tablumps.TH+                       Network.Damn.Format.Base+                       Network.Damn.Format.Damn.Internal+  -- other-extensions:    +  build-depends:       base == 4.*+                     , attoparsec+                     , bytestring+                     , fail+                     , html-entities+                     , template-haskell+                     , text+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall -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-                , containers >= 0.5-                , damnpacket-                , QuickCheck >= 2.6-                , text       >= 1.1-  default-language: Haskell2010+test-suite parse+  main-is:             parse.hs+  hs-source-dirs:      test+  type:                exitcode-stdio-1.0+  build-depends:       base, bytestring, damnpacket, HUnit, hspec, QuickCheck -benchmark parse-  type:           exitcode-stdio-1.0-  main-is:        parse.hs-  ghc-options:    -Wall -O2 -threaded-  hs-source-dirs: benchmarks-  build-depends:  base-                , containers >= 0.5-                , criterion  >= 0.8-                , damnpacket-                , text       >= 1.1-  default-language: Haskell2010+source-repository head+  location:            https://github.com/pikajude/damnpacket+  type:                git
+ src/Network/Damn.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE ViewPatterns      #-}++-- | This module provides a datatype and convenience functions for parsing,+-- manipulating, and rendering deviantART Message Network messages.+module Network.Damn (+    -- *** Datatypes+    Message(..),+    SubMessage(..),+    MessageBody,+    -- *** Working with message bodies+    bodyBytes, Formatter, bodyWithFormat,+    toBody, toBodyText,+    -- *** Working with sub-messages+    subMessage,+    pattern SubM,+    -- *** Parsing+    parseMessage,+    messageP,+    -- *** Rendering+    render,+    -- *** Tablumps+    Lump(..)+) where++import           Control.Applicative+import qualified Control.Monad+import           Control.Monad.Fail+import           Data.Attoparsec.ByteString        hiding (word8)+import qualified Data.Attoparsec.ByteString        as A+import qualified Data.Attoparsec.ByteString.Char8  as C+import           Data.ByteString+import           Data.Char+import           Data.Ix+import           Data.Monoid+import           Data.String+import           Data.Text                         hiding (singleton)+import           Data.Word+import           Network.Damn.Format.Base          (Formatter)+import           Network.Damn.Format.Damn.Internal (textToBytes)+import           Network.Damn.Tablumps+import           Prelude                           hiding (fail)++-- | A top-level dAmn message.+--+-- General syntax for a message:+--+-- @+-- name arg+-- attr1=val1+-- attr2=val2+--+-- body+-- @+--+-- As reflected in the field types of 'Message', the 'arg' and 'body' are+-- both optional.+--+-- Attribute values are considered to be textual data and generally consist+-- of part reasons, privclass names, users' "taglines" and so on. The+-- message body can either be treated as text or as a 'SubMessage' (see+-- 'MessageBody').+--+-- Note that dAmn is a primarily browser-based platform; it deals with+-- only ISO-8859-1 output and input and inserts chat messages directly into+-- the DOM. As a consequence, correctly displaying characters past the ASCII+-- block requires the use of HTML entities.+--+-- All functions in this module transparently convert HTML entities+-- embedded in 'ByteString's to 'Text' (and back; see 'toBodyText'). Thus,+-- when 'Text' appears in fields of this record or of 'SubMessage', you can+-- assume that the HTML entity decoding step has already been handled.+data Message = Message+             { messageName     :: ByteString+             , messageArgument :: Maybe ByteString+             , messageAttrs    :: [(ByteString, Text)]+             , messageBody     :: Maybe MessageBody+             } deriving (Eq, Show)++-- | A second-level dAmn message. Note that this message can omit the+-- name/argument pair.+data SubMessage = SubMessage+                { subMessageName     :: Maybe ByteString+                , subMessageArgument :: Maybe ByteString+                , subMessageAttrs    :: [(ByteString, Text)]+                , subMessageBody     :: Maybe MessageBody+                } deriving (Eq, Show)++-- | The body of a message, which can be converted to various formats+-- ('bodyWithFormat') or parsed as a 'SubMessage' ('subMessage').+data MessageBody = MessageBody+                 { -- | View the original binary content of a 'MessageBody'.+                   --+                   -- To interpret this as textual data, use+                   -- 'bodyWithFormat'.+                   bodyBytes  :: ByteString+                   -- | Try to parse a 'MessageBody' as a 'SubMessage'.+                 , subMessage :: forall m. MonadFail m => m SubMessage+                 }++instance IsString MessageBody where+    fromString = toBody . fromString++-- bodyRaw (MessageBody b _) = show b+-- bodyText (MessageBody b _) = lumpsToText b+-- bodyTextInline (MessageBody b _) = lumpsToTextInline b++instance Show MessageBody where+    show (MessageBody b _) = show b++instance Eq MessageBody where+    MessageBody b _ == MessageBody b1 _ = b == b1++-- | 'subMessage' as a pattern.+--+-- @+-- case messageBody of+--     Sub (SubMessage name args attrs body)) -> ...+--     _ -> error "No parse"+-- @+--+-- Can be nested:+--+-- @+-- isJoinPacket :: Message -> Bool+-- isJoinPacket (Message "recv" room _+--     (Sub (SubMessage (Just "join") (Just uname) _+--         (Sub (SubMessage Nothing Nothing userAttrs _)))))+--     = True+-- isJoinPacket _ = False+-- @+pattern SubM :: SubMessage -> Maybe MessageBody+pattern SubM pkt <- ((>>= subMessage) -> Just pkt)++-- | Convert a 'MessageBody' to some stringlike representation using the+-- given 'Formatter'. (See 'Network.Damn.Format.Damn.damnFormat').+bodyWithFormat :: Monoid s => Formatter s -> MessageBody -> s+bodyWithFormat f = foldMap f . toLumps . bodyBytes++messageP :: Parser Message+messageP = do+    name <- C.takeWhile1 C.isAlpha_iso8859_15+    next <- C.peekChar'+    arg <- if next == ' '+               then C.char ' ' *> (Just <$> C.takeWhile1 (/= '\n'))+               else pure Nothing++    _ <- C.char '\n'+    attrs <- many attr++    body <- parseBody++    return $ Message name arg attrs body++parseBody :: Parser (Maybe MessageBody)+parseBody = do+    next <- C.anyChar+    case next of+        '\n' -> Just . toBody+            <$> Data.Attoparsec.ByteString.takeWhile (/= 0) <* A.word8 0+        '\0' -> pure Nothing+        _    -> Control.Monad.fail "Malformed packet"++subMessageP :: Parser SubMessage+subMessageP = do+    firstAttr <- optional attr+    case firstAttr of+        Just a -> do+            otherAttrs <- many attr+            body <- parseBody+            return $ SubMessage Nothing Nothing (a:otherAttrs) body+        Nothing -> do+            Message a b c d <- messageP+            return $ SubMessage (Just a) b c d++attr :: Parser (ByteString, Text)+attr = do+    k <- takeWhile1 nameChars+    _ <- C.char '='+    v <- C.takeWhile (/= '\n')+    _ <- C.char '\n'+    return (k, bytesToText v)++nameChars :: Word8 -> Bool+nameChars x = inRange (integralOrd 'a', integralOrd 'z') x+           || inRange (integralOrd 'A', integralOrd 'Z') x+           || inRange (integralOrd '0', integralOrd '9') x+    where integralOrd = fromIntegral . ord++-- | 'MessageBody' smart constructor.+toBody :: ByteString -> MessageBody+toBody x = MessageBody x+    (either Control.Monad.fail return $ parseOnly subMessageP (x <> "\0"))++-- | Like 'toBody', but convert codepoints outside the ASCII range to HTML+-- entities.+--+-- Note that this is NOT equivalent to @toBody . encodeUtf8@.+toBodyText :: Text -> MessageBody+toBodyText = toBody . textToBytes++-- | @'parseOnly' 'messageP'@+parseMessage :: ByteString -> Either String Message+parseMessage = parseOnly messageP++-- | Convert a 'Message' back into a 'ByteString' to send to dAmn. The null+-- byte is appended. In addition, all characters outside the ASCII block+-- are converted to HTML entities, thus+--+-- >>> render (Message "foo" (Just "bar") [("attr1", "☭")] Nothing)+-- "foo bar\nattr1=&#9773;\n\NUL"+render :: Message -> ByteString+render (Message name arg attrs body) = appendArg arg name+    <> "\n"+    <> renderAttrs attrs+    <> renderBody body+    <> "\0"+    where+        appendArg (Just b) = (<> (" " <> b))+        appendArg _        = id+        renderAttrs []         = ""+        renderAttrs ((a,b):bs) = a <> "=" <> textToBytes b <> "\n" <> renderAttrs bs+        renderBody (Just (MessageBody b _)) = "\n" <> b+        renderBody _                        = ""
+ src/Network/Damn/Format/Base.hs view
@@ -0,0 +1,10 @@+module Network.Damn.Format.Base (+    module Network.Damn.Format.Base,+    module Network.Damn.Tablumps,+    Text+) where++import Data.Text+import Network.Damn.Tablumps++type Formatter m = Either Text Lump -> m
+ src/Network/Damn/Format/Damn.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Damn.Format.Damn (+    damnFormat,+    damnFormatBytes+) where++import Data.ByteString                   (ByteString)+import Data.Text.Encoding+import Network.Damn.Format.Base+import Network.Damn.Format.Damn.Internal++-- | @damnFormat@ is, essentially, a formatter that transforms a raw+-- dAmn message into the text that the sender typed into the dAmn web+-- client.+damnFormat :: Formatter Text+damnFormat = either id (decodeUtf8 . damnFormat')++-- | @encodeUtf8 . damnFormat@+--+-- This function is defined separately to avoid an encoding round-trip.+damnFormatBytes :: Formatter ByteString+damnFormatBytes = either encodeUtf8 damnFormat'
+ src/Network/Damn/Format/Damn/Internal.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Damn.Format.Damn.Internal (+    textToBytes, damnFormat'+) where++import           Data.ByteString          (ByteString)+import           Data.ByteString.Builder+import qualified Data.ByteString.Lazy     as LB (toStrict)+import           Data.Char+import           Data.Monoid+import           Data.Text                (Text)+import qualified Data.Text+import           Network.Damn.Tablumps.TH++textToBytes :: Text -> ByteString+textToBytes = LB.toStrict . toLazyByteString . Data.Text.foldr (\ c b -> maybeEscape c <> b) "" where+    maybeEscape c+        | ord c <= 127 = word8 (fromIntegral $ ord c)+        | otherwise = "&#x" <> word32Hex (fromIntegral $ ord c) <> ";"++damnFormat' :: Lump -> ByteString+damnFormat' (A x y)    = "<a href=\"" <> x <> "\" title=\"" <> y <> "\">"+damnFormat' C_A        = "</a>"+damnFormat' (Abbr x)   = "<abbr title=\"" <> x <> "\">"+damnFormat' C_Abbr     = "</abbr>"+damnFormat' (Acro x)   = "<acronym title=\"" <> x <> "\">"+damnFormat' C_Acro     = "</acronym>"+damnFormat' (Avatar x _) = ":icon" <> x <> ":"+damnFormat' B          = "<b>"+damnFormat' C_B        = "</b>"+damnFormat' Bcode      = "<bcode>"+damnFormat' C_Bcode    = "</bcode>"+damnFormat' Br         = "<br/>"+damnFormat' Code       = "<code>"+damnFormat' C_Code     = "</code>"+damnFormat' (Dev _ x)  = ":dev" <> x <> ":"+damnFormat' (Embed x y z)  = "<embed src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"+damnFormat' C_Embed    = "</embed>"+damnFormat' (Emote x _ _ _ _) = x+damnFormat' I          = "<i>"+damnFormat' C_I        = "</i>"+damnFormat' (Iframe x y z) = "<iframe src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"+damnFormat' C_Iframe   = "</iframe>"+damnFormat' (Img x y z) = "<img src=\"" <> x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"+damnFormat' Li         = "<li>"+damnFormat' C_Li       = "</li>"+damnFormat' (Link x _) = x+damnFormat' Ol         = "<ol>"+damnFormat' C_Ol       = "</ol>"+damnFormat' P          = "<p>"+damnFormat' C_P        = "</p>"+damnFormat' S          = "<s>"+damnFormat' C_S        = "</s>"+damnFormat' Sub        = "<sub>"+damnFormat' C_Sub      = "</sub>"+damnFormat' Sup        = "<sup>"+damnFormat' C_Sup      = "</sup>"+damnFormat' (Thumb x _ _ _ _ _) = ":thumb" <> x <> ":"+damnFormat' U          = "<u>"+damnFormat' C_U        = "</u>"+damnFormat' Ul         = "<ul>"+damnFormat' C_Ul       = "</ul>"
+ src/Network/Damn/Format/IRC.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++-- | Format a dAmn message body as an inline text approximation, including+-- IRC styles.+module Network.Damn.Format.IRC (+    ircFormat, Lines, unLines+) where++import           Data.ByteString                   (ByteString)+import qualified Data.ByteString                   as B+import           Data.String+import           Data.Text.Encoding+import           Network.Damn.Format.Base+import           Network.Damn.Format.Damn.Internal++newtype Lines = Lines ByteString deriving (Show, Monoid, IsString)++unLines :: Lines -> [ByteString]+unLines (Lines bs) = B.split 10 bs++-- | This formatter functions as 'Network.Damn.Format.Damn.damnFormat',+-- except that bold, italics, and underlines will be converted to mIRC+-- colors.+--+-- Additionally, @Text@ will be encoded as UTF-8.+--+-- Note that this formatter will generate 'Lines', as newlines (to which+-- @&br\\t@ translates) cannot appear in IRC messages.+ircFormat :: Formatter Lines+ircFormat = either (Lines . encodeUtf8) (Lines . ircFormat')++ircFormat' :: Lump -> ByteString+ircFormat' B   = "\x02"+ircFormat' C_B = "\x02"+ircFormat' Br  = "\n"+ircFormat' I   = "\x1D"+ircFormat' C_I = "\x1D"+ircFormat' U   = "\x1F"+ircFormat' C_U = "\x1F"+ircFormat' x   = damnFormat' x
+ src/Network/Damn/Tablumps.hs view
@@ -0,0 +1,129 @@+{-# OPTIONS_GHC -ddump-splices #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE TemplateHaskell           #-}++module Network.Damn.Tablumps (+    module Network.Damn.Tablumps,+    Lump(..)+) where++import           Control.Applicative+import           Control.Arrow                    (left)+import           Data.Attoparsec.ByteString       hiding (word8)+import qualified Data.Attoparsec.ByteString.Char8 as C+import           Data.ByteString                  (ByteString)+import           Data.Monoid+import           Data.Text                        (Text)+import           Data.Text.Encoding+import           Data.Text.Internal.Builder       (toLazyText)+import           Data.Text.Lazy                   (toStrict)+import           HTMLEntities.Decoder+import           Network.Damn.Tablumps.TH++-- type Lump = (ByteString, [ByteString])+-- data Lump = Lump deriving (Eq, Show)++tablumpP :: Parser [Either ByteString Lump]+tablumpP = many $ (Left <$> (C.takeWhile1 (/= '&')))+       <|> lump+       <|> fmap Left (C.string "&")++lump :: Parser (Either a Lump)+lump = (C.char '&' *>) $ choice+     [ $(ary 2 "a" 'A)+     , $(ary 0 "/a" 'C_A)++     , $(ary 1 "abbr" 'Abbr)+     , $(ary 0 "/abbr" 'C_Abbr)++     , $(ary 1 "acro" 'Acro)+     , $(ary 0 "/acro" 'C_Acro)++     , $(ary 2 "avatar" 'Avatar)++     , $(ary 0 "b" 'B)+     , $(ary 0 "/b" 'C_B)++     , $(ary 0 "bcode" 'Bcode)+     , $(ary 0 "/bcode" 'C_Bcode)++     , $(ary 0 "br" 'Br)++     , $(ary 0 "code" 'Code)+     , $(ary 0 "/code" 'C_Code)++     , $(ary 2 "dev" 'Dev)++     , $(ary 3 "embed" 'Embed)+     , $(ary 0 "/embed" 'C_Embed)++     , $(ary 5 "emote" 'Emote)++     , $(ary 0 "i" 'I)+     , $(ary 0 "/i" 'C_I)++     , $(ary 3 "iframe" 'Iframe)+     , $(ary 0 "/iframe" 'C_Iframe)++     , $(ary 3 "img" 'Img)++     , $(ary 0 "li" 'Li)+     , $(ary 0 "/li" 'C_Li)++     , link++     , $(ary 0 "ol" 'Ol)+     , $(ary 0 "/ol" 'C_Ol)++     , $(ary 0 "p" 'P)+     , $(ary 0 "/p" 'C_P)++     , $(ary 0 "s" 'S)+     , $(ary 0 "/s" 'C_S)++     , $(ary 0 "sub" 'Sub)+     , $(ary 0 "/sub" 'C_Sub)++     , $(ary 0 "sup" 'Sup)+     , $(ary 0 "/sup" 'C_Sup)++     , $(ary 6 "thumb" 'Thumb)++     , $(ary 0 "u" 'U)+     , $(ary 0 "/u" 'C_U)++     , $(ary 0 "ul" 'Ul)+     , $(ary 0 "/ul" 'C_Ul)+     ]+    where+        -- ary n s = do+        --     string s+        --     C.char '\t'+        --     fmap (Right . (,) s) $ count n arg+        link = do+            _ <- string "link"+            _ <- C.char '\t'+            arg1 <- arg+            arg2 <- arg+            case arg2 of+                "&" -> pure $ Right $ Link arg1 Nothing+                _ -> do+                    _ <- string "&\t"+                    pure $ Right $ Link arg1 (Just arg2)+        arg = C.takeWhile (/= '\t') <* C.char '\t'++toLumps :: ByteString -> [Either Text Lump]+toLumps t = case parseOnly tablumpP t of+    Right y -> map (left (htmlDecode . bytesToText)) $ joinLefts y+    Left _  -> [Left $ bytesToText t]+    where+        joinLefts (Left a : Left b : xs) = joinLefts (Left (a <> b) : xs)+        joinLefts (x:xs)                 = x : joinLefts xs+        joinLefts []                     = []++bytesToText :: ByteString -> Text+bytesToText = decodeLatin1++htmlDecode :: Text -> Text+htmlDecode = toStrict . toLazyText . htmlEncodedText
+ src/Network/Damn/Tablumps/TH.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE DeriveLift      #-}+{-# LANGUAGE TemplateHaskell #-}++#define ARG ByteString++module Network.Damn.Tablumps.TH where++import qualified Data.Attoparsec.ByteString.Char8 as C+import           Data.ByteString                  (ByteString, unpack)+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax++ary :: Int -> String -> Name -> ExpQ+ary n s con = [e|do+    _ <- string s+    _ <- C.char '\t'+    Right <$> $(mkApps)+    |]+    where+        mkApps = foldl (\ a b -> [e|$(a) <*> $(b)|]) [e|pure $(conE con)|]+            $ replicate n [e|C.takeWhile (/= '\t') <* C.char '\t'|]++-- | Tokens representing tablumps.+--+-- These constructors are defined first in order of arity, then+-- alphabetically.+data Lump = A ARG ARG+          | C_A+          | Abbr ARG+          | C_Abbr+          | Acro ARG+          | C_Acro+          | Avatar ARG ARG+          | B+          | C_B+          | Bcode+          | C_Bcode+          | Br+          | Code+          | C_Code+          | Dev ARG ARG+          | Embed ARG ARG ARG+          | C_Embed+          | Emote ARG ARG ARG ARG ARG+          | I+          | C_I+          | Iframe ARG ARG ARG+          | C_Iframe+          | Img ARG ARG ARG+          | Li+          | C_Li+          | Link ARG (Maybe ARG)+          | Ol+          | C_Ol+          | P+          | C_P+          | S+          | C_S+          | Sub+          | C_Sub+          | Sup+          | C_Sup+          | Thumb ARG ARG ARG ARG ARG ARG+          | U+          | C_U+          | Ul+          | C_Ul+          deriving (Lift, Eq, Show)++instance Lift ByteString where+    lift b = [e|pack ws|]+        where ws = unpack b
− src/Text/Damn/Packet.hs 
@@ -1,27 +0,0 @@--- | 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 
@@ -1,94 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}---- | 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)---- | 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)-{-# INLINE lens #-}---- | 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 })-{-# INLINE pktCommandL #-}---- | A lens on 'pktParameter'.-pktParameterL :: Functor f-              => (Maybe Text -> f (Maybe Text))-              -> Packet -> f Packet-pktParameterL = lens pktParameter (\pk b -> pk { pktParameter = b })-{-# INLINE pktParameterL #-}---- | A lens on 'pktArgs'.-pktArgsL :: Functor f-         => (Arguments -> f Arguments)-         -> Packet -> f Packet-pktArgsL = lens pktArgs (\pk b -> pk { pktArgs = b })-{-# INLINE pktArgsL #-}---- | A lens on 'pktBody'.-pktBodyL :: Functor f-         => (Maybe Text -> f (Maybe Text))-         -> Packet -> f Packet-pktBodyL = lens pktBody (\pk b -> pk { pktBody = b })-{-# INLINE pktBodyL #-}
− src/Text/Damn/Packet/Parser.hs 
@@ -1,112 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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       ((<$>), (*>), 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.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 = pktSubpacket'-          setter pkt m = pkt { pktBody = render <$> m }-{-# INLINE pktSubpacketL #-}---- | 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-                      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 -> T.Text-render (Packet cmd prm args b) =-        cmd-     <> maybe "" (" " <>) prm-     <> M.foldrWithKey-        (\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 :: T.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 = A.parseOnly headP header-          addBody (Right s) = Right $ s { pktBody = Just body }-          addBody l = l---- | Parse some text, discarding any failure message.-parse' :: T.Text -> Maybe Packet-parse' s = case parse s of-               Right pk -> Just pk-               _ -> Nothing-{-# INLINE parse' #-}--headP :: A.Parser Packet-headP = do-    cmd <- A.takeWhile1 (not . isSpace)-    prm <- A.option Nothing paramP-    args <- argsP-    return $ Packet cmd prm args Nothing-    where-        paramP = fmap Just (A.char ' ' *> A.takeWhile1 (not . isSpace)) A.<?> "parameter"-        argsP = do-            ch <- A.option Nothing (Just <$> A.char '\n')-            case ch of-                Just '\n' -> liftA3 M.insert-                                    (A.takeWhile1 (/= '='))-                                    (A.char '=' >> A.takeWhile (/= '\n'))-                                    argsP-                _         -> pure mempty---- | The login packet looks like this:------ @---login username---e=event------symbol=~---realname=Some Name--- @------ 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 :: T.Text -> T.Text-accountForLoginSpace s = if "login " `T.isPrefixOf` s-                             then T.replace "\n\n" "\n" s-                             else s-{-# INLINE accountForLoginSpace #-}
+ test/parse.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++import qualified Data.ByteString.Char8 as B8+import           Data.String+import           Network.Damn+import           Test.Hspec+import           Test.HUnit+import           Test.QuickCheck++main = hspec $+    describe "packets" $ do+        it "basic parsing" $+            "dAmnServer 0.3\n\0" @?= Just (Message "dAmnServer" (Just "0.3") [] Nothing)++        it "attrs" $+            "a\na=b\nc=d\n\0" @?= Just (Message "a" Nothing [("a","b"),("c","d")] Nothing)++        it "subpacket" $+            (subMessage =<< messageBody =<< "a\n\nb c\nd=e\n\0")+                @?= Just (SubMessage (Just "b") (Just "c") [("d","e")] Nothing)++instance IsString (Maybe Message) where+    fromString x = case parseMessage $ B8.pack x of+        Left _  -> Nothing+        Right x -> Just x
− tests/render.hs 
@@ -1,36 +0,0 @@-{-# 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 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)