diff --git a/Crypto/MAC/TOTP/Factory.hs b/Crypto/MAC/TOTP/Factory.hs new file mode 100644 --- /dev/null +++ b/Crypto/MAC/TOTP/Factory.hs @@ -0,0 +1,171 @@ +module Crypto.MAC.TOTP.Factory +( Factory (..) +, initialize +, initializeIO +, initGrace +, epochEq +, authenticate +, authenticateBS +, roundTime +, setTime +, validUntil +, shouldRefresh +, refresh +, refreshIO +, tryRefreshEvery +, startRefreshThread +, getNext +, getMessages +, getNextIO +, getMessagesIO +) where + +import Crypto.Hash hiding (hmac) +import Crypto.MAC.HMAC +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) +import Data.Int +import Data.Word +import Data.Bits +import System.Posix.Time +import System.Posix.Types (EpochTime) +import Foreign.C.Types (CTime (..)) +import Control.Concurrent +import Data.IORef +import Data.Serialize + +instance Integral CTime where + quot (CTime a) (CTime b) = CTime (a `quot` b) + rem (CTime a) (CTime b) = CTime (a `rem` b) + div (CTime a) (CTime b) = CTime (a `div` b) + mod (CTime a) (CTime b) = CTime (a `mod` b) + quotRem (CTime n) (CTime d) = (\(d,m) -> (CTime d, CTime m)) (quotRem n d) + divMod (CTime n) (CTime d) = (\(d,m) -> (CTime d, CTime m)) (divMod n d) + toInteger (CTime t) = toInteger t + +data Factory = Factory { secret :: ByteString + , secretInit :: ByteString + , count :: Int64 + , validSeconds :: CTime + , refreshEpoch :: EpochTime + , hashMethod :: ByteString -> ByteString + , blockSize :: Int + , prefix :: ByteString -> ByteString + } + +initialize :: (ByteString -> ByteString) -> Int -> Int -> ByteString -> CTime -> Factory +initialize hashMethod blockSize tokenBytes secretInit validSeconds = + if validSeconds < 1 + then error "validSeconds must be >= 1" + else Factory { secret = BS.empty + , secretInit + , count = 0 + , validSeconds + , refreshEpoch = 0 + , hashMethod + , blockSize + , prefix = BS.take tokenBytes + } + +initializeIO :: (ByteString -> ByteString) -> Int -> Int -> ByteString -> CTime -> IO (Factory) +initializeIO hashMethod blockSize tokenBytes secretInit validSeconds = do + time <- epochTime + return $ refresh time (initialize hashMethod blockSize tokenBytes secretInit validSeconds) + +initGrace :: Factory -> CTime -> Factory +initGrace (Factory _ secretInit _ validSeconds refreshEpoch hashMethod blockSize prefix) graceSeconds = + let time = refreshEpoch - graceSeconds * validSeconds in + refresh time $ Factory { secret = BS.empty + , secretInit + , count = 0 + , validSeconds + , refreshEpoch = 0 + , hashMethod + , blockSize + , prefix + } + +epochEq :: Factory -> CTime -> Factory -> Bool +epochEq baseF n f = + refreshEpoch f == refreshEpoch baseF - n * (validSeconds baseF) + +incr :: Factory -> Factory +incr f = f {count = count f + 1} + +authenticate :: Serialize b => Factory -> b -> ByteString +authenticate factory = authenticateBS factory encode + +authenticateBS :: Factory -> (b -> ByteString) -> b -> ByteString +authenticateBS factory encodeFun message = + (prefix factory) $ hmac (hashMethod factory) (blockSize factory) (secret factory) (encodeFun message) + +hashCount :: Factory -> ByteString +hashCount f = + authenticate f (count f) + +roundTime :: CTime -> CTime -> CTime +roundTime t r = (t `div` r) * r + +setTime :: CTime -> Factory -> Factory +setTime t f = + let ct'@(CTime t') = roundTime t (validSeconds f) + timeBytes = encode t' + in f { refreshEpoch = ct', secret = (hashMethod f) $ BS.concat [secretInit f, timeBytes] } + +validUntil :: Factory -> EpochTime +validUntil f = refreshEpoch f + validSeconds f + +shouldRefresh :: Factory -> EpochTime -> Bool +shouldRefresh f t = + t >= validUntil f + +refresh :: EpochTime -> Factory -> Factory +refresh time factory = + if shouldRefresh factory time + then (setTime time factory) { count = 0 } + else factory + +refreshIO :: Factory -> IO (Factory) +refreshIO factory = do + time <- epochTime + return $ refresh time factory + +tryRefreshEvery :: Int -- ^ The delay according to Control.Concurrent.threadDelay before refresh attempts. + -> IORef (Factory) -- ^ The current factory. + -> IO () +tryRefreshEvery delay factoryRef = do + threadDelay delay + time <- epochTime + atomicModifyIORef factoryRef (\f -> let f' = if validUntil f <= time + then refresh time f + else f + in (f', ())) + tryRefreshEvery delay factoryRef + +startRefreshThread :: Int -> Factory -> IO (ThreadId, IORef (Factory)) +startRefreshThread delay factory = do + time <- epochTime + let factory' = refresh time factory + factoryRef <- newIORef factory' + t <- forkIO (tryRefreshEvery delay factoryRef) + return (t, factoryRef) + +getNext :: Factory -> (Factory, ByteString) +getNext f = + (incr f, hashCount f) + +getMessages :: Int -> Factory -> (Factory, [ByteString]) +getMessages 0 f = (f, []) +getMessages n f = + let (f', keys) = getMessages (n-1) f + (f'', key) = getNext f' + in (f'', key:keys) + +getNextIO :: IORef (Factory) -> IO (ByteString) +getNextIO factoryRef = + atomicModifyIORef factoryRef getNext + +getMessagesIO ::IORef (Factory) -> Int -> IO [ByteString] +getMessagesIO _ n | n < 1 = return [] +getMessagesIO factoryRef n = + atomicModifyIORef factoryRef (getMessages n) diff --git a/Crypto/MAC/TOTP/Verifier.hs b/Crypto/MAC/TOTP/Verifier.hs new file mode 100644 --- /dev/null +++ b/Crypto/MAC/TOTP/Verifier.hs @@ -0,0 +1,191 @@ +module Crypto.MAC.TOTP.Verifier +( Verifier (..) +, initializeIO +, initialize +, tryRefreshEvery +, startRefreshThread +, refresh +, getNext +, getMessages +, getNextIO +, getMessagesIO +, isAuthentic +, isAuthenticIO +) where + +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) +import qualified Data.List as List +import Data.Int +import qualified Data.Set as Set +import System.Posix.Time +import System.Posix.Types (EpochTime) +import Foreign.C.Types (CTime (..)) +import Control.Concurrent +import Data.IORef +import Control.Exception (evaluate) + +import qualified Crypto.MAC.TOTP.Factory as Factory + +data Verifier = Verifier { factory :: Factory.Factory + , usedTokens :: Set.Set ByteString + , grace :: [GraceVerifier] + , graceSeconds :: CTime + } + +data GraceVerifier = GraceVerifier { graceFactory :: Factory.Factory + , graceUsedTokens :: Set.Set ByteString + } + +graceEq :: Verifier -> CTime -> GraceVerifier -> Bool +graceEq v n gv = + Factory.epochEq (factory v) n (graceFactory gv) + +toGrace :: Verifier -> GraceVerifier +toGrace (Verifier factory usedTokens _ _) = + GraceVerifier { graceFactory = factory, graceUsedTokens = usedTokens } + +initializeIO :: (ByteString -> ByteString)-> Int -> Int -> ByteString -> CTime -> CTime -> IO Verifier +initializeIO hashMethod blockSize tokenBytes secret validSeconds graceSeconds = do + time <- epochTime + return $ initialize time hashMethod blockSize tokenBytes secret validSeconds graceSeconds + +initialize :: EpochTime -> (ByteString -> ByteString) -> Int -> Int -> ByteString -> CTime -> CTime -> Verifier +initialize time hashMethod blockSize tokenBytes secret validSeconds graceSeconds = + if graceSeconds < 0 + then error "graceSeconds must be >= 0" + else let factory = Factory.initialize hashMethod blockSize tokenBytes secret validSeconds + factory' = Factory.refresh time factory in + Verifier { factory = factory' + , usedTokens = Set.empty + , grace = initGrace graceSeconds validSeconds factory' + , graceSeconds + } + +tryRefreshEvery :: Verifier -> Int -> IORef Verifier -> IO () +tryRefreshEvery v delay verifierRef = do + threadDelay delay + time <- epochTime + if shouldRefresh time v + then let v' = refresh time v in + do writeIORef verifierRef v' + tryRefreshEvery v' delay verifierRef + else tryRefreshEvery v delay verifierRef + +startRefreshThread :: Int -> Verifier -> IO (ThreadId, IORef Verifier) +startRefreshThread delay verifier = do + time <- epochTime + let verifier' = refresh time verifier + verifierRef <- newIORef verifier' + t <- forkIO (tryRefreshEvery verifier' delay verifierRef) + return (t, verifierRef) + +graceCount :: CTime -> CTime -> Int64 +graceCount (CTime graceSeconds) (CTime validSeconds) = + let (d, m) = graceSeconds `divMod` validSeconds in + d + if m > 0 then 1 else 0 + +graceCountV :: Verifier -> Int64 +graceCountV v = + graceCount (graceSeconds v) (Factory.validSeconds . factory $ v) + +initGrace :: CTime -> CTime -> Factory.Factory -> [GraceVerifier] +initGrace graceSeconds validSeconds factory' = + let initGraceAux n accum = + let gf = Factory.initGrace factory' n in + (GraceVerifier gf Set.empty):accum + in foldr initGraceAux [] (map CTime [1..graceCount graceSeconds validSeconds]) + +refreshGrace :: Verifier -> Verifier -> Verifier +refreshGrace verifierOld verifierNew = + let grace' = (toGrace verifierOld):(grace verifierOld) + refreshGraceAux n accum = + case List.find (graceEq verifierNew n) grace' of + Nothing -> + let gf = Factory.initGrace (factory verifierNew) n in + (GraceVerifier gf Set.empty):accum + Just f -> + f:accum + in verifierNew { grace = foldr refreshGraceAux [] (map CTime [1..graceCountV verifierNew]) } + +shouldRefresh :: EpochTime -> Verifier -> Bool +shouldRefresh time v = + Factory.shouldRefresh (factory v) time + +refresh :: EpochTime -> Verifier -> Verifier +refresh t v = + let f = factory v + f' = Factory.refresh t f in + if shouldRefresh t v + then let v' = Verifier { factory = f' + , usedTokens = Set.empty + , grace = [] + , graceSeconds = graceSeconds v + } + in refreshGrace v v' + else v + +getNextUnsafe :: Verifier -> (Verifier, ByteString) +getNextUnsafe v = + let (f', m) = Factory.getNext (factory v) + v' = v { factory = f' + , usedTokens = Set.insert m (usedTokens v) + } in + (v', m) + +getNext :: Verifier -> (Verifier, ByteString) +getNext v = + let (v', m) = getNextUnsafe v in + if Set.member m (usedTokens v) + then getNext v' + else (v', m) + +getMessages :: Int -> Verifier -> (Verifier, [ByteString]) +getMessages 0 v = (v, []) +getMessages n f = + let (v', keys) = getMessages (n-1) f + (v'', key) = getNext v' + in (v'', key:keys) + +getNextIO :: IORef Verifier -> IO ByteString +getNextIO vRef = do + atomicModifyIORef vRef getNext + +getMessagesIO :: Int -> IORef Verifier -> IO [ByteString] +getMessagesIO n _ | n < 1 = return [] +getMessagesIO n vRef = do + atomicModifyIORef vRef (getMessages n) + +isAuthenticGrace :: EpochTime -> ByteString -> ByteString -> Verifier -> ([GraceVerifier], Bool) +isAuthenticGrace currentTime message token v = isAuthenticGraceAux [] (grace v) + where isAuthenticGraceAux left [] = (left, False) + isAuthenticGraceAux left (g:gs) = + let used = graceUsedTokens g + token' = Factory.authenticateBS (graceFactory g) id message + areEq = token == token' + isNotExpired = (Factory.validUntil . graceFactory $ g) + graceSeconds v > currentTime + nextStep = isAuthenticGraceAux (g:left) gs in + if not (Set.member token used) && areEq && isNotExpired + then let g' = g { graceUsedTokens = Set.insert token used } in + (g':(gs ++ left), True) + else nextStep + +isAuthentic :: EpochTime -> ByteString -> ByteString -> Verifier -> (Verifier, Bool) +isAuthentic currentTime message token v = + let v' = refresh currentTime v + used = usedTokens v' + token' = Factory.authenticateBS (factory v') id message + areEq = token == token' in + if Set.member token used || not areEq + then case isAuthenticGrace currentTime message token v' of + (g', True) -> (v' { grace = g' }, True) + (_, False) -> (v', False) + else if areEq + then let v'' = v' { usedTokens = Set.insert token used } in + (v'', True) + else (v', False) + +isAuthenticIO :: ByteString -> ByteString -> IORef Verifier -> IO Bool +isAuthenticIO message token vRef = do + t <- epochTime + atomicModifyIORef vRef (isAuthentic t message token) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Jeff Shaw + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jeff Shaw nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/crypto-totp.cabal b/crypto-totp.cabal new file mode 100644 --- /dev/null +++ b/crypto-totp.cabal @@ -0,0 +1,21 @@ +-- Initial crypto-tmac.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: crypto-totp +version: 0.1.0.0 +synopsis: Provides generation and verification services for time-based one-time keys. +description: Please see http://tools.ietf.org/html/rfc6238 +license: BSD3 +license-file: LICENSE +author: Jeff Shaw +maintainer: shawjef3@gmail.com +-- copyright: +category: Cryptography +build-type: Simple +cabal-version: >=1.8 + +library + extensions: NamedFieldPuns, ExistentialQuantification + exposed-modules: Crypto.MAC.TOTP.Factory, Crypto.MAC.TOTP.Verifier + -- other-modules: + build-depends: base ==4.*, containers, unix, bytestring, cereal, tagged, cryptohash