commsec 0.1 → 0.2
raw patch · 3 files changed
+691/−189 lines, 3 filesdep +networkdep ~cipher-aes128
Dependencies added: network
Dependency ranges changed: cipher-aes128
Files
- Network/CommSec.hs +272/−185
- Network/CommSec/Package.hs +414/−0
- commsec.cabal +5/−4
Network/CommSec.hs view
@@ -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
+ Network/CommSec/Package.hs view
@@ -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 #-}
commsec.cabal view
@@ -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