module Text.Damn.Packet.Parser (
Packet(..),
parse, parse',
render,
pktSubpacket,
pktSubpacket',
pktSubpacketL
) where
import Prelude hiding (null)
import Control.Applicative ((<$>), (<*>), (*>), many)
import Control.Arrow (second)
import Data.Attoparsec.Text hiding (parse)
import Data.Char
import Data.Map (fromList, toList)
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 p = pktSubpacket' p
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
<> T.concat (map (\(k,v) -> "\n" <> k <> "=" <> v) (toList 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 (Left l) = Left l
parse' :: Text -> Maybe Packet
parse' s = case parse s of
Right pk -> Just pk
Left _ -> Nothing
headP :: Parser Packet
headP = do
cmd <- takeWhile1 (not . isSpace)
prm <- option Nothing paramP
args <- fromList <$> argsP
return $ Packet cmd prm args Nothing
where
paramP = fmap Just (char ' ' *> takeWhile1 (not . isSpace)) <?> "parameter"
argsP = many ((,) <$> (char '\n' >> takeTill (=='='))
<*> (char '=' >> takeTill (=='\n')))
<?> "arguments"
accountForLoginSpace :: Text -> Text
accountForLoginSpace s = if "login " `T.isPrefixOf` s
then T.replace "\n\n" "\n" s
else s