diff --git a/Network/CommSec.hs b/Network/CommSec.hs --- a/Network/CommSec.hs +++ b/Network/CommSec.hs @@ -36,7 +36,7 @@ import Foreign.Ptr import Foreign.Marshal.Alloc import Data.Word -import Data.Maybe (listToMaybe) +import Data.Maybe (isJust, listToMaybe) -- | A connection is a secure bidirectional communication channel. data Connection @@ -51,118 +51,95 @@ -- |Send a datagram, first encrypting it, using the given secure -- connection. send :: Connection -> B.ByteString -> IO () -send = sendWith takeMVar pMVar - --- |Receive a datagram sent over the given secure connection -recv :: Connection -> IO B.ByteString -recv = recvWith takeMVar pMVar - --- |Sends a message over the connection. -sendPtr :: Connection -> Ptr Word8 -> Int -> IO () -sendPtr = sendPtrWith takeMVar pMVar - --- |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 -> Ptr Word8 -> Int -> IO Int -recvPtr = recvPtrWith takeMVar pMVar - --- helper for send -sendWith :: (MVar OutContext -> IO OutContext) -> (MVar OutContext -> OutContext -> IO ()) -> Connection -> B.ByteString -> IO () -sendWith get put conn msg = B.useAsCStringLen msg $ \(ptPtr, ptLen) -> - sendPtrWith get put conn (castPtr ptPtr) ptLen -{-# INLINE sendWith #-} +send conn msg = B.useAsCStringLen msg $ \(ptPtr, ptLen) -> + sendPtr conn (castPtr ptPtr) ptLen -data RecvRes = Good | Small | Err deriving (Eq) +data RecvRes = Good | Err deriving (Eq) --- helper for recv -recvWith :: (MVar InContext -> IO InContext) -> (MVar InContext -> InContext -> IO ()) -> Connection -> IO B.ByteString -recvWith get put conn@(Conn {..}) = allocGo baseSize - where - baseSize = 2048 - allocGo :: Int -> IO B.ByteString - allocGo n = allocaBytes sizeTagLen (go n) +recv :: Connection -> IO B.ByteString +recv conn@(Conn {..}) = + allocaBytes sizeTagLen $ \tmpPtr -> + modifyMVar inCtx $ \iCtx -> + go tmpPtr iCtx - -- + where - 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 print err >> 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 #-} + go :: Ptr Word8 -> InContext -> IO (InContext, B.ByteString) + go tmpPtr iCtx = do + recvBytesPtr socket tmpPtr sizeTagLen -- XXX This is unacceptable for datagrams + sz <- fromIntegral `fmap` peekBE32 tmpPtr + when (sz > 2^28) + (fail "recv: A message is over 256MB! Probably corrupt data or the stream is unsyncronized.") + (b, (iCtx,res)) <- B.createAndTrim' sz $ \ptPtr -> -- second time iCtx shadowed + do (iCtx,resSz) <- recvPtrOfSz socket iCtx ptPtr sz -- first time iCtx shadowed + case resSz of + Left err + | err `elem` retryOn -> return (0,0,(iCtx,Err)) + | otherwise -> throw err + Right s -> return (0,s,(iCtx,Good)) + case res of + Good -> return (iCtx,b) + Err -> go tmpPtr iCtx retryOn :: [CommSecError] retryOn = [DuplicateSeq, InvalidICV, BadPadding] --- helper for sendPtr -sendPtrWith :: (MVar OutContext -> IO OutContext) -> (MVar OutContext -> OutContext -> IO ()) -> Connection -> Ptr Word8 -> Int -> IO () -sendPtrWith get put c@(Conn {..}) ptPtr ptLen = do +-- |Sends a message over the connection. +sendPtr :: Connection -> Ptr Word8 -> Int -> IO () +sendPtr 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 + modifyMVar_ outCtx $ \oCtx -> encodePtr oCtx ptPtr ctPtr ptLen sendBytesPtr socket pktPtr pktLen - return () --- helper for recvPtr -recvPtrWith :: (MVar InContext -> IO InContext) -> (MVar InContext -> InContext -> IO ()) -> Connection -> 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 +-- |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 -> Ptr Word8 -> Int -> IO Int +recvPtr c@(Conn{..}) ptPtr maxLen = + allocaBytes sizeTagLen $ \szPtr -> + modifyMVar inCtx $ \iCtx -> do + go szPtr iCtx + + where + + go szPtr iCtx = do recvBytesPtr socket szPtr sizeTagLen len <- fromIntegral `fmap` peekBE32 szPtr let ptMaxSize = decBytes (len - sizeTagLen) - allocaBytes len $ \ctPtr -> do + (iCtx, mbOutLen) <- allocaBytes len $ \ctPtr -> do -- shadow iCtx recvBytesPtr socket ctPtr len - i <- get inCtx let finish pointer = do - dRes <- decodePtr i ctPtr pointer len + dRes <- decodePtr iCtx 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 + Left err + | err `elem` retryOn -> return (iCtx, Nothing) -- preserve old context + | otherwise -> throw err + Right (resLen,i2) -> return (i2, Just resLen) + if ptMaxSize > maxLen -- shadow iCtx + then allocaBytes ptMaxSize $ \tmp -> + do res <- finish tmp + when (isJust (snd res)) -- don't bother copying in the retry case + (B.memcpy ptPtr tmp maxLen) + return res + else finish ptPtr + case mbOutLen of + Nothing -> go szPtr iCtx -- retry + Just outLen -> return (iCtx, outLen) -- Receive sz bytes and decode it into ptPtr, helper for recvWith -recvPtrOfSz :: (MVar InContext -> IO InContext) -> (MVar InContext -> InContext -> IO ()) -> Connection -> Ptr Word8 -> Int -> IO (Either CommSecError Int) -recvPtrOfSz get put (Conn {..}) ptPtr sz = +recvPtrOfSz :: Socket -> InContext -> Ptr Word8 -> Int -> IO (InContext, Either CommSecError Int) +recvPtrOfSz socket iCtx 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) + dRes <- decodePtr iCtx ct ptPtr sz + return $ case dRes of + Left err -> (iCtx, Left err) -- restore old context + Right (resLen,i2) -> (i2 , Right resLen) -- Retry until we have received exactly the specified number of bytes recvBytesPtr :: Socket -> Ptr Word8 -> Int -> IO () diff --git a/Network/CommSec/Package.hs b/Network/CommSec/Package.hs --- a/Network/CommSec/Package.hs +++ b/Network/CommSec/Package.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, DeriveDataTypeable #-} +{-# LANGUAGE CPP, BangPatterns, RecordWildCards, DeriveDataTypeable, TupleSections #-} -- | CommSec is a package that provides communication security for -- use with Haskell sockets. Using an ephemeral shared -- secret you can build contexts for sending or receiving data between one @@ -61,15 +61,13 @@ import Network.CommSec.Types import Network.CommSec.BitWindow -gPadMax,gBlockLen,gTagLen,gCtrSize :: Int -gPadMax = 16 -gBlockLen = 16 +gTagLen,gCtrSize :: Int gTagLen = 16 gCtrSize = 8 -- IPSec inspired packet format: -- --- [CNT (used for both the IV and seq) | CT of Payload + Pad | ICV] +-- [CNT (used for both the IV and seq) | CT of Payload | ICV] -- | A context useful for sending data. data OutContext = @@ -125,24 +123,14 @@ -- Encrypts multiple-of-block-sized input, returing a bytestring of the -- [ctr, ct, tag]. encryptGCM :: AESKey - -> Word64 -- ^ AES GCM Counter (IV) - -> Word32 -- ^ Salt + -> 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 + B.unsafeUseAsCString pt $ \ptPtr -> do + B.create (encBytes (B.length pt)) $ \ctPtr -> do + encryptGCMPtr key ctr salt (castPtr ptPtr) (B.length pt) (castPtr ctPtr) -- Encrypts multiple-of-block-sized input, filling a pointer with the @@ -157,20 +145,19 @@ 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 + let tagPtr = ctPtr' `plusPtr` ptLen 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 + -> Word64 -- ^ AES GCM Counter (IV) + -> Word32 -- ^ Salt -> Ptr Word8 -- ^ Ciphertext -> Int -- ^ Ciphertext length -> Ptr Word8 -- ^ Tag @@ -226,7 +213,7 @@ else return (Right pt) -- |Use an 'OutContext' to protect a message for transport. --- Message format: [ctr, ct, padding, tag]. +-- Message format: [ctr, ct, tag]. -- -- This routine can throw an exception of 'OldContext' if the context being -- used has expired. @@ -234,22 +221,19 @@ encode ctx@(Out {..}) pt | aesCtr == maxBound = throw OldContext | otherwise = - let !iv_ct_tag = encryptGCM outKey aesCtr saltOut (pad pt) + let !iv_ct_tag = encryptGCM outKey aesCtr saltOut 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 + let tagLen = gTagLen + ctrLen = gCtrSize + in ctrLen + lenMsg + tagLen --- |Given a package length, returns the maximum number of bytes the --- underlying message could be (including padding). +-- |Given a package length, returns the number of bytes in the +-- underlying message. decBytes :: Int -> Int decBytes lenPkg = let tagLen = gTagLen @@ -264,16 +248,8 @@ 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 + encryptGCMPtr outKey aesCtr saltOut ptPtr ptLen 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 @@ -286,117 +262,41 @@ !ctLen = pkgLen - tagLen - sizeOf cnt !tagPtr = pkgPtr `plusPtr` (pkgLen - tagLen) tagLen = gTagLen - paddedLen = ctLen r <- decryptGCMPtr (inKey ctx) cnt (saltIn ctx) ctPtr ctLen tagPtr tagLen msgPtr case r of Left err -> return (Left err) - Right () -> helper ctx cnt paddedLen + Right () -> fmap (ctLen,) `fmap` helper ctx cnt where {-# INLINE helper #-} - helper :: InContext -> Word64 -> Int - -> IO (Either CommSecError (Int,InContext)) - helper (InStrict {..}) cnt paddedLen - | cnt > seqVal = do - pdLen <- padLenPtr msgPtr paddedLen - case pdLen of - Nothing -> return $ Left BadPadding - Just l -> return $ Right (paddedLen - l, InStrict cnt saltIn inKey) + helper :: InContext -> Word64 + -> IO (Either CommSecError InContext) + helper (InStrict {..}) cnt + | cnt > seqVal = return $ Right (InStrict cnt saltIn inKey) | otherwise = return (Left DuplicateSeq) - helper (InSequential {..}) cnt paddedLen - | cnt == seqVal + 1 = do - pdLen <- padLenPtr msgPtr paddedLen - case pdLen of - Nothing -> return $ Left BadPadding - Just l -> return $ Right (paddedLen - l, InSequential cnt saltIn inKey) + helper (InSequential {..}) cnt + | cnt == seqVal + 1 = return $ Right (InSequential cnt saltIn inKey) | otherwise = return (Left DuplicateSeq) - helper (In {..}) cnt paddedLen = do + helper (In {..}) cnt = do case updateBitWindow bitWindow cnt of Left e -> return (Left e) - Right newMask -> do - pdLen <- padLenPtr msgPtr paddedLen - case pdLen of - Nothing -> return $ Left BadPadding - Just l -> return $ Right (paddedLen - l, In newMask saltIn inKey) + Right newMask -> return $ Right (In newMask 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]. +-- Message format: [ctr, ct, tag]. decode :: InContext -> ByteString -> Either CommSecError (ByteString, InContext) -decode ctx pkg = - 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 ctx) cnt (saltIn ctx) ct tag - in helper ctx cnt ptpd - where - {-# INLINE helper #-} - helper (In {..}) cnt ptpd = - case updateBitWindow bitWindow cnt of - Left e -> Left e - Right bw -> - case ptpd of - Left err -> Left err - Right ptPad -> - case unpad ptPad of - Nothing -> Left BadPadding - Just pt -> Right (pt, In bw saltIn inKey) - helper (InStrict {..}) cnt ptpd - | cnt > seqVal = - case ptpd of - Left err -> Left err - Right ptPad -> - case unpad ptPad of - Nothing -> Left BadPadding - Just pt -> Right (pt, InStrict cnt saltIn inKey) - | otherwise = Left DuplicateSeq - helper (InSequential {..}) cnt ptpd - | cnt == seqVal + 1 = - case ptpd of - Left err -> Left err - Right ptPad -> - case unpad ptPad of - Nothing -> Left BadPadding - Just pt -> Right (pt, InSequential cnt saltIn inKey) - | otherwise = Left DuplicateSeq - --- |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 +decode ctx pkg = unsafePerformIO $ do + let ptLen = decBytes (B.length pkg) + pt <- B.mallocByteString ptLen + r <- withForeignPtr pt $ \ptPtr -> do + B.unsafeUseAsCString pkg $ \pkgPtr -> do + decodePtr ctx (castPtr pkgPtr) (castPtr ptPtr) (B.length pkg) + case r of + Left e -> return (Left e) + Right (_,c) -> return (Right (B.fromForeignPtr pt 0 ptLen,c)) peekBE :: Ptr Word8 -> IO Word64 peekBE p = do 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.2.5 +version: 0.3 synopsis: Provide communications security using symmetric ephemeral keys description: This package provides confidentiallity, integrity and replay detection. Users must