{-|
Module      : Z.Crypto.OTP
Description : One Time Passwords
Copyright   : Dong Han, AnJie Dong, 2021
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

One time password schemes are a user authentication method that relies on a fixed secret key which is used to derive a sequence of short passwords, each of which is accepted only once. Commonly this is used to implement two-factor authentication (2FA), where the user authenticates using both a conventional password (or a public key signature) and an OTP generated by a small device such as a mobile phone.

Botan implements the HOTP and TOTP schemes from RFC 4226 and 6238.

Since the range of possible OTPs is quite small, applications must rate limit OTP authentication attempts to some small number per second. Otherwise an attacker could quickly try all 1000000 6-digit OTPs in a brief amount of time.

-}

module Z.Crypto.OTP (
  -- * HOTP
    HOTP, newHOTP, genHOTP, checkHOTP
  -- * TOTP
  , TOTP, newTOTP, genTOTP, checkTOTP
  -- * constants
  , OTPAlgo, pattern OTP_SHA1, pattern OTP_SHA256, pattern OTP_SHA512
  , OTPDigitLen, pattern OTP_DIGIT_6, pattern OTP_DIGIT_7, pattern OTP_DIGIT_8
  ) where

import           Data.Word
import           GHC.Generics
import           Z.Botan.Exception
import           Z.Botan.FFI
import           Z.Data.CBytes
import qualified Z.Data.Vector  as V
import qualified Z.Data.Text    as T
import           Z.Crypto.Hash  (HashType(..), hashTypeToCBytes)
import           Z.Foreign

-- | HOTP generates OTPs that are a short numeric sequence, between 6 and 8 digits (most applications use 6 digits), created using the HMAC of a 64-bit counter value. If the counter ever repeats the OTP will also repeat, thus both parties must assure the counter only increments and is never repeated or decremented. Thus both client and server must keep track of the next counter expected.
-- Anyone with access to the client-specific secret key can authenticate as that client, so it should be treated with the same security consideration as would be given to any other symmetric key or plaintext password.
newtype HOTP = HOTP BotanStruct
    deriving (Int -> HOTP -> ShowS
[HOTP] -> ShowS
HOTP -> String
(Int -> HOTP -> ShowS)
-> (HOTP -> String) -> ([HOTP] -> ShowS) -> Show HOTP
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HOTP] -> ShowS
$cshowList :: [HOTP] -> ShowS
show :: HOTP -> String
$cshow :: HOTP -> String
showsPrec :: Int -> HOTP -> ShowS
$cshowsPrec :: Int -> HOTP -> ShowS
Show, (forall x. HOTP -> Rep HOTP x)
-> (forall x. Rep HOTP x -> HOTP) -> Generic HOTP
forall x. Rep HOTP x -> HOTP
forall x. HOTP -> Rep HOTP x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HOTP x -> HOTP
$cfrom :: forall x. HOTP -> Rep HOTP x
Generic)
    deriving anyclass Int -> HOTP -> Builder ()
(Int -> HOTP -> Builder ()) -> Print HOTP
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> HOTP -> Builder ()
$ctoUTF8BuilderP :: Int -> HOTP -> Builder ()
T.Print

