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
data AbstractElement = AbstractElement (String, [ (String, String) ], Either String [ AbstractElement ]) deriving (Show)
showTime :: UTCTime -> String
showTime = (takeWhile (/='.')).(formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S")
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
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)
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)
genAck :: UserID -> MessageID -> AbstractElement
genAck userID msgID = AbstractElement ("ack", [], Right [ str "sender" (show userID), str "messageid" msgID ])
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 -> []
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 ]
genGetCertificate :: UserID -> MessageID -> UserID -> AbstractElement
genGetCertificate sender msgID for
= AbstractElement ("getcertificate", [], Right [ str "sender" (show sender), str "receiver" (show for), str "messageid" msgID ])
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) ]))
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)
]
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))
]
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 -> []
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)
]
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
)
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
genNack :: UserID -> MessageID -> Routed TargetContent ExternalSignature -> AbstractElement
genNack sender msgID routed
= AbstractElement ("nack", [], Right (others++[ message ]))
where
message = generateElementFromRouted "message" routed
others = [ str "sender" (show sender), str "messageid" msgID ]
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
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) ])
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
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)
generateDocument :: Element () -> Document()
generateDocument elm
= Document
(Prolog (Just (XMLDecl "1.0" (Just (EncodingDecl "utf-8")) Nothing)) [] Nothing [])
emptyST
(xmlEscape escaper elm)
[]
generateMessage' :: AbstractElement -> String
generateMessage' = encodeString . renderDocument . generateDocument . genXMLElem
generateMessage :: [MessageID] -> InternalMessage -> (String,[MessageID])
generateMessage ids msg = let (el,nids) = (generateElement ids msg) in (generateMessage' el,nids)