Skip to content

Use crypton instead of deprecated cryptonite #161

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
dancewithheart wants to merge 2 commits into
base: master
Choose a base branch
from
+31 −18
Open

Use crypton instead of deprecated cryptonite #161

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
8a2ffc6
replace deprecated cryptohash with crypton
dancewithheart May 4, 2026
40840d6
align crypton and ram
dancewithheart May 7, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
12 changes: 8 additions & 4 deletions Database/MongoDB/Internal/Protocol.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,8 @@ import Control.Concurrent (ThreadId, killThread, forkIOWithUnmask)
import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan, isEmptyTChan)

import Control.Exception.Lifted (SomeException, mask_, onException, throwIO, try)

import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L

import Control.Monad.Trans (MonadIO, liftIO)
Expand All @@ -61,7 +62,7 @@ import Data.Bson.Binary (getDocument, putDocument, getInt32, putInt32, getInt64,
putInt64, putCString)
import Data.Text (Text)

import qualified Crypto.Hash.MD5 as MD5
import Crypto.Hash( Digest, MD5, hash)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

Expand Down Expand Up @@ -794,11 +795,14 @@ type Username = Text
type Password = Text
type Nonce = Text

md5 :: BS.ByteString -> BS.ByteString
md5 = BA.convert . (hash :: BS.ByteString -> Digest MD5)

pwHash :: Username -> Password -> Text
pwHash u p = T.pack . byteStringHex . MD5.hash . TE.encodeUtf8 $ u `T.append` ":mongo:" `T.append` p
pwHash u p = T.pack . byteStringHex . md5 . TE.encodeUtf8 $ u `T.append` ":mongo:" `T.append` p

pwKey :: Nonce -> Username -> Password -> Text
pwKey n u p = T.pack . byteStringHex . MD5.hash . TE.encodeUtf8 . T.append n . T.append u $ pwHash u p
pwKey n u p = T.pack . byteStringHex . md5 . TE.encodeUtf8 . T.append n . T.append u $ pwHash u p


{- Authors: Tony Hannan <tony@10gen.com>
Expand Down
29 changes: 17 additions & 12 deletions Database/MongoDB/Query.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -62,9 +62,7 @@ import Control.Monad
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, local, runReaderT)
import Control.Monad.Trans (MonadIO, liftIO, lift)
import Control.Monad.Trans.Except
import qualified Crypto.Hash.MD5 as MD5
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.Hash.SHA256 as SHA256
import Crypto.Hash (Digest, MD5, SHA1, SHA256, hash)
import qualified Crypto.MAC.HMAC as HMAC
import qualified Crypto.Nonce as Nonce
import Data.Binary.Put (runPut)
Expand All @@ -89,6 +87,7 @@ import Data.Bson
cast
)
import Data.Bson.Binary (putDocument)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base64 as B64
Expand Down Expand Up @@ -133,9 +132,8 @@ import Database.MongoDB.Internal.Protocol
pwKey,
FlagBit (..)
)
import Control.Monad.Trans.Except
import qualified Database.MongoDB.Internal.Protocol as P
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>), splitDot)
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>))
import System.Mem.Weak (Weak)
import Text.Read (readMaybe)
import Prelude hiding (lookup)
Expand Down Expand Up @@ -289,9 +287,16 @@ authMongoCR usr pss = do

data HashAlgorithm = SHA1 | SHA256 deriving Show

hash :: HashAlgorithm -> B.ByteString -> B.ByteString
hash SHA1 = SHA1.hash
hash SHA256 = SHA256.hash
hashBytes :: HashAlgorithm -> B.ByteString -> B.ByteString
hashBytes SHA1 = BA.convert . (hash :: B.ByteString -> Digest SHA1)
hashBytes SHA256 = BA.convert . (hash :: B.ByteString -> Digest SHA256)

