You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
49 lines
1.9 KiB
49 lines
1.9 KiB
14 years ago
|
{-# LANGUAGE FlexibleContexts #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
module Network.Xmpp.Errors where
|
||
|
|
|
||
|
|
import Control.Applicative ((<$>))
|
||
|
|
import Control.Monad(unless)
|
||
|
|
import Control.Monad.Error
|
||
|
|
import Control.Monad.Error.Class
|
||
|
|
import qualified Data.Text as Text
|
||
|
|
import Data.XML.Types
|
||
|
|
import Network.Xmpp.Types
|
||
|
|
import Network.Xmpp.Pickle
|
||
|
|
|
||
|
|
|
||
|
|
-- Finds unpickling problems. Not to be used for data validation
|
||
|
|
findStreamErrors :: Element -> StreamError
|
||
|
|
findStreamErrors (Element name attrs children)
|
||
|
|
| (nameLocalName name /= "stream")
|
||
|
|
= StreamNotStreamElement $ nameLocalName name
|
||
|
|
| (nameNamespace name /= Just "http://etherx.jabber.org/streams")
|
||
|
|
= StreamInvalidStreamNamespace $ nameNamespace name
|
||
|
|
| otherwise = checkchildren (flattenAttrs attrs)
|
||
|
|
where
|
||
|
|
checkchildren children =
|
||
|
|
let to' = lookup "to" children
|
||
|
|
ver' = lookup "version" children
|
||
|
|
xl = lookup xmlLang children
|
||
|
|
in case () of () | Just (Nothing :: Maybe Jid) == (safeRead <$> to')
|
||
|
|
-> StreamWrongTo to'
|
||
|
|
| Nothing == ver'
|
||
|
|
-> StreamWrongVersion Nothing
|
||
|
|
| Just (Nothing :: Maybe LangTag) ==
|
||
|
|
(safeRead <$> xl)
|
||
|
|
-> StreamWrongLangTag xl
|
||
|
|
| otherwise
|
||
|
|
-> StreamUnknownError
|
||
|
|
safeRead x = case reads $ Text.unpack x of
|
||
|
|
[] -> Nothing
|
||
|
|
[(y,_),_] -> Just y
|
||
|
|
|
||
|
|
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
|
||
|
|
flattenAttrs attrs = map (\(name, content) ->
|
||
|
|
( name
|
||
|
|
, Text.concat $ map uncontentify content)
|
||
|
|
)
|
||
|
|
attrs
|
||
|
|
where
|
||
|
|
uncontentify (ContentText t) = t
|
||
|
|
uncontentify _ = ""
|