commsec 0.2.5 → 0.3
raw patch · 3 files changed
+104/−227 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Network/CommSec.hs +65/−88
- Network/CommSec/Package.hs +38/−138
- commsec.cabal +1/−1
Network/CommSec.hs view
@@ -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 ()
Network/CommSec/Package.hs view
@@ -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
commsec.cabal view
@@ -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