module OTP.HOTP
  ( OTP

    -- ** HMAC-SHA-1
  , newSHA1Key
  , hotpSHA1
  , hotpSHA1Check

    -- ** HMAC-SHA-256
  , newSHA256Key
  , hotpSHA256
  , hotpSHA256Check

    -- ** HMAC-SHA-512
  , newSHA512Key
  , hotpSHA512
  , hotpSHA512Check
  ) where

import Crypto.Hash.SHA1 qualified as SHA1
import Data.Bits
import Data.ByteString qualified as BS
import Data.List qualified as List
import Data.Serialize.Put
import Data.Text (Text)
import Data.Text.Display
import Data.Word
import Sel.HMAC.SHA256 qualified as SHA256
import Sel.HMAC.SHA512 qualified as SHA512
import System.IO.Unsafe (unsafePerformIO)

import OTP.Commons

-- ** HMAC-SHA-1

-- | Create an new random key to be used with the SHA-1 functions
--
-- @since 3.0.0.0
newSHA1Key :: IO SHA256.AuthenticationKey
newSHA1Key :: IO AuthenticationKey
newSHA1Key = IO AuthenticationKey
SHA256.newAuthenticationKey

-- | Compute HMAC-Based One-Time Password using secret key and counter value.
--
-- @since 3.0.0.0
hotpSHA1
  :: SHA256.AuthenticationKey
  -- ^ Shared secret
  -> Word64
  -- ^ Counter value
  -> Digits
  -- ^ Number of digits in a password. MUST be 6 digits at a minimum, and possibly 7 and 8 digits.
  -> OTP
  -- ^ HOTP
hotpSHA1 :: AuthenticationKey -> Word64 -> Digits -> OTP
hotpSHA1 AuthenticationKey
authenticationKey Word64
counter Digits
digits' = IO OTP -> OTP
forall a. IO a -> a
unsafePerformIO (IO OTP -> OTP) -> IO OTP -> OTP
forall a b. (a -> b) -> a -> b
$ do
  let digits :: Word32
digits = Digits -> Word32
digitsToWord32 Digits
digits'
  let msg :: ByteString
msg = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Putter Word64
putWord64be Word64
counter
  let key :: ByteString
key = AuthenticationKey -> ByteString
SHA256.unsafeAuthenticationKeyToBinary AuthenticationKey
authenticationKey
  let hash :: ByteString
hash = ByteString -> ByteString -> ByteString
SHA1.hmac ByteString
key ByteString
msg
  let code :: Word32
code = [Word8] -> Word32
truncateHash ([Word8] -> Word32) -> [Word8] -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
hash
  let result :: Word32
result = Word32
code Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`rem` (Word32
10 Word32 -> Word32 -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^ Word32
digits)
  OTP -> IO OTP
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OTP -> IO OTP) -> OTP -> IO OTP
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> OTP
OTP Word32
digits Word32
result

-- | Check presented password against a valid range.
--
-- @since 3.0.0.0
hotpSHA1Check
  :: SHA256.AuthenticationKey
  -- ^ Shared secret
  -> (Word64, Word64)
  -- ^ Valid counter range, before and after ideal
  -> Word64
  -- ^ Ideal (expected) counter value
  -> Digits
  -- ^ Number of digits provided
  -> Text
  -- ^ Digits entered by user
  -> Bool
  -- ^ True if password is valid
hotpSHA1Check :: AuthenticationKey
-> (Word64, Word64) -> Word64 -> Digits -> Text -> Bool
hotpSHA1Check AuthenticationKey
secret (Word64, Word64)
range Word64
counter Digits
digits Text
pass =
  let counters :: [Word64]
counters = (Word64, Word64) -> Word64 -> [Word64]
counterRange (Word64, Word64)
range Word64
counter
      passwords :: [Text]
passwords = (Word64 -> Text) -> [Word64] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word64
c -> OTP -> Text
forall a. Display a => a -> Text
display (OTP -> Text) -> OTP -> Text
forall a b. (a -> b) -> a -> b
$ AuthenticationKey -> Word64 -> Digits -> OTP
hotpSHA1 AuthenticationKey
secret Word64
c Digits
digits) [Word64]
counters
   in Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
