module Network.IRC.DCC.Internal where
import Control.Applicative ((<|>))
import Control.Monad (when)
import Data.Attoparsec.ByteString.Char8 (Parser, choice, decimal,
endOfInput, parseOnly,
space, takeByteString,
takeWhile1)
import Data.Binary (byteSwap32)
import Data.ByteString.Char8 (ByteString, pack, unwords)
import qualified Data.ByteString.UTF8 as UTF8 (fromString,
toString)
import Data.IP (IPv4, fromHostAddress,
toHostAddress)
import Data.Monoid ((<>))
import Data.Word (Word64)
import Network.IRC.CTCP (CTCPByteString, decodeCTCP,
encodeCTCP)
import Network.Socket.ByteString.Extended (PortNumber)
import qualified Path as P (Abs, File, Path, Rel,
filename, fromAbsFile,
fromRelFile,
parseAbsFile,
parseRelFile)
import Prelude hiding (abs, unwords)
class CtcpCommand a where
toCtcp :: a -> CTCPByteString
fromCtcp :: CTCPByteString -> Either String a
parseCtcp :: Parser a -> CTCPByteString -> Either String a
parseCtcp p = parseOnly (p <* endOfInput) . decodeCTCP
data DccChat
= Chat !IPv4 !PortNumber
| ChatWhiteboard !IPv4 !PortNumber
deriving (Eq, Show)
instance CtcpCommand DccChat where
toCtcp (Chat ip port) = encodeCTCP $ unwords
[ "DCC CHAT chat"
, socketToBS (ip, port)
]
toCtcp (ChatWhiteboard ip port) = encodeCTCP $ unwords
[ "DCC CHAT wboard"
, socketToBS (ip, port)
]
fromCtcp = parseCtcp $
Chat
<$> ("DCC CHAT chat" *> spaced ipBigEndian)
<*> spaced tcpPort
<|> ChatWhiteboard
<$> ("DCC CHAT wboard" *> spaced ipBigEndian)
<*> spaced tcpPort
data DccClose
= Close
deriving (Eq, Show)
instance CtcpCommand DccClose where
toCtcp Close = encodeCTCP "DCC CLOSE"
fromCtcp = parseCtcp $ Close <$ "DCC CLOSE"
data DccSend
= Send !Path !IPv4 !PortNumber !(Maybe FileOffset)
| SendReverseServer !Path !IPv4 !FileOffset !Token
deriving (Eq, Show)
instance CtcpCommand DccSend where
toCtcp (Send name ip port size) = encodeCTCP $ unwords
[ "DCC SEND"
, pathToBS name
, ipToBigEndianBS ip
, tcpPortToBS port ]
<> maybe "" ((" " <>) . fileOffsetToBS) size
toCtcp (SendReverseServer name ip size t) = encodeCTCP $ unwords
[ "DCC SEND"
, pathToBS name
, ipToBigEndianBS ip
, "0"
, fileOffsetToBS size
, tokenToBS t
]
fromCtcp = parseCtcp $
Send
<$> ("DCC SEND" *> spaced path)
<*> spaced ipBigEndian
<*> spaced tcpPort
<*> (Just <$> spaced fileOffset
<|> return Nothing)
<|> SendReverseServer
<$> ("DCC SEND" *> spaced path)
<*> spaced ipBigEndian
<*> (spaced "0" *> spaced fileOffset)
<*> spaced token
data DccResume
= Resume !Path !PortNumber !FileOffset
| ResumeReverse !Path !FileOffset !Token
deriving (Eq, Show)
instance CtcpCommand DccResume where
toCtcp (Resume name port pos) = encodeCTCP $ unwords
[ "DCC RESUME"
, pathToBS name
, tcpPortToBS port
, fileOffsetToBS pos
]
toCtcp (ResumeReverse name pos t) = encodeCTCP $ unwords
[ "DCC RESUME"
, pathToBS name
, "0"
, fileOffsetToBS pos
, tokenToBS t
]
fromCtcp = parseCtcp $
Resume
<$> ("DCC RESUME" *> spaced path)
<*> spaced tcpPort
<*> spaced fileOffset
<|> ResumeReverse
<$> ("DCC RESUME" *> spaced path)
<*> (spaced "0" *> spaced fileOffset)
<*> spaced token
data DccAccept
= Accept !Path !PortNumber !FileOffset
| AcceptReverse !Path !FileOffset !Token
deriving (Eq, Show)
acceptedPosition :: DccAccept -> FileOffset
acceptedPosition (Accept _ _ pos) = pos
acceptedPosition (AcceptReverse _ pos _) = pos
instance CtcpCommand DccAccept where
toCtcp (Accept name port pos) = encodeCTCP $ unwords
[ "DCC ACCEPT"
, pathToBS name
, tcpPortToBS port
, fileOffsetToBS pos
]
toCtcp (AcceptReverse name pos t) = encodeCTCP $ unwords
[ "DCC ACCEPT"
, pathToBS name
, "0"
, fileOffsetToBS pos
, tokenToBS t
]
fromCtcp = parseCtcp $
Accept
<$> ("DCC ACCEPT" *> spaced path)
<*> spaced tcpPort
<*> spaced fileOffset
<|> AcceptReverse
<$> ("DCC ACCEPT" *> spaced path)
<*> (spaced "0" *> spaced fileOffset)
<*> spaced token
data DccSendReverseClient
= SendReverseClient !Path !IPv4 !PortNumber !FileOffset !Token
deriving (Eq, Show)
instance CtcpCommand DccSendReverseClient where
toCtcp (SendReverseClient name ip port size t) = encodeCTCP $ unwords
[ "DCC SEND"
, pathToBS name
, ipToBigEndianBS ip
, tcpPortToBS port
, fileOffsetToBS size
, tokenToBS t
]
fromCtcp = parseCtcp $
SendReverseClient
<$> ("DCC SEND" *> spaced path)
<*> spaced ipBigEndian
<*> spaced tcpPort
<*> spaced fileOffset
<*> spaced token
data PathType
= Simple
| Quoted
deriving (Eq, Show)
data Path = Rel PathType (P.Path P.Rel P.File)
| Abs PathType (P.Path P.Abs P.File)
deriving (Eq, Show)
fromPath :: Path -> P.Path P.Rel P.File
fromPath (Rel _ name) = name
fromPath (Abs _ name) = P.filename name
path :: Parser Path
path = choice [ quoted >>= parseRelOrAbs Quoted
, simple >>= parseRelOrAbs Simple ]
where
quoted = UTF8.toString <$> ("\"" *> takeWhile1 (/= '"') <* "\"")
simple = UTF8.toString <$> takeWhile1 (/= ' ')
parseRelOrAbs ty n =
maybe (fail "Could not parse file name.") return
( Rel ty <$> P.parseRelFile n
<|> Abs ty <$> P.parseAbsFile n )
pathToBS :: Path -> ByteString
pathToBS (Rel ty name) = wrap ty . UTF8.fromString . P.fromRelFile $ name
pathToBS (Abs ty name) = wrap ty . UTF8.fromString . P.fromAbsFile $ name
wrap :: PathType -> ByteString -> ByteString
wrap Simple p = p
wrap Quoted p = "\"" <> p <> "\""
newtype FileOffset = FileOffset { toWord :: Word64 }
deriving (Eq, Ord, Num, Integral, Enum, Real, Bounded)
instance Show FileOffset where
show = show . toWord
fileOffset :: Parser FileOffset
fileOffset = FileOffset <$> decimal
fileOffsetToBS :: FileOffset -> ByteString
fileOffsetToBS = pack . show . toWord
newtype Token = Token ByteString
deriving (Eq, Show)
token :: Parser Token
token = Token <$> takeByteString
tokenToBS :: Token -> ByteString
tokenToBS (Token t) = t
socket :: Parser (IPv4, PortNumber)
socket = (,) <$> ipBigEndian <* space <*> tcpPort
socketToBS :: (IPv4, PortNumber) -> ByteString
socketToBS (i, p) = ipToBigEndianBS i <> " " <> tcpPortToBS p
ipBigEndian :: Parser IPv4
ipBigEndian = fromBigEndianIp <$> decimalInRange (0, 4294967295)
ipToBigEndianBS :: IPv4 -> ByteString
ipToBigEndianBS = pack . show . toBigEndianIp
fromBigEndianIp :: Integer -> IPv4
fromBigEndianIp = fromHostAddress . byteSwap32 . fromIntegral
toBigEndianIp :: IPv4 -> Integer
toBigEndianIp = fromIntegral . byteSwap32 . toHostAddress
tcpPort :: Parser PortNumber
tcpPort = fromInteger <$> decimalInRange (1, 65535)
tcpPortToBS :: PortNumber -> ByteString
tcpPortToBS = pack . show
decimalInRange :: (Integer, Integer) -> Parser Integer
decimalInRange (lower, upper) = do
num <- decimal
when (num < lower || num > upper) $
fail ( "Failed to parse " ++ show num ++ ", not in range ["
++ show lower ++ ", " ++ show upper ++ "]." )
return num
spaced :: Parser a -> Parser a
spaced = (space *>)