diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2017 Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Don Stewart nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# crypt + +A wrapper around `crypt()`. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/crypt-sha512.cabal b/crypt-sha512.cabal new file mode 100644 --- /dev/null +++ b/crypt-sha512.cabal @@ -0,0 +1,60 @@ +name: crypt-sha512 +version: 0 +synopsis: Pure Haskell implelementation for GNU SHA512 crypt algorithm +description: + crypt() is the password encryption function. It is based on the Data + Encryption Standard algorithm with variations intended (among other things) to + discourage use of hardware implementations of a key search. + . + This package provides a pure Haskell implementation of SHA512 crypt scheme. +category: Data +license: BSD3 +license-file: LICENSE +author: Oleg Grenrus +maintainer: Oleg Grenrus +copyright: 2017 Oleg Grenrus +homepage: https://github.com/phadej/crypt-sha512 +bug-reports: https://github.com/phadej/crypt-sha512 +extra-source-files: README.md +build-type: Simple +cabal-version: >= 1.10 +tested-with: + GHC==7.6.3, + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.1 + +source-repository head + type: git + location: git://github.com/phadej/crypt-sha512.git + +library + exposed-modules: System.POSIX.Crypt.SHA512 + build-depends: base >=4.5 && <4.11, + bytestring, + attoparsec >=0.13.1.0 && <0.14, + cryptohash-sha512 >=0.11.100.1 && <0.12 + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + +test-suite example + if !os(linux) + buildable: False + + build-depends: base, + crypt-sha512, + bytestring, + tasty, + tasty-hunit, + tasty-quickcheck, + quickcheck-instances + default-language: Haskell2010 + main-is: Example.hs + other-modules: System.POSIX.Crypt + type: exitcode-stdio-1.0 + hs-source-dirs: test + other-extensions: OverloadedStrings CApiFFI + extra-libraries: crypt + ghc-options: -Wall diff --git a/src/System/POSIX/Crypt/SHA512.hs b/src/System/POSIX/Crypt/SHA512.hs new file mode 100644 --- /dev/null +++ b/src/System/POSIX/Crypt/SHA512.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE OverloadedStrings #-} +module System.POSIX.Crypt.SHA512 ( + cryptSHA512, + cryptSHA512', + cryptSHA512Raw, + -- * Utilities + encode64, + encode64List, + ) where + +import Control.Applicative (optional) +import Data.List (foldl') +import Data.Word (Word8, Word32) +import Data.String (fromString) -- use builder +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) + +import qualified Data.ByteString as BS +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Crypto.Hash.SHA512 as SHA + +{- +import qualified Data.ByteString.Base16 as Base16 +import Debug.Trace + +traceBSId :: String -> BS.ByteString -> BS.ByteString +traceBSId n dig = trace (n ++ ": " ++ show (Base16.encode dig)) dig +-} + +traceBSId :: String -> BS.ByteString -> BS.ByteString +traceBSId _ = id + +-- | Pure Haskell implementation of SHA512 @crypt@ method. +-- +-- For @libc@ versions supporting SHA512 encryption scheme (6): +-- +-- prop> "$6$" `isPrefixOf` salt ==> crypt key salt = cryptSHA512 key salt +-- +-- === a snippet from glibc documentation +-- +-- @glibc@ implementations of @crypt@ support additional encryption algorithms. +-- +-- If /salt/ is a character string starting with the characters @"$id$"@ followed by a string terminated by @"$"@: +-- +-- @ +-- \$id$salt$encrypted +-- @ +-- +-- then instead of using the DES machine, id identifies the encryption method used and this then determines how the rest of the password string is interpreted. +-- +-- The @id@ value @6@ corresponds to SHA-512 method (since @glibc-2.17@). +-- +-- If the /salt/ string starts with +-- +-- @ +-- rounds=\$ +-- @ +-- +-- where /N/ is an unsigned decimal number the numeric value of /N/ is used +--to modify the algorithm used. For example: +-- +-- @ +-- \$6$rounds=77777$salt$encrypted +-- @ +-- +-- See +-- +cryptSHA512 + :: BS.ByteString -- ^ key + -> BS.ByteString -- ^ salt: @$6$...@ + -> Maybe BS.ByteString +cryptSHA512 key saltI = case A.parseOnly saltP saltI of + Left _ -> Nothing + Right (salt, rounds) -> Just (cryptSHA512Raw rounds key salt) + where + saltP :: A.Parser (BS.ByteString, Maybe Int) + saltP = do + _ <- A.string header + rounds <- optional roundsP + salt <- A.takeWhile (/= 36) -- ord '$' = 36 + return (BS.take 16 salt, rounds) + + roundsP :: A.Parser Int + roundsP = do + _ <- A.string "rounds=" + n <- A8.decimal + _ <- A.word8 36 + return n + +-- | Split salt-input variant of 'cryptSHA512'. Salt is encoded. +cryptSHA512' + :: Maybe Int -- ^ rounds + -> BS.ByteString -- ^ key + -> BS.ByteString -- ^ salt, will be base64 encoded + -> BS.ByteString +cryptSHA512' rounds key salt = cryptSHA512Raw rounds key (encode64 salt) + +-- | Raw input implementation of 'cryptSHA512'. +cryptSHA512Raw + :: Maybe Int -- ^ rounds, clamped into @[1000, 999999999]@ range + -> BS.ByteString -- ^ key + -> BS.ByteString -- ^ salt, first 16 characters used. + -> BS.ByteString +cryptSHA512Raw Nothing key salt' = + let salt = BS.take 16 salt' + enc = implementation 5000 key salt + in BS.concat + [ header + , salt + , "$" + , encode64' enc + ] +cryptSHA512Raw (Just n) key salt' = + let rounds = min 999999999 $ max 1000 n + salt = BS.take 16 salt' + enc = implementation rounds key salt + in BS.concat + [ header + , "rounds=" + , fromString (show rounds) + , "$" + , salt + , "$" + , encode64' enc + ] + +header :: BS.ByteString +header = "$6$" + +implementation + :: Int -- ^ rounds + -> BS.ByteString -- ^ key + -> BS.ByteString -- ^ salt + -> BS.ByteString +implementation roundsN key salt = + -- steps 4-8 + let digB = traceBSId "digest B" $ + SHA.finalize $ flip SHA.updates [key, salt, key] $ SHA.init + + -- steps 1-3 + ctxA0 = SHA.updates SHA.init [key, salt] + + -- steps 9-10 + ctxA1 = fl keyblocks ctxA0 $ \ctx block -> + if BS.length block == 64 + then SHA.update ctx digB + else SHA.update ctx (BS.take (BS.length block) digB) + + -- step 11 + ctxA2 = fl (bits (BS.length key)) ctxA1 $ \ctx one -> + if one + then SHA.update ctx digB + else SHA.update ctx key + + -- step 12 + digA = traceBSId "digest A" $ + SHA.finalize ctxA2 + + -- steps 13-15 + digDP = traceBSId "digest DP" $ + SHA.finalize $ SHA.updates SHA.init $ + replicate (BS.length key) key + + -- step 16 + p = traceBSId "byte sequence P" $ + BS.concat $ flip map keyblocks $ \block -> + BS.take (BS.length block) digDP + + -- steps 17-19 + digDS = traceBSId "digest DS" $ + SHA.finalize $ rounds (16 + fromIntegral (BS.index digA 0)) SHA.init $ \ctx -> + SHA.update ctx salt + + -- step 20 + s = traceBSId "byte sequence S" $ + BS.concat $ flip map saltblocks $ \block -> + BS.take (BS.length block) digDS + + -- step 21 + enc = rounds' roundsN digA $ \i digAC -> + -- a) start digest C + let ctxC0 = SHA.init + + -- b) for odd round numbers add the byte sequense P to digest C + -- c) for even round numbers add digest A/C + ctxC1 = if i `mod` 2 /= 0 + then SHA.update ctxC0 p + else SHA.update ctxC0 digAC + + -- d) for all round numbers not divisible by 3 add the byte sequence S + ctxC2 = if i `mod` 3 /= 0 then SHA.update ctxC1 s else ctxC1 + + -- e) for all round numbers not divisible by 7 add the byte sequence P + ctxC3 = if i `mod` 7 /= 0 then SHA.update ctxC2 p else ctxC2 + + -- f) for odd round numbers add digest A/C + -- g) for even round numbers add the byte sequence P + ctxC4 = if i `mod` 2 /= 0 + then SHA.update ctxC3 digAC + else SHA.update ctxC3 p + + -- h) finish digest C. + in SHA.finalize ctxC4 + in enc + where + -- blocks of 64 bytes! + keyblocks :: [BS.ByteString] + keyblocks = splitMany key + + saltblocks :: [BS.ByteString] + saltblocks = splitMany salt + + splitMany bs + | BS.null bs = [] + | otherwise = let (a, b) = BS.splitAt 64 bs in a : splitMany b + + -- foldl' with parameters reversed + fl xs i f = foldl' f i xs + + bits :: Int -> [Bool] + bits n + | n <= 0 = [] + | otherwise = let (m, d) = n `divMod` 2 in (d == 1) : bits m + + rounds :: Int -> a -> (a -> a) -> a + rounds n x f = rounds' n x (const f) + + -- rounds variant with a step + rounds' :: Int -> a -> (Int -> a -> a) -> a + rounds' n x f = go 0 x where + go i y | i < n = y `seq` go (i+1) (f i y) + | otherwise = y + +------------------------------------------------------------------------------- +-- Custom Base64 encoding +------------------------------------------------------------------------------- + +-- | Custom base64 encoding used by crypt SHA512 scheme. +encode64 :: BS.ByteString -> BS.ByteString +encode64 = encode64List . BS.unpack + +-- | Custom base64 encoding used by crypt SHA512 scheme. See 'encode64'. +encode64List :: [Word8] -> BS.ByteString +encode64List = BS.pack . go + where + go :: [Word8] -> [Word8] + go [] = [] + go [b] = + [ BS.index alphabet $ fromIntegral $ b .&. 0x3f + , BS.index alphabet $ fromIntegral $ b `shiftR` 6 + ] + go [b1, b0] = + [ BS.index alphabet $ fromIntegral $ w .&. 0x3f + , BS.index alphabet $ fromIntegral $ w `shiftR` 6 .&. 0x3f + , BS.index alphabet $ fromIntegral $ w `shiftR` 12 .&. 0x3f + ] + where + w :: Word32 + w = fromIntegral b0 .|. fromIntegral b1 `shiftL` 8 + go (b2:b1:b0:bs) = + (BS.index alphabet $ fromIntegral $ w .&. 0x3f) : + (BS.index alphabet $ fromIntegral $ w `shiftR` 6 .&. 0x3f) : + (BS.index alphabet $ fromIntegral $ w `shiftR` 12 .&. 0x3f) : + (BS.index alphabet $ fromIntegral $ w `shiftR` 18 .&. 0x3f) : + go bs + where + w :: Word32 + w = fromIntegral b0 + .|. fromIntegral b1 `shiftL` 8 + .|. fromIntegral b2 `shiftL` 16 + + alphabet :: BS.ByteString + alphabet = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" + +encode64' + :: BS.ByteString -- should be 64 word8 long! + -> BS.ByteString +encode64' bs | BS.length bs /= 64 = + error $ "System.POSIX.Crypt.SHA512.encode64': input should be 64 in length: " ++ show (BS.length bs) +encode64' bs = encode64List + [ i 0, i 21, i 42 + , i 22, i 43, i 1 + , i 44, i 2, i 23 + , i 3, i 24, i 45 + , i 25, i 46, i 4 + , i 47, i 5, i 26 + , i 6, i 27, i 48 + , i 28, i 49, i 7 + , i 50, i 8, i 29 + , i 9, i 30, i 51 + , i 31, i 52, i 10 + , i 53, i 11, i 32 + , i 12, i 33, i 54 + , i 34, i 55, i 13 + , i 56, i 14, i 35 + , i 15, i 36, i 57 + , i 37, i 58, i 16 + , i 59, i 17, i 38 + , i 18, i 39, i 60 + , i 40, i 61, i 19 + , i 62, i 20, i 41 + , i 63 + ] + where + i = BS.index bs diff --git a/test/Example.hs b/test/Example.hs new file mode 100644 --- /dev/null +++ b/test/Example.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import System.POSIX.Crypt +import System.POSIX.Crypt.SHA512 + +import Data.Monoid ((<>)) + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Test.QuickCheck.Instances () + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +main :: IO () +main = do + let enc = crypt "pass" "$6$saltstring" + isGlibc <- if fmap BS.length enc == Just 100 + then return True + else do + putStrLn $ "crypt doesn't recognize $6$ prefix in salt" + putStrLn $ "returned " ++ show enc + putStrLn $ "most likely you don't have glibc >=2.17" + putStrLn $ "we will skip some tests" + return False + + defaultMain $ testGroup "Tests" $ + [ sha512examples "cryptSHA512" cryptSHA512 + , cryptSHA512RawExamples + ] ++ glibcTests isGlibc + + where + glibcTests True = + [ sha512examples "crypt" crypt + , testProperty "glibc and native impl comparison" glibcNativeProp + ] + glibcTests False = [] + +glibcNativeProp :: Input -> Property +glibcNativeProp (Input key salt) = + crypt key salt === cryptSHA512 key salt + +data Input = Input BS.ByteString BS.ByteString + deriving Show + +instance Arbitrary Input where + arbitrary = do + key <- fmap BS.pack $ listOf $ elements $ BS.unpack alphabet + salt <- fmap BS.pack $ listOf $ elements $ BS.unpack alphabet + + return (Input key $ "$6$" <> salt) + where + alphabet = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" + +sha512examples + :: String + -> (BS.ByteString -> BS.ByteString -> Maybe BS.ByteString) -- crypt function + -> TestTree +sha512examples name c = testGroup name $ + [ m "$6$saltstring" + "Hello world!" + "$6$saltstring$svn8UoSVapNtMuq1ukKS4tPQd8iKwSMHWjl/O817G3uBnIFNjnQJuesI68u4OTLiBFdcbYEdFCoEOfaS35inz1" + , m "$6$rounds=10000$saltstringsaltstring" + "Hello world!" + "$6$rounds=10000$saltstringsaltst$OW1/O6BYHV6BcXZu8QVeXbDWra3Oeqh0sbHbbMCVNSnCM/UrjmM0Dp8vOuZeHBy/YTBmSK6H9qs/y3RnOaw5v." + , m "$6$rounds=5000$toolongsaltstring" + "This is just a test" + "$6$rounds=5000$toolongsaltstrin$lQ8jolhgVRVhY4b5pZKaysCLi0QBxGoNeKQzQ3glMhwllF7oGDZxUhx1yxdYcz/e1JSbq3y6JMxxl8audkUEm0" + , m "$6$rounds=1400$anotherlongsaltstring" + "a very much longer text to encrypt. This one even stretches over morethan one line." + "$6$rounds=1400$anotherlongsalts$POfYwTEok97VWcjxIiSOjiykti.o/pQs.wPvMxQ6Fm7I6IoYN3CmLs66x9t0oSwbtEW7o7UmJEiDwGqd8p4ur1" + , m "$6$rounds=77777$short" + "we have a short salt string but not a short password" + "$6$rounds=77777$short$WuQyW2YR.hBNpjjRhpYD/ifIw05xdfeEyQoMxIXbkvr0gge1a1x3yRULJ5CCaUeOxFmtlcGZelFl5CxtgfiAc0" + , m "$6$rounds=123456$asaltof16chars.." + "a short string" + "$6$rounds=123456$asaltof16chars..$BtCwjqMJGx5hrJhZywWvt0RLE8uZ4oPwcelCjmw2kSYu.Ec6ycULevoBK25fs2xXgMNrCzIMVcgEJAstJeonj1" + , m "$6$rounds=10$roundstoolow" + "the minimum number is still observed" + "$6$rounds=1000$roundstoolow$kUMsbe306n21p9R.FRkW3IGn.S9NPN0x50YhH1xhLsPuWGsUSklZt58jaTfF4ZEQpyUNGc0dqbpBYYBaHHrsX." + -- regressions + , m "$6$saltstring" + "xXHJ" + "$6$saltstring$RiyF6qtDbUHgB5fPL.afjplfUYs7h6e8AC8OGC1IZ0ZzQQuh6BWLwaGzlxnl2cSJ8kQvEGUxj4mwH/DosJPzx/" + , m "$6$saltstring" + "xyny33AP6" + "$6$saltstring$Ev29zY/SO64MAYRTBEO3wrxXeeGGNxagYNWDK3Mh2Zucgx3d1Y7/i4tWvHd86WIDLH2iLaZByx3GRvaikhBpb." + , m "$6$saltstring" + "xyny33AP6!" + "$6$saltstring$nsREMPgSFfMi0atBqyK8d78dtjt2IdZP4ih2hE38sTshzqC8D5E5wFBUxT9eN/gEos64NxxhUQzDaAyqogHUL0" + ] + where + m salt key expected = testCase (BS8.unpack salt) $ do + c key salt @?= Just expected + +cryptSHA512RawExamples :: TestTree +cryptSHA512RawExamples = testGroup "cryptSHA512Raw" + [ m Nothing "saltstring" + "Hello world!" + "$6$saltstring$svn8UoSVapNtMuq1ukKS4tPQd8iKwSMHWjl/O817G3uBnIFNjnQJuesI68u4OTLiBFdcbYEdFCoEOfaS35inz1" + , m (Just 10000) "saltstringsaltstring" + "Hello world!" + "$6$rounds=10000$saltstringsaltst$OW1/O6BYHV6BcXZu8QVeXbDWra3Oeqh0sbHbbMCVNSnCM/UrjmM0Dp8vOuZeHBy/YTBmSK6H9qs/y3RnOaw5v." + , m (Just 5000) "toolongsaltstring" + "This is just a test" + "$6$rounds=5000$toolongsaltstrin$lQ8jolhgVRVhY4b5pZKaysCLi0QBxGoNeKQzQ3glMhwllF7oGDZxUhx1yxdYcz/e1JSbq3y6JMxxl8audkUEm0" + , m (Just 1400) "anotherlongsaltstring" + "a very much longer text to encrypt. This one even stretches over morethan one line." + "$6$rounds=1400$anotherlongsalts$POfYwTEok97VWcjxIiSOjiykti.o/pQs.wPvMxQ6Fm7I6IoYN3CmLs66x9t0oSwbtEW7o7UmJEiDwGqd8p4ur1" + , m (Just 77777) "short" + "we have a short salt string but not a short password" + "$6$rounds=77777$short$WuQyW2YR.hBNpjjRhpYD/ifIw05xdfeEyQoMxIXbkvr0gge1a1x3yRULJ5CCaUeOxFmtlcGZelFl5CxtgfiAc0" + , m (Just 123456) "asaltof16chars.." + "a short string" + "$6$rounds=123456$asaltof16chars..$BtCwjqMJGx5hrJhZywWvt0RLE8uZ4oPwcelCjmw2kSYu.Ec6ycULevoBK25fs2xXgMNrCzIMVcgEJAstJeonj1" + , m (Just 10) "roundstoolow" + "the minimum number is still observed" + "$6$rounds=1000$roundstoolow$kUMsbe306n21p9R.FRkW3IGn.S9NPN0x50YhH1xhLsPuWGsUSklZt58jaTfF4ZEQpyUNGc0dqbpBYYBaHHrsX." + ] + where + m rounds salt key expected = testCase (BS8.unpack salt ++ " " ++ show rounds) $ do + cryptSHA512Raw rounds key salt @?= expected diff --git a/test/System/POSIX/Crypt.hsc b/test/System/POSIX/Crypt.hsc new file mode 100644 --- /dev/null +++ b/test/System/POSIX/Crypt.hsc @@ -0,0 +1,35 @@ + {-# LANGUAGE Trustworthy, CApiFFI #-} +module System.POSIX.Crypt (crypt) where + +#include + +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Foreign (nullPtr) +import Foreign.C (CString) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.ByteString as BS + +-- crypt is not re-entrable +lock :: MVar () +lock = unsafePerformIO $ newMVar () +{-# NOINLINE lock #-} + +foreign import ccall unsafe "crypt" + c_crypt :: CString -> CString -> IO CString + +-- | Calls @crypt@. +crypt + :: BS.ByteString -- ^ key + -> BS.ByteString -- ^ salt + -> Maybe BS.ByteString +crypt key salt = unsafePerformIO $ withMVar lock $ \_ -> + BS.useAsCString key $ \ckey -> + BS.useAsCString salt $ \csalt -> do + res <- c_crypt ckey csalt + if res == nullPtr + then return Nothing + else do + bs <- BS.packCString res + bs `seq` return (Just bs) +{-# NOINLINE crypt #-}