#define PATTERNS (__GLASGOW_HASKELL__ >= 710)
#if PATTERNS
#endif
module Network.Damn (
Message(..),
SubMessage(..),
MessageBody,
bodyBytes, Formatter, bodyWithFormat,
toBody, toBodyText,
subMessage,
#if PATTERNS
pattern SubM,
#endif
parseMessage,
messageP,
render,
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)
#if __GLASGOW_HASKELL__ <= 708
import Data.Foldable (foldMap)
#endif
data Message = Message
{ messageName :: ByteString
, messageArgument :: Maybe ByteString
, messageAttrs :: [(ByteString, Text)]
, messageBody :: Maybe MessageBody
} deriving (Eq, Show)
data SubMessage = SubMessage
{ subMessageName :: Maybe ByteString
, subMessageArgument :: Maybe ByteString
, subMessageAttrs :: [(ByteString, Text)]
, subMessageBody :: Maybe MessageBody
} deriving (Eq, Show)
data MessageBody = MessageBody
{
bodyBytes :: ByteString
, subMessage :: forall m. MonadFail m => m SubMessage
}
instance IsString MessageBody where
fromString = toBody . fromString
instance Show MessageBody where
show (MessageBody b _) = show b
instance Eq MessageBody where
MessageBody b _ == MessageBody b1 _ = b == b1
#if PATTERNS
pattern SubM :: SubMessage -> Maybe MessageBody
pattern SubM pkt <- ((>>= subMessage) -> Just pkt)
#endif
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, htmlDecode $ 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
toBody :: ByteString -> MessageBody
toBody x = MessageBody x
(either Control.Monad.fail return $ parseOnly subMessageP (x <> "\0"))
toBodyText :: Text -> MessageBody
toBodyText = toBody . textToBytes
parseMessage :: ByteString -> Either String Message
parseMessage = parseOnly messageP
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 _ = ""