{-# LANGUAGE FlexibleContexts, RelaxedPolyRec #-} -- | Maintainer: Martin Wegner -- Date: 2007-06-15 module Network.AdHoc.Generator ( generateMessage , generateMessage' , genRootElem , genAnonymous , genObscure ) where import Codec.Binary.Base64 import Data.ByteString hiding (map,concat,head,tail,takeWhile) import qualified Data.ByteString as BS import Data.Char import Codec.Binary.UTF8.String (encodeString) import Data.Word import Data.Time import Network.GnuTLS hiding (CipherUnknown) import Network.GnuTLS.X509 import System.Locale (defaultTimeLocale) import Text.XML.HaXml.Escape import Text.XML.HaXml.Types import Text.XML.HaXml.XmlContent import Network.AdHoc.Channel import Network.AdHoc.Encryption import Network.AdHoc.Message import Network.AdHoc.MessageID import Network.AdHoc.Signature import Network.AdHoc.UserID import Network.AdHoc.XMLRenderer -- | This structure represents an abstract element tree to be used for generating the XML afterwards. -- It is designed for the special needs of the protocol schema and thus not as common as the HaXML -- structures. data AbstractElement = AbstractElement (String, [ (String, String) ], Either String [ AbstractElement ]) deriving (Show) -- -- Time helper function -- showTime :: UTCTime -> String showTime = (takeWhile (/='.')).(formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S") -- XXX: The takeWhile is only required in older versions of the time package -- -- Signature creation helper functions -- genStringToSign :: AbstractElement -> String genStringToSign (AbstractElement (name, _, children)) = case children of Left strn -> if name == "receiver" then "" else strn Right elems -> concat $ map genStringToSign elems genSignature :: AbstractElement -> PrivateKey -> ByteString genSignature elm key = let signed = (signData key DigMd5 (encodeString $ genStringToSign elm)) in case signed of Left err -> error $ "Internal GnuTLS error: " ++ show err Right bs -> bs -- -- Common helper functions for generating the tree -- genXMLCont :: Element () -> Content() genXMLCont elm = CElem elm () genXMLElem :: AbstractElement -> Element () genXMLElem (AbstractElement (name, attributes, children)) = Elem name [ mkAttr (fst a) (snd a) | a <- attributes ] content where content = case children of Left str -> [ CString False str () ] Right elems -> genXMLElems elems genXMLElems :: [ AbstractElement ] -> [ Content () ] genXMLElems = map (genXMLCont.genXMLElem) -- Helper functions for generating the internal abstract tree -- | Takes the given element and puts it into the root element of a message. genRootElem :: String -> AbstractElement -> Bool -> Maybe Delay -> TTL -> InternalSignature -> AbstractElement genRootElem name elm flood delay ttl sign = AbstractElement (name, attributes, Right [ elm ]) where delayAttr = case delay of Just d -> [ ("delay", (show d)) ] Nothing -> [] defaultAttributes = [ ("xmlns:xsi", "http://www.w3.org/2001/XMLSchema-instance"), ("xsi:schemaLocation", "http://www.ibr.cs.tu-bs.de/chat-message http://www.ibr.cs.tu-bs.de/courses/ss07/sep-cm/protocol/chat-message.xsd"), ("xmlns", "http://www.ibr.cs.tu-bs.de/chat-message"), ("flood", (map toLower $ show flood)), ("ttl", (show ttl)) ] signature = case sign of Left key -> Just (Signature MD5 (genSignature elm key)) Right (Just (rsign, _)) -> Just rsign _ -> Nothing signAttr = case signature of Just (Signature t s) -> [ ("signtype", show t), ("signature", encode $ unpack s) ] Nothing -> [] attributes = delayAttr++defaultAttributes++signAttr genRootElemDefault :: AbstractElement -> AbstractElement genRootElemDefault elm = genRootElem "chat-message" elm False Nothing 360 (Right Nothing) str :: String -> String -> AbstractElement str n v = AbstractElement (n, [], Left v) -- -- Generate internal abstract tree for the different nested messages -- -- ACK genAck :: UserID -> MessageID -> AbstractElement genAck userID msgID = AbstractElement ("ack", [], Right [ str "sender" (show userID), str "messageid" msgID ]) -- HELLO genHello :: MessageID -> [ UserID ] -> Int -> Maybe String -> AbstractElement genHello msgid senders version greeting = AbstractElement ("hello", [], Right (senders'++[ str "messageid" msgid, str "version" (show version) ]++lGreeting)) where senders' = map ((str "sender").show) senders lGreeting = case greeting of Just rgreeting -> [ str "greeting" rgreeting ] Nothing -> [] -- ROUTING genRouting :: MessageID -> [ (UserID, Int) ] -> AbstractElement genRouting msgid routes = AbstractElement ("routing", [], Right ([ str "messageid" msgid ]++destinations)) where destinations = [ AbstractElement ("destination", [], Right [ str "user" (show user), str "hops" (show hops) ]) | (user, hops) <- routes ] -- GETCERTIFICATE genGetCertificate :: UserID -> MessageID -> UserID -> AbstractElement genGetCertificate sender msgID for = AbstractElement ("getcertificate", [], Right [ str "sender" (show sender), str "receiver" (show for), str "messageid" msgID ]) -- CERTIFICATE genCertificate :: UserID -> MessageID -> [ UserID ] -> UserID -> [ Word8 ] -> AbstractElement genCertificate sender msgID receivers for certData = AbstractElement ("certificate", [], Right ([ sender' ]++receivers'++[ msgID' ]++[ certificate ])) where sender' = str "sender" (show sender) receivers' = map ((str "receiver").show) receivers msgID' = str "messageid" msgID certificate = AbstractElement ("certificate", [], Right ([ str "user" (show for), str "data" (encode certData) ])) -- GETKEY genGetKey :: UserID -> MessageID -> UserID -> ChannelName -> ChannelID -> AbstractElement genGetKey sender msgID receiver cname cid = AbstractElement ("getkey", [], Right elems) where elems = [ str "sender" (show sender), str "receiver" (show receiver), str "messageid" msgID, str "channel" (show cname), str "channelid" (show cid) ] -- KEY genKey :: UserID -> MessageID -> UserID -> ChannelName -> ChannelID -> CipherType -> ByteString -> AbstractElement genKey sender msgID receiver cname cid cipher key = AbstractElement ("key", [], Right elems) where cipher' = case cipher of CipherDES_CBC -> "DES-CBC" CipherNone -> "NONE" CipherUnknown str -> str elems = [ str "sender" (show sender), str "receiver" (show receiver), str "messageid" msgID, str "channel" (show cname), str "channelid" (show cid), str "cipher" cipher', str "key" (encode (unpack key)) ] -- OBSCURE -- | Generates the tree of 'AbstractElement's for an obscure message. genObscure :: UserID -> Maybe MessageID -> ByteString -> AbstractElement genObscure receiver msgID obscData = AbstractElement ("obscure", [], Right ([ str "receiver" (show receiver) ]++messageID++[ str "text" (encode $ unpack obscData) ])) where messageID = case msgID of Just rmsgID -> [ str "messageid" rmsgID ] Nothing -> [] -- attachment genAttachment :: Attachment -> AbstractElement genAttachment (Attachment filename appType fileData) = AbstractElement ("attachment", [], Right children) where children = [ str "filename" filename, str "applicationtype" appType, str "data" (encode $ BS.unpack fileData) ] genEncryptedAttachment :: EncryptedAttachment -> AbstractElement genEncryptedAttachment (EncryptedAttachment filename appType fileData) = AbstractElement ("attachment", ivAttr, Right children) where ivAttr = [ ("iv", encode (unpack64 [ encryptedIV filename ])) ] children = [ str "filename" (encode $ BS.unpack $ encryptedData filename), str "applicationtype" (encode $ BS.unpack $ encryptedData appType), str "data" (encode $ BS.unpack $ encryptedData fileData) ] -- MESSAGE text and attachment's genMessageContent :: MessageContent -> (AbstractElement, [ AbstractElement ]) genMessageContent cont = case cont of UnencryptedMessage txt attach -> (str "text" txt,map genAttachment attach) EncryptedMessage txt attach -> ( AbstractElement ("text" ,[ ("iv", encode $ unpack64 [encryptedIV txt]) ],Left (encode $ BS.unpack $ encryptedData txt)), map genEncryptedAttachment attach ) -- MESSAGE genMessage :: Maybe UserID -> Maybe MessageID -> [ UserID ] -> Maybe (ChannelName, ChannelID) -> MessageContent -> UTCTime -> AbstractElement genMessage sender msgID receivers chan cont time = AbstractElement ("message", [], Right (sender'++receivers'++messageID++others++channel++[ elemText ]++attachments)) where sender' = case sender of Just rsender -> [ str "sender" (show rsender) ] Nothing -> [] receivers' = map ((str "receiver").show) receivers messageID = case msgID of Just rmsgID -> [ str "messageid" rmsgID ] Nothing -> [] others = [ str "timestamp" (showTime time) ] channel = case chan of Nothing -> [] Just (cname, cid) -> [ str "channel" (show cname), str "channelid" (show cid) ] (elemText, attachments) = genMessageContent cont -- NACK genNack :: UserID -> MessageID -> Routed TargetContent ExternalSignature -> AbstractElement genNack sender msgID routed = AbstractElement ("nack", [], Right (others++[ message ])) where -- Nested message is named "message" instead of "chat-message": message = generateElementFromRouted "message" routed others = [ str "sender" (show sender), str "messageid" msgID ] -- CHANNEL genChannel :: UserID -> MessageID -> ChannelName -> ChannelID -> String -> [ UserID ] -> Bool -> AbstractElement genChannel sender msgID cname cid title members private = AbstractElement ("channel", [ ("closed", map toLower (show private)) ], Right (others++members')) where others = [ str "sender" (show sender), str "messageid" msgID, str "channel" (show cname), str "channelid" (show cid), str "description" title ] members' = map ((str "member").show) members -- JOIN/LEAVE genJoinLeave :: String -> UserID -> MessageID -> ChannelName -> ChannelID -> AbstractElement genJoinLeave what who msgID cname cid = AbstractElement (what, [], Right [ str "sender" (show who), str "messageid" msgID, str "channel" (show cname), str "channelid" (show cid) ]) -- MESSAGE to channel "Anonymous" -- | Generates the tree of 'AbstractElement's for an anonymous message. genAnonymous :: Bool -> Maybe UserID -> Maybe MessageID -> String -> [ Attachment ] -> UTCTime -> AbstractElement genAnonymous showChan sender msgID text attachments time = genMessage sender msgID [] channel (UnencryptedMessage text attachments) time where channel = if showChan then Just (anonymous,ChannelID "Anonymous" "Anonymous") else Nothing generateElementFromRouted :: ToInternalSignature sig => String -> Routed TargetContent sig -> AbstractElement generateElementFromRouted name (Routed ttl user messageID content sign) = genRootElem name elm False delay ttl (toInternal sign) where elm = case content of GetCertificate for -> genGetCertificate user messageID for Certificate receivers for certData -> genCertificate user messageID receivers for (unpack certData) GetKey receiver cname cid -> genGetKey user messageID receiver cname cid Key receiver cname cid cipher key -> genKey user messageID receiver cname cid cipher (rsaData key) Message receivers cname cid cont time _ -> genMessage (Just user) (Just messageID) receivers (Just (cname, cid)) cont time Nack routed -> genNack user messageID routed delay = case content of Message _ _ _ _ _ rdelay -> Just rdelay _ -> Nothing -- -- Generate internal abstract tree for messages represented by InternalMessage -- generateElementWithMsgID :: InternalMessage -> MessageID -> AbstractElement generateElementWithMsgID _ _ = undefined generateElement :: [MessageID] -> InternalMessage -> (AbstractElement,[MessageID]) generateElement ids (Ack userID messageID) = (genRootElemDefault $ genAck userID messageID, ids) generateElement ids (Hello receivers version greeting) = (genRootElemDefault $ genHello (head ids) receivers version greeting, tail ids) generateElement ids (Routing routes) = (genRootElemDefault $ genRouting (head ids) routes, tail ids) generateElement ids (Target routed) = (generateElementFromRouted "chat-message" routed, ids) generateElement ids (Flood (Routed ttl sender messageID content sign)) = (genRootElem "chat-message" elm True delay ttl sign, ids) where elm = case content of Channel cname cid title members private -> genChannel sender messageID cname cid title members private Join cname cid -> genJoinLeave "join" sender messageID cname cid Leave cname cid -> genJoinLeave "leave" sender messageID cname cid Anonymous text attachments time _ -> genAnonymous True (Just sender) (Just messageID) text attachments time delay = case content of Anonymous _ _ _ rdelay -> Just rdelay _ -> Nothing generateElement ids (Obscure (Routed ttl receiver messageID content ())) = (genRootElem "chat-message" (genObscure receiver (Just messageID) (rsaData content)) False Nothing ttl (Right Nothing), ids) -- -- Generate XML document tree for messages represented by InternalMessage -- generateDocument :: Element () -> Document() generateDocument elm = Document (Prolog (Just (XMLDecl "1.0" (Just (EncodingDecl "utf-8")) Nothing)) [] Nothing []) emptyST (xmlEscape escaper elm) [] -- | Takes an 'AbstractElement' and generates the XML document from it. generateMessage' :: AbstractElement -> String generateMessage' = encodeString . renderDocument . generateDocument . genXMLElem -- | Takes an 'InternalMessage' and generates the XML document from it. generateMessage :: [MessageID] -> InternalMessage -> (String,[MessageID]) generateMessage ids msg = let (el,nids) = (generateElement ids msg) in (generateMessage' el,nids)