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           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)

-- | 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 -> Result Packet
pktSubpacket Packet { pktBody = b } =
        case b of Nothing -> Failure "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
                      Success 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 -> 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
{-# INLINE render #-}

-- | Parse some text, providing a packet or the reason for parse failure.
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 some text, discarding any failure message.
parse' :: ByteString -> Maybe Packet
parse' s = case parse s of
               Success pk -> Just pk
               _ -> Nothing
{-# INLINE parse' #-}

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')))
                                    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 :: 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)
{-# INLINE accountForLoginSpace #-}