Parser.hs

{-# 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 #-}