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 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)
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 }
pktSubpacket :: Packet -> Result Packet
pktSubpacket Packet { pktBody = b } =
case b of Nothing -> Failure "Parent packet has no body!"
Just pk -> parse pk
pktSubpacket' :: Packet -> Maybe Packet
pktSubpacket' p = case pktSubpacket p of
Success pk -> Just pk
_ -> Nothing
render :: Packet -> ByteString
render (Packet cmd prm args b) =
T.encodeUtf8 cmd
<> maybe "" ((" " <>) . T.encodeUtf8) prm
<> M.foldrWithKey
(\k v m -> "\n" <> T.encodeUtf8 k <> "=" <> T.encodeUtf8 v <> m) "" args
<> maybe "" ("\n\n" <>) b
parse :: ByteString -> Result Packet
parse str = if B.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 }
addBody l = l
parse' :: ByteString -> Maybe Packet
parse' s = case parse s of
Success pk -> Just pk
_ -> Nothing
headP :: Parser Packet
headP = do
cmd <- some (satisfy (not . isSpace))
prm <- option Nothing paramP
args <- argsP
return $ Packet (T.pack cmd) (fmap T.pack prm) args Nothing
where
paramP = fmap Just (char ' ' *> some (satisfy (not . isSpace))) <?> "parameter"
argsP = do
ch <- optional (char '\n')
case ch of
Just '\n' -> liftA3 M.insert
(T.pack <$> some (notChar '='))
(char '=' *> fmap T.pack (some (notChar '\n')) <* char '\n')
argsP
_ -> pure mempty
--e=event
--symbol=~
accountForLoginSpace :: ByteString -> ByteString
accountForLoginSpace s = if "login " `B.isPrefixOf` s
then 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)