pontarius-xmpp/source/Network/Xmpp/Sasl/Common.hs

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Xmpp.Sasl.Common where

import           Control.Applicative ((<$>))
import           Control.Monad.Error
import qualified Data.Attoparsec.ByteString.Char8 as AP
import           Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import           Data.Maybe (maybeToList)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Word (Word8)
import           Data.XML.Pickle
import           Data.XML.Types
import           Network.Xmpp.Marshal
import           Network.Xmpp.Sasl.StringPrep
import           Network.Xmpp.Sasl.Types
import           Network.Xmpp.Stream
import           Network.Xmpp.Types

import qualified System.Random as Random

import           Control.Monad.State.Strict

--makeNonce :: ErrorT AuthFailure (StateT StreamState IO) BS.ByteString
makeNonce :: IO BS.ByteString
makeNonce = do
    g <- liftIO Random.newStdGen
    return $ B64.encode . BS.pack . map toWord8 . take 15 $ Random.randoms g
  where
    toWord8 :: Int -> Word8
    toWord8 x = fromIntegral x :: Word8

-- The <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element, with an
-- optional round-trip value.
saslInitE :: Text.Text -> Maybe Text.Text -> Element
saslInitE mechanism rt =
    Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
        [("mechanism", [ContentText mechanism])]
        (maybeToList $ NodeContent . ContentText <$> rt)

-- SASL response with text payload.
saslResponseE :: Maybe Text.Text -> Element
saslResponseE resp =
    Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
    []
    (maybeToList $ NodeContent . ContentText <$> resp)

-- The <success xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element.
xpSuccess :: PU [Node] (Maybe Text.Text)
xpSuccess = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}success"
    (xpOption $ xpContent xpId)

-- Parses the incoming SASL data to a mapped list of pairs.
pairs :: BS.ByteString -> Either String Pairs
pairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
    AP.skipSpace
    name <- AP.takeWhile1 (/= '=')
    _ <- AP.char '='
    qt <- ((AP.char '"' >> return True) `mplus` return False)
    content <- AP.takeWhile1 (AP.notInClass [',', '"'])
    when qt . void $ AP.char '"'
    return (name, content)

-- Failure element pickler.
xpFailure :: PU [Node] SaslFailure
xpFailure = xpWrap
    (\(txt, (failure, _, _)) -> SaslFailure failure txt)
    (\(SaslFailure failure txt) -> (txt,(failure,(),())))
    (xpElemNodes
        "{urn:ietf:params:xml:ns:xmpp-sasl}failure"
        (xp2Tuple
             (xpOption $ xpElem
                  "{urn:ietf:params:xml:ns:xmpp-sasl}text"
                  xpLangTag
                  (xpContent xpId))
        (xpElemByNamespace
             "urn:ietf:params:xml:ns:xmpp-sasl"
             xpSaslError
             (xpUnit)
             (xpUnit))))

xpSaslError :: PU Text.Text SaslError
xpSaslError = ("xpSaslError", "") <?>
        xpIso saslErrorFromText saslErrorToText
  where
    saslErrorToText SaslAborted              = "aborted"
    saslErrorToText SaslAccountDisabled      = "account-disabled"
    saslErrorToText SaslCredentialsExpired   = "credentials-expired"
    saslErrorToText SaslEncryptionRequired   = "encryption-required"
    saslErrorToText SaslIncorrectEncoding    = "incorrect-encoding"
    saslErrorToText SaslInvalidAuthzid       = "invalid-authzid"
    saslErrorToText SaslInvalidMechanism     = "invalid-mechanism"
    saslErrorToText SaslMalformedRequest     = "malformed-request"
    saslErrorToText SaslMechanismTooWeak     = "mechanism-too-weak"
    saslErrorToText SaslNotAuthorized        = "not-authorized"
    saslErrorToText SaslTemporaryAuthFailure = "temporary-auth-failure"
    saslErrorFromText "aborted" = SaslAborted
    saslErrorFromText "account-disabled" = SaslAccountDisabled
    saslErrorFromText "credentials-expired" = SaslCredentialsExpired
    saslErrorFromText "encryption-required" = SaslEncryptionRequired
    saslErrorFromText "incorrect-encoding" = SaslIncorrectEncoding
    saslErrorFromText "invalid-authzid" = SaslInvalidAuthzid
    saslErrorFromText "invalid-mechanism" = SaslInvalidMechanism
    saslErrorFromText "malformed-request" = SaslMalformedRequest
    saslErrorFromText "mechanism-too-weak" = SaslMechanismTooWeak
    saslErrorFromText "not-authorized" = SaslNotAuthorized
    saslErrorFromText "temporary-auth-failure" = SaslTemporaryAuthFailure
    saslErrorFromText _ = SaslNotAuthorized