hmacBytes :: HashAlgorithm -> B.ByteString -> B.ByteString -> B.ByteString
hmacBytes SHA1 key msg = BA.convert (HMAC.hmac key msg :: HMAC.HMAC SHA1)
hmacBytes SHA256 key msg = BA.convert (HMAC.hmac key msg :: HMAC.HMAC SHA256)

md5 :: B.ByteString -> B.ByteString
md5 = BA.convert . (hash :: B.ByteString -> Digest MD5)

authSCRAMSHA1 :: MonadIO m => Username -> Password -> Action m Bool
authSCRAMSHA1 = authSCRAMWith SHA1
Expand All @@ -309,7 +314,7 @@ saslprep = id
authSCRAMWith :: MonadIO m => HashAlgorithm -> Username -> Password -> Action m Bool
-- ^ Authenticate with the current database, using the SCRAM-SHA-1 authentication mechanism (default in MongoDB server >= 3.0)
authSCRAMWith algo un pw = toAuthResult $ do
let hmac = HMAC.hmac (hash algo) 64
let hmac = hmacBytes algo
nonce <- liftIO (Nonce.withGenerator Nonce.nonce128 <&> B64.encode)
let firstBare = B.concat [B.pack $ "n=" ++ T.unpack un ++ ",r=", nonce]
let client1 =
Expand All @@ -332,11 +337,11 @@ authSCRAMWith algo un pw = toAuthResult $ do
shortcircuit (B.isInfixOf nonce snonce) "nonce"
let withoutProof = B.concat [B.pack "c=biws,r=", snonce]
let digest = case algo of
SHA1 -> B16.encode $ MD5.hash $ B.pack $ T.unpack un ++ ":mongo:" ++ T.unpack pw
SHA1 -> B16.encode $ md5 $ B.pack $ T.unpack un ++ ":mongo:" ++ T.unpack pw
SHA256 -> B.pack $ T.unpack $ saslprep pw
let saltedPass = scramHI algo digest salt iterations
let clientKey = hmac saltedPass (B.pack "Client Key")
let storedKey = hash algo clientKey
let storedKey = hashBytes algo clientKey
let authMsg = B.concat [firstBare, B.pack ",", serverPayload1, B.pack ",", withoutProof]
let clientSig = hmac storedKey authMsg
let pval = B64.encode . BS.pack $ BS.zipWith xor clientKey clientSig
Expand Down Expand Up @@ -373,7 +378,7 @@ shortcircuit False reason = throwE (show reason)
scramHI :: HashAlgorithm -> B.ByteString -> B.ByteString -> Int -> B.ByteString
scramHI algo digest salt iters = snd $ foldl com (u1, u1) [1..(iters-1)]
where
hmacd = HMAC.hmac (hash algo) 64 digest
hmacd = hmacBytes algo digest
u1 = hmacd (B.concat [salt, BS.pack [0, 0, 0, 1]])
com (u,uc) _ = let u' = hmacd u in (u', BS.pack $ BS.zipWith xor uc u')

Expand Down
8 changes: 6 additions & 2 deletions mongoDB.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -38,11 +38,12 @@ Library
, conduit
, conduit-extra
, mtl >= 2
, cryptohash -any
, crypton >= 1.1
, parsec -any
, random -any
, random-shuffle -any
, resourcet
, ram >= 0.20.1 && < 0.23
, monad-control >= 0.3.1
, lifted-base >= 0.1.0.3
, pureMD5
Expand Down Expand Up @@ -102,6 +103,8 @@ test-suite test
, old-locale
, text
, time
build-tool-depends:
hspec-discover:hspec-discover

default-language: Haskell2010
default-extensions: OverloadedStrings
Expand All @@ -122,12 +125,13 @@ Benchmark bench
, bytestring -any
, containers -any
, mtl >= 2
, cryptohash -any
, crypton >= 1.1
, nonce >= 1.0.5
, stm
, parsec -any
, random -any
, random-shuffle -any
, ram >= 0.20.1 && < 0.23
, monad-control >= 0.3.1
, lifted-base >= 0.1.0.3
, transformers
Expand Down