diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,12 @@
# CHANGELOG
+## 3.0.0.0 — 13-04-2024
+
+* The library has been transferred to the Haskell Cryptography Group's stewardship;
+* Switch to use `sel` for the cryptography provider;
+* Support for GHC from 9.4 to 9.8;
+* See the `OTP.TOTP` and the test suite for example usage.
+
## 2.0.0
### Changed
* Change versioning to semver
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2012 Artem Leshchev
+Copyright (c) 2023 The Haskell Cryptography Group
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,72 +1,19 @@
-# What
-
-One time password implementation according to RFC4226 and RFC6238 in
-Haskell.
-
-# Generation passwords
-
-If you need to generate HOTP password described in RFC4226, then use
-
-```haskell
->>> hotp SHA1 "1234" 100 6
-317569
-
->>> hotp SHA512 "1234" 100 6
-134131
-```
-
-Or
-
-```haskell
->>> totp SHA1 "1234" (read "2010-10-10 00:01:00 UTC") 30 8
-43388892
-```
-
-to generate TOTP password described in RFC6238.
-
-# Checking passwords
-
-```haskell
-hotpCheck :: (HashAlgorithm a)
- => a -- ^ Hashing algorithm
- -> ByteString -- ^ Shared secret
- -> (Word64, Word64) -- ^ how much counters to take lower and higher than ideal
- -> Word64 -- ^ ideal (expected) counter value
- -> Word -- ^ Number of digits in password
- -> Word32 -- ^ Password entered by user
- -> Bool -- ^ True if password acceptable
-```
-
-```haskell
->>> hotpCheck SHA1 "1234" (0,0) 10 6 50897
-True
-
->>> hotpCheck SHA1 "1234" (0,0) 9 6 50897
-False
-
->>> hotpCheck SHA1 "1234" (0,1) 9 6 50897
-True
-```
-
-Here almost the same aguments as for `hotp` function, but there is
-also `(0, 0)` tuple. This tuple describes range of counters to check
-in case of desynchronisation of counters between client and
-server. I.e. if you specify `(1, 1)` and ideal counter will be `10`
-then function will check passwords for `[9, 10, 11]` list of
-counters.
-
-There is also some protection, so if you specify `(minBound,
-maxBound)` then function will check just 1000 counters around ideal.
+
+ one-time-password
+
-Here is the same for TOTP:
+
+
+ 
+
+
+ 
+
+
-```haskell
->>> totpCheck SHA1 "1234" (0, 0) (read "2010-10-10 00:00:00 UTC") 30 6 778374
-True
+A One-Time Password (OTP) is a dynamic password used once in conjunction with an account's usual password, a for the purpose of two-factor authentication.
->>> totpCheck SHA1 "1234" (0, 0) (read "2010-10-10 00:00:30 UTC") 30 6 778374
-False
+It can be based on a counter (HOTP) or a timestamp (TOTP). This module provides both methods.
->>> totpCheck SHA1 "1234" (1, 0) (read "2010-10-10 00:00:30 UTC") 30 6 778374
-True
-```
+Mobile authenticator applications will typically require a TOTP secret. They are most commonly provided as QR codes to scan.
+This library can generate a URI that can be used by a QR Code generator.
diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,355 @@
+module Main (main) where
+
+import Chronos (Time (..), Timespan (..), datetimeToTime, decode_YmdHMS, now, second, w3c)
+import Data.ByteString (StrictByteString)
+import qualified Data.ByteString.Char8 as BSC8
+import Data.Maybe (fromJust)
+import Data.Text (Text)
+import Data.Text.Display
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.IO as TIO
+import Data.Version (showVersion)
+import Data.Word
+import Options.Applicative
+import Paths_one_time_password (version)
+import Sel (secureMain)
+import qualified Sel.HMAC.SHA256 as SHA256
+import qualified Sel.HMAC.SHA512 as SHA512
+import System.Exit (exitFailure)
+import Torsor (scale)
+
+import OTP.Commons
+import OTP.HOTP
+import OTP.TOTP
+
+main :: IO ()
+main =
+ secureMain $ do
+ now' <- now
+ let parserInfo = info (cmdP now' <**> helper <**> simpleVersioner (showVersion version)) (progDesc "One time passwords (OTP) utilities" <> briefDesc)
+ customExecParser (prefs showHelpOnEmpty) parserInfo >>= runCmd
+
+type RawSharedSecret = StrictByteString
+
+data Command
+ = -- | Compute HMAC-Based One-Time Password using secret key and counter value.
+ -- ^ Shared secret
+ -- ^ Counter value
+ -- ^ Number of digits in a password
+ HotpMk Algorithm RawSharedSecret Word64 Digits
+ | -- | Check presented password against a valid range.
+ -- ^ Shared secret
+ -- ^ Valid counter range, before and after ideal
+ -- ^ Ideal (expected) counter value
+ -- ^ Number of digits in a password
+ -- ^ Password entered by user
+ HotpCheck Algorithm RawSharedSecret (Word64, Word64) Word64 Digits Text
+ | -- | Compute a Time-Based One-Time Password using secret key and time.
+ -- ^ Shared secret
+ -- ^ Time of TOTP
+ -- ^ Time range in seconds
+ -- ^ Number of digits in a password
+ TotpMk Algorithm RawSharedSecret Time Timespan Digits
+ | -- | Check presented password against time periods.
+ -- ^ Shared secret
+ -- ^ Valid counter range, before and after ideal
+ -- ^ Time of TOTP
+ -- ^ Time range in seconds
+ -- ^ Numer of digits in a password
+ -- ^ Password given by user
+ TotpCheck Algorithm RawSharedSecret (Word64, Word64) Time Timespan Digits Text
+ | -- | Create a URI suitable for authenticators.
+ -- ^ Shared secret key. Must be encoded in base32.
+ -- ^ Name of the account (usually an email address)
+ -- ^ Issuer
+ -- ^ Amount of digits expected from the end-user
+ -- ^ Amount of time before the generated code expires
+ -- ^ Algorithm required
+ TotpMkUri Text Text Text Digits Timespan Algorithm
+ | -- | Create an new random key to be used with the SHA-1 functions
+ KeyGen Algorithm
+
+cmdP :: Time -> Parser Command
+cmdP now' =
+ hsubparser
+ ( command "hotp" (info hotpCmdP (progDesc "HOTP commands"))
+ <> command "totp" (info totpCmdP (progDesc "TOTP commands"))
+ <> command "key-gen" (info keyGenCmdP (progDesc "Generate keys"))
+ )
+ where
+ hotpCmdP =
+ hsubparser $
+ command
+ "make"
+ (info hotpMakeP (progDesc "Compute HMAC-Based One-Time Password using secret key and counter value"))
+ <> command
+ "check"
+ (info hotpCheckP (progDesc "Check presented password against a valid range"))
+
+ totpCmdP =
+ hsubparser $
+ command
+ "make"
+ (info totpMakeP (progDesc "Compute a Time-Based One-Time Password using secret key and time"))
+ <> command
+ "check"
+ (info totpCheckP (progDesc "Check presented password against time periods"))
+ <> command
+ "uri"
+ (info totpUriP (progDesc "Create a URI suitable for authenticators"))
+
+ hotpMakeP :: Parser Command
+ hotpMakeP =
+ HotpMk
+ <$> algorithmP
+ <*> rawSharedSecretP
+ <*> counterP
+ <*> digitsP
+
+ hotpCheckP :: Parser Command
+ hotpCheckP =
+ HotpCheck
+ <$> algorithmP
+ <*> rawSharedSecretP
+ <*> timeRangeP
+ <*> counterP
+ <*> digitsP
+ <*> passwordP
+
+ totpMakeP :: Parser Command
+ totpMakeP =
+ TotpMk
+ <$> algorithmP
+ <*> rawSharedSecretP
+ <*> timeP
+ <*> timespanP
+ <*> digitsP
+ totpCheckP :: Parser Command
+ totpCheckP =
+ TotpCheck
+ <$> algorithmP
+ <*> rawSharedSecretP
+ <*> timeRangeP
+ <*> timeP
+ <*> timespanP
+ <*> digitsP
+ <*> passwordP
+ totpUriP :: Parser Command
+ totpUriP =
+ TotpMkUri
+ <$> base32RawSharedSecretP
+ <*> accountNameP
+ <*> issuerP
+ <*> digitsP
+ <*> timespanP
+ <*> algorithmP
+
+ keyGenCmdP :: Parser Command
+ keyGenCmdP =
+ KeyGen
+ <$> algorithmP
+
+ algorithmP :: Parser Algorithm
+ algorithmP =
+ option (maybeReader mkAlgorithm) $
+ long "algorithm"
+ <> short 'a'
+ <> metavar "ALGORITHM"
+ <> help "Hash algorithm (sha1, sha256, sha512)"
+ <> value HMAC_SHA1
+ <> showDefault
+ <> completeWith ["sha1", "sha256", "sha512"]
+
+ mkAlgorithm :: String -> Maybe Algorithm
+ mkAlgorithm =
+ \case
+ "sha1" -> Just HMAC_SHA1
+ "sha256" -> Just HMAC_SHA256
+ "sha512" -> Just HMAC_SHA512
+ _ -> Nothing
+
+ rawSharedSecretP :: Parser RawSharedSecret
+ rawSharedSecretP =
+ option (BSC8.pack <$> str) $
+ long "secret"
+ <> short 's'
+ <> metavar "SECRET"
+ <> help "Shared secret"
+
+ digitsP :: Parser Digits
+ digitsP =
+ option (auto >>= mkReaderFromMaybe "Invalid number of digits" . mkDigits) $
+ long "digits"
+ <> short 'd'
+ <> metavar "DIGITS"
+ <> help "Number of digits in a password (at least 6)"
+ <> value (fromJust $ mkDigits 6)
+ <> showDefault
+
+ timespanP :: Parser Timespan
+ timespanP =
+ option (fmap (flip scale second) auto) $
+ long "timespan"
+ <> short 'n'
+ <> metavar "TIMESPAN"
+ <> help "Time range in seconds"
+ <> value (scale 30 second)
+ <> showDefault
+
+ timeP :: Parser Time
+ timeP =
+ option (auto >>= mkReaderFromMaybe "Invalid time" . mkTime) $
+ long "time"
+ <> short 't'
+ <> metavar "TIME"
+ <> help "Time of TOTP (iso or 'now')"
+ <> value now'
+ <> showDefault
+
+ mkTime :: Text -> Maybe Time
+ mkTime =
+ \case
+ "now" -> Just now'
+ x -> datetimeToTime <$> decode_YmdHMS w3c x
+
+ counterP :: Parser Word64
+ counterP =
+ option auto $
+ long "counter"
+ <> short 'c'
+ <> metavar "COUNTER"
+ <> help "Ideal counter value"
+ <> value 0
+ <> showDefault
+
+ timeRangeP :: Parser (Word64, Word64)
+ timeRangeP = (,) <$> counterRangeLowP <*> counterRangeHighP
+ where
+ counterRangeLowP =
+ option auto $
+ long "counter-range-low"
+ <> metavar "COUNTER_RANGE_LOW"
+ <> help "Valid counter range, before specified counter"
+ <> value 0
+ <> showDefault
+
+ counterRangeHighP =
+ option auto $
+ long "counter-range-high"
+ <> metavar "COUNTER_RANGE_HIGH"
+ <> help "Valid counter range, after specified counter"
+ <> value 0
+ <> showDefault
+
+ passwordP :: Parser Text
+ passwordP =
+ option auto $
+ long "password"
+ <> short 'p'
+ <> metavar "PASSWORD"
+ <> help "Password"
+
+ base32RawSharedSecretP :: Parser Text
+ base32RawSharedSecretP =
+ option str $
+ long "secret"
+ <> short 's'
+ <> metavar "SECRET"
+ <> help "Shared secret"
+
+ accountNameP :: Parser Text
+ accountNameP =
+ option str $
+ long "account-name"
+ <> short 'a'
+ <> metavar "ACCOUNT-NAME"
+ <> help "Name of the account (usually an email address)"
+
+ issuerP :: Parser Text
+ issuerP =
+ option str $
+ long "issuer"
+ <> short 'i'
+ <> metavar "ISSUER"
+ <> help "Issuer"
+
+ mkReaderFromMaybe :: String -> Maybe a -> ReadM a
+ mkReaderFromMaybe err = maybe (readerError err) return
+
+-- Define the main parser for Command
+
+runCmd :: Command -> IO ()
+runCmd =
+ \case
+ HotpMk algorithm rawSecret counter digits' ->
+ case algorithm of
+ HMAC_SHA1 -> do
+ secret <- read256Secret rawSecret
+ displayOtp $ hotpSHA1 secret counter digits'
+ HMAC_SHA256 -> do
+ secret <- read256Secret rawSecret
+ displayOtp $ hotpSHA256 secret counter digits'
+ HMAC_SHA512 -> do
+ secret <- read512Secret rawSecret
+ displayOtp $ hotpSHA512 secret counter digits'
+ HotpCheck algorithm rawSecret range counter digits' pass ->
+ case algorithm of
+ HMAC_SHA1 -> do
+ secret <- read256Secret rawSecret
+ displayCheckedOtp $ hotpSHA1Check secret range counter digits' pass
+ HMAC_SHA256 -> do
+ secret <- read256Secret rawSecret
+ displayCheckedOtp $ hotpSHA256Check secret range counter digits' pass
+ HMAC_SHA512 -> do
+ secret <- read512Secret rawSecret
+ displayCheckedOtp $ hotpSHA512Check secret range counter digits' pass
+ TotpMk algorithm rawSecret time period digits' ->
+ case algorithm of
+ HMAC_SHA1 -> do
+ secret <- read256Secret rawSecret
+ displayOtp $ totpSHA1 secret time period digits'
+ HMAC_SHA256 -> do
+ secret <- read256Secret rawSecret
+ displayOtp $ totpSHA256 secret time period digits'
+ HMAC_SHA512 -> do
+ secret <- read512Secret rawSecret
+ displayOtp $ totpSHA512 secret time period digits'
+ TotpCheck algorithm rawSecret range time period digits' pass ->
+ case algorithm of
+ HMAC_SHA1 -> do
+ secret <- read256Secret rawSecret
+ displayCheckedOtp $ totpSHA1Check secret range time period digits' pass
+ HMAC_SHA256 -> do
+ secret <- read256Secret rawSecret
+ displayCheckedOtp $ totpSHA256Check secret range time period digits' pass
+ HMAC_SHA512 -> do
+ secret <- read512Secret rawSecret
+ displayCheckedOtp $ totpSHA512Check secret range time period digits' pass
+ TotpMkUri secret account issuer digits' period algorithm ->
+ TIO.putStrLn $ totpToURI secret account issuer digits' period algorithm
+ KeyGen algorithm ->
+ case algorithm of
+ HMAC_SHA1 ->
+ TIO.putStrLn . TE.decodeUtf8 . SHA256.unsafeAuthenticationKeyToHexByteString =<< newSHA1Key
+ HMAC_SHA256 ->
+ TIO.putStrLn . TE.decodeUtf8 . SHA256.unsafeAuthenticationKeyToHexByteString =<< newSHA256Key
+ HMAC_SHA512 ->
+ TIO.putStrLn . TE.decodeUtf8 . SHA512.unsafeAuthenticationKeyToHexByteString =<< newSHA512Key
+ where
+ displayOtp :: OTP -> IO ()
+ displayOtp = TIO.putStrLn . display
+ displayCheckedOtp :: Bool -> IO ()
+ displayCheckedOtp p =
+ if p
+ then putStrLn "Match"
+ else putStrLn "don't match" >> exitFailure
+ read256Secret :: RawSharedSecret -> IO SHA256.AuthenticationKey
+ read256Secret rawSecret =
+ case SHA256.authenticationKeyFromHexByteString rawSecret of
+ Right secret -> return secret
+ Left err -> TIO.putStrLn ("Cannot read secret: " <> err) >> exitFailure
+ read512Secret :: RawSharedSecret -> IO SHA512.AuthenticationKey
+ read512Secret rawSecret =
+ case SHA512.authenticationKeyFromHexByteString rawSecret of
+ Right secret -> return secret
+ Left err -> TIO.putStrLn ("Cannot read secret: " <> err) >> exitFailure
diff --git a/one-time-password.cabal b/one-time-password.cabal
--- a/one-time-password.cabal
+++ b/one-time-password.cabal
@@ -1,56 +1,131 @@
-name: one-time-password
-version: 2.0.0
-synopsis: HMAC-Based and Time-Based One-Time Passwords
-
-description: Implements HMAC-Based One-Time Password Algorithm as
- defined in RFC 4226 and Time-Based One-Time Password
- Algorithm as defined in RFC 6238.
+cabal-version: 3.4
+name: one-time-password
+version: 3.0.0.0
+synopsis: HMAC-Based and Time-Based One-Time Passwords
+description:
+ Implements HMAC-Based One-Time Password Algorithm as
+ defined in RFC 4226 and Time-Based One-Time Password
+ Algorithm as defined in RFC 6238.
-license: MIT
-license-file: LICENSE
-copyright: (c) 2012 Artem Leshchev, 2016 Aleksey Uimanov
-author: Artem Leshchev, Aleksey Uimanov
-maintainer: s9gf4ult@gmail.com
-homepage: https://github.com/s9gf4ult/one-time-password
-bug-reports: https://github.com/s9gf4ult/one-time-password/issues
-category: Cryptography
-build-type: Simple
-cabal-version: >=1.10
+license: MIT
+license-file: LICENSE
+copyright: (c) 2023 The Haskell Cryptography Group
+author: Hécate Moonlight
+maintainer: The Haskell Cryptography Group contributors
+homepage: https://github.com/haskell-cryptography/one-time-password
+bug-reports:
+ https://github.com/haskell-cryptography/one-time-password/issues
-extra-source-files: CHANGELOG.md
- , README.md
+category: Cryptography
+build-type: Simple
+extra-source-files: README.md
+extra-doc-files: CHANGELOG.md
+tested-with: GHC ==9.4.8 || ==9.6.4 || ==9.8.2
source-repository head
type: git
- location: git://github.com/s9gf4ult/one-time-password.git
+ location: git://github.com/haskell-cryptography/one-time-password.git
+common ghc-options
+ ghc-options:
+ -Wall -Wcompat -Widentities -Wincomplete-record-updates
+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints
+ -fhide-source-paths -Wno-unused-do-bind -fshow-hole-constraints
+ -Wno-unticked-promoted-constructors -Werror=unused-imports
+ -fdicts-strict -fmax-worker-args=16 -fspec-constr-recursive=16
+ -Wunused-packages
+
+ default-language: GHC2021
+
library
- default-language: Haskell2010
- hs-source-dirs: src
- default-extensions: OverloadedStrings
- , ScopedTypeVariables
- exposed-modules: Data.OTP
- build-depends: base >= 3 && < 5
- , bytestring
- , cereal
- , cryptonite
- , memory
- , time >= 1.1
- ghc-options: -Wall
+ import: ghc-options
+ hs-source-dirs: src
+ -- cabal-fmt: expand src/
+ exposed-modules:
+ OTP.Commons
+ OTP.HOTP
+ OTP.TOTP
+
+ build-depends:
+ , base >=4.17 && <5
+ , bytestring ^>=0.11
+ , cereal ^>=0.5
+ , chronos ^>=1.1.6
+ , cryptohash-sha1 ^>=0.11
+ , network-uri ^>=2.6
+ , sel ^>=0.0
+ , text ^>=2.1
+ , text-display ^>=0.0
+
+ ghc-options: -Wall
+
test-suite tests
- default-language: Haskell2010
- type: exitcode-stdio-1.0
- hs-source-dirs: test
- ghc-options: -Wall
- default-extensions: ExistentialQuantification
- , OverloadedStrings
- , RankNTypes
- main-is: Test.hs
- build-depends: base >= 3 && < 5
- , bytestring
- , cryptonite
- , one-time-password
- , tasty
- , tasty-hunit
- , time >= 1.1
+ import: ghc-options
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ default-extensions: OverloadedStrings
+ main-is: Test.hs
+ other-modules:
+ Test.Comparison
+ Test.HOTP
+ Test.Properties
+ Test.TOTP
+ Test.Utils
+
+ build-depends:
+ , base >=4.17 && <5
+ , base16
+ , base32 ^>=0.4
+ , bytestring
+ , chronos
+ , cryptonite
+ , one-time-password
+ , sel
+ , tasty
+ , tasty-hunit
+ , tasty-quickcheck
+ , text
+ , text-display
+ , torsor
+
+executable one-time-password
+ import: ghc-options
+ main-is: Main.hs
+ hs-source-dirs: app
+ default-extensions:
+ DataKinds
+ DefaultSignatures
+ DeriveAnyClass
+ DeriveGeneric
+ DerivingStrategies
+ DerivingVia
+ DuplicateRecordFields
+ FlexibleContexts
+ GADTs
+ GeneralizedNewtypeDeriving
+ KindSignatures
+ LambdaCase
+ OverloadedRecordDot
+ OverloadedStrings
+ RankNTypes
+ RecordWildCards
+ ScopedTypeVariables
+ TypeApplications
+ TypeFamilies
+ TypeOperators
+
+ build-depends:
+ , base >=4.17 && <5
+ , bytestring
+ , chronos
+ , one-time-password
+ , optparse-applicative >=0.15 && <0.19
+ , sel
+ , text
+ , text-display
+ , torsor ^>=0.1
+
+ other-modules: Paths_one_time_password
+ autogen-modules: Paths_one_time_password
+ ghc-options: -Wall
diff --git a/src/Data/OTP.hs b/src/Data/OTP.hs
deleted file mode 100644
--- a/src/Data/OTP.hs
+++ /dev/null
@@ -1,260 +0,0 @@
--- |Implements HMAC-Based One-Time Password Algorithm as defined in RFC 4226 and
--- Time-Based One-Time Password Algorithm as defined in RFC 6238.
-module Data.OTP
- ( -- * HOTP
- hotp
- , hotpCheck
- -- * TOTP
- , totp
- , totpCheck
- -- * Auxiliary
- , totpCounter
- , counterRange
- , totpCounterRange
- ) where
-
-import Crypto.Hash
-import Crypto.MAC.HMAC
-import Data.Bits
-import Data.ByteArray (unpack, ByteArrayAccess)
-import Data.Serialize.Get
-import Data.Serialize.Put
-import Data.Time
-import Data.Time.Clock.POSIX
-import Data.Word
-
-import qualified Data.ByteString as BS
-
-{- | Compute HMAC-Based One-Time Password using secret key and counter value.
-
->>> hotp SHA1 "1234" 100 6
-317569
-
->>> hotp SHA512 "1234" 100 6
-134131
-
->>> hotp SHA512 "1234" 100 8
-55134131
-
--}
-
-hotp
- :: forall a key
- . (HashAlgorithm a, ByteArrayAccess key)
- => a -- ^ Hashing algorithm from module "Crypto.Hash.IO"
- -> key -- ^ Shared secret
- -> Word64 -- ^ Counter value
- -> Word -- ^ Number of digits in a password
- -> Word32 -- ^ HOTP
-hotp _ key cnt digits =
- let msg = runPut $ putWord64be cnt
- h :: HMAC a
- h = hmac key msg
- w = trunc $ unpack h
- in w `mod` (10 ^ digits)
- where
- trunc :: [Word8] -> Word32
- trunc b =
- let offset = last b .&. 15 -- take low 4 bits of last byte
- rb = BS.pack $ take 4 $ drop (fromIntegral offset) b -- resulting 4 byte value
- in case runGet getWord32be rb of
- Left e -> error e
- Right res -> res .&. (0x80000000 - 1) -- reset highest bit
-
-{- | Check presented password against a valid range.
-
->>> hotp SHA1 "1234" 10 6
-50897
-
->>> hotpCheck SHA1 "1234" (0,0) 10 6 50897
-True
-
->>> hotpCheck SHA1 "1234" (0,0) 9 6 50897
-False
-
->>> hotpCheck SHA1 "1234" (0,1) 9 6 50897
-True
-
->>> hotpCheck SHA1 "1234" (1,0) 11 6 50897
-True
-
->>> hotpCheck SHA1 "1234" (2,2) 8 6 50897
-True
-
->>> hotpCheck SHA1 "1234" (2,2) 7 6 50897
-False
-
->>> hotpCheck SHA1 "1234" (2,2) 12 6 50897
-True
-
->>> hotpCheck SHA1 "1234" (2,2) 13 6 50897
-False
-
--}
-
-hotpCheck
- :: (HashAlgorithm a, ByteArrayAccess key)
- => a -- ^ Hashing algorithm
- -> key -- ^ Shared secret
- -> (Word64, Word64) -- ^ Valid counter range, before and after ideal
- -> Word64 -- ^ Ideal (expected) counter value
- -> Word -- ^ Number of digits in a password
- -> Word32 -- ^ Password entered by user
- -> Bool -- ^ True if password is valid
-hotpCheck alg secr rng cnt len pass =
- let counters = counterRange rng cnt
- passwds = map (\c -> hotp alg secr c len) counters
- in any (pass ==) passwds
-
-{- | Compute a Time-Based One-Time Password using secret key and time.
-
->>> totp SHA1 "1234" (read "2010-10-10 00:01:00 UTC") 30 6
-388892
-
->>> totp SHA1 "1234" (read "2010-10-10 00:01:00 UTC") 30 8
-43388892
-
->>> totp SHA1 "1234" (read "2010-10-10 00:01:15 UTC") 30 8
-43388892
-
->>> totp SHA1 "1234" (read "2010-10-10 00:01:31 UTC") 30 8
-39110359
-
--}
-
-totp
- :: (HashAlgorithm a, ByteArrayAccess key)
- => a -- ^ Hash algorithm to use
- -> key -- ^ Shared secret
- -> UTCTime -- ^ Time of TOTP
- -> Word64 -- ^ Time range in seconds
- -> Word -- ^ Number of digits in a password
- -> Word32 -- ^ TOTP
-totp alg secr time period len =
- hotp alg secr (totpCounter time period) len
-
-{- | Check presented password against time periods.
-
->>> totp SHA1 "1234" (read "2010-10-10 00:00:00 UTC") 30 6
-778374
-
->>> totpCheck SHA1 "1234" (0, 0) (read "2010-10-10 00:00:00 UTC") 30 6 778374
-True
-
->>> totpCheck SHA1 "1234" (0, 0) (read "2010-10-10 00:00:30 UTC") 30 6 778374
-False
-
->>> totpCheck SHA1 "1234" (1, 0) (read "2010-10-10 00:00:30 UTC") 30 6 778374
-True
-
->>> totpCheck SHA1 "1234" (1, 0) (read "2010-10-10 00:01:00 UTC") 30 6 778374
-False
-
->>> totpCheck SHA1 "1234" (2, 0) (read "2010-10-10 00:01:00 UTC") 30 6 778374
-True
--}
-
-totpCheck
- :: (HashAlgorithm a, ByteArrayAccess key)
- => a -- ^ Hashing algorithm
- -> key -- ^ Shared secret
- -> (Word64, Word64) -- ^ Valid counter range, before and after ideal
- -> UTCTime -- ^ Time of TOTP
- -> Word64 -- ^ Time range in seconds
- -> Word -- ^ Numer of digits in a password
- -> Word32 -- ^ Password given by user
- -> Bool -- ^ True if password is valid
-totpCheck alg secr rng time period len pass =
- let counters = totpCounterRange rng time period
- passwds = map (\c -> hotp alg secr c len) counters
- in any (pass ==) passwds
-
-
-{- | Calculate HOTP counter using time. Starting time (T0
-according to RFC6238) is 0 (begining of UNIX epoch)
-
->>> totpCounter (read "2010-10-10 00:00:00 UTC") 30
-42888960
-
->>> totpCounter (read "2010-10-10 00:00:30 UTC") 30
-42888961
-
->>> totpCounter (read "2010-10-10 00:01:00 UTC") 30
-42888962
-
--}
-
-totpCounter
- :: UTCTime -- ^ Time of totp
- -> Word64 -- ^ Time range in seconds
- -> Word64 -- ^ Resulting counter
-totpCounter time period =
- let timePOSIX = floor $ utcTimeToPOSIXSeconds time
- in timePOSIX `div` period
-
-{- | Make a sequence of acceptable counters, protected from
-arithmetic overflow. Maximum range is limited to 1000 due to huge
-counter ranges being insecure.
-
->>> counterRange (0, 0) 9000
-[9000]
-
->>> counterRange (1, 0) 9000
-[8999,9000]
-
->>> length $ counterRange (5000, 0) 9000
-501
-
->>> length $ counterRange (5000, 5000) 9000
-1000
-
->>> counterRange (2, 2) maxBound
-[18446744073709551613,18446744073709551614,18446744073709551615]
-
->>> counterRange (2, 2) minBound
-[0,1,2]
-
->>> counterRange (2, 2) (maxBound `div` 2)
-[9223372036854775805,9223372036854775806,9223372036854775807,9223372036854775808,9223372036854775809]
-
->>> counterRange (5, 5) 9000
-[8995,8996,8997,8998,8999,9000,9001,9002,9003,9004,9005]
-
-RFC recommends avoiding excessively large values for counter ranges.
--}
-
-counterRange
- :: (Word64, Word64) -- ^ Number of counters before and after ideal
- -> Word64 -- ^ Ideal counter value
- -> [Word64]
-counterRange (tolow', tohigh') ideal =
- let tolow = min 500 tolow'
- tohigh = min 499 tohigh'
- l = trim 0 ideal (ideal - tolow)
- h = trim ideal maxBound (ideal + tohigh)
- in [l..h]
- where
- trim l h = max l . min h
-
-{- | Make a sequence of acceptable periods.
-
->>> totpCounterRange (0, 0) (read "2010-10-10 00:01:00 UTC") 30
-[42888962]
-
->>> totpCounterRange (2, 0) (read "2010-10-10 00:01:00 UTC") 30
-[42888960,42888961,42888962]
-
->>> totpCounterRange (0, 2) (read "2010-10-10 00:01:00 UTC") 30
-[42888962,42888963,42888964]
-
->>> totpCounterRange (2, 2) (read "2010-10-10 00:01:00 UTC") 30
-[42888960,42888961,42888962,42888963,42888964]
-
--}
-
-totpCounterRange :: (Word64, Word64)
- -> UTCTime
- -> Word64
- -> [Word64]
-totpCounterRange rng time period =
- counterRange rng $ totpCounter time period
diff --git a/src/OTP/Commons.hs b/src/OTP/Commons.hs
new file mode 100644
--- /dev/null
+++ b/src/OTP/Commons.hs
@@ -0,0 +1,195 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module OTP.Commons
+ ( -- * Auxiliary
+ OTP (..)
+ , Digits
+ , Algorithm (..)
+ , mkDigits
+ , digitsToWord32
+ , totpCounter
+ , counterRange
+ , totpCounterRange
+ ) where
+
+import Chronos (Time (..), Timespan (..), asSeconds, sinceEpoch)
+import Data.Int (Int64)
+import Data.Text.Display
+import Data.Text.Lazy.Builder (Builder)
+import Data.Text.Lazy.Builder qualified as Text
+import Data.Word
+import Text.Printf (printf)
+
+-- $setup
+-- >>> import Chronos qualified
+-- >>> import Chronos (DatetimeFormat(..))
+-- >>> import Torsor qualified
+-- >>> import Data.Maybe (fromJust)
+-- >>> :set -XOverloadedStrings
+-- >>> let format = DatetimeFormat (Just '-') (Just ' ') (Just ':')
+-- >>> let decode txt = Chronos.datetimeToTime $ fromJust $ Chronos.decode_YmdHMS format txt
+
+-- |
+--
+-- @since 3.0.0.0
+data Algorithm
+ = HMAC_SHA1
+ | HMAC_SHA256
+ | HMAC_SHA512
+ deriving stock
+ ( Eq
+ -- ^ @since 3.0.0.0
+ , Ord
+ -- ^ @since 3.0.0.0
+ , Show
+ -- ^ @since 3.0.0.0
+ )
+
+-- |
+--
+-- @since 3.0.0.0
+instance Display Algorithm where
+ displayBuilder HMAC_SHA1 = "SHA1"
+ displayBuilder HMAC_SHA256 = "SHA256"
+ displayBuilder HMAC_SHA512 = "SHA512"
+
+-- |
+--
+-- @since 3.0.0.0
+data OTP = OTP
+ { digits :: Word32
+ , code :: Word32
+ }
+ deriving stock
+ ( Eq
+ -- ^ @since 3.0.0.0
+ , Ord
+ -- ^ @since 3.0.0.0
+ , Show
+ -- ^ @since 3.0.0.0
+ )
+
+-- |
+--
+-- @since 3.0.0.0
+instance Display OTP where
+ displayBuilder OTP{digits, code} = displayWord32AsOTP digits code
+
+displayWord32AsOTP :: Word32 -> Word32 -> Builder
+displayWord32AsOTP digits code = Text.fromString $ printf ("%0" <> show digits <> "u") code
+
+-- |
+--
+-- @since 3.0.0.0
+newtype Digits = Digits Word32
+ deriving newtype (Eq, Show, Ord)
+ deriving
+ (Display)
+ via ShowInstance Digits
+
+digitsToWord32 :: Digits -> Word32
+digitsToWord32 (Digits digits) = digits
+
+-- |
+--
+-- RFC 4226 §5.3 says "Implementations MUST extract a 6-digit code at a minimum and possibly 7 and 8-digit code".
+--
+-- This function validates that the number of desired digits is equal or greater than 6.
+mkDigits
+ :: Word32
+ -> Maybe Digits
+mkDigits userDigits
+ | userDigits >= 6 = Just (Digits userDigits)
+ | otherwise = Nothing
+
+-- | Calculate HOTP counter using time. Starting time (T0
+-- according to RFC6238) is 0 (begining of UNIX epoch)
+-- >>> let timestamp = decode "2010-10-10 00:00:30"
+-- >>> let timespan = Torsor.scale 30 Chronos.second
+-- >>> totpCounter timestamp timespan
+-- 42888961
+--
+-- >>> let timestamp2 = decode "2010-10-10 00:00:45"
+-- >>> totpCounter timestamp2 timespan
+-- 42888961
+--
+-- >>> let timestamp3 = decode "2010-10-10 00:01:00"
+-- >>> totpCounter timestamp3 timespan
+-- 42888962
+--
+-- @since 3.0.0.0
+totpCounter
+ :: Time
+ -- ^ Time of totp
+ -> Timespan
+ -- ^ Time range in seconds
+ -> Word64
+ -- ^ Resulting counter
+totpCounter time period =
+ ts2word (asSeconds (sinceEpoch time)) `quot` ts2word (asSeconds period)
+ where
+ ts2word :: Int64 -> Word64
+ ts2word = fromIntegral
+
+-- | Make a sequence of acceptable counters, protected from
+-- arithmetic overflow. Maximum range is limited to 1000 due to huge
+-- counter ranges being insecure.
+--
+-- >>> counterRange (0, 0) 9000
+-- [9000]
+--
+-- >>> counterRange (1, 0) 9000
+-- [8999,9000]
+--
+-- >>> length $ counterRange (5000, 0) 9000
+-- 501
+--
+-- >>> length $ counterRange (5000, 5000) 9000
+-- 1000
+--
+-- >>> counterRange (2, 2) maxBound
+-- [18446744073709551613,18446744073709551614,18446744073709551615]
+--
+-- >>> counterRange (2, 2) minBound
+-- [0,1,2]
+--
+-- >>> counterRange (2, 2) (maxBound `div` 2)
+-- [9223372036854775805,9223372036854775806,9223372036854775807,9223372036854775808,9223372036854775809]
+--
+-- >>> counterRange (5, 5) 9000
+-- [8995,8996,8997,8998,8999,9000,9001,9002,9003,9004,9005]
+--
+-- RFC recommends avoiding excessively large values for counter ranges.
+--
+-- @since 3.0.0.0
+counterRange
+ :: (Word64, Word64)
+ -- ^ Number of counters before and after ideal
+ -> Word64
+ -- ^ Ideal counter value
+ -> [Word64]
+counterRange (tolow', tohigh') ideal =
+ let tolow = min 500 tolow'
+ tohigh = min 499 tohigh'
+ l = trim 0 ideal (ideal - tolow)
+ h = trim ideal maxBound (ideal + tohigh)
+ in [l .. h]
+ where
+ trim l h = max l . min h
+
+-- | Make a sequence of acceptable periods.
+--
+-- >>> let time = decode "2010-10-10 00:00:30"
+-- >>> let timespan = Torsor.scale 30 Chronos.second
+-- >>> totpCounterRange (1, 1) time timespan
+-- [42888960,42888961,42888962]
+--
+-- @since 3.0.0.0
+totpCounterRange
+ :: (Word64, Word64)
+ -> Time
+ -> Timespan
+ -> [Word64]
+totpCounterRange range time period =
+ counterRange range $ totpCounter time period
diff --git a/src/OTP/HOTP.hs b/src/OTP/HOTP.hs
new file mode 100644
--- /dev/null
+++ b/src/OTP/HOTP.hs
@@ -0,0 +1,199 @@
+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 = 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 counter digits' = unsafePerformIO $ do
+ let digits = digitsToWord32 digits'
+ let msg = runPut $ putWord64be counter
+ let key = SHA256.unsafeAuthenticationKeyToBinary authenticationKey
+ let hash = SHA1.hmac key msg
+ let code = truncateHash $ BS.unpack hash
+ let result = code `rem` (10 ^ digits)
+ pure $ OTP digits 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 secret range counter digits pass =
+ let counters = counterRange range counter
+ passwords = fmap (\c -> display $ hotpSHA1 secret c digits) counters
+ in elem pass 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 = 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 key counter digits' = unsafePerformIO $ do
+ let digits = digitsToWord32 digits'
+ let msg = runPut $ putWord64be counter
+ hash <- SHA256.authenticationTagToBinary <$> SHA256.authenticate msg key
+ let code = truncateHash $ BS.unpack hash
+ let result = code `rem` (10 ^ digits)
+ pure $ OTP digits 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 secret range counter digits pass =
+ let counters = counterRange range counter
+ passwords = fmap (\c -> display $ hotpSHA256 secret c digits) counters
+ in elem pass 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 = 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 key counter digits' = unsafePerformIO $ do
+ let digits = digitsToWord32 digits'
+ let msg = runPut $ putWord64be counter
+ hash <- SHA512.authenticationTagToBinary <$> SHA512.authenticate msg key
+ let code = truncateHash $ BS.unpack hash
+ let result = code `rem` (10 ^ digits)
+ pure $ OTP digits 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 secret range counter digits pass =
+ let counters = counterRange range counter
+ passwords = fmap (\c -> display $ hotpSHA512 secret c digits) counters
+ in elem pass 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 b =
+ let to32 = fromIntegral @Word8 @Word32
+ offset = List.last b .&. 0xF
+ code = case List.take 4 $ List.drop (fromIntegral offset) b of -- resulting 4 byte value
+ [b0, b1, b2, b3] ->
+ ((to32 b0 .&. 0x7F) .<<. 24)
+ .|. ((to32 b1 .&. 0xFF) .<<. 16)
+ .|. ((to32 b2 .&. 0xFF) .<<. 8)
+ .|. (to32 b3 .&. 0xFF)
+ _ -> error "The impossible happened"
+ in code .&. 0x7FFFFFFF -- clear the highest bit
diff --git a/src/OTP/TOTP.hs b/src/OTP/TOTP.hs
new file mode 100644
--- /dev/null
+++ b/src/OTP/TOTP.hs
@@ -0,0 +1,250 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Time-based One-Time Passwords (TOTP) with the HMAC-SHA-1, HMAC-SHA-256 and HMAC-SHA-512 algorithms.
+--
+-- They are single-use codes used for .
+module OTP.TOTP
+ ( -- ** Usage
+ -- $usage
+ OTP
+
+ -- ** HMAC-SHA-1
+ , newSHA1Key
+ , totpSHA1
+ , totpSHA1Check
+
+ -- ** HMAC-SHA-256
+ , newSHA256Key
+ , totpSHA256
+ , totpSHA256Check
+
+ -- ** HMAC-SHA-512
+ , newSHA512Key
+ , totpSHA512
+ , totpSHA512Check
+
+ -- ** URI Generation
+ , totpToURI
+ ) where
+
+import Chronos (Time (..), Timespan (..), asSeconds)
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Text.Display (display)
+import Data.Word (Word64)
+import Network.URI (escapeURIString, isUnescapedInURI)
+import Sel.HMAC.SHA256 qualified as SHA256
+import Sel.HMAC.SHA512 qualified as SHA512
+
+import OTP.Commons
+ ( Algorithm
+ , Digits
+ , OTP
+ , totpCounter
+ , totpCounterRange
+ )
+import OTP.HOTP
+ ( hotpSHA1
+ , hotpSHA256
+ , hotpSHA512
+ , newSHA1Key
+ , newSHA256Key
+ , newSHA512Key
+ )
+
+-- $usage
+--
+-- > import Chronos (Timespan, now, second)
+-- > import Data.ByteString.Base32 qualified as Base32
+-- > import Data.Maybe (fromJust)
+-- > import Data.Text (Text)
+-- > import OTP.Commons
+-- > import OTP.TOTP
+-- > import Sel.HMAC.SHA256 qualified as HMAC
+-- > import Torsor (scale)
+-- >
+-- > period :: Timespan
+-- > period = scale 30 second
+-- >
+-- > sixDigits :: Digits
+-- > sixDigits = fromJust $ mkDigits 6
+-- >
+-- > uriFromKey :: Text -> Text -> HMAC.AuthenticationKey -> Text
+-- > uriFromKey domain email key =
+-- > let
+-- > issuer = "your-domain"
+-- > in
+-- > totpToURI
+-- > (Base32.encodeBase32Unpadded $ HMAC.unsafeAuthenticationKeyToBinary key)
+-- > email
+-- > issuer
+-- > sixDigits
+-- > period
+-- > HMAC_SHA1
+-- >
+-- > validateTOTP :: HMAC.AuthenticationKey -> Text -> IO Bool
+-- > validateTOTP key code = do
+-- > timestamp <- now
+-- > pure $
+-- > totpSHA1Check
+-- > key
+-- > (1, 1)
+-- > timestamp
+-- > period
+-- > sixDigits
+-- > code
+
+-- | Compute a Time-based One-Time Password using secret key and time.
+--
+-- @since 3.0.0.0
+totpSHA1
+ :: SHA256.AuthenticationKey
+ -- ^ Shared secret
+ -> Time
+ -- ^ Time of TOTP
+ -> Timespan
+ -- ^ Time range in seconds
+ -> Digits
+ -- ^ Number of digits in a password
+ -> OTP
+ -- ^ TOTP
+totpSHA1 secret time period = hotpSHA1 secret (totpCounter time period)
+
+-- | Compute a Time-based One-Time Password using secret key and time.
+--
+-- @since 3.0.0.0
+totpSHA256
+ :: SHA256.AuthenticationKey
+ -- ^ Shared secret
+ -> Time
+ -- ^ Time of TOTP
+ -> Timespan
+ -- ^ Time range in seconds
+ -> Digits
+ -- ^ Number of digits in a password
+ -> OTP
+ -- ^ TOTP
+totpSHA256 secret time period = hotpSHA256 secret (totpCounter time period)
+
+-- | Compute a Time-based One-Time Password using secret key and time.
+--
+-- @since 3.0.0.0
+totpSHA512
+ :: SHA512.AuthenticationKey
+ -- ^ Shared secret
+ -> Time
+ -- ^ Time of TOTP
+ -> Timespan
+ -- ^ Time range in seconds
+ -> Digits
+ -- ^ Number of digits in a password
+ -> OTP
+ -- ^ TOTP
+totpSHA512 secret time period = hotpSHA512 secret (totpCounter time period)
+
+-- | Check presented password against time periods.
+--
+-- @since 3.0.0.0
+totpSHA1Check
+ :: SHA256.AuthenticationKey
+ -- ^ Shared secret
+ -> (Word64, Word64)
+ -- ^ Valid counter range, before and after ideal
+ -> Time
+ -- ^ Time of TOTP
+ -> Timespan
+ -- ^ Time range in seconds
+ -> Digits
+ -- ^ Numer of digits in a password
+ -> Text
+ -- ^ Password given by user
+ -> Bool
+ -- ^ True if password is valid
+totpSHA1Check secret range time period digits pass =
+ let counters = totpCounterRange range time period
+ passwords = fmap (\c -> display $ hotpSHA1 secret c digits) counters
+ in elem pass passwords
+
+-- | Check presented password against time periods.
+--
+-- @since 3.0.0.0
+totpSHA256Check
+ :: SHA256.AuthenticationKey
+ -- ^ Shared secret
+ -> (Word64, Word64)
+ -- ^ Valid counter range, before and after ideal
+ -> Time
+ -- ^ Time of TOTP
+ -> Timespan
+ -- ^ Time range in seconds
+ -> Digits
+ -- ^ Numer of digits in a password
+ -> Text
+ -- ^ Password given by user
+ -> Bool
+ -- ^ True if password is valid
+totpSHA256Check secret range time period digits pass =
+ let counters = totpCounterRange range time period
+ passwords = fmap (\c -> display $ hotpSHA256 secret c digits) counters
+ in elem pass passwords
+
+-- | Check presented password against time periods.
+--
+-- @since 3.0.0.0
+totpSHA512Check
+ :: SHA512.AuthenticationKey
+ -- ^ Shared secret
+ -> (Word64, Word64)
+ -- ^ Valid counter range, before and after ideal
+ -> Time
+ -- ^ Time of TOTP
+ -> Timespan
+ -- ^ Time range in seconds
+ -> Digits
+ -- ^ Numer of digits in a password
+ -> Text
+ -- ^ Password given by user
+ -> Bool
+ -- ^ True if password is valid
+totpSHA512Check secret range time period digits pass =
+ let counters = totpCounterRange range time period
+ passwords = fmap (\c -> display $ hotpSHA512 secret c digits) counters
+ in elem pass passwords
+
+-- | Create a URI suitable for authenticators.
+--
+-- The result of this function is best given to a QR Code generator for end-users to scan.
+--
+-- @since 3.0.0.0
+totpToURI
+ :: Text
+ -- ^ Shared secret key. Must be encoded in base32.
+ -> Text
+ -- ^ Name of the account (usually an email address)
+ -> Text
+ -- ^ Issuer
+ -> Digits
+ -- ^ Amount of digits expected from the end-user
+ -> Timespan
+ -- ^ Amount of time before the generated code expires
+ -> Algorithm
+ -- ^ Algorithm required
+ -> Text
+totpToURI secret account issuer digits period algorithm =
+ Text.pack $
+ escapeURIString isUnescapedInURI $
+ Text.unpack $
+ "otpauth://totp/"
+ <> issuer
+ <> ":"
+ <> account
+ <> "?secret="
+ <> secret
+ <> "&issuer="
+ <> issuer
+ <> "&digits="
+ <> display digits
+ <> "&algorithm="
+ <> display algorithm
+ <> "&period="
+ <> display (asSeconds period)
diff --git a/test/Test.hs b/test/Test.hs
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -1,79 +1,26 @@
module Main where
-import Crypto.Hash
-import Data.ByteString (ByteString)
-import Data.OTP
-import Data.Time
-import Data.Word
+import Sel
import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Data.ByteString.Char8 as BC
-
-hotpSecret :: ByteString
-hotpSecret = "12345678901234567890"
-
-testHotp :: Word64 -> Word32 -> TestTree
-testHotp key result = testCase (show result) $ do
- let h = hotp SHA1 hotpSecret key 6
- result @=? h
-
-hotpResults :: [Word32]
-hotpResults =
- [ 755224, 287082, 359152
- , 969429, 338314, 254676
- , 287922, 162583, 399871
- , 520489
- ]
-
-
-data SomeAlg = forall a. (HashAlgorithm a, Show a) => SomeAlg a
-
-instance Show SomeAlg where
- show (SomeAlg a) = show a
-
-
-testTotp :: (ByteString, UTCTime, SomeAlg, Word32) -> TestTree
-testTotp (secr, key, alg', result) =
- testCase (show alg' ++ " => " ++ show result) $ case alg' of
- SomeAlg alg -> do
- let t = totp alg secr key 30 8
- result @=? t
-
-sha1Secr :: ByteString
-sha1Secr = BC.pack $ take 20 $ cycle "12345678901234567890"
-
-sha256Secr :: ByteString
-sha256Secr = BC.pack $ take 32 $ cycle "12345678901234567890"
-
-sha512Secr :: ByteString
-sha512Secr = BC.pack $ take 64 $ cycle "12345678901234567890"
-
-totpData :: [(ByteString, UTCTime, SomeAlg, Word32)]
-totpData =
- [ (sha1Secr, read "1970-01-01 00:00:59 UTC", SomeAlg SHA1, 94287082)
- , (sha256Secr, read "1970-01-01 00:00:59 UTC", SomeAlg SHA256, 46119246)
- , (sha512Secr, read "1970-01-01 00:00:59 UTC", SomeAlg SHA512, 90693936)
- , (sha1Secr, read "2005-03-18 01:58:29 UTC", SomeAlg SHA1, 07081804)
- , (sha256Secr, read "2005-03-18 01:58:29 UTC", SomeAlg SHA256, 68084774)
- , (sha512Secr, read "2005-03-18 01:58:29 UTC", SomeAlg SHA512, 25091201)
- , (sha1Secr, read "2005-03-18 01:58:31 UTC", SomeAlg SHA1, 14050471)
- , (sha256Secr, read "2005-03-18 01:58:31 UTC", SomeAlg SHA256, 67062674)
- , (sha512Secr, read "2005-03-18 01:58:31 UTC", SomeAlg SHA512, 99943326)
- , (sha1Secr, read "2009-02-13 23:31:30 UTC", SomeAlg SHA1, 89005924)
- , (sha256Secr, read "2009-02-13 23:31:30 UTC", SomeAlg SHA256, 91819424)
- , (sha512Secr, read "2009-02-13 23:31:30 UTC", SomeAlg SHA512, 93441116)
- , (sha1Secr, read "2033-05-18 03:33:20 UTC", SomeAlg SHA1, 69279037)
- , (sha256Secr, read "2033-05-18 03:33:20 UTC", SomeAlg SHA256, 90698825)
- , (sha512Secr, read "2033-05-18 03:33:20 UTC", SomeAlg SHA512, 38618901)
- , (sha1Secr, read "2603-10-11 11:33:20 UTC", SomeAlg SHA1, 65353130)
- , (sha256Secr, read "2603-10-11 11:33:20 UTC", SomeAlg SHA256, 77737706)
- , (sha512Secr, read "2603-10-11 11:33:20 UTC", SomeAlg SHA512, 47863826)
- ]
+import Test.Tasty.QuickCheck (QuickCheckTests)
+import Test.Comparison qualified as Comparison
+import Test.HOTP qualified as HOTP
+import Test.Properties qualified as Properties
+import Test.TOTP qualified as TOTP
main :: IO ()
-main = defaultMain $ testGroup "test vectors"
- [ testGroup "hotp" $ map (uncurry testHotp) $ zip [0..] hotpResults
- , testGroup "totp" $ map testTotp totpData
- ]
+main =
+ secureMain $
+ defaultMain $
+ adjustOption moreTests $
+ testGroup
+ "one-time-password tests"
+ [ HOTP.spec
+ , TOTP.spec
+ , Properties.spec
+ , Comparison.spec
+ ]
+
+moreTests :: QuickCheckTests -> QuickCheckTests
+moreTests = max 10_000
diff --git a/test/Test/Comparison.hs b/test/Test/Comparison.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Comparison.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Test.Comparison where
+
+import Chronos qualified
+import Data.Base16.Types qualified as Base
+import Data.ByteString.Base16 qualified as Base
+import Sel.HMAC.SHA256 qualified as SHA256
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Chronos (Time (..))
+import Crypto.Hash.Algorithms qualified as Crypton
+import Crypto.OTP qualified as Crypton
+import Data.ByteString (StrictByteString)
+import Data.Int (Int64)
+import Data.Text.Display
+import Data.Word (Word64)
+import OTP.Commons
+import OTP.TOTP qualified as TOTP
+import Sel.HMAC.SHA512 qualified as SHA512
+import Test.Utils
+import Torsor
+
+spec :: TestTree
+spec =
+ testGroup
+ "Comparing outputs of other implementations"
+ [ testGroup
+ "Crypton"
+ [ testCase "HMAC-SHA1 TOTP" testCryptonSHA1TOTP
+ , testCase "HMAC-SH256 TOTP" testCryptonSHA256TOTP
+ , testCase "HMAC-SH512 TOTP" testCryptonSHA512TOTP
+ ]
+ ]
+
+testCryptonSHA1TOTP :: Assertion
+testCryptonSHA1TOTP = do
+ let hexKey = "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString hexKey
+ let cryptoniteKey = Base.decodeBase16 $ Base.assertBase16 @StrictByteString hexKey
+ timestamp@(Time ns) <- Chronos.now
+ let seconds = ns `quot` (10 ^ (9 :: Int64))
+ let timeStep = scale 30 Chronos.second
+ digits <- assertJust $ mkDigits 6
+
+ let cryptoniteTOTP =
+ Crypton.totp
+ Crypton.defaultTOTPParams
+ cryptoniteKey
+ (fromIntegral @Int64 @Word64 seconds)
+
+ let ownTotp = TOTP.totpSHA1 key timestamp timeStep digits
+
+ assertEqual
+ "OTPs are the same"
+ (display ownTotp.code)
+ (display cryptoniteTOTP)
+
+testCryptonSHA256TOTP :: Assertion
+testCryptonSHA256TOTP = do
+ let hexKey = "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString hexKey
+ let cryptonKey = Base.decodeBase16 $ Base.assertBase16 @StrictByteString hexKey
+ timestamp@(Time ns) <- Chronos.now
+ let seconds = ns `quot` (10 ^ (9 :: Int64))
+ let timeStep = scale 30 Chronos.second
+ digits <- assertJust $ mkDigits 6
+ totpParams <-
+ assertRight $
+ Crypton.mkTOTPParams
+ Crypton.SHA256
+ 0
+ 30
+ Crypton.OTP6
+ Crypton.TwoSteps
+
+ let cryptoniteTOTP =
+ Crypton.totp
+ totpParams
+ cryptonKey
+ (fromIntegral @Int64 @Word64 seconds)
+
+ let ownTotp = TOTP.totpSHA256 key timestamp timeStep digits
+
+ assertEqual
+ "OTPs are the same"
+ (display ownTotp.code)
+ (display cryptoniteTOTP)
+
+testCryptonSHA512TOTP :: Assertion
+testCryptonSHA512TOTP = do
+ let hexKey = "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ key <- assertRight $ SHA512.authenticationKeyFromHexByteString hexKey
+ let cryptonKey = Base.decodeBase16 $ Base.assertBase16 @StrictByteString hexKey
+ timestamp@(Time ns) <- Chronos.now
+ let seconds = ns `quot` (10 ^ (9 :: Int64))
+ let timeStep = scale 30 Chronos.second
+ digits <- assertJust $ mkDigits 6
+ totpParams <-
+ assertRight $
+ Crypton.mkTOTPParams
+ Crypton.SHA512
+ 0
+ 30
+ Crypton.OTP6
+ Crypton.TwoSteps
+
+ let cryptoniteTOTP =
+ Crypton.totp
+ totpParams
+ cryptonKey
+ (fromIntegral @Int64 @Word64 seconds)
+
+ let ownTotp = TOTP.totpSHA512 key timestamp timeStep digits
+
+ assertEqual
+ "OTPs are the same"
+ (display ownTotp.code)
+ (display cryptoniteTOTP)
diff --git a/test/Test/HOTP.hs b/test/Test/HOTP.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/HOTP.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE DataKinds #-}
+
+module Test.HOTP where
+
+import Data.Foldable (forM_)
+import Data.Text.Display
+import OTP.HOTP
+import Sel.HMAC.SHA256 qualified as SHA256
+import Sel.HMAC.SHA512 qualified as SHA512
+
+import Data.Text qualified as Text
+import OTP.Commons
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Utils
+
+spec :: TestTree
+spec =
+ testGroup
+ "HOTP"
+ [ testGroup
+ "HMAC-SHA-1"
+ [ testCase "Expected codes" testExpectedHotpSHA1Codes
+ , testCase "Validate code" testValidateHotpSHA1
+ ]
+ , testGroup
+ "HMAC-SHA-256"
+ [ testCase "Expected codes" testExpectedHotpSHA256Codes
+ , testCase "Validate code" testValidateHotpSHA256
+ ]
+ , testGroup
+ "HMAC-SHA-512"
+ [ testCase "Expected codes" testExpectedHOTP512Codes
+ , testCase "Validate code" testValidateHOTP512
+ ]
+ ]
+
+testExpectedHotpSHA1Codes :: Assertion
+testExpectedHotpSHA1Codes = do
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let counters = [0 .. 10]
+ let results = fmap (\counter -> display $ hotpSHA1 key counter digits) counters
+ assertEqual
+ "HMAC-SHA1 Codes are expected and stable"
+ [ "023113"
+ , "181354"
+ , "151026"
+ , "300498"
+ , "479326"
+ , "661773"
+ , "464666"
+ , "430540"
+ , "941671"
+ , "303579"
+ , "027354"
+ ]
+ results
+
+ forM_ results $ \code ->
+ assertBool
+ ("Code " <> show code <> " is not 6 characters long")
+ (Text.length (display code) == 6)
+
+testValidateHotpSHA1 :: Assertion
+testValidateHotpSHA1 = do
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let code = hotpSHA1 key 30 digits
+ let result = hotpSHA1Check key (29, 31) 30 digits (display code)
+ assertBool
+ "Code is checked"
+ result
+
+testExpectedHotpSHA256Codes :: Assertion
+testExpectedHotpSHA256Codes = do
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let counters = [0 .. 10]
+ let results = fmap (\counter -> display $ hotpSHA256 key counter digits) counters
+ assertEqual
+ "Codes are expected and stable"
+ [ "545840"
+ , "042194"
+ , "783687"
+ , "856777"
+ , "199784"
+ , "809856"
+ , "270404"
+ , "137308"
+ , "219373"
+ , "965280"
+ , "635343"
+ ]
+ results
+
+ forM_ results $ \code ->
+ assertBool
+ ("Code " <> show code <> " is not 6 characters long")
+ (Text.length (display code) == 6)
+
+testValidateHotpSHA256 :: Assertion
+testValidateHotpSHA256 = do
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let code = hotpSHA256 key 30 digits
+ let result = hotpSHA256Check key (29, 31) 30 digits (display code)
+ assertBool
+ "Code is checked"
+ result
+
+testExpectedHOTP512Codes :: Assertion
+testExpectedHOTP512Codes = do
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA512.authenticationKeyFromHexByteString "11f1bf4c4136f33194c95c80e29dfb091f488ca9ac12b07907e4ed145fd35269"
+ let counters = [0 .. 10]
+ let results = fmap (\counter -> display $ hotpSHA512 key counter digits) counters
+
+ assertEqual
+ "Codes are expected and stable"
+ [ "789887"
+ , "828664"
+ , "852597"
+ , "476319"
+ , "098272"
+ , "202574"
+ , "057559"
+ , "321460"
+ , "156051"
+ , "151927"
+ , "131108"
+ ]
+ results
+
+ forM_ results $ \code ->
+ assertBool
+ ("Code " <> show code <> " is not 6 characters long")
+ (Text.length (display code) == 6)
+
+testValidateHOTP512 :: Assertion
+testValidateHOTP512 = do
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA512.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let code = hotpSHA512 key 30 digits
+ let result = hotpSHA512Check key (29, 31) 30 digits (display code)
+ assertBool
+ "Code is checked"
+ result
diff --git a/test/Test/Properties.hs b/test/Test/Properties.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Properties.hs
@@ -0,0 +1,183 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.Properties where
+
+import Chronos
+import Control.Monad (guard)
+import Data.ByteString.Char8 qualified as SBSC
+import Data.Function ((&))
+import Data.Functor ((<&>))
+import Data.Int (Int64)
+import Data.Maybe (fromJust)
+import Data.Text qualified as Text
+import Data.Text.Display (Display (..), display)
+import Data.Word (Word32)
+import Sel.HMAC.SHA256 qualified as HMAC
+import System.IO.Unsafe (unsafeDupablePerformIO)
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Torsor qualified
+
+import OTP.Commons
+import OTP.HOTP qualified as HOTP
+import OTP.TOTP qualified as TOTP
+
+spec :: TestTree
+spec =
+ testGroup
+ "Properties"
+ [ digitNumberProperty
+ , timePeriodProperty
+ ]
+
+-- Properties
+
+digitNumberProperty :: TestTree
+digitNumberProperty = testProperty "Digit parameter determines the length of the output" $
+ property $ \(arbitraryDigits, key, timestamp) ->
+ let period = Torsor.scale 30 second
+ ArbitraryDigits digits = arbitraryDigits
+ totp =
+ TOTP.totpSHA1
+ (getKey key)
+ timestamp
+ period
+ digits
+ expectedLength = digitsToWord32 digits
+ actualLength = totp.digits
+ in expectedLength === actualLength
+
+timePeriodProperty :: TestTree
+timePeriodProperty = testProperty "A code stays stable within a time frame with the same key & digit parameters" $
+ property $ \(Key key, ArbitraryDigits digits, SeparationTime separationTime, ArbitraryTime signtime) ->
+ let period = Torsor.scale separationTime second
+ validUntil = Torsor.add period signtime
+ (Timespan nanoseconds) = period
+ checktime = Torsor.add (Timespan (negate $ nanoseconds `div` 2)) validUntil
+ totp =
+ TOTP.totpSHA1
+ key
+ signtime
+ period
+ digits
+ signCounter = totpCounter signtime period
+ checkCounters = totpCounterRange (1, 0) checktime period
+ checkCodes = fmap (\c -> HOTP.hotpSHA1 key c digits) checkCounters
+ in counterexample
+ ( Text.unpack $
+ mconcat
+ [ "Time: "
+ , display signtime
+ , ", Separation time (tested period): "
+ , display period
+ , ", Valid until: "
+ , display validUntil
+ , ", Time tested: "
+ , display checktime
+ , ", Code tested: "
+ , display totp
+ , ", Codes checked against: "
+ , display checkCodes
+ , ", Counter at generation: "
+ , display signCounter
+ , ", Counters checked for: "
+ , display checkCounters
+ ]
+ )
+ ( TOTP.totpSHA1Check
+ key
+ (1, 0)
+ checktime
+ period
+ digits
+ (display totp)
+ )
+
+newtype ArbitraryDigits = ArbitraryDigits Digits
+ deriving (Eq, Show) via Digits
+
+instance Arbitrary ArbitraryDigits where
+ arbitrary = ArbitraryDigits . fromJust . mkDigits . fromIntegral @Int @Word32 <$> chooseInt (6, 9)
+
+deriving instance Arbitrary Time
+
+newtype Key = Key {getKey :: HMAC.AuthenticationKey}
+ deriving newtype (Eq, Ord)
+
+-- This instance deliberately exposes the actual value of the key so that
+-- failing tests will return more information. This is safe because the 'Key'
+-- type is local to this testing module and is only used to generate random
+-- test keys for property tests.
+instance Show Key where
+ show (Key key) = SBSC.unpack $ HMAC.unsafeAuthenticationKeyToHexByteString key
+
+instance Arbitrary Key where
+ arbitrary = pure $ Key $ unsafeDupablePerformIO HMAC.newAuthenticationKey
+
+-- | A separation time is a period in which we test the validity of a code.
+newtype SeparationTime = SeparationTime Int64
+ deriving (Eq, Show, Ord, Num, Enum, Real, Integral) via Int64
+
+instance Arbitrary SeparationTime where
+ arbitrary =
+ chooseInt (1, 30)
+ <&> fromIntegral @Int @Int64
+ <&> SeparationTime
+ shrink (SeparationTime time) = do
+ t' <- shrink time
+ guard (t' >= 1)
+ pure $ SeparationTime t'
+
+instance Display Time where
+ displayBuilder time =
+ let format = DatetimeFormat (Just '-') (Just ' ') (Just ':')
+ in time
+ & timeToDatetime
+ & builder_YmdHMS (SubsecondPrecisionFixed 0) format
+
+instance Display Timespan where
+ displayBuilder timespan = displayBuilder (asSeconds timespan) <> "s"
+
+newtype ArbitraryTime = ArbitraryTime Time
+ deriving (Eq, Show, Ord, Display) via Time
+
+instance Arbitrary ArbitraryTime where
+ arbitrary = do
+ datetime <- arbitrary @Datetime
+ pure $ ArbitraryTime (datetimeToTime datetime)
+
+instance Arbitrary TimeOfDay where
+ arbitrary =
+ TimeOfDay
+ <$> choose (0, 23)
+ <*> choose (0, 59)
+ -- never use leap seconds for property-based tests
+ <*> ( do
+ subsecPrecision <- chooseInt (0, 9)
+ secs <- chooseInt (0, 59)
+ case subsecPrecision of
+ 0 -> pure (fromIntegral @Int @Int64 secs * 1_000_000_000)
+ _ -> do
+ subsecs <- chooseInt (0, ((10 :: Int) ^ subsecPrecision) - 1)
+ let subsecs' = subsecs * ((10 :: Int) ^ (9 - subsecPrecision))
+ if subsecs' < 0 || subsecs' >= 1_000_000_000
+ then error "Mistake in Arbitrary instance for TimeOfDay"
+ else
+ pure
+ ( (fromIntegral @Int @Int64 secs * 1_000_000_000)
+ + fromIntegral @Int @Int64 subsecs
+ )
+ )
+
+instance Arbitrary Date where
+ arbitrary =
+ Date
+ <$> fmap Year (choose (1800, 2100))
+ <*> fmap Month (choose (0, 11))
+ <*> fmap DayOfMonth (choose (1, 28))
+
+instance Arbitrary Datetime where
+ arbitrary = Datetime <$> arbitrary <*> arbitrary
diff --git a/test/Test/TOTP.hs b/test/Test/TOTP.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/TOTP.hs
@@ -0,0 +1,104 @@
+module Test.TOTP where
+
+import Chronos
+import Data.ByteString.Base32 qualified as Base32
+import Data.Maybe (fromJust)
+import Data.Text.Display (display)
+import Sel.HMAC.SHA256 qualified as SHA256
+import Sel.HMAC.SHA512 qualified as SHA512
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Utils
+import Torsor (scale)
+
+import OTP.Commons (Algorithm (..), mkDigits, totpCounter)
+import OTP.TOTP (totpSHA1, totpSHA1Check, totpSHA256, totpSHA256Check, totpSHA512, totpSHA512Check, totpToURI)
+
+spec :: TestTree
+spec =
+ testGroup
+ "TOTP"
+ [ testCase "TOTP counter from time" testTOTPCounterFromTime
+ , testCase "HMAC-SHA-1 TOTP codes" testSHA1TOTPCodes
+ , testCase "HMAC-SHA-256 TOTP codes" testSHA256TOTPCodes
+ , testCase "HMAC-SHA-512 TOTP codes" testSHA512TOTPCodes
+ , testCase "URI generation" testTOTPURIGeneration
+ ]
+
+testTOTPCounterFromTime :: Assertion
+testTOTPCounterFromTime = do
+ let dtf = DatetimeFormat (Just '-') (Just ' ') (Just ':')
+ let decode txt = datetimeToTime $ fromJust $ Chronos.decode_YmdHMS dtf txt
+ assertEqual
+ "Correct counter from date 2010-10-10 00:00:00"
+ (totpCounter (decode "2010-10-10 00:00:00") (scale 30 second))
+ 42888960
+
+ assertEqual
+ "Correct counter from date 2010-10-10 00:00:30"
+ (totpCounter (decode "2010-10-10 00:00:30") (scale 30 second))
+ 42888961
+
+ assertEqual
+ "Correct counter from date 2010-10-10 00:01:00"
+ (totpCounter (decode "2010-10-10 00:01:00") (scale 30 second))
+ 42888962
+
+testSHA1TOTPCodes :: Assertion
+testSHA1TOTPCodes = do
+ timestamp <- now
+ let timeStep = scale 30 second
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let code = totpSHA1 key timestamp timeStep digits
+ let result = totpSHA1Check key (0, 1) timestamp timeStep digits (display code)
+ assertBool
+ "Can check own code"
+ result
+
+testSHA256TOTPCodes :: Assertion
+testSHA256TOTPCodes = do
+ timestamp <- now
+ let timeStep = scale 30 second
+ digits <- assertJust $ mkDigits 6
+
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let code = totpSHA256 key timestamp timeStep digits
+ let result = totpSHA256Check key (0, 1) timestamp timeStep digits (display code)
+ assertBool
+ "Can check own code"
+ result
+
+testSHA512TOTPCodes :: Assertion
+testSHA512TOTPCodes = do
+ timestamp <- now
+ let timeStep = scale 30 second
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA512.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let code = totpSHA512 key timestamp timeStep digits
+ let result = totpSHA512Check key (0, 1) timestamp timeStep digits (display code)
+ assertBool
+ "Code is checked"
+ result
+
+testTOTPURIGeneration :: Assertion
+testTOTPURIGeneration = do
+ let period = scale 30 second
+ digits <- assertJust $ mkDigits 6
+ key <- assertRight $ SHA256.authenticationKeyFromHexByteString "e90cbae2d7d187f614806347cfd75002bd0db847451109599da507e8da88bf43"
+ let issuer = "Localhost Inc"
+ let account = "username@localhost.localdomain"
+
+ let uri =
+ totpToURI
+ (Base32.encodeBase32 $ SHA256.unsafeAuthenticationKeyToBinary key)
+ account
+ issuer
+ digits
+ period
+ HMAC_SHA1
+
+ assertEqual
+ "Expected URI"
+ "otpauth://totp/Localhost%20Inc:username@localhost.localdomain?secret=5EGLVYWX2GD7MFEAMND47V2QAK6Q3OCHIUIQSWM5UUD6RWUIX5BQ====&issuer=Localhost%20Inc&digits=6&algorithm=SHA1&period=30"
+ uri
diff --git a/test/Test/Utils.hs b/test/Test/Utils.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Utils.hs
@@ -0,0 +1,12 @@
+module Test.Utils where
+
+import GHC.Stack
+import Test.Tasty.HUnit qualified as Test
+
+assertRight :: HasCallStack => Either a b -> IO b
+assertRight (Left _a) = Test.assertFailure "Test return Left instead of Right"
+assertRight (Right b) = pure b
+
+assertJust :: HasCallStack => Maybe a -> IO a
+assertJust Nothing = Test.assertFailure "Test return Nothing instead of Just"
+assertJust (Just a) = pure a