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.Attoparsec.Text hiding (parse)
import Data.Char
import qualified Data.Map as M
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Text.Damn.Packet.Internal
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 -> Either String Packet
pktSubpacket Packet { pktBody = b } =
case b of Nothing -> Left "Parent packet has no body!"
Just pk -> parse pk
pktSubpacket' :: Packet -> Maybe Packet
pktSubpacket' p = case pktSubpacket p of
Left _ -> Nothing
Right pk -> Just pk
render :: Packet -> Text
render (Packet cmd prm args b) =
cmd
<> maybe "" (" " <>) prm
<> M.foldrWithKey (\k v m -> "\n" <> k <> "=" <> v <> m) "" args
<> maybe "" ("\n\n" <>) b
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 l@Left{..} = l
parse' :: Text -> Maybe Packet
parse' s = case parse s of
Left _ -> Nothing
Right pk -> Just pk
headP :: Parser Packet
headP = do
cmd <- takeWhile1 (not . isSpace)
prm <- option Nothing paramP
args <- argsP
return $ Packet cmd prm args Nothing
where
paramP = fmap Just (char ' ' *> takeWhile1 (not . isSpace)) <?> "parameter"
argsP = do
ch <- peekChar
case ch of
Just '\n' -> liftA3 M.insert
(char '\n' >> takeTill (=='='))
(char '=' >> takeTill (=='\n'))
argsP
_ -> pure mempty
--e=event
--symbol=~
accountForLoginSpace :: Text -> Text
accountForLoginSpace s = if "login " `T.isPrefixOf` s
then T.replace "\n\n" "\n" s
else s