module Z.Crypto.OTP (
HOTP, newHOTP, genHOTP, checkHOTP
, TOTP, newTOTP, genTOTP, checkTOTP
, 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
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
genHOTP :: HasCallStack
=> HOTP
-> Word64
-> 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)
checkHOTP :: HasCallStack
=> HOTP
-> Word32
-> Word64
-> Int
-> 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
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
genTOTP :: HasCallStack
=> TOTP
-> Word64
-> 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)
checkTOTP :: HasCallStack
=> TOTP
-> Word32
-> Word64
-> Int
-> 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