packages feed

crypto-totp (empty) → 0.1.0.0

raw patch · 5 files changed

+415/−0 lines, 5 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, cryptohash, tagged, unix

Files

+ Crypto/MAC/TOTP/Factory.hs view
@@ -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)
+ Crypto/MAC/TOTP/Verifier.hs view
@@ -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)
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ crypto-totp.cabal view
@@ -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