-- Challenge element pickler.
xpChallenge :: PU [Node] (Maybe Text.Text)
xpChallenge = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
                      (xpOption $ xpContent xpId)

-- | Pickler for SaslElement.
xpSaslElement :: PU [Node] SaslElement
xpSaslElement = xpAlt saslSel
                [ xpWrap SaslSuccess   (\(SaslSuccess x)   -> x) xpSuccess
                , xpWrap SaslChallenge (\(SaslChallenge c) -> c) xpChallenge
                ]
  where
    saslSel (SaslSuccess   _) = 0
    saslSel (SaslChallenge _) = 1

-- | Add quotationmarks around a byte string.
quote :: BS.ByteString -> BS.ByteString
quote x = BS.concat ["\"",x,"\""]

saslInit :: Text.Text -> Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) ()
saslInit mechanism payload = do
    r <- lift . pushElement . saslInitE mechanism $
        Text.decodeUtf8 . B64.encode <$> payload
    case r of
        Right () -> return ()
        Left e  -> throwError $ AuthStreamFailure e

-- | Pull the next element.
pullSaslElement :: ErrorT AuthFailure (StateT StreamState IO) SaslElement
pullSaslElement = do
    mbse <- lift $ pullUnpickle (xpEither xpFailure xpSaslElement)
    case mbse of
        Left e -> throwError $ AuthStreamFailure e
        Right (Left e) -> throwError $ AuthSaslFailure e
        Right (Right r) -> return r

-- | Pull the next element, checking that it is a challenge.
pullChallenge :: ErrorT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString)
pullChallenge = do
  e <- pullSaslElement
  case e of
      SaslChallenge Nothing -> return Nothing
      SaslChallenge (Just scb64)
          | Right sc <- B64.decode . Text.encodeUtf8 $ scb64
             -> return $ Just sc
      _ -> throwError AuthOtherFailure -- TODO: Log

-- | Extract value from Just, failing with AuthOtherFailure on Nothing.
saslFromJust :: Maybe a -> ErrorT AuthFailure (StateT StreamState IO) a
saslFromJust Nothing = throwError $ AuthOtherFailure -- TODO: Log
saslFromJust (Just d) = return d

-- | Pull the next element and check that it is success.
pullSuccess :: ErrorT AuthFailure (StateT StreamState IO) (Maybe Text.Text)
pullSuccess = do
    e <- pullSaslElement
    case e of
        SaslSuccess x -> return x
        _ -> throwError $ AuthOtherFailure -- TODO: Log

-- | Pull the next element. When it's success, return it's payload.
-- If it's a challenge, send an empty response and pull success.
pullFinalMessage :: ErrorT AuthFailure (StateT StreamState IO) (Maybe BS.ByteString)
pullFinalMessage = do
    challenge2 <- pullSaslElement
    case challenge2 of
        SaslSuccess   x -> decode x
        SaslChallenge x -> do
            _b <- respond Nothing
            _s <- pullSuccess
            decode x
  where
    decode Nothing  = return Nothing
    decode (Just d) = case B64.decode $ Text.encodeUtf8 d of
        Left _e -> throwError $ AuthOtherFailure -- TODO: Log
        Right x -> return $ Just x

-- | Extract p=q pairs from a challenge.
toPairs :: BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) Pairs
toPairs ctext = case pairs ctext of
    Left _e -> throwError AuthOtherFailure -- TODO: Log
    Right r -> return r

-- | Send a SASL response element. The content will be base64-encoded.
respond :: Maybe BS.ByteString -> ErrorT AuthFailure (StateT StreamState IO) ()
respond m = do
    r <- lift . pushElement . saslResponseE . fmap (Text.decodeUtf8 . B64.encode) $ m
    case r of
        Left e -> throwError $ AuthStreamFailure e
        Right () -> return ()

-- | Run the appropriate stringprep profiles on the credentials.
-- May fail with 'AuthStringPrepFailure'
prepCredentials :: Text.Text -> Maybe Text.Text -> Text.Text
                -> ErrorT AuthFailure (StateT StreamState IO) (Text.Text, Maybe Text.Text, Text.Text)
prepCredentials authcid authzid password = case credentials of
    Nothing -> throwError $ AuthIllegalCredentials
    Just creds -> return creds
  where
    credentials = do
        ac <- normalizeUsername authcid
        az <- case authzid of
          Nothing -> Just Nothing
          Just az' -> Just <$> normalizeUsername az'
        pw <- normalizePassword password
        return (ac, az, pw)

-- | Bit-wise xor of byte strings
xorBS :: BS.ByteString -> BS.ByteString -> BS.ByteString
xorBS x y = BS.pack $ BS.zipWith xor x y

-- | Join byte strings with ","
merge :: [BS.ByteString] -> BS.ByteString
merge = BS.intercalate ","

-- | Infix concatenation of byte strings
(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString
(+++) = BS.append