/usr/share/doc/libghc-network-protocol-xmpp-doc/html/src/Network-Protocol-XMPP-Client-Authentication.html is in libghc-network-protocol-xmpp-doc 0.4.6-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | <?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->
<title>lib/Network/Protocol/XMPP/Client/Authentication.hs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
<pre><a name="line-1"></a><span class='hs-comment'>{-# LANGUAGE OverloadedStrings #-}</span>
<a name="line-2"></a><span class='hs-comment'>{-# LANGUAGE DeriveDataTypeable #-}</span>
<a name="line-3"></a>
<a name="line-4"></a><span class='hs-comment'>-- Copyright (C) 2009-2011 John Millikin <jmillikin@gmail.com></span>
<a name="line-5"></a><span class='hs-comment'>-- </span>
<a name="line-6"></a><span class='hs-comment'>-- This program is free software: you can redistribute it and/or modify</span>
<a name="line-7"></a><span class='hs-comment'>-- it under the terms of the GNU General Public License as published by</span>
<a name="line-8"></a><span class='hs-comment'>-- the Free Software Foundation, either version 3 of the License, or</span>
<a name="line-9"></a><span class='hs-comment'>-- any later version.</span>
<a name="line-10"></a><span class='hs-comment'>-- </span>
<a name="line-11"></a><span class='hs-comment'>-- This program is distributed in the hope that it will be useful,</span>
<a name="line-12"></a><span class='hs-comment'>-- but WITHOUT ANY WARRANTY; without even the implied warranty of</span>
<a name="line-13"></a><span class='hs-comment'>-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the</span>
<a name="line-14"></a><span class='hs-comment'>-- GNU General Public License for more details.</span>
<a name="line-15"></a><span class='hs-comment'>-- </span>
<a name="line-16"></a><span class='hs-comment'>-- You should have received a copy of the GNU General Public License</span>
<a name="line-17"></a><span class='hs-comment'>-- along with this program. If not, see <<a href="http://www.gnu.org/licenses/">http://www.gnu.org/licenses/</a>>.</span>
<a name="line-18"></a>
<a name="line-19"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>Protocol</span><span class='hs-varop'>.</span><span class='hs-conid'>XMPP</span><span class='hs-varop'>.</span><span class='hs-conid'>Client</span><span class='hs-varop'>.</span><span class='hs-conid'>Authentication</span>
<a name="line-20"></a> <span class='hs-layout'>(</span> <span class='hs-conid'>Result</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-21"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>authenticate</span>
<a name="line-22"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-23"></a>
<a name="line-24"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>Exc</span>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span> <span class='hs-layout'>(</span><span class='hs-varid'>when</span><span class='hs-layout'>)</span>
<a name="line-26"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Class</span> <span class='hs-layout'>(</span><span class='hs-conid'>MonadIO</span><span class='hs-layout'>,</span> <span class='hs-varid'>liftIO</span><span class='hs-layout'>)</span>
<a name="line-27"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Error</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>E</span>
<a name="line-28"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>ByteString</span> <span class='hs-layout'>(</span><span class='hs-conid'>ByteString</span><span class='hs-layout'>)</span>
<a name="line-29"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>ByteString</span><span class='hs-varop'>.</span><span class='hs-conid'>Char8</span>
<a name="line-30"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span>
<a name="line-31"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span> <span class='hs-layout'>(</span><span class='hs-conid'>Text</span><span class='hs-layout'>)</span>
<a name="line-32"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>Encoding</span> <span class='hs-layout'>(</span><span class='hs-varid'>encodeUtf8</span><span class='hs-layout'>)</span>
<a name="line-33"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Typeable</span> <span class='hs-layout'>(</span><span class='hs-conid'>Typeable</span><span class='hs-layout'>)</span>
<a name="line-34"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>Protocol</span><span class='hs-varop'>.</span><span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>GNU</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>SASL</span>
<a name="line-35"></a>
<a name="line-36"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>Protocol</span><span class='hs-varop'>.</span><span class='hs-conid'>XMPP</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>M</span>
<a name="line-37"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>Protocol</span><span class='hs-varop'>.</span><span class='hs-conid'>XMPP</span><span class='hs-varop'>.</span><span class='hs-conid'>XML</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>X</span>
<a name="line-38"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>Protocol</span><span class='hs-varop'>.</span><span class='hs-conid'>XMPP</span><span class='hs-varop'>.</span><span class='hs-conid'>JID</span> <span class='hs-layout'>(</span><span class='hs-conid'>JID</span><span class='hs-layout'>,</span> <span class='hs-varid'>formatJID</span><span class='hs-layout'>,</span> <span class='hs-varid'>jidResource</span><span class='hs-layout'>)</span>
<a name="line-39"></a>
<a name="line-40"></a><a name="Result"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>Result</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Success</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Failure</span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-conid'>Element</span>
<a name="line-41"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Show</span><span class='hs-layout'>,</span> <span class='hs-conid'>Eq</span><span class='hs-layout'>)</span>
<a name="line-42"></a>
<a name="line-43"></a><a name="AuthException"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>AuthException</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>XmppError</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-conid'>Error</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>SaslError</span> <span class='hs-conid'>Text</span>
<a name="line-44"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Typeable</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span><span class='hs-layout'>)</span>
<a name="line-45"></a>
<a name="line-46"></a><a name="instance%20Exc.Exception%20AuthException%20authenticate%20::%20%5bByteString%5d%20--%20%5e%20Mechanisms%20-%3e%20JID%20--%20%5e%20User%20JID%20-%3e%20JID%20--%20%5e%20Server%20JID%20-%3e%20Text%20--%20%5e%20Username%20-%3e%20Text%20--%20%5e%20Password%20-%3e%20M.XMPP%20()%20authenticate%20xmppMechanisms%20userJID%20serverJID%20username%20password%20=%20xmpp"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Exc</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span> <span class='hs-conid'>AuthException</span>
<a name="line-47"></a>
<a name="line-48"></a><a name="authenticate"></a><span class='hs-definition'>authenticate</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ByteString</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- ^ Mechanisms</span>
<a name="line-49"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>JID</span> <span class='hs-comment'>-- ^ User JID</span>
<a name="line-50"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>JID</span> <span class='hs-comment'>-- ^ Server JID</span>
<a name="line-51"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Text</span> <span class='hs-comment'>-- ^ Username</span>
<a name="line-52"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Text</span> <span class='hs-comment'>-- ^ Password</span>
<a name="line-53"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-conid'>XMPP</span> <span class='hs-conid'>()</span>
<a name="line-54"></a><span class='hs-definition'>authenticate</span> <span class='hs-varid'>xmppMechanisms</span> <span class='hs-varid'>userJID</span> <span class='hs-varid'>serverJID</span> <span class='hs-varid'>username</span> <span class='hs-varid'>password</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>xmpp</span> <span class='hs-keyword'>where</span>
<a name="line-55"></a> <span class='hs-varid'>mechanisms</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Mechanism</span> <span class='hs-varid'>xmppMechanisms</span>
<a name="line-56"></a> <span class='hs-varid'>authz</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>formatJID</span> <span class='hs-layout'>(</span><span class='hs-varid'>userJID</span> <span class='hs-layout'>{</span> <span class='hs-varid'>jidResource</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span>
<a name="line-57"></a> <span class='hs-varid'>hostname</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>formatJID</span> <span class='hs-varid'>serverJID</span>
<a name="line-58"></a>
<a name="line-59"></a> <span class='hs-varid'>xmpp</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-60"></a> <span class='hs-varid'>ctx</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-varid'>getSession</span>
<a name="line-61"></a> <span class='hs-varid'>res</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Exc</span><span class='hs-varop'>.</span><span class='hs-varid'>try</span> <span class='hs-varop'>.</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>runSASL</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>
<a name="line-62"></a> <span class='hs-varid'>suggested</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>clientSuggestMechanism</span> <span class='hs-varid'>mechanisms</span>
<a name="line-63"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>suggested</span> <span class='hs-keyword'>of</span>
<a name="line-64"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>saslError</span> <span class='hs-str'>"No supported authentication mechanism"</span>
<a name="line-65"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>mechanism</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>authSasl</span> <span class='hs-varid'>ctx</span> <span class='hs-varid'>mechanism</span>
<a name="line-66"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>res</span> <span class='hs-keyword'>of</span>
<a name="line-67"></a> <span class='hs-conid'>Right</span> <span class='hs-conid'>Success</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span>
<a name="line-68"></a> <span class='hs-conid'>Right</span> <span class='hs-layout'>(</span><span class='hs-conid'>Failure</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-varid'>throwError</span> <span class='hs-layout'>(</span><span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-conid'>AuthenticationFailure</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-69"></a> <span class='hs-conid'>Left</span> <span class='hs-layout'>(</span><span class='hs-conid'>XmppError</span> <span class='hs-varid'>err</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-varid'>throwError</span> <span class='hs-varid'>err</span>
<a name="line-70"></a> <span class='hs-conid'>Left</span> <span class='hs-layout'>(</span><span class='hs-conid'>SaslError</span> <span class='hs-varid'>err</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>E</span><span class='hs-varop'>.</span><span class='hs-varid'>throwError</span> <span class='hs-layout'>(</span><span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-conid'>AuthenticationError</span> <span class='hs-varid'>err</span><span class='hs-layout'>)</span>
<a name="line-71"></a>
<a name="line-72"></a> <span class='hs-varid'>authSasl</span> <span class='hs-varid'>ctx</span> <span class='hs-varid'>mechanism</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-73"></a> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Mechanism</span> <span class='hs-varid'>mechBytes</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mechanism</span>
<a name="line-74"></a> <span class='hs-varid'>sessionResult</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>runClient</span> <span class='hs-varid'>mechanism</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>
<a name="line-75"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>setProperty</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>PropertyAuthzID</span> <span class='hs-layout'>(</span><span class='hs-varid'>encodeUtf8</span> <span class='hs-varid'>authz</span><span class='hs-layout'>)</span>
<a name="line-76"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>setProperty</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>PropertyAuthID</span> <span class='hs-layout'>(</span><span class='hs-varid'>encodeUtf8</span> <span class='hs-varid'>username</span><span class='hs-layout'>)</span>
<a name="line-77"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>setProperty</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>PropertyPassword</span> <span class='hs-layout'>(</span><span class='hs-varid'>encodeUtf8</span> <span class='hs-varid'>password</span><span class='hs-layout'>)</span>
<a name="line-78"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>setProperty</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>PropertyService</span> <span class='hs-str'>"xmpp"</span>
<a name="line-79"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>setProperty</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>PropertyHostname</span> <span class='hs-layout'>(</span><span class='hs-varid'>encodeUtf8</span> <span class='hs-varid'>hostname</span><span class='hs-layout'>)</span>
<a name="line-80"></a>
<a name="line-81"></a> <span class='hs-layout'>(</span><span class='hs-varid'>b64text</span><span class='hs-layout'>,</span> <span class='hs-varid'>rc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>step64</span> <span class='hs-str'>""</span>
<a name="line-82"></a> <span class='hs-varid'>putElement</span> <span class='hs-varid'>ctx</span> <span class='hs-varop'>$</span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-varid'>element</span> <span class='hs-str'>"{urn:ietf:params:xml:ns:xmpp-sasl}auth"</span>
<a name="line-83"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-str'>"mechanism"</span><span class='hs-layout'>,</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-varid'>pack</span> <span class='hs-layout'>(</span><span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>ByteString</span><span class='hs-varop'>.</span><span class='hs-conid'>Char8</span><span class='hs-varop'>.</span><span class='hs-varid'>unpack</span> <span class='hs-varid'>mechBytes</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-84"></a> <span class='hs-keyglyph'>[</span><span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-conid'>NodeContent</span> <span class='hs-layout'>(</span><span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-conid'>ContentText</span> <span class='hs-layout'>(</span><span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-varid'>pack</span> <span class='hs-layout'>(</span><span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>ByteString</span><span class='hs-varop'>.</span><span class='hs-conid'>Char8</span><span class='hs-varop'>.</span><span class='hs-varid'>unpack</span> <span class='hs-varid'>b64text</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-85"></a>
<a name="line-86"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>rc</span> <span class='hs-keyword'>of</span>
<a name="line-87"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Complete</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>saslFinish</span> <span class='hs-varid'>ctx</span>
<a name="line-88"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>NeedsMore</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>saslLoop</span> <span class='hs-varid'>ctx</span>
<a name="line-89"></a>
<a name="line-90"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>sessionResult</span> <span class='hs-keyword'>of</span>
<a name="line-91"></a> <span class='hs-conid'>Right</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>x</span>
<a name="line-92"></a> <span class='hs-conid'>Left</span> <span class='hs-varid'>err</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>saslError</span> <span class='hs-layout'>(</span><span class='hs-varid'>show</span> <span class='hs-varid'>err</span><span class='hs-layout'>)</span>
<a name="line-93"></a>
<a name="line-94"></a><a name="saslLoop"></a><span class='hs-definition'>saslLoop</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-conid'>Session</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Session</span> <span class='hs-conid'>Result</span>
<a name="line-95"></a><span class='hs-definition'>saslLoop</span> <span class='hs-varid'>ctx</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-96"></a> <span class='hs-varid'>e</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getElement</span> <span class='hs-varid'>ctx</span>
<a name="line-97"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>challengeTexts</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-varid'>elementNodes</span> <span class='hs-varid'>e</span> <span class='hs-varop'>>>=</span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-varid'>isContent</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>return</span> <span class='hs-varop'>.</span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-varid'>contentText</span>
<a name="line-98"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>challenge</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>concatMap</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-varid'>unpack</span> <span class='hs-varid'>challengeTexts</span>
<a name="line-99"></a> <span class='hs-keyword'>case</span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-varid'>elementName</span> <span class='hs-varid'>e</span> <span class='hs-keyword'>of</span>
<a name="line-100"></a> <span class='hs-comment'>-- The server needs more data before it can authenticate this client.</span>
<a name="line-101"></a> <span class='hs-varid'>n</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>n</span> <span class='hs-varop'>==</span> <span class='hs-str'>"{urn:ietf:params:xml:ns:xmpp-sasl}challenge"</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-102"></a> <span class='hs-varid'>when</span> <span class='hs-layout'>(</span><span class='hs-varid'>null</span> <span class='hs-varid'>challenge</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>saslError</span> <span class='hs-str'>"Received empty challenge"</span><span class='hs-layout'>)</span>
<a name="line-103"></a> <span class='hs-layout'>(</span><span class='hs-varid'>b64text</span><span class='hs-layout'>,</span> <span class='hs-varid'>rc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>step64</span> <span class='hs-layout'>(</span><span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>ByteString</span><span class='hs-varop'>.</span><span class='hs-conid'>Char8</span><span class='hs-varop'>.</span><span class='hs-varid'>pack</span> <span class='hs-varid'>challenge</span><span class='hs-layout'>)</span>
<a name="line-104"></a> <span class='hs-varid'>putElement</span> <span class='hs-varid'>ctx</span> <span class='hs-layout'>(</span><span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-varid'>element</span>
<a name="line-105"></a> <span class='hs-str'>"{urn:ietf:params:xml:ns:xmpp-sasl}response"</span>
<a name="line-106"></a> <span class='hs-conid'>[]</span>
<a name="line-107"></a> <span class='hs-keyglyph'>[</span><span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-conid'>NodeContent</span> <span class='hs-layout'>(</span><span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-conid'>ContentText</span> <span class='hs-layout'>(</span><span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-varid'>pack</span> <span class='hs-layout'>(</span><span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>ByteString</span><span class='hs-varop'>.</span><span class='hs-conid'>Char8</span><span class='hs-varop'>.</span><span class='hs-varid'>unpack</span> <span class='hs-varid'>b64text</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-108"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>rc</span> <span class='hs-keyword'>of</span>
<a name="line-109"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Complete</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>saslFinish</span> <span class='hs-varid'>ctx</span>
<a name="line-110"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>NeedsMore</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>saslLoop</span> <span class='hs-varid'>ctx</span>
<a name="line-111"></a>
<a name="line-112"></a> <span class='hs-comment'>-- The server has authenticated this client, but the client-side</span>
<a name="line-113"></a> <span class='hs-comment'>-- SASL protocol wants more data from the server.</span>
<a name="line-114"></a> <span class='hs-varid'>n</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>n</span> <span class='hs-varop'>==</span> <span class='hs-str'>"{urn:ietf:params:xml:ns:xmpp-sasl}success"</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-115"></a> <span class='hs-varid'>when</span> <span class='hs-layout'>(</span><span class='hs-varid'>null</span> <span class='hs-varid'>challenge</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>saslError</span> <span class='hs-str'>"Received empty challenge"</span><span class='hs-layout'>)</span>
<a name="line-116"></a> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>rc</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-varid'>step64</span> <span class='hs-layout'>(</span><span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>ByteString</span><span class='hs-varop'>.</span><span class='hs-conid'>Char8</span><span class='hs-varop'>.</span><span class='hs-varid'>pack</span> <span class='hs-varid'>challenge</span><span class='hs-layout'>)</span>
<a name="line-117"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>rc</span> <span class='hs-keyword'>of</span>
<a name="line-118"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Complete</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>Success</span>
<a name="line-119"></a> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>NeedsMore</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>saslError</span> <span class='hs-str'>"Server didn't provide enough SASL data."</span>
<a name="line-120"></a>
<a name="line-121"></a> <span class='hs-comment'>-- The server has rejected this client's credentials.</span>
<a name="line-122"></a> <span class='hs-varid'>n</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>n</span> <span class='hs-varop'>==</span> <span class='hs-str'>"{urn:ietf:params:xml:ns:xmpp-sasl}failure"</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Failure</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-123"></a>
<a name="line-124"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>saslError</span> <span class='hs-layout'>(</span><span class='hs-str'>"Server sent unexpected element during authentication."</span><span class='hs-layout'>)</span>
<a name="line-125"></a>
<a name="line-126"></a><a name="saslFinish"></a><span class='hs-definition'>saslFinish</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-conid'>Session</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Session</span> <span class='hs-conid'>Result</span>
<a name="line-127"></a><span class='hs-definition'>saslFinish</span> <span class='hs-varid'>ctx</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-128"></a> <span class='hs-varid'>elemt</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getElement</span> <span class='hs-varid'>ctx</span>
<a name="line-129"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>if</span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-varid'>elementName</span> <span class='hs-varid'>elemt</span> <span class='hs-varop'>==</span> <span class='hs-str'>"{urn:ietf:params:xml:ns:xmpp-sasl}success"</span>
<a name="line-130"></a> <span class='hs-keyword'>then</span> <span class='hs-conid'>Success</span>
<a name="line-131"></a> <span class='hs-keyword'>else</span> <span class='hs-conid'>Failure</span> <span class='hs-varid'>elemt</span>
<a name="line-132"></a>
<a name="line-133"></a><a name="putElement"></a><span class='hs-definition'>putElement</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-conid'>Session</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-conid'>Element</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Session</span> <span class='hs-conid'>()</span>
<a name="line-134"></a><span class='hs-definition'>putElement</span> <span class='hs-varid'>ctx</span> <span class='hs-varid'>elemt</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>
<a name="line-135"></a> <span class='hs-varid'>res</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-varid'>runXMPP</span> <span class='hs-varid'>ctx</span> <span class='hs-layout'>(</span><span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-varid'>putElement</span> <span class='hs-varid'>elemt</span><span class='hs-layout'>)</span>
<a name="line-136"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>res</span> <span class='hs-keyword'>of</span>
<a name="line-137"></a> <span class='hs-conid'>Left</span> <span class='hs-varid'>err</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Exc</span><span class='hs-varop'>.</span><span class='hs-varid'>throwIO</span> <span class='hs-layout'>(</span><span class='hs-conid'>XmppError</span> <span class='hs-varid'>err</span><span class='hs-layout'>)</span>
<a name="line-138"></a> <span class='hs-conid'>Right</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>x</span>
<a name="line-139"></a>
<a name="line-140"></a><a name="getElement"></a><span class='hs-definition'>getElement</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-conid'>Session</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SASL</span><span class='hs-varop'>.</span><span class='hs-conid'>Session</span> <span class='hs-conid'>X</span><span class='hs-varop'>.</span><span class='hs-conid'>Element</span>
<a name="line-141"></a><span class='hs-definition'>getElement</span> <span class='hs-varid'>ctx</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>
<a name="line-142"></a> <span class='hs-varid'>res</span> <span class='hs-keyglyph'><-</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-varid'>runXMPP</span> <span class='hs-varid'>ctx</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-varid'>getElement</span>
<a name="line-143"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>res</span> <span class='hs-keyword'>of</span>
<a name="line-144"></a> <span class='hs-conid'>Left</span> <span class='hs-varid'>err</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Exc</span><span class='hs-varop'>.</span><span class='hs-varid'>throwIO</span> <span class='hs-layout'>(</span><span class='hs-conid'>XmppError</span> <span class='hs-varid'>err</span><span class='hs-layout'>)</span>
<a name="line-145"></a> <span class='hs-conid'>Right</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>x</span>
<a name="line-146"></a>
<a name="line-147"></a><a name="saslError"></a><span class='hs-definition'>saslError</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MonadIO</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<a name="line-148"></a><span class='hs-definition'>saslError</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Exc</span><span class='hs-varop'>.</span><span class='hs-varid'>throwIO</span> <span class='hs-varop'>.</span> <span class='hs-conid'>SaslError</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-varid'>pack</span>
</pre></body>
</html>
|