packages feed

sasl (empty) → 0.0.0.0

raw patch · 26 files changed

+1411/−0 lines, 26 filesdep +basedep +base64-bytestringdep +bytestringsetup-changed

Dependencies added: base, base64-bytestring, bytestring, cryptohash, monads-tf, papillon, simple-pipe

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.++  * Neither the name of the Yoshikuni Jujo nor the names of its+    contributors may be used to endorse or promote products derived from+    this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,1 @@+import Distribution.Simple; main = defaultMain
+ examples/clientD.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import "monads-tf" Control.Monad.State+import Data.Pipe+import Data.Pipe.ByteString+import System.IO+import Network.Sasl+import Network.Sasl.DigestMd5.Client++import qualified Data.ByteString as BS++data St = St [(BS.ByteString, BS.ByteString)] deriving Show++instance SaslState St where+	getSaslState (St s) = s+	putSaslState s _ = St s++serverFile :: String+serverFile = "examples/digestMd5sv.txt"++main :: IO ()+main = do+	let (_, (_, p)) = sasl+	r <- runPipe (fromFileLn serverFile =$= input =$= p =$= toHandleLn stdout)+		`runStateT` St [+			("username", "yoshikuni"),+			("password", "password"),+			("cnonce", "00DEADBEEF00"),+			("nc", "00000001"),+			("uri", "xmpp/localhost") ]+	print r++input :: Pipe BS.ByteString (Either Success BS.ByteString) (StateT St IO) ()+input = await >>= \mbs -> case mbs of+	Just "success" -> yield . Left $ Success Nothing+	Just ch -> yield (Right ch) >> input+	_ -> return ()
+ examples/clientE.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import "monads-tf" Control.Monad.State+import Data.Pipe+import Data.Pipe.ByteString+import System.IO+import Network.Sasl+import Network.Sasl.External.Client++import qualified Data.ByteString as BS++data St = St [(BS.ByteString, BS.ByteString)] deriving Show++instance SaslState St where+	getSaslState (St s) = s+	putSaslState s _ = St s++serverFile :: String+serverFile = "examples/externalSv.txt"++main :: IO ()+main = do+	let (_, (_, p)) = sasl+	r <- runPipe (fromFileLn serverFile =$= input =$= p =$= toHandleLn stdout)+		`runStateT` St [("username", "yoshikuni")]+	print r++input :: Pipe BS.ByteString (Either Success BS.ByteString) (StateT St IO) ()+input = await >>= \mbs -> case mbs of+	Just "success" -> yield . Left $ Success Nothing+	Just ch -> yield (Right ch) >> input+	_ -> return ()
+ examples/clientP.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import "monads-tf" Control.Monad.State+import Data.Pipe+import Data.Pipe.ByteString+import System.IO+import Network.Sasl+import Network.Sasl.Plain.Client++import qualified Data.ByteString as BS++data St = St [(BS.ByteString, BS.ByteString)] deriving Show++instance SaslState St where+	getSaslState (St s) = s+	putSaslState s _ = St s++serverFile :: String+serverFile = "examples/plainSv.txt"++main :: IO ()+main = do+	let (_, (_, p)) = sasl+	r <- runPipe (fromFileLn serverFile =$= input =$= p =$= toHandleLn stdout)+		`runStateT` St [("authcid", "yoshikuni"), ("password", "password")]+	print r++input :: Pipe BS.ByteString (Either Success BS.ByteString) (StateT St IO) ()+input = await >>= \mbs -> case mbs of+	Just "success" -> yield . Left $ Success Nothing+	Just ch -> yield (Right ch) >> input+	_ -> return ()
+ examples/clientS.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import "monads-tf" Control.Monad.State+import Data.Pipe+import Data.Pipe.ByteString+import System.IO+import Network.Sasl+import Network.Sasl.ScramSha1.Client++import qualified Data.ByteString as BS++data St = St [(BS.ByteString, BS.ByteString)] deriving Show++instance SaslState St where+	getSaslState (St s) = s+	putSaslState s _ = St s++serverFile :: String+serverFile = "examples/scramSha1sv.txt"++main :: IO ()+main = do+	let	(_, (_, p)) = sasl+		sp = saltedPassword "password" "pepper" 4492+	r <- runPipe (fromFileLn serverFile =$= input =$= p =$= toHandleLn stdout)+		`runStateT` St [+			("username", "yoshikuni"),+			("password", "password"),+--			("ClientKey", clientKey sp), ("ServerKey", serverKey sp),+--			("SaltedPassword", sp),+			("cnonce", "00DEADBEEF00")+			]+	print r++input :: Pipe BS.ByteString (Either Success BS.ByteString) (StateT St IO) ()+input = await >>= \mbs -> case mbs of+	Just "success" -> yield . Left $ Success Nothing+	Just ch -> yield (Right ch) >> input+	_ -> return ()
+ examples/serverD.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import "monads-tf" Control.Monad.State+import Data.Pipe+import Data.Pipe.ByteString+import Network.Sasl+import Network.Sasl.DigestMd5.Server+import System.IO++import qualified Data.ByteString as BS++data St = St [(BS.ByteString, BS.ByteString)] deriving Show++instance SaslState St where+	getSaslState (St s) = s+	putSaslState s _ = St s++clientFile :: String+clientFile = "examples/digestMd5cl.txt"++main :: IO ()+main = do+	let (_, (_, p)) = sasl $ \"yoshikuni" -> return $+		mkStored "yoshikuni" "localhost" "password"+	r <- runPipe (fromFileLn clientFile =$= p =$= output =$= toHandleLn stdout)+		`runStateT` St [+			("realm", "localhost"),+			("nonce", "7658cddf-0e44-4de2-87df-41323bce97f4"),+			("qop", "auth"),+			("charset", "utf-8"),+			("algorithm", "md5-sess") ]+	print r++output :: Pipe (Either Success BS.ByteString) BS.ByteString (StateT St IO) ()+output = await >>= \mch -> case mch of+	Just (Left (Success Nothing)) -> yield "success"+	Just (Right bs) -> yield bs >> output+	_ -> return ()
+ examples/serverE.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe+import Data.Pipe.ByteString+import Network.Sasl+import Network.Sasl.External.Server+import System.IO++import qualified Data.ByteString as BS++data St = St [(BS.ByteString, BS.ByteString)] deriving Show++instance SaslState St where+	getSaslState (St s) = s+	putSaslState s _ = St s++clientFile :: String+clientFile = "examples/externalCl.txt"++main :: IO ()+main = do+	let (_, (_, p)) = sasl check+	r <- runPipe (fromFileLn clientFile =$= p =$= output =$= toHandleLn stdout)+		`runStateT` St []+	print r++check :: (MonadError m, SaslError (ErrorType m)) =>+	BS.ByteString -> m ()+check "yoshikuni" = return ()+check _ = throwError $ fromSaslError NotAuthorized "incorrct username"++output :: Pipe (Either Success BS.ByteString) BS.ByteString (StateT St IO) ()+output = await >>= \mch -> case mch of+	Just (Left (Success Nothing)) -> yield "success"+	Just (Right bs) -> yield bs >> output+	_ -> return ()
+ examples/serverP.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe+import Data.Pipe.ByteString+import Network.Sasl+import Network.Sasl.Plain.Server+import System.IO++import qualified Data.ByteString as BS++data St = St [(BS.ByteString, BS.ByteString)] deriving Show++instance SaslState St where+	getSaslState (St s) = s+	putSaslState s _ = St s++clientFile :: String+clientFile = "examples/plainCl.txt"++main :: IO ()+main = do+	let (_, (_, p)) = sasl check+	r <- runPipe (fromFileLn clientFile =$= p =$= output =$= toHandleLn stdout)+		`runStateT` St []+	print r++check :: (Monad m, MonadError m, SaslError (ErrorType m)) =>+	BS.ByteString -> BS.ByteString -> BS.ByteString -> m ()+check "" "yoshikuni" "password" = return ()+check _ _ _ = throwError $+	fromSaslError NotAuthorized "incorrect username or password"++output :: Pipe (Either Success BS.ByteString) BS.ByteString (StateT St IO) ()+output = await >>= \mch -> case mch of+	Just (Left (Success Nothing)) -> yield "success"+	Just (Right bs) -> yield bs >> output+	_ -> return ()
+ examples/serverS.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import "monads-tf" Control.Monad.State+import Data.Pipe+import Data.Pipe.ByteString+import System.IO+import Network.Sasl+import Network.Sasl.ScramSha1.Server++import qualified Data.ByteString as BS++data St = St [(BS.ByteString, BS.ByteString)] deriving Show++instance SaslState St where+	getSaslState (St s) = s+	putSaslState s _ = St s++clientFile :: String+clientFile = "examples/scramSha1cl.txt"++main :: IO ()+main = do+	let	slt = "pepper"+		i = 4492+		(stk, svk) = salt "password" slt i+		(_, (_, p)) = sasl $ \"yoshikuni" -> return (slt, stk, svk, i)+	r <- runPipe (fromFileLn clientFile =$= p =$= output =$= toHandleLn stdout)+		`runStateT` St [("snonce", "7658cddf-0e44-4de2-87df-4132bce97f4")]+	print r++output :: Pipe (Either Success BS.ByteString) BS.ByteString (StateT St IO) ()+output = await >>= \mch -> case mch of+	Just (Left (Success Nothing)) -> yield "success"+	Just (Left (Success (Just bs))) -> yield bs+	Just (Right bs) -> yield bs >> output+	_ -> return ()
+ sasl.cabal view
@@ -0,0 +1,157 @@+build-type:	Simple+cabal-version:	>= 1.8++name:		sasl+version:	0.0.0.0+stability:	Experimental+author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage:	https://github.com/YoshikuniJujo/sasl/wiki++license:	BSD3+license-file:	LICENSE++category:	Network+synopsis:	SASL implementation using simple-pipe+description:+    Example programs+    .+    SCRAM-SHA-1 Client sample+    .+    scramSha1sv.txt+    .+    > r=00DEADBEEF007658cddf-0e44-4de2-87df-4132bce97f4,s=cGVwcGVy,i=4492+    > v=q0+IZgUtQTHYItaurlNyET1imLI=+    > success+    .+    examples/clientS.hs+    .+    extensions+    .+    * OverloadedStrings+    .+    * PackageImports+    .+    > import "monads-tf" Control.Monad.State+    > import Data.Pipe+    > import Data.Pipe.ByteString+    > import System.IO+    > import Network.Sasl+    > import Network.Sasl.ScramSha1.Client+    >+    > import qualified Data.ByteString as BS+    >+    > data St = St [(BS.ByteString, BS.ByteString)] deriving Show+    > +    > instance SaslState St where+    > 	getSaslState (St s) = s+    > 	putSaslState s _ = St s+    >+    > serverFile :: String+    > serverFile = "examples/scramSha1sv.txt"+    >+    > main :: IO ()+    > main = do+    > 	let	(_, (_, p)) = sasl+    > 	r <- runPipe (fromFileLn serverFile =$= input =$= p =$= toHandleLn stdout)+    > 		`runStateT` St [+    > 			("username", "yoshikuni"),+    > 			("password", "password"),+    > 			("cnonce", "00DEADBEEF00") ]+    > 	print r+    >+    > input :: Pipe BS.ByteString (Either Success BS.ByteString) (StateT St IO) ()+    > input = await >>= \mbs -> case mbs of+    > 	Just "success" -> yield . Left $ Success Nothing+    > 	Just ch -> yield (Right ch) >> input+    > 	_ -> return ()+    .+    SCRAM-SHA-1 Server sample+    .+    scramSha1cl.txt+    .+    > n,,n=yoshikuni,r=00DEADBEEF00+    > c=biws,r=00DEADBEEF007658cddf-0e44-4de2-87df-4132bce97f4,p=zup7ghwpAW43cP4Xu3YZTNnHo0g=+    >+    .+    examples/serverS.hs+    .+    extensions+    .+    * OverloadedStrings+    .+    * PackageImports+    .+    > import "monads-tf" Control.Monad.State+    > import Data.Pipe+    > import Data.Pipe.ByteString+    > import System.IO+    > import Network.Sasl+    > import Network.Sasl.ScramSha1.Server+    >+    > import qualified Data.ByteString as BS+    >+    > data St = St [(BS.ByteString, BS.ByteString)] deriving Show+    >+    > instance SaslState St where+    > 	getSaslState (St s) = s+    > 	putSaslState s _ = St s+    >+    > clientFile :: String+    > clientFile = "examples/scramSha1cl.txt"+    >+    > main :: IO ()+    > main = do+    > 	let	slt = "pepper"+    > 		i = 4492+    > 		(stk, svk) = salt "password" slt i+    > 		(_, (_, p)) = sasl $ \"yoshikuni" -> return (slt, stk, svk, i)+    > 	r <- runPipe (fromFileLn clientFile =$= p =$= output =$= toHandleLn stdout)+    > 		`runStateT` St [("snonce", "7658cddf-0e44-4de2-87df-4132bce97f4")]+    > 	print r+    >+    > output :: Pipe (Either Success BS.ByteString) BS.ByteString (StateT St IO) ()+    > output = await >>= \mch -> case mch of+    > 	Just (Left (Success Nothing)) -> yield "success"+    > 	Just (Left (Success (Just bs))) -> yield bs+    > 	Just (Right bs) -> yield bs >> output+    > 	_ -> return ()+    .+    See examples directory for more examples.++extra-source-files:+    examples/clientD.hs+    examples/serverD.hs+    examples/clientS.hs+    examples/serverS.hs+    examples/clientP.hs+    examples/serverP.hs+    examples/clientE.hs+    examples/serverE.hs++source-repository	head+    type:	git+    location:	git://github.com/YoshikuniJujo/sasl.git++source-repository	this+    type:	git+    location:	git://github.com/YoshikuniJujo/sasl.git+    tag:	sasl-0.0.0.0++library+    hs-source-dirs:	src+    exposed-modules:+        Network.Sasl,+        Network.Sasl.Plain.Client, Network.Sasl.Plain.Server,+        Network.Sasl.External.Client, Network.Sasl.External.Server,+        Network.Sasl.DigestMd5.Client, Network.Sasl.DigestMd5.Server,+        Network.Sasl.ScramSha1.Client, Network.Sasl.ScramSha1.Server+    other-modules:+        Network.Sasl.DigestMd5.DigestMd5, Network.Sasl.DigestMd5.Papillon,+        Network.Sasl.ScramSha1.Fields, Network.Sasl.ScramSha1.Hmac,+        Network.Sasl.ScramSha1.ScramSha1, Network.Sasl.ScramSha1.Functions+    build-depends:+        base == 4.*, bytestring == 0.10.*, simple-pipe == 0.0.0.*,+        papillon == 0.1.*, cryptohash == 0.11.*, base64-bytestring == 1.0.*,+        monads-tf == 0.1.*+    ghc-options:	-Wall
+ src/Network/Sasl.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings, TupleSections,+ 	FlexibleContexts, TypeSynonymInstances, PackageImports #-}++module Network.Sasl (+	-- * Main+	Client(..), client, Server(..), server, Success(..),+	-- * Types and Classes+	SaslState(..), Send, Receive,+	-- * Error+	SaslError(..), SaslErrorType(..) ) where++import "monads-tf" Control.Monad.Error+import "monads-tf" Control.Monad.Error.Class+import Data.Maybe+import Data.Pipe++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++class SaslState s where+	getSaslState :: s -> [(BS.ByteString, BS.ByteString)]+	putSaslState :: [(BS.ByteString, BS.ByteString)] -> s -> s++data Server m = Server (Maybe (Receive m)) [(Send m, Receive m)] (Maybe (Send m))+data Client m = Client (Maybe (Send m)) [(Receive m, Send m)] (Maybe (Receive m))++type Send m = m BS.ByteString+type Receive m = BS.ByteString -> m ()++data Success = Success (Maybe BS.ByteString) deriving Show++data SaslErrorType+	= Aborted+	| AccountDisabled+	| CredentialExpired+	| EncryptionRequired+	| IncorrectEncoding+	| InvalidAuthzid+	| InvalidMechanism+	| MalformedRequest+	| MechanismTooWeak+	| NotAuthorized+	| TemporaryAuthFailure+	| SaslErrorType BS.ByteString+	deriving Show++class Error e => SaslError e where+	fromSaslError :: SaslErrorType -> BS.ByteString -> e++instance SaslError IOError where+	fromSaslError et em = strMsg $ show et ++ ":" ++ BSC.unpack em++server :: Monad m =>+	Server m -> (Bool, Pipe BS.ByteString (Either Success BS.ByteString) m ())+server s@(Server i _ _) = (isJust i, pipeSv_ s)++pipeSv_ :: Monad m =>+	Server m -> Pipe BS.ByteString (Either Success BS.ByteString) m ()+pipeSv_ (Server (Just rcv) srs send') = await >>=+	maybe (return ()) ((>> pipeSv_ (Server Nothing srs send')) . lift . rcv)+pipeSv_ (Server _ [] (Just send')) = lift send' >>= yield . Left . Success . Just+pipeSv_ (Server _ [] _) = yield . Left $ Success Nothing+pipeSv_ (Server _ ((send, rcv) : srs) send') = do+	lift send >>= yield . Right+	await >>= maybe (return ())+		((>> pipeSv_ (Server Nothing srs send')) . lift . rcv)++client :: Monad m => Client m -> (Bool,+	Pipe (Either Success BS.ByteString) BS.ByteString m ())+client c@(Client i _ _) = (isJust i, pipeCl_ c)++voidM :: Monad m => m a -> m ()+voidM = (>> return ())++pipeCl_ :: Monad m =>+	Client m -> Pipe (Either Success BS.ByteString) BS.ByteString m ()+pipeCl_ (Client (Just i) rss rcv') =+	lift i >>= yield >> pipeCl_ (Client Nothing rss rcv')+pipeCl_ (Client _ [] (Just rcv)) = await >>= \mi -> case mi of+	Just (Left (Success (Just d))) -> lift $ rcv d+	Just (Right d) -> lift (rcv d) >> yield "" >> await >>= \mi' -> case mi' of+		Just (Left (Success Nothing)) -> return ()+		_ -> error $ "pipeCl_: " ++ show mi'+	_ -> return ()+pipeCl_ (Client _ [] _) = voidM await+pipeCl_ (Client _ ((rcv, send) : rss) rcv') = await >>= \mbs -> case mbs of+	Just (Right bs) -> lift (rcv bs) >> lift send >>= yield >>+		pipeCl_ (Client Nothing rss rcv')+	_ -> return ()
+ src/Network/Sasl/DigestMd5/Client.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.Sasl.DigestMd5.Client (sasl) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe++import Network.Sasl+import Network.Sasl.DigestMd5.DigestMd5+import Network.Sasl.DigestMd5.Papillon++import qualified Data.ByteString as BS++sasl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => (+	BS.ByteString,+	(Bool, Pipe (Either Success BS.ByteString) BS.ByteString m ()) )+sasl = ("DIGEST-MD5", client digestMd5Cl)+++digestMd5Cl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => Client m+digestMd5Cl = Client Nothing (zip svs cls) (Just . const $ return ()) -- Nothing++cls :: (MonadState m, SaslState (StateType m)) => [Send m]+-- client = [mkResponse, return ""]+cls = [mkResponse]++svs :: (MonadState m, SaslState (StateType m)) => [Receive m]+svs = [putReceive]++mkResponse :: (MonadState m, SaslState (StateType m)) => Send m+mkResponse = do+	st <- gets getSaslState+	let	Just ps = lookup "password" st+		Just rlm = lookup "realm" st+		Just n = lookup "nonce" st+		Just q = lookup "qop" st+		Just c = lookup "charset" st+		Just un = lookup "username" st+		Just uri = lookup "uri" st+		Just cn = lookup "cnonce" st+		Just nc = lookup "nc" st+	modify . putSaslState $ [+		("username", un),+		("digest-uri", uri),+		("nc", nc),+		("cnonce", cn) ] ++ st+	return . fromDigestResponse $ DR {+		drUserName = un,+		drRealm = rlm,+		drPassword = ps,+		drCnonce = cn,+		drNonce = n,+		drNc = nc,+		drQop = q,+		drDigestUri = uri,+		drCharset = c }++putReceive :: (MonadState m, SaslState (StateType m)) => Receive m+putReceive bs = do+	let Just ch = parseAtts bs+	st <- gets getSaslState+	let	Just rlm = lookup "realm" ch+		Just n = lookup "nonce" ch+		Just q = lookup "qop" ch+		Just c = lookup "charset" ch+		Just a = lookup "algorithm" ch+	modify . putSaslState $ [+		("realm", rlm),+		("nonce", n),+		("qop", q),+		("charset", c),+		("algorithm", a) ] ++ st
+ src/Network/Sasl/DigestMd5/DigestMd5.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Sasl.DigestMd5.DigestMd5 (+	DigestResponse(..), fromDigestResponse,+	mkStored, digestMd5,++	DigestMd5Challenge(..), fromDigestMd5Challenge,+) where++import Control.Applicative+import Crypto.Hash.MD5+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Numeric+import Data.Word++(+++) :: ByteString -> ByteString -> ByteString+(+++) = BS.append++hash32 :: ByteString -> ByteString+hash32 = BSC.pack . concatMap hex2 . BS.unpack . hash++hex2 :: Word8 -> String+hex2 w = replicate (2 - length s) '0' ++ s+	where+	s = showHex w ""++mkStored :: ByteString -> ByteString -> ByteString -> ByteString+mkStored username rlm password =+	hash $ username +++ ":" +++ rlm +++ ":" +++ password++digestMd5 :: Bool -> ByteString -> ByteString -> ByteString ->+	ByteString -> ByteString -> ByteString -> ByteString+digestMd5 isClient y q uri n nc cnonce = z+	where+	a1 = y +++ ":" +++ n +++ ":" +++ cnonce+	ha1 = hash32 a1+	a2 = (if isClient then "AUTHENTICATE" else "") +++ ":" +++ uri+	ha2 = hash32 a2+	kd = ha1 +++ ":" +++ n +++ ":" +++ nc +++ ":" +++ cnonce +++ ":" ++++		q +++ ":" +++ ha2+	z = hash32 kd++data DigestResponse = DR {+	drUserName :: BS.ByteString,+	drRealm :: BS.ByteString,+	drPassword :: BS.ByteString,+	drCnonce :: BS.ByteString,+	drNonce :: BS.ByteString,+	drNc :: BS.ByteString,+	drQop :: BS.ByteString,+	drDigestUri :: BS.ByteString,+	drCharset :: BS.ByteString }+	deriving Show++fromDigestResponse :: DigestResponse -> BS.ByteString+fromDigestResponse = kvsToS . responseToKvs True++kvsToS :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString+kvsToS [] = ""+kvsToS [(k, v)] = k `BS.append` "=" `BS.append` v+kvsToS ((k, v) : kvs) =+	k `BS.append` "=" `BS.append` v `BS.append` "," `BS.append` kvsToS kvs++responseToKvs :: Bool -> DigestResponse -> [(BS.ByteString, BS.ByteString)]+responseToKvs isClient rsp = [+	("username", quote $ drUserName rsp),+	("realm", quote $ drRealm rsp),+	("nonce", quote $ drNonce rsp),+	("cnonce", quote $ drCnonce rsp),+	("nc", drNc rsp),+	("qop", drQop rsp),+	("digest-uri", quote $ drDigestUri rsp),+	("response", calcMd5 isClient rsp),+	("charset", drCharset rsp)+	]++quote :: BS.ByteString -> BS.ByteString+quote = (`BS.append` "\"") . ("\"" `BS.append`)++calcMd5 :: Bool -> DigestResponse -> BS.ByteString+calcMd5 isClient = digestMd5 isClient+	<$> (mkStored <$> drUserName <*> drRealm <*> drPassword)+	<*> drQop <*> drDigestUri+	<*> drNonce <*> drNc <*> drCnonce++data DigestMd5Challenge = DigestMd5Challenge {+	realm :: BS.ByteString,+	nonce :: BS.ByteString,+	qop :: BS.ByteString,+	charset :: BS.ByteString,+	algorithm :: BS.ByteString }+	deriving Show++fromDigestMd5Challenge :: DigestMd5Challenge -> BS.ByteString+fromDigestMd5Challenge c = BS.concat [+	"realm=", BSC.pack . show $ realm c, ",",+	"nonce=", BSC.pack . show $ nonce c, ",",+	"qop=", BSC.pack . show $ qop c, ",",+	"charset=", charset c, ",", "algorithm=", algorithm c ]
+ src/Network/Sasl/DigestMd5/Papillon.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-}++module Network.Sasl.DigestMd5.Papillon (parseAtts) where++import Text.Papillon+import Data.ByteString.Char8 (ByteString, pack)++import qualified Data.ByteString as BS+-- import qualified Data.ByteString.Char8 as BSC++parseAtts :: BS.ByteString -> Maybe [(BS.ByteString, BS.ByteString)]+parseAtts = either (const Nothing) (Just . fst) . runError . atts . parse++isTextChar :: Char -> Bool+isTextChar = (`elem` (['0' .. '9'] ++ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ "-"))++[papillon|++source: ByteString++atts :: [(ByteString, ByteString)]+	= a:att ',' as:atts		{ a : as }+	/ a:att				{ [a] }++att :: (ByteString, ByteString)+	= k:(<(`notElem` "=")>)+ '=' v:txt	{ (pack k, v) }++txt :: ByteString+	= '"' t:(<(`notElem` "\"")>)* '"'	{ pack t }+	/ t:(<isTextChar>)+			{ pack t }++|]++{-+instance Source ByteString where+	type Token ByteString = Char+	data Pos ByteString = NoPos+	getToken = BSC.uncons+	initialPos = NoPos+	updatePos _ _ = NoPos+	-}
+ src/Network/Sasl/DigestMd5/Server.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeSynonymInstances,+	PackageImports #-}++module Network.Sasl.DigestMd5.Server (+	Success(..), SaslError(..), sasl, mkStored) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import "monads-tf" Control.Monad.Error.Class+import Data.Pipe++import qualified Data.ByteString as BS++import Network.Sasl+import Network.Sasl.DigestMd5.DigestMd5+import Network.Sasl.DigestMd5.Papillon++sasl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, SaslError (ErrorType m) ) =>+	(BS.ByteString -> m BS.ByteString) -> (+		BS.ByteString,+		(Bool, Pipe BS.ByteString (Either Success BS.ByteString) m ()) )+sasl rt = ("DIGEST-MD5", server $ digestMd5Sv rt)++digestMd5Sv :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) =>+	(BS.ByteString -> m BS.ByteString) -> Server m+digestMd5Sv lu = Server Nothing (zip svs cls) (Just $ mkRspAuth lu)++svs :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => [Send m]+svs = [mkChallenge]++cls :: (MonadState m, SaslState (StateType m)) => [Receive m]+cls = [putResponse]++mkChallenge :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m)) => Send m+mkChallenge = do+	st <- gets getSaslState+	let	Just rlm = lookup "realm" st+		Just n = lookup "nonce" st+		Just q = lookup "qop" st+		Just c = lookup "charset" st+		Just a = lookup "algorithm" st+	return $ fromDigestMd5Challenge DigestMd5Challenge {+		realm = rlm,+		nonce = n,+		qop = q,+		charset = c,+		algorithm = a }+++mkRspAuth :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m)) =>+	(BS.ByteString -> m BS.ByteString) -> Send m+mkRspAuth lu = do+	st <- gets getSaslState+	let	Just un = lookup "username" st+	stored <- lu un+	let	Just q = lookup "qop" st+		Just uri = lookup "digest-uri" st+		Just n = lookup "nonce" st+		Just nc = lookup "nc" st+		Just cn = lookup "cnonce" st+		Just rsp = lookup "response" st+		clc = digestMd5 True stored q uri n nc cn+		clcs = digestMd5 False stored q uri n nc cn+	unless (clc == rsp) . throwError $ strMsg "not authenticated"+	return $ "rspauth=" `BS.append` clcs++putResponse :: (MonadState m, SaslState (StateType m)) => Receive m+putResponse bs = do+	st <- gets getSaslState+	let	Just rs = parseAtts bs+		Just rlm = lookup "realm" rs+--		Just n = lookup "nonce" rs+		Just q = lookup "qop" rs+		Just c = lookup "charset" rs+		Just un = lookup "username" rs+		Just uri = lookup "digest-uri" rs+		Just cn = lookup "cnonce" rs+		Just nc = lookup "nc" rs+		Just rsp = lookup "response" rs+	modify . putSaslState $ [+		("realm", rlm),+--		("nonce", n),+		("qop", q),+		("charset", c),+		("username", un),+		("digest-uri", uri),+		("cnonce", cn),+		("nc", nc),+		("response", rsp) ] ++ st
+ src/Network/Sasl/External/Client.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.Sasl.External.Client (sasl) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe++import qualified Data.ByteString as BS++import Network.Sasl++sasl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => (+	BS.ByteString,+	(Bool, Pipe (Either Success BS.ByteString) BS.ByteString m ()) )+sasl = ("EXTERNAL", client script)++script :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => Client m+script = Client (Just clientMessage) [] Nothing++clientMessage :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => Send m+clientMessage = do+	st <- gets getSaslState+	let	Just username = lookup "username" st+	return username
+ src/Network/Sasl/External/Server.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.Sasl.External.Server (sasl) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe++import qualified Data.ByteString as BS++import Network.Sasl++sasl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, SaslError (ErrorType m) ) =>+	(BS.ByteString -> m ()) -> (+		BS.ByteString,+		(Bool, Pipe BS.ByteString (Either Success BS.ByteString) m ()) )+sasl rt = ("EXTERNAL", server $ script rt)++script :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) =>+	(BS.ByteString -> m ()) -> Server m+script rt = Server (Just $ clientMessage rt) [] Nothing++clientMessage :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) =>+	(BS.ByteString -> m ()) -> Receive m+clientMessage rt rs = do+	rt rs+--	unless ok . throwError $ strMsg "not authenticate"+	st <- gets getSaslState+	modify . putSaslState $ ("username", rs) : st
+ src/Network/Sasl/Plain/Client.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.Sasl.Plain.Client (sasl) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Maybe+import Data.Pipe++import qualified Data.ByteString as BS++import Network.Sasl++sasl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => (+	BS.ByteString,+	(Bool, Pipe (Either Success BS.ByteString) BS.ByteString m ()) )+sasl = ("PLAIN", client script)++script :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => Client m+script = Client (Just clientMessage) [] Nothing++clientMessage :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => Send m+clientMessage = do+	st <- gets getSaslState+	let	az = fromMaybe "" $ lookup "authzid" st+		Just ac = lookup "authcid" st+		Just ps = lookup "password" st+	return $ BS.concat [az, "\0", ac, "\0", ps]
+ src/Network/Sasl/Plain/Server.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.Sasl.Plain.Server (sasl) where++import Control.Arrow+import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Pipe++import qualified Data.ByteString as BS++import Network.Sasl++sasl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, SaslError (ErrorType m) ) =>+	(BS.ByteString -> BS.ByteString -> BS.ByteString -> m ()) -> (+		BS.ByteString,+		(Bool, Pipe BS.ByteString (Either Success BS.ByteString) m ()) )+sasl rt = ("PLAIN", server $ script rt)++readResponse :: BS.ByteString -> (BS.ByteString, BS.ByteString, BS.ByteString)+readResponse rs = (az, ac, ps)+	where+	(az, rst) = second BS.tail $ BS.span (/= 0) rs+	(ac, ps) = second BS.tail $ BS.span (/= 0) rst++script :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) =>+	(BS.ByteString -> BS.ByteString -> BS.ByteString -> m ()) -> Server m+script rt = Server (Just $ clientMessage rt) [] Nothing++clientMessage :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) =>+	(BS.ByteString -> BS.ByteString -> BS.ByteString -> m ()) -> Receive m+clientMessage rt rs = do+	let (az, ac, ps) = readResponse rs+	rt az ac ps+--	unless ok . throwError $ strMsg "not authenticate"+	st <- gets getSaslState+	modify . putSaslState $ ("username", ac) : st
+ src/Network/Sasl/ScramSha1/Client.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.Sasl.ScramSha1.Client (+	sasl, saltedPassword, clientKey, serverKey ) where++import Control.Applicative+import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import "monads-tf" Control.Monad.Error.Class+import Data.Pipe++import Network.Sasl+import Network.Sasl.ScramSha1.ScramSha1++import qualified Data.ByteString.Char8 as BSC++sasl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => (+	BSC.ByteString,+	(Bool, Pipe (Either Success BSC.ByteString) BSC.ByteString m ()) )+sasl = ("SCRAM-SHA-1", client scramSha1Client)++scramSha1Client :: (+	MonadState m, SaslState (StateType m),+	MonadError m, Error (ErrorType m) ) => Client m+scramSha1Client =+	Client (Just clientFirst) [(serverFirst, clientFinal)] (Just serverFinal)++clientFirst :: (MonadState m, SaslState (StateType m)) => Send m+clientFirst = do+	st <- gets getSaslState+	let	Just un = lookup "username" st+		Just nnc = lookup "cnonce" st+		cfmb = clientFirstMessageBare un nnc+	modify . putSaslState $ ("client-first-message-bare", cfmb) : st+	return $ "n,," `BSC.append` cfmb++serverFirst :: (MonadState m, SaslState (StateType m)) => Receive m+serverFirst ch = do+	let Just (nnc, slt, i) = readServerFirstMessage ch+	st <- gets getSaslState+	modify . putSaslState $ [+		("server-first-message", ch),+		("nonce", nnc),+		("salt", slt),+		("i", BSC.pack $ show i) ] ++ st++clientFinal :: (MonadState m, SaslState (StateType m)) => Send m+clientFinal = do+	st <- gets getSaslState+	let	Just ck = case lookup "ClientKey" st of+			Just c -> Just c+			_ -> case lookup "SaltedPassword" st of+				Just sp -> Just $ clientKey sp+				_ -> do	(ps, slt, i) <- psslti st+				{-+				_ -> do	ps <- lookup "password" st+					slt <- lookup "salt" st+					i <- lookup "i" st+					-}+					return . clientKey . saltedPassword ps slt+						. read $ BSC.unpack i+		cb = "n,,"+		Just nonce = lookup "nonce" st+		Just cfmb = lookup "client-first-message-bare" st+		Just sfm = lookup "server-first-message" st+		cfmwop = clientFinalMessageWithoutProof cb nonce+		am = BSC.concat [cfmb, ",", sfm, ",", cfmwop]+	modify . putSaslState $ ("client-final-message-without-proof", cfmwop) : st+	return $ cfmwop `BSC.append` ",p="+		`BSC.append` clientProof ck am+--			(clientKey $ saltedPassword ps slt . read $ BSC.unpack i)+--			am++psslti :: [(BSC.ByteString, BSC.ByteString)] ->+	Maybe (BSC.ByteString, BSC.ByteString, BSC.ByteString)+psslti st = (,,) <$> lookup "password" st <*> lookup "salt" st <*> lookup "i" st++serverFinal :: (+		MonadState m, SaslState (StateType m),+		MonadError m, Error (ErrorType m)+	) => Receive m+serverFinal ch = do+	let Just v = readServerFinalMessage ch+	st <- gets getSaslState+	let	Just sk = case lookup "ServerKey" st of+			Just s -> Just s+			_ -> case lookup "SaltedPassword" st of+				Just sp -> Just $ serverKey sp+				_ -> do	(ps, slt, i) <- psslti st+				{-+				_ -> do	ps <- lookup "password" st+					slt <- lookup "salt" st+					i <- lookup "i" st+					-}+					return . serverKey . saltedPassword ps slt+						. read $ BSC.unpack i+		Just cfmb = lookup "client-first-message-bare" st+		Just sfm = lookup "server-first-message" st+		Just cfmwop = lookup "client-final-message-without-proof" st+		am = BSC.concat [cfmb, ",", sfm, ",", cfmwop]+		sfnm = serverFinalMessage sk+--			(serverKey . saltedPassword ps slt . read $ BSC.unpack i)+			am+	let Just v' = readServerFinalMessage sfnm+	unless (v == v') . throwError $ strMsg "serverFinal: bad"+	modify . putSaslState $ [("verify", v), ("sfm", sfm)] ++ st
+ src/Network/Sasl/ScramSha1/Fields.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Sasl.ScramSha1.Fields (readFields) where++import qualified Data.ByteString.Char8 as BSC++readFields :: BSC.ByteString -> [(BSC.ByteString, BSC.ByteString)]+readFields = map sepKV . sepByComma++sepKV :: BSC.ByteString -> (BSC.ByteString, BSC.ByteString)+sepKV bs = case BSC.span (/= '=') bs of+	(k, "") -> (k, "")+	(k, v) -> (k, BSC.tail v)++sepByComma :: BSC.ByteString -> [BSC.ByteString]+sepByComma bs = case BSC.span (/= ',') bs of+	(itm, "") -> [itm]+	(itm, rst) -> itm : sepByComma (BSC.tail rst)
+ src/Network/Sasl/ScramSha1/Functions.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Sasl.ScramSha1.Functions (+	xo, SHA1.hash,++	saltedPassword,+	clientKey,+	storedKey,+	serverKey,++	clientSignature,+	clientProof,+	serverSignature,+	) where++import Data.Bits++import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Crypto.Hash.SHA1 as SHA1++import Network.Sasl.ScramSha1.Hmac++int1 :: BS.ByteString+int1 = "\0\0\0\1"++xo :: BS.ByteString -> BS.ByteString -> BS.ByteString+"" `xo` b2 = b2+b1 `xo` "" = b1+b1 `xo` b2 = BS.pack $ zipWith xor (BS.unpack b1) (BS.unpack b2)++hi :: BS.ByteString -> BS.ByteString -> Int -> BS.ByteString+hi str salt i =+	foldl1 xo . take i . tail . iterate (hmac SHA1.hash 64 str) $ salt `BS.append` int1++saltedPassword :: BS.ByteString -> BS.ByteString -> Int -> BS.ByteString+saltedPassword = hi++clientKey :: BS.ByteString -> BS.ByteString+clientKey sp = hmac SHA1.hash 64 sp "Client Key"++storedKey :: BS.ByteString -> BS.ByteString+storedKey = SHA1.hash . clientKey++clientSignature :: BS.ByteString -> BS.ByteString -> BS.ByteString+clientSignature = hmac SHA1.hash 64++clientProof :: BS.ByteString -> BS.ByteString -> BS.ByteString+clientProof ck am = B64.encode $ ck `xo` clientSignature (SHA1.hash ck) am++serverKey :: BS.ByteString -> BS.ByteString+serverKey sp = hmac SHA1.hash 64 sp "Server Key"++serverSignature :: BS.ByteString -> BS.ByteString -> BS.ByteString+serverSignature sk am = B64.encode $ hmac SHA1.hash 64 sk am
+ src/Network/Sasl/ScramSha1/Hmac.hs view
@@ -0,0 +1,33 @@+module Network.Sasl.ScramSha1.Hmac (hmac, bsToHex) where++import Data.Word+import Data.Bits+import Numeric++import qualified Data.ByteString as BS++type Hash = BS.ByteString -> BS.ByteString++ipad, opad :: [Word8]+ipad = repeat 0x36+opad = repeat 0x5c++hmac :: Hash -> Int -> BS.ByteString -> BS.ByteString -> BS.ByteString+hmac h bs k = h . (makePad opad k' `BS.append`) . h . (makePad ipad k' `BS.append`)+	where+	k' = makeKey h bs k++makeKey :: Hash -> Int -> BS.ByteString -> BS.ByteString+makeKey h bs k+	| BS.length k > bs = makeKey h bs $ h k+	| otherwise = k `BS.append` BS.replicate (bs - BS.length k) 0++makePad :: [Word8] -> BS.ByteString -> BS.ByteString+makePad iop = BS.pack . mkp iop . BS.unpack+	where+	mkp _ [] = []+	mkp (p : ps) (k : ks) = p `xor` k : mkp ps ks+	mkp _ _ = error "makePad: bad"++bsToHex :: BS.ByteString -> String+bsToHex = concatMap (`showHex` "") . BS.unpack
+ src/Network/Sasl/ScramSha1/ScramSha1.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Sasl.ScramSha1.ScramSha1 (+	clientFirstMessageBare,+	serverFirstMessage,+	clientFinalMessageWithoutProof,+	serverFinalMessage,++	readClientFirstMessage,+	readServerFirstMessage,+	readClientFinalMessage,+	readServerFinalMessage,++	xo, hash,+	saltedPassword, clientKey, storedKey, serverKey,+	clientSignature, clientProof,+	) where++import Control.Applicative++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Base64 as B64++import Network.Sasl.ScramSha1.Fields+import Network.Sasl.ScramSha1.Functions++clientFirstMessageBare :: BS.ByteString -> BS.ByteString -> BS.ByteString+clientFirstMessageBare un nnc = BS.concat ["n=", un, ",r=", nnc]++serverFirstMessage :: BS.ByteString -> BS.ByteString -> Int -> BS.ByteString+serverFirstMessage snnc slt i = BS.concat+	["r=", snnc, ",s=", B64.encode slt, ",i=", BSC.pack $ show i]++clientFinalMessageWithoutProof :: BS.ByteString -> BS.ByteString -> BS.ByteString+clientFinalMessageWithoutProof cb snnc =+	BS.concat ["c=", B64.encode cb, ",r=", snnc]++serverFinalMessage :: BS.ByteString -> BS.ByteString -> BS.ByteString+serverFinalMessage sk am = BS.concat ["v=", serverSignature sk am]+--	serverSignature (serverKey $ saltedPassword ps slt i) am ]++readClientFirstMessage :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)+readClientFirstMessage rs = case BS.splitAt 3 rs of+	("n,,", rs') -> do+		let kv = readFields rs'+		(,) <$> lookup "n" kv <*> lookup "r" kv+	_ -> Nothing++readServerFirstMessage :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString, Int)+readServerFirstMessage ch = do+	let kv = readFields ch+	(,,)	<$> lookup "r" kv+		<*> ((\(Right r) -> r) . B64.decode <$> lookup "s" kv)+		<*> (read . BSC.unpack <$> lookup "i" kv)++readClientFinalMessage ::+ 	BS.ByteString -> Maybe (BS.ByteString, BS.ByteString, BS.ByteString)+readClientFinalMessage rs = do+	let kv = readFields rs+	(,,)	<$> ((\(Right r) -> r) . B64.decode <$> lookup "c" kv)+		<*> lookup "r" kv+		<*> ((\(Right r) -> r) . B64.decode <$> lookup "p" kv)++readServerFinalMessage :: BS.ByteString -> Maybe BS.ByteString+readServerFinalMessage = lookup "v" . readFields
+ src/Network/Sasl/ScramSha1/Server.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.Sasl.ScramSha1.Server (sasl, salt) where++import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import "monads-tf" Control.Monad.Error.Class+import Data.Pipe++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++import Network.Sasl+import Network.Sasl.ScramSha1.ScramSha1++sasl :: (+	MonadState m, SaslState (StateType m),+	MonadError m, SaslError (ErrorType m) ) =>+	(BS.ByteString -> m (BS.ByteString, BS.ByteString, BS.ByteString, Int)) -> (+		BSC.ByteString,+		(Bool, Pipe BS.ByteString (Either Success BS.ByteString) m ()) )+sasl rt = ("SCRAM-SHA-1", server $ scramSha1Server rt)++salt :: BSC.ByteString -> BSC.ByteString -> Int -> (BSC.ByteString, BSC.ByteString)+salt ps slt i = (storedKey sp, serverKey sp)+	where sp = saltedPassword ps slt i++scramSha1Server :: (+		MonadState m, SaslState (StateType m),+		MonadError m, Error (ErrorType m) ) =>+	(BSC.ByteString -> m (BSC.ByteString, BSC.ByteString, BSC.ByteString, Int))+		-> Server m+scramSha1Server rt = Server+	(Just clientFirst) [(serverFirst rt, clientFinal rt)] (Just $ serverFinal rt)++clientFirst :: (MonadState m, SaslState (StateType m)) => Receive m+clientFirst rs = do+	let Just (un, cnnc) = readClientFirstMessage rs+	st <- gets getSaslState+	modify . putSaslState $ [+		("client-first-message-bare", BSC.drop 3 rs),+		("username", un),+		("cnonce", cnnc) ] ++ st++serverFirst :: (MonadState m, SaslState (StateType m)) =>+	(BSC.ByteString -> m (BSC.ByteString, BSC.ByteString, BSC.ByteString, Int))+		-> Send m+serverFirst rt = do+	st <- gets getSaslState+	let	Just un = lookup "username" st+		Just cnnc = lookup "cnonce" st+		Just snnc = lookup "snonce" st+--		Just slt = lookup "salt" st+--		Just i = lookup "i" st+	(slt, _, _, i) <- rt un+	let	sfm = serverFirstMessage (cnnc `BSC.append` snnc) slt i+	modify . putSaslState $ ("server-first-message", sfm) : st+	return sfm++dropProof :: String -> String+dropProof "" = ""+dropProof (',' : 'p' : '=' : _) = ""+dropProof (c : cs) = c : dropProof cs++dropProofBS :: BSC.ByteString -> BSC.ByteString+dropProofBS = BSC.pack . dropProof . BSC.unpack++clientFinal :: (+		MonadState m, SaslState (StateType m),+		MonadError m, Error (ErrorType m) ) =>+	(BSC.ByteString -> m (BSC.ByteString, BSC.ByteString, BSC.ByteString, Int))+		-> Receive m+clientFinal rt rs = do+	st <- gets getSaslState+	let	Just ("n,,", nnc, prf) = readClientFinalMessage rs+		Just un = lookup "username" st+	(_, sk, _, _) <- rt un+	let	Just cfmb = lookup "client-first-message-bare" st+		Just sfm = lookup "server-first-message" st+		cfmwop = dropProofBS rs+		am = BSC.concat [cfmb, ",", sfm, ",", cfmwop]+		cs = clientSignature sk am+		ck = prf `xo` cs+		sk' = hash ck+	unless (sk == sk') . throwError $ strMsg "clientFinal: bad"+	modify . putSaslState $ [+		("client-final-message-without-proof", cfmwop),+		("nonce", nnc),+		("proof", prf),+		("StoredKey", sk),+		("StoredKey'", sk')+		] ++ st++serverFinal :: (MonadState m, SaslState (StateType m)) =>+	(BSC.ByteString -> m (BSC.ByteString, BSC.ByteString, BSC.ByteString, Int))+		-> Send m+serverFinal rt = do+	st <- gets getSaslState+	let	Just un = lookup "username" st+	(_, _, sk, _) <- rt un+	let	Just cfmb = lookup "client-first-message-bare" st+		Just sfm = lookup "server-first-message" st+		Just cfmwop = lookup "client-final-message-without-proof" st+		am = BSC.concat [cfmb, ",", sfm, ",", cfmwop]+	return $ serverFinalMessage sk am