{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
-- |
-- Module      : Network.TLS.Handshake.Server
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Network.TLS.Handshake.Server
    ( handshakeServer
    , handshakeServerWith
    ) where

import Network.TLS.Crypto
import Network.TLS.Context
import Network.TLS.Session
import Network.TLS.Struct
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Packet
import Network.TLS.Extension
import Network.TLS.IO
import Network.TLS.State hiding (getNegotiatedProtocol)
import Network.TLS.Receiving
import Network.TLS.Measurement
import Data.Maybe
import Data.List (intersect)
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()

import Data.Certificate.X509(X509, certSubjectDN, x509Cert)

import Control.Applicative ((<$>))
import Control.Monad.State
import qualified Control.Exception as E

import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Certificate

-- Put the server context in handshake mode.
--
-- Expect to receive as first packet a client hello handshake message
--
-- This is just a helper to pop the next message from the recv layer,
-- and call handshakeServerWith.
handshakeServer :: MonadIO m => ServerParams -> Context -> m ()
handshakeServer sparams ctx = do
        hss <- recvPacketHandshake ctx
        case hss of
                [ch] -> handshakeServerWith sparams ctx ch
                _    -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss)

-- | Put the server context in handshake mode.
--
-- Expect a client hello message as parameter.
-- This is useful when the client hello has been already poped from the recv layer to inspect the packet.
--
-- When the function returns, a new handshake has been succesfully negociated.
-- On any error, a HandshakeFailed exception is raised.
--
-- handshake protocol (<- receiving, -> sending, [] optional):
--    (no session)           (session resumption)
--      <- client hello       <- client hello
--      -> server hello       -> server hello
--      -> [certificate]
--      -> [server key xchg]
--      -> [cert request]
--      -> hello done
--      <- [certificate]
--      <- client key xchg
--      <- [cert verify]
--      <- change cipher      -> change cipher
--      <- [NPN]
--      <- finish             -> finish
--      -> change cipher      <- change cipher
--      -> finish             <- finish
--
handshakeServerWith :: MonadIO m => ServerParams -> Context -> Handshake -> m ()
handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts _) = do
        -- check if policy allow this new handshake to happens
        handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)
        unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")
        updateMeasure ctx incrementNbHandshakes

        -- Handle Client hello
        usingState_ ctx $ processHandshake clientHello
        when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
        when (not $ elem ver (pAllowedVersions params)) $
                throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)
        when (commonCipherIDs == []) $
                throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure)
        when (null commonCompressions) $
                throwCore $ Error_Protocol ("no compression in common with the client", True, HandshakeFailure)
        usingState_ ctx $ modify (\st -> st
                { stVersion       = ver
                , stPendingCipher = Just usedCipher
                , stCompression   = usedCompression
                })

        resumeSessionData <- case clientSession of
                (Session (Just clientSessionId)) -> withSessionManager params (\s -> liftIO $ sessionResume s clientSessionId)
                (Session Nothing)                -> return Nothing
        case resumeSessionData of
                Nothing -> do
                        handshakeSendServerData
                        liftIO $ contextFlush ctx
                        -- Receive client info until client Finished.
                        recvClientData sparams ctx
                        sendChangeCipherAndFinish ctx False
                Just sessionData -> do
                        usingState_ ctx (setSession clientSession True)
                        serverhello <- makeServerHello clientSession
                        sendPacket ctx $ Handshake [serverhello]
                        usingState_ ctx $ setMasterSecret $ sessionSecret sessionData
                        sendChangeCipherAndFinish ctx False
                        recvChangeCipherAndFinish ctx
        handshakeTerminate ctx
        where
                params             = ctxParams ctx
                commonCipherIDs    = intersect ciphers (map cipherID $ pCiphers params)
                commonCiphers      = filter (flip elem commonCipherIDs . cipherID) (pCiphers params)
                usedCipher         = (onCipherChoosing sparams) ver commonCiphers
                commonCompressions = compressionIntersectID (pCompressions params) compressions
                usedCompression    = head commonCompressions
                srvCerts           = map fst $ pCertificates params
                privKeys           = map snd $ pCertificates params
                needKeyXchg        = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher
                clientRequestedNPN = isJust $ lookup extensionID_NextProtocolNegotiation exts

                ---

                -- When the client sends a certificate, check whether
                -- it is acceptable for the application.
                --
                ---

                makeServerHello session = do
                        srand <- getStateRNG ctx 32 >>= return . ServerRandom
                        case privKeys of
                                (Just privkey : _) -> usingState_ ctx $ setPrivateKey privkey
                                _                  -> return () -- return a sensible error

                        -- in TLS12, we need to check as well the certificates we are sending if they have in the extension
                        -- the necessary bits set.
                        secReneg   <- usingState_ ctx getSecureRenegotiation
                        secRengExt <- if secReneg
                                then do
                                        vf <- usingState_ ctx $ do
                                                cvf <- getVerifiedData True
                                                svf <- getVerifiedData False
                                                return $ extensionEncode (SecureRenegotiation cvf $ Just svf)
                                        return [ (0xff01, vf) ]
                                else return []
                        nextProtocols <-
                          if clientRequestedNPN
                            then liftIO $ onSuggestNextProtocols params
                            else return Nothing
                        npnExt <- case nextProtocols of
                                    Just protos -> do usingState_ ctx $ do setExtensionNPN True
                                                                           setServerNextProtocolSuggest protos
                                                      return [ ( extensionID_NextProtocolNegotiation
                                                               , extensionEncode $ NextProtocolNegotiation protos) ]
                                    Nothing -> return []
                        let extensions = secRengExt ++ npnExt
                        usingState_ ctx (setVersion ver >> setServerRandom srand)
                        return $ ServerHello ver srand session (cipherID usedCipher)
                                                       (compressionID usedCompression) extensions

                handshakeSendServerData = do
                        serverSession <- newSession ctx
                        usingState_ ctx (setSession serverSession False)
                        serverhello   <- makeServerHello serverSession
                        -- send ServerHello & Certificate & ServerKeyXchg & CertReq
                        sendPacket ctx $ Handshake [ serverhello, Certificates srvCerts ]
                        when needKeyXchg $ do
                                let skg = SKX_RSA Nothing
                                sendPacket ctx (Handshake [ServerKeyXchg skg])

                        -- FIXME we don't do this on a Anonymous server

                        -- When configured, send a certificate request
                        -- with the DNs of all confgure CA
                        -- certificates.
                        --
                        when (serverWantClientCert sparams) $ do
                          usedVersion <- usingState_ ctx $ stVersion <$> get
                          let certTypes = [ CertificateType_RSA_Sign ]
                              hashSigs = if usedVersion < TLS12
                                         then Nothing
                                         else Just (pHashSignatures $ ctxParams ctx)
                              creq = CertRequest certTypes hashSigs
                                       (map extractCAname $ serverCACertificates sparams)
                          usingState_ ctx $ setCertReqSent True
                          sendPacket ctx (Handshake [creq])

                        -- Send HelloDone
                        sendPacket ctx (Handshake [ServerHelloDone])

                extractCAname :: X509 -> DistinguishedName
                extractCAname cert = certSubjectDN (x509Cert cert)

