diff --git a/Network/CommSec.hs b/Network/CommSec.hs --- a/Network/CommSec.hs +++ b/Network/CommSec.hs @@ -1,207 +1,294 @@ -{-# LANGUAGE BangPatterns, RecordWildCards #-} --- | CommSec, for communications security. +{-# LANGUAGE RecordWildCards, RankNTypes #-} module Network.CommSec - ( -- * Types - OutContext(..) - , InContext(..) - -- * Build contexts for use sending and receiving - , newInContext, newOutContext - -- Encryption and decryption routines - , recv - , send + ( + -- * Types + Connection(..), Safe, Unsafe + -- * Send and receive operations + , send, recv + , sendPtr, recvPtr + , sendUnsafe, recvUnsafe + , sendPtrUnsafe, recvPtrUnsafe + -- * Establishing a connection from a shared secret + -- ** Thread Safe + , accept + , connect + -- ** Non-threadsafe + , acceptUnsafe + , connectUnsafe + -- * Establishing a connection from a public identity (PKI) + -- , acceptId + -- , connectId + -- * Re-exports + , SocketType(..) ) where -import Prelude hiding (seq) -import qualified Crypto.Cipher.AES128.Internal as AES -import Crypto.Cipher.AES128.Internal (AESKey) -import Crypto.Cipher.AES128 () -import qualified Data.ByteString.Internal as B +import Crypto.Classes (buildKey) +import Crypto.Cipher.AES128.Internal (encryptCTR) +import Crypto.Cipher.AES128 (AESKey) +import Network.CommSec.Package +import Network.Socket (Socket, SocketType(..), sendBuf, recvBuf, HostName, PortNumber) +import qualified Network.Socket as Net +import Data.IORef +import Control.Concurrent.MVar +import Control.Exception (throw) import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B -import Crypto.Classes (buildKey) -import Data.ByteString (ByteString) -import Data.Bits -import Data.Maybe (fromMaybe) -import Data.Word -import Data.List +import qualified Data.ByteString.Internal as B import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.Storable -import Foreign.Marshal.Alloc (allocaBytes) -import System.IO.Unsafe +import Foreign.Marshal.Alloc +import Data.Word --- IPSec inspired packet format: --- --- [CNT (IV and seq) | Payload | Pad | ICV] +-- | Unsafe connections are not thread safe. Concurrent use can compromise +-- security. +type Unsafe = IORef --- | A context useful for sending data. -data OutContext = - Out { aesCtr :: {-# UNPACK #-} !Word64 - , saltOut :: {-# UNPACK #-} !Word32 - , outKey :: AESKey - } +-- | Safe connections are more expensive due to the use of an 'MVar' but, +-- unlike their 'Unsafe' counterparts, Safe connections can be used +-- concurrently. +type Safe = MVar --- | A context useful for receiving data. -data InContext = - In { base :: {-# UNPACK #-} !Word64 - , mask :: {-# UNPACK #-} !Word64 - , saltIn :: {-# UNPACK #-} !Word32 - , inKey :: AESKey - } +-- | A connection is a secure bidirectional communication channel. +data Connection c + = Conn { inCtx :: c InContext + , outCtx :: c OutContext + , socket :: Socket + } --- | Given at least 24 bytes of entropy, produce an out context that can --- communicate with an identically initialized in context. -newOutContext :: ByteString -> OutContext -newOutContext bs - | B.length bs < 24 = error "Not enough entropy" - | otherwise = - let aesCtr = 0 - saltOut = unsafePerformIO $ B.unsafeUseAsCString bs $ peekBE32 . castPtr - outKey = fromMaybe (error "Could not build a key") $ buildKey $ B.drop (sizeOf saltOut) bs - in Out {..} +send :: Connection Safe -> B.ByteString -> IO () +send = sendWith takeMVar putMVar --- | Given at least 24 bytes of entropy, produce an in context that can --- communicate with an identically initialized out context. -newInContext :: ByteString -> InContext -newInContext bs - | B.length bs < 24 = error "Not enough entropy" - | otherwise = - let base = 0 - mask = 0 - saltIn = unsafePerformIO $ B.unsafeUseAsCString bs $ peekBE32 . castPtr - inKey = fromMaybe (error "Could not build a key") $ buildKey $ B.drop (sizeOf saltIn) bs - in In {..} +recv :: Connection Safe -> IO B.ByteString +recv = recvWith takeMVar putMVar --- Encrypts multiple-of-block-sized input, returing a bytestring of the --- [ctr, ct, tag]. -encryptGCM :: AESKey - -> Word64 -- ^ AES GCM Counter (IV) - -> Word32 -- ^ Salt - -> ByteString -- ^ Plaintext - -> ByteString -encryptGCM key ctr salt pt = unsafePerformIO $ do - let ivLen = sizeOf ctr + sizeOf salt - tagLen = 16 - paddedLen = B.length pt - allocaBytes ivLen $ \ptrIV -> do - -- Build the IV - pokeBE32 ptrIV salt - pokeBE (ptrIV `plusPtr` sizeOf salt) ctr - B.unsafeUseAsCString pt $ \ptrPT -> do - B.create (paddedLen + sizeOf ctr + tagLen) $ \ctPtr -> do - pokeBE ctPtr ctr - let tagPtr = ctPtr' `plusPtr` paddedLen - ctPtr' = ctPtr `plusPtr` sizeOf ctr - AES.encryptGCM key ptrIV ivLen nullPtr 0 (castPtr ptrPT) (B.length pt) (castPtr ctPtr') tagPtr +-- |Sends a message over the connection. +sendPtr :: Connection Safe -> Ptr Word8 -> Int -> IO () +sendPtr = sendPtrWith takeMVar putMVar --- Decrypts multiple-of-block-sized input, returing a bytestring of the --- [ctr, ct, tag]. -decryptGCM :: AESKey - -> Word64 -- ^ AES GCM Counter (IV) - -> Word32 -- ^ Salt - -> ByteString -- ^ Ciphertext - -> ByteString -- ^ Tag - -> Either String ByteString -- Plaintext (or an exception due to bad tag) -decryptGCM key ctr salt ct tag - | B.length tag < 16 = Left "Tag too small" - | otherwise = unsafePerformIO $ do - let ivLen = sizeOf ctr + sizeOf salt - tagLen = 16 - paddedLen = B.length ct - allocaBytes ivLen $ \ptrIV -> allocaBytes tagLen $ \ctagPtr -> do - -- Build the IV - pokeBE32 ptrIV salt - pokeBE (ptrIV `plusPtr` sizeOf salt) ctr - B.unsafeUseAsCString tag $ \tagPtr -> do - B.unsafeUseAsCString ct $ \ptrCT -> do - pt <- B.create paddedLen $ \ptrPT -> do - AES.decryptGCM key ptrIV ivLen nullPtr 0 (castPtr ptrCT) (B.length ct) (castPtr ptrPT) ctagPtr - w1 <- peekBE ctagPtr - w2 <- peekBE (ctagPtr `plusPtr` sizeOf w1) - y1 <- peekBE (castPtr tagPtr) - y2 <- peekBE (castPtr tagPtr `plusPtr` sizeOf y1) - if (w1 /= y1 || w2 /= y2) - then return (Left $ "Tags do not match: " ++ show (w1,w2,y1,y2)) - else return (Right pt) +-- |Blocks till it receives a valid message, placing the resulting plaintext +-- in the provided buffer. If the incoming message is larger that the +-- provided buffer then the message is truncated. This process also incurs +-- an additional copy. +recvPtr :: Connection Safe -> Ptr Word8 -> Int -> IO Int +recvPtr = recvPtrWith takeMVar putMVar --- |Use an 'OutContext' to protect a message for transport. --- Message format: [ctr, ct, padding, tag]. -send :: OutContext -> ByteString -> (ByteString, OutContext) -send ctx@(Out {..}) pt = - let !iv_ct_tag = encryptGCM outKey aesCtr saltOut (pad pt) - in (iv_ct_tag, ctx { aesCtr = 1 + aesCtr }) +-- |Sends a message. +sendUnsafe :: Connection Unsafe -> B.ByteString -> IO () +sendUnsafe = sendWith readIORef writeIORef --- |Use an 'InContext' to decrypt a message, verifying the ICV and sequence --- number. --- Message format: [ctr, ct, padding, tag]. -recv :: InContext -> ByteString -> Either String (ByteString, InContext) -recv (In {..}) pkg - | base >= maxBound - 64 = Left "This cipher context has been used too long." - | otherwise = - let cnt = unsafePerformIO $ B.unsafeUseAsCString pkg (peekBE . castPtr) - cntLen = sizeOf cnt - tagLen = 16 - tag = B.drop (B.length pkg - tagLen) pkg - ct = let st = (B.drop cntLen pkg) in B.take (B.length st - tagLen) st - ptpd = decryptGCM inKey cnt saltIn ct tag - in case updateBaseMask base mask cnt of - Nothing -> Left "Dup!" - Just (base',mask') -> - case ptpd of - Left err -> Left err - Right ptPad -> - case unpad ptPad of - Nothing -> Left "Bad padding" - Just pt -> Right (pt, In base' mask' saltIn inKey) +-- |Receives a message. +recvUnsafe :: Connection Unsafe -> IO B.ByteString +recvUnsafe = recvWith readIORef writeIORef -pad :: ByteString -> ByteString -pad bs = - let pd = B.replicate pdLen pdValue - len = 16 - r = len - (B.length bs `rem` len) - pdLen = if r == 0 then len else r - pdValue = fromIntegral pdLen - in B.concat [bs,pd] +-- |Sends a message. +sendPtrUnsafe :: Connection Unsafe -> Ptr Word8 -> Int -> IO () +sendPtrUnsafe = sendPtrWith readIORef writeIORef --- Unsafe varient of PCKS5 padding -unpad :: ByteString -> Maybe ByteString -unpad bs - | len > 0 = Just $ B.take (len - fromIntegral (B.last bs)) bs - | otherwise = Nothing - where - len = B.length bs +-- |Blocks till it receives a valid message, placing the resulting plaintext +-- in the provided buffer. If the incoming message is larger that the +-- provided buffer then the message is truncated. This process also incurs +-- an additional copy. +recvPtrUnsafe :: Connection Unsafe -> Ptr Word8 -> Int -> IO Int +recvPtrUnsafe = recvPtrWith readIORef writeIORef -updateBaseMask :: Word64 -> Word64 -> Word64 -> Maybe (Word64,Word64) -updateBaseMask !base !mask !seq - | base <= seq && base >= seqBase = - let pos = fromIntegral $ seq - base - in if testBit mask pos - then Nothing - else Just (base, setBit mask pos) - | base < seqBase = updateBaseMask seq (mask `shiftR` fromIntegral (seq - base)) seq - | base > seq = Nothing - where - !seqBase | seq < 64 = 0 - | otherwise = seq-63 +-- helper for send, sendUnsafe +sendWith :: (c OutContext -> IO OutContext) -> (c OutContext -> OutContext -> IO ()) -> Connection c -> B.ByteString -> IO () +sendWith get put conn msg = B.useAsCStringLen msg $ \(ptPtr, ptLen) -> + sendPtrWith get put conn (castPtr ptPtr) ptLen +{-# INLINE sendWith #-} -peekBE :: Ptr Word8 -> IO Word64 -peekBE p = do - let op n = fromIntegral `fmap` peekElemOff p n - as <- mapM op [0..7] - return (foldl1' (\r a -> (r `shiftL` 8) .|. a) as) +data RecvRes = Good | Small | Err deriving (Eq) -pokeBE :: Ptr Word8 -> Word64 -> IO () -pokeBE p w = do - let op n = pokeElemOff p n (fromIntegral (w `shiftR` (56-(8*n) :: Int))) - mapM_ op [0..7] +-- helper for recv, recvUnsafe +recvWith :: (c InContext -> IO InContext) -> (c InContext -> InContext -> IO ()) -> Connection c -> IO B.ByteString +recvWith get put conn@(Conn {..}) = allocGo baseSize + where + baseSize = 1024 + allocGo :: Int -> IO B.ByteString + allocGo n = allocaBytes sizeTagLen (go n) -pokeBE32 :: Ptr Word8 -> Word32 -> IO () -pokeBE32 p w = do - let op n = pokeElemOff p n (fromIntegral (w `shiftR` (24 - (8*n) :: Int))) - mapM_ op [0..3] + -- -peekBE32 :: Ptr Word8 -> IO Word32 -peekBE32 p = do - let op n = fromIntegral `fmap` peekElemOff p n - as <- mapM op [0..3] - return (foldl1' (\r a -> (r `shiftL` 8) .|. a) as) + go :: Int -> Ptr Word8 -> IO B.ByteString + go sz tmpPtr + | sz > 2^28 = error "recvWith: A message is over 256MB! Probably corrupt data or the stream is unsyncronized." + | otherwise = do + recvBytesPtr socket tmpPtr sizeTagLen + sz <- fromIntegral `fmap` peekBE32 tmpPtr + (b,res) <- B.createAndTrim' sz $ \ptPtr -> do + resSz <- recvPtrOfSz get put conn ptPtr sz + case resSz of + Left err -> if err `elem` retryOn then return (0,0,Err) + else throw err + Right s -> + if s > sz + then return (0,0,Small) + else return (0,s,Good) + case res of + Good -> return b + Small -> go (sz * 2) tmpPtr + Err -> go sz tmpPtr +{-# INLINE recvWith #-} + +retryOn :: [CommSecError] +retryOn = [DuplicateSeq, InvalidICV, BadPadding] + +-- helper for sendPtr, sendPtrUnsafe +sendPtrWith :: (c OutContext -> IO OutContext) -> (c OutContext -> OutContext -> IO ()) -> Connection c -> Ptr Word8 -> Int -> IO () +sendPtrWith get put c@(Conn {..}) ptPtr ptLen = do + let ctLen = encBytes ptLen + pktLen = sizeTagLen + ctLen + allocaBytes pktLen $ \pktPtr -> do + let ctPtr = pktPtr `plusPtr` sizeTagLen + pokeBE32 pktPtr (fromIntegral ctLen) + o <- get outCtx + o2 <- encodePtr o ptPtr ctPtr ptLen + put outCtx o2 + Net.sendBuf socket pktPtr pktLen + return () + +-- helper for recvPtr, recvPtrUnsafe +recvPtrWith :: (c InContext -> IO InContext) -> (c InContext -> InContext -> IO ()) -> Connection c -> Ptr Word8 -> Int -> IO Int +recvPtrWith get put c@(Conn{..}) ptPtr maxLen = do + r <- go + case r of + Nothing -> recvPtrWith get put c ptPtr maxLen + Just res -> return res + where + go :: IO (Maybe Int) + go = allocaBytes sizeTagLen $ \szPtr -> do + recvBytesPtr socket szPtr sizeTagLen + len <- fromIntegral `fmap` peekBE32 szPtr + let ptMaxSize = decBytes (len - sizeTagLen) + allocaBytes len $ \ctPtr -> do + recvBytesPtr socket ctPtr len + i <- get inCtx + let finish pointer = do + dRes <- decodePtr i ctPtr pointer len + case dRes of + Left err -> if err `elem` retryOn then return Nothing + else throw err + Right (resLen,i2) -> put inCtx i2 >> return (Just resLen) + if ptMaxSize > maxLen + then allocaBytes ptMaxSize (\tmp -> do + res <- finish tmp + B.memcpy ptPtr tmp maxLen + return res) + else finish ptPtr + +-- Receive sz bytes and decode it into ptPtr, helper for recvWith +recvPtrOfSz :: (c InContext -> IO InContext) -> (c InContext -> InContext -> IO ()) -> Connection c -> Ptr Word8 -> Int -> IO (Either CommSecError Int) +recvPtrOfSz get put (Conn {..}) ptPtr sz = + allocaBytes sz $ \ct -> do + recvBytesPtr socket ct sz + i <- get inCtx + dRes <- decodePtr i ct ptPtr sz + case dRes of + Left err -> return (Left err) + Right (resLen,i2) -> put inCtx i2 >> return (Right resLen) + +-- Retry until we have received exactly the specified number of bytes +recvBytesPtr :: Socket -> Ptr Word8 -> Int -> IO () +recvBytesPtr s p 0 = return () +recvBytesPtr s p l = do + nr <- recvBuf s l p + recvBytesPtr s (p `plusPtr` nr) (l - nr) + +-- Retry until we have sent exactly the specified number of bytes +sendBytesPtr :: Socket -> Ptr Word8 -> Int -> IO () +sendBytesPtr s p 0 = return () +sendBytesPtr s p l = do + nr <- sendBuf s p l + sendBytesPtr s (p `plusPtr` nr) (l - nr) + +-- Use counter mode to expand input entropy that is at least 16 bytes long +expandSecret :: B.ByteString -> Int -> B.ByteString +expandSecret entropy sz = + let k = buildKey entropy + in case k of + Nothing -> error "Build key failed" + Just key -> + let iv = B.replicate 16 0 + in enc key iv input + where + input = B.replicate sz 0 + enc :: AESKey -> B.ByteString -> B.ByteString -> B.ByteString + enc k i pt = B.unsafeCreate sz $ \ctPtr -> + B.useAsCString pt $ \ptPtr -> + B.useAsCString i $ \iv -> + encryptCTR k (castPtr iv) (castPtr ctPtr) (castPtr ptPtr) sz + +-- |Expands the provided 128 (or more) bit secret into two +-- keys to create a connection. +-- +-- ex: accept ent me.com 3134 Stream +accept :: B.ByteString -> PortNumber -> SocketType -> IO (Connection Safe) +accept = doAccept newMVar + +doAccept :: (forall x. x -> IO (c x)) -> B.ByteString -> PortNumber -> SocketType -> IO (Connection c) +doAccept create s p streamOrDgram + | B.length s < 16 = error "Invalid input entropy" + | otherwise = do + let ent = expandSecret s 64 + k1 = B.take 32 ent + k2 = B.drop 32 ent + iCtx = newInContext k1 + oCtx = newOutContext k2 + sockaddr = Net.SockAddrInet p Net.iNADDR_ANY + sock <- Net.socket Net.AF_INET streamOrDgram Net.defaultProtocol + Net.setSocketOption sock Net.ReuseAddr 1 + Net.bind sock sockaddr + Net.listen sock 10 + socket <- fst `fmap` Net.accept sock + Net.setSocketOption socket Net.NoDelay 1 + Net.close sock + inCtx <- create iCtx + outCtx <- create oCtx + return (Conn {..}) + +doConnect :: (forall x. x -> IO (c x)) -> B.ByteString -> HostName -> PortNumber -> SocketType -> IO (Connection c) +doConnect create s hn p streamOrDgram + | B.length s < 16 = error "Invalid input entropy" + | otherwise = do + ha <- Net.inet_addr hn + let ent = expandSecret s 64 + k2 = B.take 32 ent + k1 = B.drop 32 ent + iCtx = newInContext k1 + oCtx = newOutContext k2 + sockaddr = Net.SockAddrInet p ha + socket <- Net.socket Net.AF_INET streamOrDgram Net.defaultProtocol + Net.connect socket sockaddr + Net.setSocketOption socket Net.NoDelay 1 + Net.setSocketOption socket Net.ReuseAddr 1 + inCtx <- create iCtx + outCtx <- create oCtx + return (Conn {..}) + +-- |Expands the provided 128 (or more) bit secret into two +-- keys to create a connection. +connect :: B.ByteString + -> HostName + -> PortNumber + -> SocketType + -> IO (Connection Safe) +connect = doConnect newMVar + +-- |Expands the provided 128 (or more) bit secret into two +-- keys to create a connection. +acceptUnsafe :: B.ByteString + -> PortNumber + -> SocketType + -> IO (Connection Unsafe) +acceptUnsafe = doAccept newIORef + +-- |Expands the provided 128 (or more) bit secret into two +-- keys to create a connection. +connectUnsafe :: B.ByteString + -> HostName + -> PortNumber + -> SocketType + -> IO (Connection Unsafe) +connectUnsafe = doConnect newIORef + +-- |We use a word32 to indicate the size of a datagram +sizeTagLen = 4 diff --git a/Network/CommSec/Package.hs b/Network/CommSec/Package.hs new file mode 100644 --- /dev/null +++ b/Network/CommSec/Package.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE CPP, BangPatterns, RecordWildCards, DeriveDataTypeable #-} +-- | CommSec is a package that provides communication security for +-- a datagram (vs streaming) style of communications. Using an ephemeral shared +-- secret you can build contexts for sending to or receiving from with one or more +-- peers. +-- +-- Do not reuse the shared secret! Key agreement mechanisms that leverage +-- PKI might be added later. +module Network.CommSec.Package + ( -- * Types + OutContext(..) + , InContext(..) + , CommSecError(..) + -- , Secret, Socket + -- * Build contexts for use sending and receiving + , newInContext, newOutContext -- , newSecret + -- * Pure / ByteString based encryption and decryption routines + , decode + , encode + -- * IO / Pointer based encryption and decryption routines + , decodePtr + , encodePtr + -- * Utility functions + , encBytes, decBytes + -- * Wrappers for network sending and receiving + -- , send, recv + -- , sendPtr, recvPtr + -- , connect, unsafeConnect + -- , listen, unsafeListen + -- * Utilities + , peekBE32 + , pokeBE32 + , peekBE + , pokeBE + ) where + +import Prelude hiding (seq) +import qualified Crypto.Cipher.AES128.Internal as AES +import Crypto.Cipher.AES128.Internal (AESKey) +import Crypto.Cipher.AES128 () +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import Crypto.Classes (buildKey) +import Data.ByteString (ByteString) +import Data.Bits +import Data.Maybe (fromMaybe) +import Data.Word +import Data.List +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Utils (copyBytes) +import System.IO.Unsafe +import Data.Data +import Data.Typeable +import Control.Exception + +gPadMax,gBlockLen,gTagLen,gCtrSize :: Int +gPadMax = 16 +gBlockLen = 16 +gTagLen = 16 +gCtrSize = 8 + +-- IPSec inspired packet format: +-- +-- [CNT (used for both the IV and seq) | CT of Payload + Pad | ICV] + +-- | A context useful for sending data. +data OutContext = + Out { aesCtr :: {-# UNPACK #-} !Word64 + , saltOut :: {-# UNPACK #-} !Word32 + , outKey :: AESKey + } + +-- | A context useful for receiving data. +data InContext = + In { base :: {-# UNPACK #-} !Word64 + , mask :: {-# UNPACK #-} !Word64 + , saltIn :: {-# UNPACK #-} !Word32 + , inKey :: AESKey + } + +-- |Errors that can be returned by the decoding/receicing operations. +data CommSecError + = OldContext -- The context is too old (sequence number rollover) + | DuplicateSeq -- The sequence number we previously seen (possible replay attack) + | InvalidICV -- The integrity check value is invalid + | BadPadding -- The padding was invalid (corrupt sender?) + deriving (Eq,Ord,Show,Enum,Data,Typeable) + +instance Exception CommSecError + +-- | Given at least 24 bytes of entropy, produce an out context that can +-- communicate with an identically initialized in context. +newOutContext :: ByteString -> OutContext +newOutContext bs + | B.length bs < 24 = error $ "Not enough entropy: " ++ show (B.length bs) + | otherwise = + let aesCtr = 0 + saltOut = unsafePerformIO $ B.unsafeUseAsCString bs $ peekBE32 . castPtr + outKey = fromMaybe (error "Could not build a key") $ buildKey $ B.drop (sizeOf saltOut) bs + in Out {..} + +-- | Given at least 24 bytes of entropy, produce an in context that can +-- communicate with an identically initialized out context. +newInContext :: ByteString -> InContext +newInContext bs + | B.length bs < 24 = error $ "Not enough entropy: " ++ show (B.length bs) + | otherwise = + let base = 0 + mask = 0 + saltIn = unsafePerformIO $ B.unsafeUseAsCString bs $ peekBE32 . castPtr + inKey = fromMaybe (error "Could not build a key") $ buildKey $ B.drop (sizeOf saltIn) bs + in In {..} + +-- Encrypts multiple-of-block-sized input, returing a bytestring of the +-- [ctr, ct, tag]. +encryptGCM :: AESKey + -> Word64 -- ^ AES GCM Counter (IV) + -> Word32 -- ^ Salt + -> ByteString -- ^ Plaintext + -> ByteString +encryptGCM key ctr salt pt = unsafePerformIO $ do + let ivLen = sizeOf ctr + sizeOf salt + tagLen = gTagLen + paddedLen = B.length pt + allocaBytes ivLen $ \ptrIV -> do + -- Build the IV + pokeBE32 ptrIV salt + pokeBE (ptrIV `plusPtr` sizeOf salt) ctr + B.unsafeUseAsCString pt $ \ptrPT -> do + B.create (paddedLen + sizeOf ctr + tagLen) $ \ctPtr -> do + pokeBE ctPtr ctr + let tagPtr = ctPtr' `plusPtr` paddedLen + ctPtr' = ctPtr `plusPtr` sizeOf ctr + AES.encryptGCM key ptrIV ivLen nullPtr 0 (castPtr ptrPT) (B.length pt) (castPtr ctPtr') tagPtr + + +-- Encrypts multiple-of-block-sized input, filling a pointer with the +-- result of [ctr, ct, tag]. +encryptGCMPtr :: AESKey + -> Word64 -- ^ AES GCM Counter (IV) + -> Word32 -- ^ Salt + -> Ptr Word8 -- ^ Plaintext buffer + -> Int -- ^ Plaintext length + -> Ptr Word8 -- ^ ciphertext buffer (at least encBytes large) + -> IO () +encryptGCMPtr key ctr salt ptPtr ptLen ctPtr = do + let ivLen = sizeOf ctr + sizeOf salt + tagLen = gTagLen + paddedLen = ptLen + allocaBytes ivLen $ \ptrIV -> do + -- Build the IV + pokeBE32 ptrIV salt + pokeBE (ptrIV `plusPtr` sizeOf salt) ctr + pokeBE ctPtr ctr + let tagPtr = ctPtr' `plusPtr` paddedLen + ctPtr' = ctPtr `plusPtr` sizeOf ctr + AES.encryptGCM key ptrIV ivLen nullPtr 0 (castPtr ptPtr) ptLen (castPtr ctPtr') tagPtr + +-- | GCM decrypt and verify ICV. +decryptGCMPtr :: AESKey + -> Word64 -- ^ AES GCM Counter (IV) + -> Word32 -- ^ Salt + -> Ptr Word8 -- ^ Ciphertext + -> Int -- ^ Ciphertext length + -> Ptr Word8 -- ^ Tag + -> Int -- ^ Tag length + -> Ptr Word8 -- ^ Plaintext result ptr (at least 'decBytes' large) + -> IO (Either CommSecError ()) +decryptGCMPtr key ctr salt ctPtr ctLen tagPtr tagLen ptPtr + | tagLen /= gTagLen = return $ Left InvalidICV + | otherwise = do + let ivLen = sizeOf ctr + sizeOf salt + paddedLen = ctLen + allocaBytes ivLen $ \ptrIV -> allocaBytes tagLen $ \ctagPtr -> do + -- Build the IV + pokeBE32 ptrIV salt + pokeBE (ptrIV `plusPtr` sizeOf salt) ctr + AES.decryptGCM key ptrIV ivLen nullPtr 0 (castPtr ctPtr) paddedLen (castPtr ptPtr) ctagPtr + w1 <- peekBE ctagPtr + w2 <- peekBE (ctagPtr `plusPtr` sizeOf w1) + y1 <- peekBE (castPtr tagPtr) + y2 <- peekBE (castPtr tagPtr `plusPtr` sizeOf y1) + if (w1 /= y1 || w2 /= y2) + then return (Left InvalidICV) + else return (Right ()) + +-- Decrypts multiple-of-block-sized input, returing a bytestring of the +-- [ctr, ct, tag]. +decryptGCM :: AESKey + -> Word64 -- ^ AES GCM Counter (IV) + -> Word32 -- ^ Salt + -> ByteString -- ^ Ciphertext + -> ByteString -- ^ Tag + -> Either CommSecError ByteString -- Plaintext (or an exception due to bad tag) +decryptGCM key ctr salt ct tag + | B.length tag < gTagLen = Left InvalidICV + | otherwise = unsafePerformIO $ do + let ivLen = sizeOf ctr + sizeOf salt + tagLen = gTagLen + paddedLen = B.length ct + allocaBytes ivLen $ \ptrIV -> allocaBytes tagLen $ \ctagPtr -> do + -- Build the IV + pokeBE32 ptrIV salt + pokeBE (ptrIV `plusPtr` sizeOf salt) ctr + B.unsafeUseAsCString tag $ \tagPtr -> do + B.unsafeUseAsCString ct $ \ptrCT -> do + pt <- B.create paddedLen $ \ptrPT -> do + AES.decryptGCM key ptrIV ivLen nullPtr 0 (castPtr ptrCT) (B.length ct) (castPtr ptrPT) ctagPtr + w1 <- peekBE ctagPtr + w2 <- peekBE (ctagPtr `plusPtr` sizeOf w1) + y1 <- peekBE (castPtr tagPtr) + y2 <- peekBE (castPtr tagPtr `plusPtr` sizeOf y1) + if (w1 /= y1 || w2 /= y2) + then return (Left InvalidICV) + else return (Right pt) + +-- |Use an 'OutContext' to protect a message for transport. +-- Message format: [ctr, ct, padding, tag]. +-- +-- This routine can throw an exception of 'OldContext' if the context being +-- used has expired. +encode :: OutContext -> ByteString -> (ByteString, OutContext) +encode ctx@(Out {..}) pt + | aesCtr == maxBound = throw OldContext + | otherwise = + let !iv_ct_tag = encryptGCM outKey aesCtr saltOut (pad pt) + in (iv_ct_tag, ctx { aesCtr = 1 + aesCtr }) + +-- |Given a message length, returns the number of bytes an encoded message +-- will consume. +encBytes :: Int -> Int +encBytes lenMsg = + let lenBlock = gBlockLen + tagLen = lenBlock + ctrLen = gCtrSize + r = lenBlock - (lenMsg `rem` lenBlock) + pdLen = if r == 0 then lenBlock else r + in ctrLen + lenMsg + pdLen + tagLen + +-- |Given a package length, returns the maximum number of bytes the +-- underlying message could be (including padding). +decBytes :: Int -> Int +decBytes lenPkg = + let tagLen = gTagLen + ctrLen = gCtrSize + in lenPkg - tagLen - ctrLen + +-- |@encodePtr outCtx msg result msgLen@ will encode @msgLen@ bytes at +-- location @msg@, placing the result at location @result@. The buffer +-- pointed to by @result@ must be at least @encBytes msgLen@ bytes large, +-- the actual package will be exactly @encBytes msgLen@ in size. +encodePtr :: OutContext -> Ptr Word8 -> Ptr Word8 -> Int -> IO OutContext +encodePtr ctx@(Out {..}) ptPtr pkgPtr ptLen + | aesCtr == maxBound = throw OldContext + | otherwise = do + let !totalLen = padding + ptLen + !padding = padLen ptLen + allocaBytes totalLen $ \ptPaddedPtr -> do + copyBytes ptPaddedPtr ptPtr ptLen + memset (ptPaddedPtr `plusPtr` ptLen) padding (fromIntegral padding) + encryptGCMPtr outKey aesCtr saltOut ptPaddedPtr totalLen pkgPtr + return (ctx { aesCtr = 1 + aesCtr }) + where + memset :: Ptr Word8 -> Int -> Word8 -> IO () + memset ptr1 len val = mapM_ (\o -> pokeElemOff ptr1 o val) [0..len-1] + +-- |@decodePtr inCtx pkg msg pkgLen@ decrypts and verifies a package at +-- location @pkg@ of size @pkgLen@. The resulting message is placed at +-- location @msg@ and its size is returned along with a new context (or +-- error). +decodePtr :: InContext -> Ptr Word8 -> Ptr Word8 -> Int -> IO (Either CommSecError (Int,InContext)) +decodePtr (In {..}) pkgPtr msgPtr pkgLen + | base >= maxBound - 64 = return $ Left OldContext + | otherwise = do + cnt <- peekBE pkgPtr + let !ctPtr = pkgPtr `plusPtr` sizeOf cnt + !ctLen = pkgLen - tagLen - sizeOf cnt + !tagPtr = pkgPtr `plusPtr` (pkgLen - tagLen) + tagLen = gTagLen + paddedLen = ctLen + r <- decryptGCMPtr inKey cnt saltIn ctPtr ctLen tagPtr tagLen msgPtr + case r of + Left err -> return (Left err) + Right () -> do + case updateBaseMask base mask cnt of + Nothing -> return (Left DuplicateSeq) + Just (base',mask') -> do + pdLen <- padLenPtr msgPtr paddedLen + case pdLen of + Nothing -> return $ Left BadPadding + Just l -> return $ Right (paddedLen - l, In base' mask' saltIn inKey) + +-- |Use an 'InContext' to decrypt a message, verifying the ICV and sequence +-- number. Unlike sending, receiving is more likely to result in an +-- exceptional condition and thus it returns an 'Either' value. +-- +-- Message format: [ctr, ct, padding, tag]. +decode :: InContext -> ByteString -> Either CommSecError (ByteString, InContext) +decode (In {..}) pkg + | base >= maxBound - 64 = Left OldContext + | otherwise = + let cnt = unsafePerformIO $ B.unsafeUseAsCString pkg (peekBE . castPtr) + cntLen = sizeOf cnt + tagLen = gTagLen + tag = B.drop (B.length pkg - tagLen) pkg + ct = let st = (B.drop cntLen pkg) in B.take (B.length st - tagLen) st + ptpd = decryptGCM inKey cnt saltIn ct tag + in case updateBaseMask base mask cnt of + Nothing -> Left DuplicateSeq + Just (base',mask') -> + case ptpd of + Left err -> Left err + Right ptPad -> + case unpad ptPad of + Nothing -> Left BadPadding + Just pt -> Right (pt, In base' mask' saltIn inKey) + +-- |Pad a bytestring to block size +pad :: ByteString -> ByteString +pad bs = + let pd = B.replicate pdLen pdValue + pdLen = padLen (B.length bs) + pdValue = fromIntegral pdLen + in B.concat [bs,pd] + +-- |Given length of a plaintext message, return the length of the padding +-- needed. +padLen :: Int -> Int +padLen ptLen = + let blkLen = gBlockLen + r = blkLen - (ptLen `rem` blkLen) + in if r == 0 then blkLen else r +{-# INLINE padLen #-} + +-- |Remove padding from a padded bytestring. This is a varient of PCKS5 padding that does not check the pad values. +unpad :: ByteString -> Maybe ByteString +unpad bs + | len > 0 = Just $ B.take (len - fromIntegral (B.last bs)) bs + | otherwise = Nothing + where + len = B.length bs + +-- |Given a pointer to padded data and the length of the data, determine the length of the padding. +-- Perhaps this should be called 'unpadPtr' +padLenPtr :: Ptr Word8 -> Int -> IO (Maybe Int) +padLenPtr ptr len + | len <= gPadMax = return Nothing + | otherwise = do + r <- fromIntegral `fmap` (peekElemOff ptr (len-1) :: IO Word8) + if r <= gPadMax then return (Just r) else return Nothing + +updateBaseMask :: Word64 -> Word64 -> Word64 -> Maybe (Word64,Word64) +updateBaseMask !base !mask !seq + | base <= seq && base >= seqBase = + let pos = fromIntegral $ seq - base + in if testBit mask pos + then Nothing + else Just (base, setBit mask pos) +#ifdef SEQ_WINDOW_JUMPS + -- If all packets are received iun order, you will hit this case on every + -- 64th packet and perform a single shiftR operation. If packets are + -- received out of order then this method is more likely to incorrectly + -- mark packets as duplicate. + | base < seqBase = updateBaseMask seq (mask `shiftR` fromIntegral (seq - base)) seq +#else + -- If all packets are received in order, you will theoretically hit this + -- case on every 64th packet, perform 64 shiftRight operations (due to lack of + -- a msnzb operation), and + -- proceed with the next 63 packets incurring only a bitSet operation. + | base < seqBase = + let newBase = seqBase + newMask = mask `shiftR` fromIntegral (seqBase - base) + shiftIt !b !m + | testBit m 0 = shiftIt (b+1) (shiftR m 1) + | otherwise = (b,m) + (finalBase, finalMask) = shiftIt newBase newMask + in updateBaseMask finalBase finalMask seq +#endif + | base > seq = Nothing + where + !seqBase | seq < 64 = 0 + | otherwise = seq-63 +{-# INLINE updateBaseMask #-} + + +peekBE :: Ptr Word8 -> IO Word64 +peekBE p = do + let op n = fromIntegral `fmap` peekElemOff p n + as <- mapM op [0..7] + return (foldl1' (\r a -> (r `shiftL` 8) .|. a) as) +{-# INLINE peekBE #-} + +pokeBE :: Ptr Word8 -> Word64 -> IO () +pokeBE p w = do + let op n = pokeElemOff p n (fromIntegral (w `shiftR` (56-(8*n) :: Int))) + mapM_ op [0..7] +{-# INLINE pokeBE #-} + +pokeBE32 :: Ptr Word8 -> Word32 -> IO () +pokeBE32 p w = do + let op n = pokeElemOff p n (fromIntegral (w `shiftR` (24 - (8*n) :: Int))) + mapM_ op [0..3] +{-# INLINE pokeBE32 #-} + +peekBE32 :: Ptr Word8 -> IO Word32 +peekBE32 p = do + let op n = fromIntegral `fmap` peekElemOff p n + as <- mapM op [0..3] + return (foldl1' (\r a -> (r `shiftL` 8) .|. a) as) +{-# INLINE peekBE32 #-} diff --git a/commsec.cabal b/commsec.cabal --- a/commsec.cabal +++ b/commsec.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: commsec -version: 0.1 +version: 0.2 synopsis: Communications security description: A basic communications security package that provides confidentiallity, integrity and replay detection. license: BSD3 @@ -15,9 +15,10 @@ cabal-version: >=1.8 library - exposed-modules: Network.CommSec + exposed-modules: Network.CommSec, Network.CommSec.Package -- other-modules: build-depends: base >4.5 && < 5, - cipher-aes128, + cipher-aes128 >= 0.2, bytestring, - crypto-api + crypto-api, + network >= 2.5