pass [Text]
passwords

-- ** HMAC-SHA-256

-- | Create an new random key to be used with the SHA256 functions
--
-- @since 3.0.0.0
newSHA256Key :: IO SHA256.AuthenticationKey
newSHA256Key :: IO AuthenticationKey
newSHA256Key = IO AuthenticationKey
SHA256.newAuthenticationKey

-- | Compute HMAC-Based One-Time Password using secret key and counter value.
--
-- @since 3.0.0.0
hotpSHA256
  :: SHA256.AuthenticationKey
  -- ^ Shared secret
  -> Word64
  -- ^ Counter value
  -> Digits
  -- ^ Number of digits in a password. MUST be 6 digits at a minimum, and possibly 7 and 8 digits.
  -> OTP
  -- ^ HOTP
hotpSHA256 :: AuthenticationKey -> Word64 -> Digits -> OTP
hotpSHA256 AuthenticationKey
key Word64
counter Digits
digits' = IO OTP -> OTP
forall a. IO a -> a
unsafePerformIO (IO OTP -> OTP) -> IO OTP -> OTP
forall a b. (a -> b) -> a -> b
$ do
  let digits :: Word32
digits = Digits -> Word32
digitsToWord32 Digits
digits'
  let msg :: ByteString
msg = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Putter Word64
putWord64be Word64
counter
  ByteString
hash <- AuthenticationTag -> ByteString
SHA256.authenticationTagToBinary (AuthenticationTag -> ByteString)
-> IO AuthenticationTag -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> AuthenticationKey -> IO AuthenticationTag
SHA256.authenticate ByteString
msg AuthenticationKey
key
  let code :: Word32
code = [Word8] -> Word32
truncateHash ([Word8] -> Word32) -> [Word8] -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
hash
  let result :: Word32
result = Word32
code Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`rem` (Word32
10 Word32 -> Word32 -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^ Word32
digits)
  OTP -> IO OTP
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OTP -> IO OTP) -> OTP -> IO OTP
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> OTP
OTP Word32
digits Word32
result

-- | Check presented password against a valid range.
--
-- @since 3.0.0.0
hotpSHA256Check
  :: SHA256.AuthenticationKey
  -- ^ Shared secret
  -> (Word64, Word64)
  -- ^ Valid counter range, before and after ideal
  -> Word64
  -- ^ Ideal (expected) counter value
  -> Digits
  -- ^ Number of digits provided
  -> Text
  -- ^ Digits entered by user
  -> Bool
  -- ^ True if password is valid
hotpSHA256Check :: AuthenticationKey
-> (Word64, Word64) -> Word64 -> Digits -> Text -> Bool
hotpSHA256Check AuthenticationKey
secret (Word64, Word64)
range Word64
counter Digits
digits Text
pass =
  let counters :: [Word64]
counters = (Word64, Word64) -> Word64 -> [Word64]
counterRange (Word64, Word64)
range Word64
counter
      passwords :: [Text]
passwords = (Word64 -> Text) -> [Word64] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word64
c -> OTP -> Text
forall a. Display a => a -> Text
display (OTP -> Text) -> OTP -> Text
forall a b. (a -> b) -> a -> b
$ AuthenticationKey -> Word64 -> Digits -> OTP
hotpSHA256 AuthenticationKey
secret Word64
c Digits
digits) [Word64]
counters
   in Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
pass [Text]
passwords

-- ** HMAC-SHA-256

-- | Create an new random key to be used with the SHA512 functions
--
-- @since 3.0.0.0
newSHA512Key :: IO SHA512.AuthenticationKey
newSHA512Key :: IO AuthenticationKey
newSHA512Key = IO AuthenticationKey
SHA512.newAuthenticationKey