handshakeServerWith _ _ _ = fail "unexpected handshake type received. expecting client hello"

-- | receive Client data in handshake until the Finished handshake.
--
--      <- [certificate]
--      <- client key xchg
--      <- [cert verify]
--      <- change cipher
--      <- [NPN]
--      <- finish
--
recvClientData :: MonadIO m => ServerParams -> Context -> m ()
recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate)
    where
                processClientCertificate (Certificates certs) = do

                  -- Call application callback to see whether the
                  -- certificate chain is acceptable.
                  --
                  usage <- liftIO $ E.catch (onClientCertificate sparams certs) rejectOnException
                  case usage of
                    CertificateUsageAccept        -> return ()
                    CertificateUsageReject reason -> certificateRejected reason

                  -- Remember cert chain for later use.
                  --
                  usingState_ ctx $ setClientCertChain certs

                  -- FIXME: We should check whether the certificate
                  -- matches our request and that we support
                  -- verifying with that certificate.

                  return $ RecvStateHandshake processClientKeyExchange

                processClientCertificate p = processClientKeyExchange p

                processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
                processClientKeyExchange p                 = unexpected (show p) (Just "client key exchange")

                -- Check whether the client correctly signed the handshake.
                -- If not, ask the application on how to proceed.
                --
                processCertificateVerify (Handshake [hs@(CertVerify mbHashSig (CertVerifyData bs))]) = do
                    usingState_ ctx $ processHandshake hs
                    chain <- usingState_ ctx $ getClientCertChain
                    case chain of
                        Just (_:_) -> return ()
                        _          -> throwCore $ Error_Protocol ("change cipher message expected", True, UnexpectedMessage)

                    -- Fetch all handshake messages up to now.
                    msgs <- usingState_ ctx $ B.concat <$> getHandshakeMessages

                    usedVersion <- usingState_ ctx $ stVersion <$> get

                    (signature, hsh) <- case usedVersion of
                        SSL3 -> do
                            Just masterSecret <- usingState_ ctx $ getMasterSecret
                            let digest = generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit hashMD5SHA1) msgs)
                                hsh = HashDescr id id
                            return (digest, hsh)

                        x | x == TLS10 || x == TLS11 -> do
                            let hashf bs' = hashFinal (hashUpdate (hashInit hashMD5SHA1) bs')
                                hsh = HashDescr hashf id
                            return (msgs,hsh)
                        _ -> do
                            let Just sentHashSig = mbHashSig
                            hsh <- getHashAndASN1 sentHashSig
                            return (msgs,hsh)

                    -- Verify the signature.
                    verif <- usingState_ ctx $ verifyRSA hsh signature bs

                    case verif of
                        True -> do
                            -- When verification succeeds, commit the
                            -- client certificate chain to the context.
                            --
                            Just certs <- usingState_ ctx $ getClientCertChain
                            usingState_ ctx $ setClientCertificateChain certs
                            return ()

                        False -> do
                            -- Either verification failed because of an
                            -- invalid format (with an error message), or
                            -- the signature is wrong.  In either case,
                            -- ask the application if it wants to
                            -- proceed, we will do that.
                            res <- liftIO $ onUnverifiedClientCert sparams
                            if res
                                then do
                                    -- When verification fails, but the
                                    -- application callbacks accepts, we
                                    -- also commit the client certificate
                                    -- chain to the context.
                                    Just certs <- usingState_ ctx $ getClientCertChain
                                    usingState_ ctx $ setClientCertificateChain certs
                                else throwCore $ Error_Protocol ("verification failed", True, BadCertificate)
                    return $ RecvStateNext expectChangeCipher

                processCertificateVerify p = do
                    chain <- usingState_ ctx $ getClientCertChain
                    case chain of
                        Just (_:_) -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage)
                        _          -> return ()
                    expectChangeCipher p

                expectChangeCipher ChangeCipherSpec = do
                    npn <- usingState_ ctx getExtensionNPN
                    return $ RecvStateHandshake $ if npn then expectNPN else expectFinish
                expectChangeCipher p                = unexpected (show p) (Just "change cipher")

                expectNPN (HsNextProtocolNegotiation _) = return $ RecvStateHandshake expectFinish
                expectNPN p                             = unexpected (show p) (Just "Handshake NextProtocolNegotiation")

                expectFinish (Finished _) = return RecvStateDone
                expectFinish p            = unexpected (show p) (Just "Handshake Finished")
