reformatted, partially documented and made all functions except xmppSASL

where-local

src/Network/XMPP/SASL.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings  #-}
+
 module Network.XMPP.SASL where
 
 import           Control.Applicative
@@ -32,147 +33,146 @@ import           Network.XMPP.Pickle
 
 import qualified System.Random as Random
 
-
-saslInitE :: Text -> Element
-saslInitE mechanism =
-    Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
-        [ ("mechanism", [ContentText  mechanism]) ]
-        []
-
-saslResponseE :: Text -> Element
-saslResponseE resp =
-    Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
-    []
-    [NodeContent $ ContentText resp]
-
-saslResponse2E :: Element
-saslResponse2E =
-    Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
-    []
-    []
-
 data AuthError = AuthXmlError
-               | AuthMechanismError [Text]
+               | AuthMechanismError [Text] -- ^ Wraps mechanisms offered
                | AuthChallengeError
-               | AuthStreamError StreamError
-               | AuthConnectionError
+               | AuthStreamError StreamError -- ^ Stream error on stream restart
+               | AuthConnectionError -- ^ No host name set in state
+               | AuthError -- General instance used for the Error instance
                  deriving Show
 
 instance Error AuthError where
-    noMsg = AuthXmlError
-
-xmppSASL:: Text -> Text -> XMPPConMonad (Either AuthError Text)
+    noMsg = AuthError
+
+-- Uses the DIGEST-MD5 method (if available) to authenticate. Updates the
+-- sUsername XMPPConMonad field with a `Just' value and restarts the stream upon
+-- success. This computation wraps an ErrorT computation, which means that
+-- catchError can be used to catch any errors.
+xmppSASL :: Text -- ^ User name
+         -> Text -- ^ Password
+         -> XMPPConMonad (Either AuthError ())
 xmppSASL uname passwd = runErrorT $ do
     realm <- gets sHostname
     case realm of
         Just realm' -> do
-          ErrorT $ xmppStartSASL realm' uname passwd
+            ErrorT $ xmppStartSASL realm'
             modify (\s -> s{sUsername = Just uname})
-          return uname
         Nothing -> throwError AuthConnectionError
-
-xmppStartSASL  :: Text
-               -> Text
-               -> Text
+  where
+    xmppStartSASL :: Text -- ^ SASL realm
                   -> XMPPConMonad (Either AuthError ())
-xmppStartSASL realm username passwd = runErrorT $ do
+    xmppStartSASL realm = runErrorT $ do
         mechanisms <- gets $ saslMechanisms . sFeatures
-  unless ("DIGEST-MD5" `elem` mechanisms)
-      . throwError $ AuthMechanismError mechanisms
-  lift . pushN $ saslInitE "DIGEST-MD5"
-  challenge' <-  lift $ B64.decode . Text.encodeUtf8
-                         <$> pullPickle challengePickle
+        unless ("DIGEST-MD5" `elem` mechanisms) .
+            throwError $ AuthMechanismError mechanisms
+        -- Push element and receive the challenge (in XMPPConMonad).
+        _ <- lift . pushN $ saslInitE "DIGEST-MD5" -- TODO: Check boolean?
+        challenge' <- lift $ B64.decode . Text.encodeUtf8 <$>
+            pullPickle challengePickle
         challenge <- case challenge' of
             Left _e -> throwError AuthChallengeError
             Right r -> return r
         pairs <- case toPairs challenge of
             Left _ -> throwError AuthChallengeError
             Right p -> return p
-  g <- liftIO $ Random.newStdGen
-  lift . pushN . saslResponseE $ createResponse g realm username passwd pairs
+        g <- liftIO Random.newStdGen
+        _ <- lift . pushN . -- TODO: Check boolean?
+            saslResponseE $ createResponse g realm pairs
         challenge2 <- lift $ pullPickle (xpEither failurePickle challengePickle)
         case challenge2 of
-    Left _x -> throwError $ AuthXmlError
+            Left _x -> throwError AuthXmlError
             Right _ -> return ()
         lift $ pushN saslResponse2E
         e <- lift pullElement
         case e of
-      Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] -> return ()
+            Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] ->
+                return ()
             _ -> throwError AuthXmlError -- TODO: investigate
+        -- The SASL authentication has succeeded; the stream is restarted.
         _ <- ErrorT $ left AuthStreamError <$> xmppRestartStream
         return ()
-
-createResponse :: Random.RandomGen g
+    -- The <auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/> element.
+    saslInitE :: Text -> Element
+    saslInitE mechanism =
+        Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
+            [("mechanism", [ContentText mechanism])]
+            []
+    -- SASL response with text payload.
+    saslResponseE :: Text -> Element
+    saslResponseE resp =
+        Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
+        []
+        [NodeContent $ ContentText resp]
+    -- SASL response without payload.
+    saslResponse2E :: Element
+    saslResponse2E =
+        Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
+        []
+        []
+    -- Parses the incoming SASL data to a mapped list of pairs.
+    toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)]
+    toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
+        AP.skipSpace
+        name <- AP.takeWhile1 (/= '=')
+        _ <- AP.char '='
+        quote <- ((AP.char '"' >> return True) `mplus` return False)
+        content <- AP.takeWhile1 (AP.notInClass [',', '"'])
+        when quote . void $ AP.char '"'
+        return (name, content)
+    -- Produce the response to the challenge.
+    createResponse :: Random.RandomGen g
                    => g
                    -> Text
+                   -> [(BS8.ByteString, BS8.ByteString)] -- Pairs
                    -> Text
-               -> Text
-               -> [(BS8.ByteString, BS8.ByteString)]
-               -> Text
-createResponse g hostname username passwd' pairs = let
+    createResponse g hostname pairs = let
         Just qop   = L.lookup "qop" pairs
         Just nonce = L.lookup "nonce" pairs
-  uname      = Text.encodeUtf8 username
-  passwd     = Text.encodeUtf8 passwd'
-  -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7)
-  -- compatibility.
+        uname_     = Text.encodeUtf8 uname
+        passwd_    = Text.encodeUtf8 passwd
+        -- Using Int instead of Word8 for random 1.0.0.0 (GHC 7) compatibility.
         cnonce     = BS.tail . BS.init .
-           B64.encode . BS.pack . map toWord8 . take 8 $ Random.randoms g
+                         B64.encode . BS.pack . map toWord8 .
+                         take 8 $ Random.randoms g
         nc         = "00000001"
-  digestURI  = ("xmpp/" `BS.append` (Text.encodeUtf8 hostname))
+        digestURI  = "xmpp/" `BS.append` Text.encodeUtf8 hostname
         digest     = md5Digest
-             uname
+            uname_
             (lookup "realm" pairs)
-             passwd
+            passwd_
             digestURI
             nc
             qop
             nonce
             cnonce
-  response = BS.intercalate"," . map (BS.intercalate "=") $
-   [  ["username"  , quote uname     ]]
-   ++ case L.lookup "realm" pairs of
+        response = BS.intercalate "," . map (BS.intercalate "=") $
+            [["username", quote uname_]] ++
+                case L.lookup "realm" pairs of
                     Just realm -> [["realm" , quote realm ]]
-       Nothing -> []
-   ++
+                    Nothing -> [] ++
                         [ ["nonce"     , quote nonce    ]
                         , ["cnonce"    , quote cnonce   ]
                         , ["nc"        ,       nc       ]
                         , ["qop"       ,       qop      ]
-   ,  ["digest-uri", quote digestURI ]
+                        , ["digest-uri", quote digestURI]
                         , ["response"  ,       digest   ]
                         , ["charset"   ,       "utf-8"  ]
                         ]
         in Text.decodeUtf8 $ B64.encode response
-  where
+    quote :: BS8.ByteString -> BS8.ByteString
     quote x = BS.concat ["\"",x,"\""]
-    toWord8 x = fromIntegral (x :: Int) :: Word8
-
-toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)]
-toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
-  AP.skipSpace
-  name <- AP.takeWhile1 (/= '=')
-  _ <- AP.char '='
-  quote <- ((AP.char '"' >> return True) `mplus` return False)
-  content <- AP.takeWhile1 (AP.notInClass ",\"" )
-  when quote . void $ AP.char '"'
-  return (name,content)
-
-hash :: [BS8.ByteString] -> BS8.ByteString
-hash = BS8.pack . show
-       . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
-
-hashRaw :: [BS8.ByteString] -> BS8.ByteString
-hashRaw = toStrict . Binary.encode
+    toWord8 :: Int -> Word8
+    toWord8 x = fromIntegral x :: Word8
+    hash :: [BS8.ByteString] -> BS8.ByteString
+    hash = BS8.pack . show
            . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
-
-
-toStrict :: BL.ByteString -> BS8.ByteString
-toStrict = BS.concat . BL.toChunks
-
--- TODO: this only handles MD5-sess
-
-md5Digest :: BS8.ByteString
+    hashRaw :: [BS8.ByteString] -> BS8.ByteString
+    hashRaw = toStrict . Binary.encode .
+        (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
+    toStrict :: BL.ByteString -> BS8.ByteString
+    toStrict = BS.concat . BL.toChunks
+    -- TODO: this only handles MD5-sess
+    md5Digest :: BS8.ByteString
               -> Maybe BS8.ByteString
               -> BS8.ByteString
               -> BS8.ByteString
@@ -181,17 +181,18 @@ md5Digest :: BS8.ByteString
               -> BS8.ByteString
               -> BS8.ByteString
               -> BS8.ByteString
-md5Digest uname realm password digestURI nc qop nonce cnonce=
-  let ha1 = hash [hashRaw [uname, maybe "" id realm, password], nonce, cnonce]
+    md5Digest uname realm password digestURI nc qop nonce cnonce =
+      let ha1 = hash [ hashRaw [uname, maybe "" id realm, password]
+                     , nonce
+                     , cnonce
+                     ]
           ha2 = hash ["AUTHENTICATE", digestURI]
-  in hash [ha1,nonce, nc, cnonce,qop,ha2]
-
--- Pickling
-failurePickle :: PU [Node] (SaslFailure)
-failurePickle = xpWrap (\(txt,(failure,_,_))
-                           -> SaslFailure failure txt)
-                       (\(SaslFailure failure txt)
-                           -> (txt,(failure,(),())))
+      in hash [ha1, nonce, nc, cnonce, qop, ha2]
+    -- Failure element pickler.
+    failurePickle :: PU [Node] SaslFailure
+    failurePickle = xpWrap
+        (\(txt, (failure, _, _)) -> SaslFailure failure txt)
+        (\(SaslFailure failure txt) -> (txt,(failure,(),())))
         (xpElemNodes
             "{urn:ietf:params:xml:ns:xmpp-sasl}failure"
             (xp2Tuple
@@ -204,9 +205,7 @@ failurePickle = xpWrap (\(txt,(failure,_,_))
                  xpPrim
                  (xpUnit)
                  (xpUnit))))
-
-
-challengePickle :: PU [Node] Text.Text
-challengePickle =  xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
+    -- Challenge element pickler.
+    challengePickle :: PU [Node] Text.Text
+    challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
                           (xpIsolate $ xpContent xpId)
-