type OTPAlgo = HashType
pattern OTP_SHA1    :: OTPAlgo
pattern OTP_SHA256  :: OTPAlgo
pattern OTP_SHA512  :: OTPAlgo
pattern $bOTP_SHA1 :: OTPAlgo
$mOTP_SHA1 :: forall r. OTPAlgo -> (Void# -> r) -> (Void# -> r) -> r
OTP_SHA1    = SHA160
pattern $bOTP_SHA256 :: OTPAlgo
$mOTP_SHA256 :: forall r. OTPAlgo -> (Void# -> r) -> (Void# -> r) -> r
OTP_SHA256  = SHA256
pattern $bOTP_SHA512 :: OTPAlgo
$mOTP_SHA512 :: forall r. OTPAlgo -> (Void# -> r) -> (Void# -> r) -> r
OTP_SHA512  = SHA512

type OTPDigitLen = Int
pattern OTP_DIGIT_6 :: OTPDigitLen
pattern OTP_DIGIT_7 :: OTPDigitLen
pattern OTP_DIGIT_8 :: OTPDigitLen
pattern $bOTP_DIGIT_6 :: Int
$mOTP_DIGIT_6 :: forall r. Int -> (Void# -> r) -> (Void# -> r) -> r
OTP_DIGIT_6 = 6
pattern $bOTP_DIGIT_7 :: Int
$mOTP_DIGIT_7 :: forall r. Int -> (Void# -> r) -> (Void# -> r) -> r
OTP_DIGIT_7 = 7
pattern $bOTP_DIGIT_8 :: Int
$mOTP_DIGIT_8 :: forall r. Int -> (Void# -> r) -> (Void# -> r) -> r
OTP_DIGIT_8 = 8

newHOTP :: HasCallStack => V.Bytes -> OTPAlgo -> OTPDigitLen -> IO HOTP
{-# INLINABLE newHOTP #-}
newHOTP :: Bytes -> OTPAlgo -> Int -> IO HOTP
newHOTP Bytes
key OTPAlgo
otpAlgo Int
digits =
    Bytes -> (BA# Word8 -> Int -> Int -> IO HOTP) -> IO HOTP
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
key ((BA# Word8 -> Int -> Int -> IO HOTP) -> IO HOTP)
-> (BA# Word8 -> Int -> Int -> IO HOTP) -> IO HOTP
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
key' Int
keyOff Int
keyLen ->
    CBytes -> (BA# Word8 -> IO HOTP) -> IO HOTP
forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe (OTPAlgo -> CBytes
hashTypeToCBytes OTPAlgo
otpAlgo) ((BA# Word8 -> IO HOTP) -> IO HOTP)
-> (BA# Word8 -> IO HOTP) -> IO HOTP
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
hashAlgo' ->
        BotanStruct -> HOTP
HOTP (BotanStruct -> HOTP) -> IO BotanStruct -> IO HOTP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MBA# BotanStructT -> IO CInt)
-> FunPtr (BotanStructT -> IO ()) -> IO BotanStruct
forall a.
HasCallStack =>
(MBA# BotanStructT -> IO CInt)
-> FunPtr (BotanStructT -> IO a) -> IO BotanStruct
newBotanStruct
            (\ MBA# BotanStructT
hotp -> MBA# BotanStructT
-> BA# Word8 -> Int -> Int -> BA# Word8 -> Int -> IO CInt
hs_botan_hotp_init MBA# BotanStructT
hotp BA# Word8
key' Int
keyOff Int
keyLen BA# Word8
hashAlgo' Int
digits)
            FunPtr (BotanStructT -> IO ())
botan_hotp_destroy

-- | Generate a HOTP code for the provided counter.
genHOTP :: HasCallStack
        => HOTP   -- ^ the HOTP object
        -> Word64 -- ^ HOTP counter
        -> IO Word32
{-# INLINABLE genHOTP #-}
genHOTP :: HOTP -> Word64 -> IO Word32
genHOTP (HOTP BotanStruct
hotp) Word64
counter =
    BotanStruct -> (BotanStructT -> IO Word32) -> IO Word32
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
hotp ((BotanStructT -> IO Word32) -> IO Word32)
-> (BotanStructT -> IO Word32) -> IO Word32
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
hotp' ->
    (Word32, CInt) -> Word32
forall a b. (a, b) -> a
fst ((Word32, CInt) -> Word32) -> IO (Word32, CInt) -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MBA# BotanStructT -> IO CInt) -> IO (Word32, CInt)
forall a b. Prim a => (MBA# BotanStructT -> IO b) -> IO (a, b)
allocPrimUnsafe (\ MBA# BotanStructT
code -> BotanStructT -> MBA# BotanStructT -> Word64 -> IO CInt
botan_hotp_generate BotanStructT
hotp' MBA# BotanStructT
code Word64
counter)

-- | Verify a HOTP code.
checkHOTP :: HasCallStack
          => HOTP   -- ^ the HOTP object
          -> Word32 -- ^ the presented HOTP code
          -> Word64 -- ^ the HOTP counter
          -> Int    -- ^ resync range
          -> IO (Bool, Word64)
{-# INLINABLE checkHOTP #-}
checkHOTP :: HOTP -> Word32 -> Word64 -> Int -> IO (Bool, Word64)
checkHOTP (HOTP BotanStruct
totp) Word32
code Word64
c Int
range = do
    BotanStruct
-> (BotanStructT -> IO (Bool, Word64)) -> IO (Bool, Word64)
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
totp ((BotanStructT -> IO (Bool, Word64)) -> IO (Bool, Word64))
-> (BotanStructT -> IO (Bool, Word64)) -> IO (Bool, Word64)
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
totp' -> do
        (Word64
nc, CInt
ret) <- (MBA# BotanStructT -> IO CInt) -> IO (Word64, CInt)
forall a b. Prim a => (MBA# BotanStructT -> IO b) -> IO (a, b)
allocPrimUnsafe ((MBA# BotanStructT -> IO CInt) -> IO (Word64, CInt))
-> (MBA# BotanStructT -> IO CInt) -> IO (Word64, CInt)
forall a b. (a -> b) -> a -> b
$ \ MBA# BotanStructT
nc' ->
            BotanStructT
-> MBA# BotanStructT -> Word32 -> Word64 -> CSize -> IO CInt
botan_hotp_check BotanStructT
totp' MBA# BotanStructT
nc' Word32
code Word64
c (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
range)
        if CInt
ret CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
BOTAN_FFI_SUCCESS
        then (Bool, Word64) -> IO (Bool, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Word64
nc)
        else if CInt
ret CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> CInt
0
            then (Bool, Word64) -> IO (Bool, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Word64
nc)
            else CInt -> IO (Bool, Word64)
forall x. HasCallStack => CInt -> IO x
throwBotanError CInt
ret

--------------------------------------------------------------------------------

-- | TOTP is based on the same algorithm as HOTP, but instead of a counter a timestamp is used.
newtype TOTP = TOTP BotanStruct
    deriving (Int -> TOTP -> ShowS
[TOTP] -> ShowS
TOTP -> String
(Int -> TOTP -> ShowS)
-> (TOTP -> String) -> ([TOTP] -> ShowS) -> Show TOTP
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TOTP] -> ShowS
$cshowList :: [TOTP] -> ShowS
show :: TOTP -> String
$cshow :: TOTP -> String
showsPrec :: Int -> TOTP -> ShowS
$cshowsPrec :: Int -> TOTP -> ShowS
Show, (forall x. TOTP -> Rep TOTP x)
-> (forall x. Rep TOTP x -> TOTP) -> Generic TOTP
forall x. Rep TOTP x -> TOTP
forall x. TOTP -> Rep TOTP x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TOTP x -> TOTP
$cfrom :: forall x. TOTP -> Rep TOTP x
Generic)
    deriving anyclass Int -> TOTP -> Builder ()
(Int -> TOTP -> Builder ()) -> Print TOTP
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> TOTP -> Builder ()
$ctoUTF8BuilderP :: Int -> TOTP -> Builder ()
T.Print

newTOTP :: HasCallStack => V.Bytes -> OTPAlgo -> OTPDigitLen -> Int -> IO TOTP
{-# INLINABLE newTOTP #-}
newTOTP :: Bytes -> OTPAlgo -> Int -> Int -> IO TOTP
newTOTP Bytes
key OTPAlgo
otpAlgo Int
digits Int
timeStep =
    Bytes -> (BA# Word8 -> Int -> Int -> IO TOTP) -> IO TOTP
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
key ((BA# Word8 -> Int -> Int -> IO TOTP) -> IO TOTP)
-> (BA# Word8 -> Int -> Int -> IO TOTP) -> IO TOTP
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
key' Int
keyOff Int
keyLen ->
    CBytes -> (BA# Word8 -> IO TOTP) -> IO TOTP
forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe (OTPAlgo -> CBytes
hashTypeToCBytes OTPAlgo
otpAlgo) ((BA# Word8 -> IO TOTP) -> IO TOTP)
-> (BA# Word8 -> IO TOTP) -> IO TOTP
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
hashAlgo' ->
        BotanStruct -> TOTP
TOTP (BotanStruct -> TOTP) -> IO BotanStruct -> IO TOTP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MBA# BotanStructT -> IO CInt)
-> FunPtr (BotanStructT -> IO ()) -> IO BotanStruct
forall a.
HasCallStack =>
(MBA# BotanStructT -> IO CInt)
-> FunPtr (BotanStructT -> IO a) -> IO BotanStruct
newBotanStruct
            (\ MBA# BotanStructT
hotp -> MBA# BotanStructT
-> BA# Word8 -> Int -> Int -> BA# Word8 -> Int -> Int -> IO CInt
hs_botan_totp_init MBA# BotanStructT
hotp BA# Word8
key' Int
keyOff Int
keyLen BA# Word8
hashAlgo' Int
digits Int
timeStep)
            FunPtr (BotanStructT -> IO ())
botan_totp_destroy

-- | Generate a TOTP code for the provided timestamp.
genTOTP :: HasCallStack
        => TOTP   -- ^ the TOTP object
        -> Word64 -- ^ the current local timestamp
        -> IO Word32
{-# INLINABLE genTOTP #-}
genTOTP :: TOTP -> Word64 -> IO Word32
genTOTP (TOTP BotanStruct
totp) Word64
timestamp =
    BotanStruct -> (BotanStructT -> IO Word32) -> IO Word32
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
totp ((BotanStructT -> IO Word32) -> IO Word32)
-> (BotanStructT -> IO Word32) -> IO Word32
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
totp' ->
    (Word32, CInt) -> Word32
forall a b. (a, b) -> a
fst ((Word32, CInt) -> Word32) -> IO (Word32, CInt) -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MBA# BotanStructT -> IO CInt) -> IO (Word32, CInt)
forall a b. Prim a => (MBA# BotanStructT -> IO b) -> IO (a, b)
allocPrimUnsafe (\ MBA# BotanStructT
code -> BotanStructT -> MBA# BotanStructT -> Word64 -> IO CInt
botan_totp_generate BotanStructT
totp' MBA# BotanStructT
code Word64
timestamp)

-- | Verify a TOTP code.
checkTOTP :: HasCallStack
          => TOTP   -- ^ the TOTP object
          -> Word32 -- ^ the presented OTP
          -> Word64 -- ^ timestamp the current local timestamp
          -> Int    -- ^ specifies the acceptable amount of clock drift
                    --   (in terms of time steps) between the two hosts.
          -> IO Bool
{-# INLINABLE checkTOTP #-}
checkTOTP :: TOTP -> Word32 -> Word64 -> Int -> IO Bool
checkTOTP (TOTP BotanStruct
totp) Word32
code Word64
timestamp Int
driftAmount = do
    BotanStruct -> (BotanStructT -> IO Bool) -> IO Bool
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
totp ((BotanStructT -> IO Bool) -> IO Bool)
-> (BotanStructT -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
totp' -> do
        CInt
ret <- BotanStructT -> Word32 -> Word64 -> CSize -> IO CInt
botan_totp_check BotanStructT
totp' Word32
code Word64
timestamp (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
driftAmount)
        if CInt
ret CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
BOTAN_FFI_SUCCESS
        then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else if CInt
ret CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> CInt
0
            then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            else CInt -> IO Bool
forall x. HasCallStack => CInt -> IO x
throwBotanError CInt
ret