module Network.Hermes.Core(
withHermes, CoreContext, TrustLevel(..), HermesID, HermesException(..)
,newContext, restoreContext, restoreContext', snapshotContext, addAuthority, setKeySignature
,myHermesID, setTimeout, timeout, setTrustLimit, snapshotContext'
,startListener
,connect, setHermesID
,send, send', recv, recv', NoTag(..), acceptType, refuseType
) where
import Prelude hiding(catch)
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Monad.Tools
import "monads-tf" Control.Monad.State
import Control.Concurrent.STM
import Control.Exception(throwIO, throw, onException, block, unblock, catch, IOException(..))
import Data.Typeable
import System.Log.Logger
import Data.Maybe
import Data.Word
import qualified Data.Set as S
import Data.Map(Map)
import qualified Data.Map as M
import qualified Network
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import System.IO(Handle, hFlush, hClose)
import qualified System.Timeout
import qualified Data.Serialize
import Data.Serialize(encode,decode,Serialize)
import Data.Serialize.Put
import Data.Serialize.Get
import Network.Hermes.Protocol
import Network.Hermes.Types
import Network.Hermes.Misc
import Network.Hermes.MChan
import qualified Network.Hermes.Net as N
import Codec.Crypto.AES.Random
import Codec.Crypto.RSA as RSA
import Codec.Crypto.AES.IO as AES
import Codec.Digest.SHA
hashKey :: PublicKey -> HermesID
hashKey = byteStringToInteger . hash SHA256 . encode
withHermes :: IO a -> IO a
withHermes = Network.withSocketsDo
hGet :: Handle -> Int -> IO B.ByteString
hGet h i = do
bs <- B.hGet h i
unless (B.length bs == i) $ throwIO EOF
return bs
cryptSend :: Connection
-> Int
-> B.ByteString
-> Int
-> B.ByteString
-> IO ()
cryptSend Connection{..} tagIndex tag messageIndex message = do
let header = runPut $ do
putWord32le $ fromIntegral $ B.length message
putWord32le $ fromIntegral $ B.length tag
putWord32le $ fromIntegral messageIndex
putWord32le $ fromIntegral tagIndex
headerHMAC = B.take 16 $ hmac SHA256 aesKey header
payloadHMAC = hmac SHA256 aesKey (BL.fromChunks [tag,message])
debugM "hermes.core" $ " message index: " ++ show messageIndex
debugM "hermes.core" $ " tag index : " ++ show tagIndex
debugM "hermes.core" $ " header HMAC : " ++ showBSasHex headerHMAC
debugM "hermes.core" $ " payload HMAC : " ++ showBSasHex payloadHMAC
debugM "hermes.core" $ " tag : " ++ showBSasHex tag
debugM "hermes.core" $ " message : " ++ showBSasHex message
forM_ [header,headerHMAC,payloadHMAC,tag,message] (\bs -> AES.crypt aesctx bs >>= B.hPut handle)
hFlush handle
cryptRecv :: Handle
-> B.ByteString
-> AESCtx
-> IO (Int,B.ByteString,Int,B.ByteString)
cryptRecv h key ctx = do
header <- AES.crypt ctx =<< hGet h 16
expectedHeaderHMAC <- AES.crypt ctx =<< hGet h 16
let (messageLength,tagLength,messageIndex,tagIndex) =
flip runGet' header $ liftM4 (,,,) getWord32le getWord32le getWord32le getWord32le
headerHMAC = B.take 16 $ hmac SHA256 key header
debugM "hermes.core" $ "Receiving message, type index " ++ show (messageIndex,tagIndex)
debugM "hermes.core" $ " header HMAC : " ++ showBSasHex headerHMAC
unless (headerHMAC == expectedHeaderHMAC) $ throwIO MessageError
expectedPayloadHMAC <- AES.crypt ctx =<< hGet h 32
tag <- AES.crypt ctx =<< hGet h (fromIntegral tagLength)
message <- AES.crypt ctx =<< hGet h (fromIntegral messageLength)
let payloadHMAC = hmac SHA256 key (BL.fromChunks [tag,message])
debugM "hermes.core" $ " payload HMAC: " ++ showBSasHex payloadHMAC
unless (payloadHMAC == expectedPayloadHMAC) $ throwIO MessageError
debugM "hermes.core" $ " tag : " ++ showBSasHex tag
debugM "hermes.core" $ " message : " ++ showBSasHex message
return (fromIntegral tagIndex, tag, fromIntegral messageIndex, message)
baseSend :: CoreContext
-> HermesID
-> Type
-> B.ByteString
-> Type
-> B.ByteString
-> IO ()
baseSend ctx uuid tagType tag msgType msg = trySend True
where
trySend firstTry = flip catch (handler firstTry) $ do
infoM "hermes.core" $ "Sending message, type " ++ show (tagType,msgType)
if uuid == myHermesID ctx
then do insertMessage ctx msgType tagType tag uuid msg
else do withConnection ctx uuid $ \conn -> do
let fetchIndex typeString = do
(typeIndex,sendType) <- atomically $ do
maybeIndex <- M.lookup typeString <$> readTVar (typeMap conn)
case maybeIndex of
Just index -> return (index,False)
Nothing -> do
index <- succ <$> readTVar (typeMax conn)
modifyTVar (typeMap conn) (M.insert typeString index)
writeTVar (typeMax conn) index
return (index,True)
when sendType $ cryptSend conn 0 B.empty 0 (encode (typeIndex,typeString))
return typeIndex
fetchIndex :: Type -> IO Int
tagIndex <- fetchIndex tagType
messageIndex <- fetchIndex msgType
cryptSend conn tagIndex tag messageIndex msg
atomically $ modifyTVar (peerFailures ctx) (M.insert uuid 0)
handler :: Bool -> IOException -> IO ()
handler firstTry e = do
noticeM "hermes.core" $ "IO error while sending: " ++ show e ++ if firstTry then ", retrying" else ""
killConnection ctx uuid
if firstTry then trySend False else return ()
killConnection :: CoreContext -> HermesID -> IO ()
killConnection ctx uuid = do
h <- atomically $ do
mvar <- M.lookup uuid <$> readTVar (peerConnections ctx)
var <- case mvar of
Nothing -> return Nothing
Just v -> Just . handle <$> takeTMVar v
modifyTVar (peerConnections ctx) (M.delete uuid)
return $ var
maybe (return ()) hClose h
send :: (Serialize msg, Typeable msg) => CoreContext -> HermesID -> msg -> IO ()
send cc uuid msg = send' cc uuid msg NoTag
data NoTag = NoTag
deriving(Typeable)
instance Data.Serialize.Serialize NoTag where
get = return NoTag
put _ = return ()
send' :: (Serialize msg, Typeable msg, Serialize tag, Typeable tag)
=> CoreContext -> HermesID -> msg -> tag -> IO ()
send' ctx uuid msg tag = baseSend ctx uuid (showType tag) (encode tag) (showType msg) (encode msg)
recv :: forall msg. (Serialize msg, Typeable msg) => CoreContext -> IO (HermesID,msg)
recv ctx = recv' ctx NoTag
recv' :: forall msg tag. (Serialize msg, Typeable msg, Serialize tag, Typeable tag)
=> CoreContext
-> tag
-> IO (HermesID,msg)
recv' ctx tag = do
let tagType = showType tag
messageType = showType (undefined :: msg)
key = (messageType,tagType,encode tag)
infoM "hermes.core" $ "Requesting message of type " ++ show (messageType,showType tag,encode tag)
acceptType ctx (undefined :: msg) tag
msg <- atomically $ readMChan (messageBox ctx) key
case msg of
Nothing -> throwIO RecvCancelled
Just msg' -> do
infoM "hermes.core" $ "Message of type " ++ show (tagType,messageType) ++ " returned"
return $ second decode' msg'
acceptType :: forall tag msg. (Typeable msg, Serialize tag, Typeable tag)
=> CoreContext
-> msg
-> tag
-> IO ()
acceptType CoreContext{messageBox} (showType -> messageType) tag = do
let key = (messageType,showType tag,encode tag)
debugM "hermes.core" $ "Accepting key: " ++ show key
atomically $ ensureMChan messageBox key
refuseType :: forall tag msg. (Typeable msg, Serialize tag, Typeable tag)
=> CoreContext
-> msg
-> tag
-> IO ()
refuseType CoreContext{messageBox} (showType -> messageType) tag = do
let key = (messageType,showType tag,encode tag)
debugM "hermes.core" $ "Refusing key: " ++ show key
atomically $ deleteMChan messageBox key
restoreContext' :: CoreContextSnapshot -> STM CoreContext
restoreContext' CoreContextSnapshot{..} = do
let myKey = myKeySnap
myPrivateKey = myPrivateKeySnap
myHermesID = myHermesIDSnap
myKeySignature <- newTVar myKeySignatureSnap
authorities <- newTVar authoritiesSnap
listeners <- newTVar S.empty
listenerKillers <- newTVar M.empty
peerAddress <- newTVar peerAddressSnap
peerKeys <- newTVar peerKeysSnap
peerConnections <- newTVar M.empty
peerFailures <- newTVar peerFailuresSnap
trustLimit <- newTVar trustLimitSnap
messageBox <- newMChan
timeLimit <- newTVar timeLimitSnap
return $ CoreContext {..}
restoreContext :: B.ByteString -> IO CoreContext
restoreContext (decode' -> snapshot) = do
infoM "hermes.core" "Restoring context from snapshot"
atomically $ restoreContext' snapshot
snapshotContext :: CoreContext -> STM CoreContextSnapshot
snapshotContext ctx = do
let myKeySnap = myKey ctx
myPrivateKeySnap = myPrivateKey ctx
myHermesIDSnap = myHermesID ctx
myKeySignatureSnap <- readTVar (myKeySignature ctx)
authoritiesSnap <- readTVar (authorities ctx)
peerAddressSnap <- readTVar (peerAddress ctx)
peerKeysSnap <- readTVar (peerKeys ctx)
trustLimitSnap <- readTVar (trustLimit ctx)
timeLimitSnap <- readTVar (timeLimit ctx)
peerFailuresSnap <- readTVar (peerFailures ctx)
return $ CoreContextSnapshot {..}
snapshotContext' :: CoreContext -> IO B.ByteString
snapshotContext' ctx = encode <$> atomically (snapshotContext ctx)
setHermesID :: CoreContext -> HermesID -> Maybe Address -> Maybe PeerKey -> IO ()
setHermesID ctx uuid address key = atomically $ do
when (isJust address) $ modifyTVar (peerAddress ctx) (M.insert uuid (fromJust address))
when (isJust key) $ modifyTVar (peerKeys ctx) (M.insert uuid (fromJust key))
setTrustLimit :: CoreContext -> TrustLevel -> IO ()
setTrustLimit ctx = atomically . writeTVar (trustLimit ctx)
setTimeout :: CoreContext -> Double -> IO ()
setTimeout ctx = atomically . writeTVar (timeLimit ctx)
timeout :: CoreContext -> IO a -> IO a
timeout ctx act = do
limit <- atomically $ readTVar (timeLimit ctx)
ret <- System.Timeout.timeout (round $ limit * 1000000) act
maybe (throwIO Timeout) return ret
addAuthority :: CoreContext -> PublicKey -> IO ()
addAuthority ctx authority = atomically $ modifyTVar (authorities ctx) (authority :)
setKeySignature :: CoreContext -> Signature -> IO ()
setKeySignature ctx sig = atomically $ writeTVar (myKeySignature ctx) (Just sig)
newContext :: IO CoreContext
newContext = do
infoM "hermes.core" "Creating new context"
aesGen <- newAESGen
let (myKey,myPrivateKey,_) = RSA.generateKeyPair aesGen rsaKeySize
myHermesID = hashKey myKey
myKeySignature <- newTVarIO Nothing
authorities <- newTVarIO []
listeners <- newTVarIO S.empty
listenerKillers <- newTVarIO M.empty
peerAddress <- newTVarIO M.empty
peerKeys <- newTVarIO M.empty
peerConnections <- newTVarIO M.empty
peerFailures <- newTVarIO M.empty
trustLimit <- newTVarIO Indirect
timeLimit <- newTVarIO 30
messageBox <- newMChanIO
return CoreContext {..}
connect :: CoreContext -> Address -> IO HermesID
connect ctx address = block $ do
infoM "hermes.core" $ "Connecting to " ++ show address
(conn, uuid) <- unblock $ negotiate ctx address Nothing
closeIt <- atomically $ do
modifyTVar (peerAddress ctx) (M.insert uuid address)
ifM (M.member uuid <$> readTVar (peerConnections ctx))
(return True)
(do box <- newTMVar conn
modifyTVar (peerConnections ctx) (M.insert uuid box)
return False)
when closeIt (hClose (handle conn))
return uuid
startListener :: CoreContext
-> Address
-> Maybe Address
-> IO ()
startListener ctx localAddress remoteAddressMaybe = do
infoM "hermes.core" $ "Listener started on address " ++ show localAddress
let remoteAddress = maybe localAddress id remoteAddressMaybe
address = ListenerAddress {..}
ok <- atomically $ do
set <- readTVar (listeners ctx)
if S.member address set
then return False
else writeTVar (listeners ctx) (S.insert address set) >> return True
unless ok $ throwM ListenerAlreadyExists
killer <- N.streamServer localAddress (handleConnection ctx)
atomically $ do
False <- M.member address <$> readTVar (listenerKillers ctx)
modifyTVar (listenerKillers ctx) (M.insert address killer)
handleConnection :: CoreContext -> Handle -> Address -> IO ()
handleConnection ctx h address = traplogging "hermes.core" CRITICAL "trap: handleConnection" $ do
flip catch (\e -> case e of
EOF -> infoM "hermes.core.handleConnection" $ "EOF on " ++ show address
) $ do
infoM "hermes.core" $ "Incoming connection from " ++ show address
exchangeVersions h
AHermesID theirHermesID <- rawRecv h
rawSend h (AHermesID $ myHermesID ctx)
answerKeyQuery ctx h
theirKey <- ensureKey ctx h theirHermesID
challenge <- prandBytes 16
debugM "hermes.core" $ "Sending challenge: " ++ showBSasHex challenge
do gen <- newAESGen
rawSend h $ AChallenge $ fst $ rsaEncrypt gen (peerKey theirKey) challenge
ASessionSetup setupBS <- rawRecv h
let setupMsg@SessionSetup{..} = decode' $ rsaDecrypt (myPrivateKey ctx) setupBS
infoM "hermes.core" $ "Receiving session setup: " ++ show setupMsg
unless (challenge == setupChallenge) (throwM $ AuthError "Challenge mismatch")
when (isJust clientAddress) $
atomically $ modifyTVar (peerAddress ctx) (M.insert theirHermesID (fromJust clientAddress))
aesctx <- AES.newCtx AES.CTR setupKey setupIV AES.Decrypt
indexMap <- newTVarIO (M.empty :: Map Int Type)
infoM "hermes.core" $ "Connection setup for " ++ show address ++ " complete"
forever $ do
(tagIndex,tag,messageIndex,message) <- cryptRecv h setupKey aesctx
case messageIndex of
0 -> do
let decoded = decode' message
infoM "hermes.core" $ "New type registered: " ++ show decoded
atomically $ modifyTVar indexMap (uncurry M.insert decoded)
_ -> do
let getType typeIndex = atomically $ fromJust . M.lookup typeIndex <$> readTVar indexMap
tagType <- getType tagIndex
messageType <- getType messageIndex
infoM "hermes.core" $ "Received message of type " ++ show (tagType,messageType)
insertMessage ctx messageType tagType tag theirHermesID message
insertMessage ctx messageType tagType tag theirHermesID message = do
accepted <- atomically $ writeMChan (messageBox ctx) (messageType,tagType,tag) (theirHermesID,message)
unless accepted $ do
warningM "hermes.core" $ "Message discarded: type, tag type, tag value: " ++
show (messageType,tagType,tag)
unless (messageType == showType RejectedMessage) $
send' ctx theirHermesID RejectedMessage (tagType,tag)
negotiate :: CoreContext
-> Address
-> Maybe HermesID
-> IO (Connection,HermesID)
negotiate ctx address expectedHermesID = block $ do
infoM "hermes.core" $ "Negotiating connection to " ++ show address ++ ", HermesID " ++ show expectedHermesID
h <- N.connectStream address
flip onException (hClose h) $ unblock $ do
exchangeVersions h
rawSend h $ AHermesID $ myHermesID ctx
AHermesID theirHermesID <- rawRecv h
unless (maybe True (== theirHermesID) expectedHermesID) $ do
atomically $ whenM ((== Just address) . M.lookup (fromJust expectedHermesID)
<$> readTVar (peerAddress ctx))
(modifyTVar (peerAddress ctx) (M.delete theirHermesID))
throwM $ AddressUnknown theirHermesID
theirKey <- ensureKey ctx h theirHermesID
answerKeyQuery ctx h
AChallenge challengeEncrypted <- rawRecv h
let setupChallenge = rsaDecrypt (myPrivateKey ctx) challengeEncrypted
setupKey <- prandBytes (aesKeySize `div` 8)
setupIV <- prandBytes 16
clientAddress <- atomically $ listToMaybe . map remoteAddress . S.toList <$> readTVar (listeners ctx)
let setupMsg = SessionSetup {..}
debugM "hermes.core" $ "Sending session setup: " ++ show setupMsg
do g <- newAESGen
rawSend h $ ASessionSetup $ fst $ rsaEncrypt g (peerKey theirKey) (encode setupMsg)
aesctx <- AES.newCtx AES.CTR setupKey setupIV AES.Encrypt
infoM "hermes.core" $ "Negotiation complete"
typeMap <- newTVarIO M.empty
typeMax <- newTVarIO 0
return (Connection { aesctx = aesctx, handle = h, aesKey = setupKey, typeMap, typeMax }, theirHermesID)
withConnection :: CoreContext -> HermesID -> (Connection -> IO a) -> IO a
withConnection ctx theirHermesID act = do
address <- atomically $ maybe (throw $ AddressUnknown theirHermesID) id . M.lookup theirHermesID <$> readTVar (peerAddress ctx)
withTMVar
(peerConnections ctx)
theirHermesID
(fst <$> negotiate ctx address (Just theirHermesID))
(get >>= liftIO . act)
withTMVar :: Ord a =>
TVar (Map a (TMVar b))
-> a
-> IO b
-> StateT b IO r
-> IO r
withTMVar tvar key filler act = block $ do
(needFill,var) <- atomically $ do
exists <- M.member key <$> readTVar tvar
if exists
then do var <- fromJust . M.lookup key <$> readTVar tvar
return (False,var)
else do placeholder <- newEmptyTMVar
modifyTVar tvar (M.insert key placeholder)
return (True,placeholder)
if needFill
then flip onException (atomically $ modifyTVar tvar (M.delete key)) $ unblock $ do
fill <- filler
(ret, fill') <- runStateT act fill
atomically $ putTMVar var fill'
return ret
else unblock $ runTMVar var act
ensureKey :: MonadIO m => CoreContext -> Handle -> HermesID -> m PeerKey
ensureKey ctx h uuid = do
maybeTheirKey <- getKey ctx uuid
if isNothing maybeTheirKey
then do
theirKey <- requestKey ctx h uuid
limit <- liftIO $ atomically $ readTVar (trustLimit ctx)
when (trust theirKey < limit)
(throwM $ AuthError $ "Key insufficiently trusted: " ++ show (trust theirKey))
liftIO $ atomically $ modifyTVar (peerKeys ctx) (M.insert uuid theirKey)
return theirKey
else do
rawSend h $ AKeyQuery KeyOK
return (fromJust maybeTheirKey)
requestKey :: MonadIO m => CoreContext -> Handle -> HermesID -> m PeerKey
requestKey ctx h uuid = liftIO $ do
rawSend h $ AKeyQuery RequestKey
AKeyReply reply <- rawRecv h
let key = keyReplyKey reply
keyHermesID = hashKey key
keyBS = encode key
unless (keyHermesID == uuid) (throwM $ AuthError "key HermesID mismatch")
case keyReplySig reply of
Nothing -> return $ PeerKey { peerKey = key, trust = None, signature = Nothing }
Just sig -> do
authorityKeys <- atomically $ readTVar (authorities ctx)
let ok = or $ map (\authority -> rsaVerify authority keyBS sig) authorityKeys
unless ok (throwM $ AuthError "signature not verifiable")
return $ PeerKey { peerKey = key, trust = Indirect, signature = Just sig }
getKey :: MonadIO m => CoreContext -> HermesID -> m (Maybe PeerKey)
getKey ctx uuid = liftIO $ atomically $ do
maybeKey <- M.lookup uuid <$> readTVar (peerKeys ctx)
limit <- readTVar (trustLimit ctx)
case maybeKey of
Just key -> return $ if trust key < limit then Nothing else Just key
Nothing -> return Nothing
answerKeyQuery :: MonadIO m => CoreContext -> Handle -> m ()
answerKeyQuery ctx h = answerKeyQuery' =<< rawRecv h
where
answerKeyQuery' (AKeyQuery KeyOK) = return ()
answerKeyQuery' (AKeyQuery RequestKey) = do
let keyReplyKey = myKey ctx
keyReplySig <- liftIO $ atomically $ readTVar (myKeySignature ctx)
rawSend h $ AKeyReply $ KeyReply{..}
answerKeyQuery' _ = throwM $ AuthError "answerKeyQuery: Unexpected reply"
exchangeVersions :: MonadIO m => Handle -> m ()
exchangeVersions h = liftIO $ do
B.hPut h magicString
B.hPut h (encode protocolVersion)
hFlush h
theirString <- hGet h (B.length magicString)
unless (magicString == theirString) (throwIO WrongProtocol)
theirVersion <- decode' <$> hGet h 4
unless (theirVersion == protocolVersion) (throwIO $ ProtocolVersionMismatch protocolVersion theirVersion)
rawSend :: (MonadIO m) => Handle -> AnyMessage -> m ()
rawSend h (encode -> msg) = liftIO $ do
B.hPut h $ encode (fromIntegral $ B.length msg :: Word32)
B.hPut h msg
hFlush h
rawRecv :: (MonadIO m) => Handle -> m AnyMessage
rawRecv h = liftIO $ do
size <- decode' <$> hGet h 4 :: IO Word32
decode' <$> hGet h (fromIntegral size)