diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+# Revision history for damn
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -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.
diff --git a/benchmarks/parse.hs b/benchmarks/parse.hs
deleted file mode 100644
--- a/benchmarks/parse.hs
+++ /dev/null
@@ -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
diff --git a/damnpacket.cabal b/damnpacket.cabal
--- a/damnpacket.cabal
+++ b/damnpacket.cabal
@@ -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
diff --git a/src/Network/Damn.hs b/src/Network/Damn.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Damn.hs
@@ -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=☭\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 _ = ""
diff --git a/src/Network/Damn/Format/Base.hs b/src/Network/Damn/Format/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Damn/Format/Base.hs
@@ -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
diff --git a/src/Network/Damn/Format/Damn.hs b/src/Network/Damn/Format/Damn.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Damn/Format/Damn.hs
@@ -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'
diff --git a/src/Network/Damn/Format/Damn/Internal.hs b/src/Network/Damn/Format/Damn/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Damn/Format/Damn/Internal.hs
@@ -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) = " x <> "\" title=\"" <> y <> "\">"
+damnFormat' C_A = ""
+damnFormat' (Abbr x) = " x <> "\">"
+damnFormat' C_Abbr = ""
+damnFormat' (Acro x) = " x <> "\">"
+damnFormat' C_Acro = ""
+damnFormat' (Avatar x _) = ":icon" <> x <> ":"
+damnFormat' B = ""
+damnFormat' C_B = ""
+damnFormat' Bcode = ""
+damnFormat' C_Bcode = ""
+damnFormat' Br = "
"
+damnFormat' Code = ""
+damnFormat' C_Code = ""
+damnFormat' (Dev _ x) = ":dev" <> x <> ":"
+damnFormat' (Embed x y z) = ""
+damnFormat' (Emote x _ _ _ _) = x
+damnFormat' I = ""
+damnFormat' C_I = ""
+damnFormat' (Iframe x y z) = ""
+damnFormat' (Img x y z) = "![](\"")
x <> "\" height=\"" <> y <> "\" width=\"" <> z <> "\">"
+damnFormat' Li = ""
+damnFormat' C_Li = ""
+damnFormat' (Link x _) = x
+damnFormat' Ol = ""
+damnFormat' C_Ol = "
"
+damnFormat' P = ""
+damnFormat' C_P = "
"
+damnFormat' S = ""
+damnFormat' C_S = ""
+damnFormat' Sub = ""
+damnFormat' C_Sub = ""
+damnFormat' Sup = ""
+damnFormat' C_Sup = ""
+damnFormat' (Thumb x _ _ _ _ _) = ":thumb" <> x <> ":"
+damnFormat' U = ""
+damnFormat' C_U = ""
+damnFormat' Ul = ""
diff --git a/src/Network/Damn/Format/IRC.hs b/src/Network/Damn/Format/IRC.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Damn/Format/IRC.hs
@@ -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
diff --git a/src/Network/Damn/Tablumps.hs b/src/Network/Damn/Tablumps.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Damn/Tablumps.hs
@@ -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
diff --git a/src/Network/Damn/Tablumps/TH.hs b/src/Network/Damn/Tablumps/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Network/Damn/Tablumps/TH.hs
@@ -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
diff --git a/src/Text/Damn/Packet.hs b/src/Text/Damn/Packet.hs
deleted file mode 100644
--- a/src/Text/Damn/Packet.hs
+++ /dev/null
@@ -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
diff --git a/src/Text/Damn/Packet/Internal.hs b/src/Text/Damn/Packet/Internal.hs
deleted file mode 100644
--- a/src/Text/Damn/Packet/Internal.hs
+++ /dev/null
@@ -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 #-}
diff --git a/src/Text/Damn/Packet/Parser.hs b/src/Text/Damn/Packet/Parser.hs
deleted file mode 100644
--- a/src/Text/Damn/Packet/Parser.hs
+++ /dev/null
@@ -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 #-}
diff --git a/test/parse.hs b/test/parse.hs
new file mode 100644
--- /dev/null
+++ b/test/parse.hs
@@ -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
diff --git a/tests/render.hs b/tests/render.hs
deleted file mode 100644
--- a/tests/render.hs
+++ /dev/null
@@ -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)