Parser.hs

{-# 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       ((<$>), (<*>), (*>), 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

-- | 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 p = pktSubpacket' p
          setter pkt m = pkt { pktBody = render <$> m }

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

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