-- | Compute HMAC-Based One-Time Password using secret key and counter value.
--
-- @since 3.0.0.0
hotpSHA512
  :: SHA512.AuthenticationKey
  -- ^ Shared secret
  -> Word64
  -- ^ Counter value
  -> Digits
  -- ^ Number of digits in a password
  -> OTP
  -- ^ HOTP
hotpSHA512 :: AuthenticationKey -> Word64 -> Digits -> OTP
hotpSHA512 AuthenticationKey
key Word64
counter Digits
digits' = IO OTP -> OTP
forall a. IO a -> a
unsafePerformIO (IO OTP -> OTP) -> IO OTP -> OTP
forall a b. (a -> b) -> a -> b
$ do
  let digits :: Word32
digits = Digits -> Word32
digitsToWord32 Digits
digits'
  let msg :: ByteString
msg = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Putter Word64
putWord64be Word64
counter
  ByteString
hash <- AuthenticationTag -> ByteString
SHA512.authenticationTagToBinary (AuthenticationTag -> ByteString)
-> IO AuthenticationTag -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> AuthenticationKey -> IO AuthenticationTag
SHA512.authenticate ByteString
msg AuthenticationKey
key
  let code :: Word32
code = [Word8] -> Word32
truncateHash ([Word8] -> Word32) -> [Word8] -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
hash
  let result :: Word32
result = Word32
code Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`rem` (Word32
10 Word32 -> Word32 -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^ Word32
digits)
  OTP -> IO OTP
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OTP -> IO OTP) -> OTP -> IO OTP
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> OTP
OTP Word32
digits Word32
result

-- |
--
-- @since 3.0.0.0
hotpSHA512Check
  :: SHA512.AuthenticationKey
  -- ^ Shared secret
  -> (Word64, Word64)
  -- ^ Valid counter range, before and after ideal
  -> Word64
  -- ^ Ideal (expected) counter value
  -> Digits
  -- ^ Number of digits in a password
  -> Text
  -- ^ Password entered by user
  -> Bool
  -- ^ True if password is valid
hotpSHA512Check :: AuthenticationKey
-> (Word64, Word64) -> Word64 -> Digits -> Text -> Bool
hotpSHA512Check AuthenticationKey
secret (Word64, Word64)
range Word64
counter Digits
digits Text
pass =
  let counters :: [Word64]
counters = (Word64, Word64) -> Word64 -> [Word64]
counterRange (Word64, Word64)
range Word64
counter
      passwords :: [Text]
passwords = (Word64 -> Text) -> [Word64] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word64
c -> OTP -> Text
forall a. Display a => a -> Text
display (OTP -> Text) -> OTP -> Text
forall a b. (a -> b) -> a -> b
$ AuthenticationKey -> Word64 -> Digits -> OTP
hotpSHA512 AuthenticationKey
secret Word64
c Digits
digits) [Word64]
counters
   in Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
pass [Text]
passwords

-- | Take a hash and truncate it to its low 4 bits of the last byte.
--
-- >>> truncateHash [32,34,234,40,232, 123, 253, 20, 4]
-- 1752956180
--
-- @since 3.0.0.0
truncateHash :: [Word8] -> Word32
truncateHash :: [Word8] -> Word32
truncateHash [Word8]
b =
  let to32 :: Word8 -> Word32
to32 = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word32
      offset :: Word8
offset = [Word8] -> Word8
forall a. HasCallStack => [a] -> a
List.last [Word8]
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xF
      code :: Word32
code = case Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
List.take Int
4 ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
List.drop (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
offset) [Word8]
b of -- resulting 4 byte value
        [Word8
b0, Word8
b1, Word8
b2, Word8
b3] ->
          ((Word8 -> Word32
to32 Word8
b0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7F) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
.<<. Int
24)
            Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word32
to32 Word8
b1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
.<<. Int
16)
            Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word32
to32 Word8
b2 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
.<<. Int
8)
            Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word32
to32 Word8
b3 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF)
        [Word8]
_ -> [Char] -> Word32
forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened"
   in Word32
code Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7FFFFFFF -- clear the highest bit