module Network.EAP.Authentication (authenticateMSCHAPv2,
generateAuthenticatorResponse,
generateNTResponse,
ntPasswordHash) where
import Prelude hiding (concatMap)
import Data.Bits ((.|.), (.&.), complement, shiftL, shiftR, xor)
import Data.ByteString.Lazy.Char8 (pack, unpack)
import Data.ByteString.Builder (toLazyByteString, byteStringHex)
import Data.ByteString.Lazy (ByteString, append, cons, concatMap, fromStrict, toStrict)
import Data.ByteArray (convert)
import Data.Char (toUpper)
import Control.Monad.Except (ExceptT(..), Except, throwError)
import Control.Monad.State.Lazy (State, execState, modify)
import Crypto.Cipher.DES (DES)
import Crypto.Cipher.Types (cipherInit, ecbEncrypt)
import Crypto.Hash.Algorithms (MD4, SHA1(..))
import Crypto.Hash (Context,
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
passwordHash = do
let peerChallenge = getMSCHAPv2ResponsePeerChallenge
username = getMSCHAPv2ResponseName
r <- generateNTResponse challenge peerChallenge username passwordHash
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 passwordHash = do
let challenge = challengeHash peerChallenge authenticatorChallenge username
zPasswordHash = (toStrict 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
generateAuthenticatorResponse :: ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> Except CryptoError ByteString
generateAuthenticatorResponse username passwordHash ntResponse authChallenge peerChallenge = do
let passwordHashHash = md4Hash passwordHash
digest1 = sha1Hash $ do
hash . fromStrict $ passwordHashHash
hash ntResponse
hash magic1
challenge = challengeHash peerChallenge authChallenge username
digest2 = sha1Hash $ do
hash . fromStrict $ digest1
hash . fromStrict $ challenge
hash magic2
return $ "S=" `append` (pack . fmap toUpper . unpack . toLazyByteString $ byteStringHex digest2)
where magic1 = "Magic server to client signing constant"
magic2 = "Pad to make it do more than one iteration"
challengeHash :: ByteString
-> ByteString
-> ByteString
-> SB.ByteString
challengeHash peerChallenge authenticatorChallenge username =
SB.take 8 . sha1Hash $ do
hash peerChallenge
hash authenticatorChallenge
hash username
ntPasswordHash :: ByteString -> SB.ByteString
ntPasswordHash = md4Hash . concatMap with0s
where with0s = flip cons "\NUL"
md4Hash :: ByteString -> SB.ByteString
md4Hash = convert . (hashlazy :: ByteString -> Digest MD4)
sha1Hash :: State (Context SHA1) () -> SB.ByteString
sha1Hash = convert . hashFinalize . flip execState ctx0
where ctx0 = hashInitWith SHA1
hash :: ByteString -> State (Context SHA1) ()
hash = modify . flip hashUpdate . toStrict
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