module Network.EAP.Authentication (authenticateMSCHAPv2,
generateNTResponse) where
import Prelude hiding (concatMap)
import Data.Bits ((.|.), (.&.), complement, shiftL, shiftR, xor)
import Data.ByteString.Lazy (ByteString, cons, concatMap, toStrict)
import Data.ByteArray (convert)
import Control.Monad.Except (ExceptT(..), Except, throwError)
import Control.Monad.State.Lazy (execState, modify)
import Crypto.Cipher.DES (DES)
import Crypto.Cipher.Types (cipherInit, ecbEncrypt)
import Crypto.Hash.Algorithms (MD4, SHA1(..))
import Crypto.Hash (Digest, hashFinalize, hashInitWith, hashUpdate, hashlazy)
import Crypto.Error (CryptoError, CryptoFailable(..))
import Network.EAP.Types
import qualified Data.ByteString as SB
authenticateMSCHAPv2
:: MSCHAPv2Data
-> ByteString
-> ByteString
-> Except CryptoError Bool
authenticateMSCHAPv2
MSCHAPv2ResponseData{ getMSCHAPv2ResponseData = MSCHAPv2ResponseDataField{..}, .. }
challenge
password = do
let peerChallenge = getMSCHAPv2ResponsePeerChallenge
username = getMSCHAPv2ResponseName
r <- generateNTResponse challenge peerChallenge username password
return $ r == toStrict getMSCHAPv2ResponseNTResponse
authenticateMSCHAPv2 msCHAPv2Data _ _ =
error $ "Invalid authentication attempt of " ++ show msCHAPv2Data
generateNTResponse :: ByteString
-> ByteString
-> ByteString
-> ByteString
-> Except CryptoError SB.ByteString
generateNTResponse authenticatorChallenge peerChallenge username password = do
let challenge = challengeHash
passwordHash = ntPasswordHash password
zPasswordHash = passwordHash `SB.append` SB.replicate 5 0
(pHash0, rest) = SB.splitAt 7 zPasswordHash
(pHash1, pHash2) = SB.splitAt 7 rest
r0 <- encryptDES pHash0 challenge
r1 <- encryptDES pHash1 challenge
r2 <- encryptDES pHash2 challenge
return $ r0 `SB.append` r1 `SB.append` r2
where challengeHash = SB.take 8 . convert . hashFinalize . flip execState ctx0 $ do
hash peerChallenge
hash authenticatorChallenge
hash username
hash = modify . flip hashUpdate . toStrict
ctx0 = hashInitWith SHA1
ntPasswordHash = convert . (hashlazy :: ByteString -> Digest MD4) . concatMap with0s
with0s = flip cons "\NUL"
encryptDES :: SB.ByteString -> SB.ByteString -> Except CryptoError SB.ByteString
encryptDES key msg = do
(cipher :: DES) <- ExceptT . return $ initCipher
ExceptT . return . Right $ ecbEncrypt cipher msg
where initCipher = case cipherInit $ addParity key of
CryptoFailed e -> throwError e
CryptoPassed c -> Right c
addParity :: SB.ByteString -> SB.ByteString
addParity = expand . SB.foldl f ((0, 0), SB.empty)
where f ((i, carry), acc) word =
let v = carry .|. (word `shiftR` i)
carry' = word `shiftL` (7 i)
v' = v .&. 0xfe
v'' = v' .|. (complement $ parity v') .&. 1
acc' = acc `SB.snoc` v''
in ((i+1, carry'), acc')
expand ((_, carry), str) = str `SB.snoc` carry
parity x0 = foldl (\x i -> x `xor` (x `shiftR` i)) x0 [1, 2, 4, 8, 16] .&. 1