never executed always true always false
1 module PureClaw.Security.Pairing
2 ( -- * Pairing state
3 PairingState
4 , mkPairingState
5 -- * Operations
6 , generatePairingCode
7 , attemptPair
8 , verifyToken
9 , revokeToken
10 -- * Configuration
11 , PairingConfig (..)
12 , defaultPairingConfig
13 -- * Errors
14 , PairingError (..)
15 ) where
16
17 import Control.Concurrent.STM
18 import Crypto.Random qualified as CR
19 import Data.Bits (shiftL, (.|.))
20 import Data.ByteString (ByteString)
21 import Data.ByteString qualified as BS
22 import Data.Map.Strict (Map)
23 import Data.Map.Strict qualified as Map
24 import Data.Set (Set)
25 import Data.Set qualified as Set
26 import Data.Text (Text)
27 import Data.Text qualified as T
28 import Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
29 import Data.Word (Word32)
30
31 import PureClaw.Security.Crypto
32 import PureClaw.Security.Secrets
33
34 -- | Configuration for the pairing system.
35 data PairingConfig = PairingConfig
36 { _pc_codeExpiry :: NominalDiffTime
37 , _pc_maxAttempts :: Int
38 , _pc_lockoutDuration :: NominalDiffTime
39 , _pc_tokenBytes :: Int
40 }
41 deriving stock (Show, Eq)
42
43 -- | Sensible defaults: 5 minute code expiry, 5 attempts before lockout,
44 -- 15 minute lockout, 32-byte tokens.
45 defaultPairingConfig :: PairingConfig
46 defaultPairingConfig = PairingConfig
47 { _pc_codeExpiry = 300
48 , _pc_maxAttempts = 5
49 , _pc_lockoutDuration = 900
50 , _pc_tokenBytes = 32
51 }
52
53 -- | Errors from pairing operations.
54 data PairingError
55 = InvalidCode
56 | LockedOut
57 | CodeExpired
58 deriving stock (Show, Eq)
59
60 -- | Per-client attempt tracking.
61 data AttemptInfo = AttemptInfo
62 { _ai_count :: Int
63 , _ai_lastAttempt :: UTCTime
64 }
65
66 -- | Mutable pairing state, managed via STM.
67 data PairingState = PairingState
68 { _ps_config :: PairingConfig
69 , _ps_codes :: TVar (Map Text UTCTime)
70 , _ps_attempts :: TVar (Map Text AttemptInfo)
71 , _ps_tokens :: TVar (Set ByteString)
72 }
73
74 -- | Create a fresh pairing state.
75 mkPairingState :: PairingConfig -> IO PairingState
76 mkPairingState config = PairingState config
77 <$> newTVarIO Map.empty
78 <*> newTVarIO Map.empty
79 <*> newTVarIO Set.empty
80
81 -- | Generate a cryptographically random 6-digit pairing code.
82 -- The code is registered in the pairing state with an expiry time.
83 generatePairingCode :: PairingState -> IO PairingCode
84 generatePairingCode st = do
85 bytes <- CR.getRandomBytes 4 :: IO ByteString
86 let n = (fromIntegral (BS.index bytes 0) `shiftL` 24
87 .|. fromIntegral (BS.index bytes 1) `shiftL` 16
88 .|. fromIntegral (BS.index bytes 2) `shiftL` 8
89 .|. fromIntegral (BS.index bytes 3)) :: Word32
90 codeText = T.justifyRight 6 '0' (T.pack (show (n `mod` 1000000)))
91 now <- getCurrentTime
92 let expiry = addUTCTime (_pc_codeExpiry (_ps_config st)) now
93 atomically $ modifyTVar' (_ps_codes st) (Map.insert codeText expiry)
94 pure (mkPairingCode codeText)
95
96 -- | Attempt to pair using a code. Returns a bearer token on success.
97 -- Tracks per-client attempts and enforces lockout after too many failures.
98 attemptPair :: PairingState -> Text -> PairingCode -> IO (Either PairingError BearerToken)
99 attemptPair st clientId code = do
100 now <- getCurrentTime
101 withPairingCode code $ \codeText -> do
102 let config = _ps_config st
103 result <- atomically $ do
104 attempts <- readTVar (_ps_attempts st)
105 case Map.lookup clientId attempts of
106 Just info
107 | _ai_count info >= _pc_maxAttempts config
108 , diffUTCTime now (_ai_lastAttempt info) < _pc_lockoutDuration config
109 -> pure (Left LockedOut)
110 _ -> do
111 codes <- readTVar (_ps_codes st)
112 case Map.lookup codeText codes of
113 Nothing -> do
114 bumpAttempts st clientId now
115 pure (Left InvalidCode)
116 Just expiry
117 | now > expiry -> do
118 modifyTVar' (_ps_codes st) (Map.delete codeText)
119 bumpAttempts st clientId now
120 pure (Left CodeExpired)
121 | otherwise -> do
122 modifyTVar' (_ps_codes st) (Map.delete codeText)
123 modifyTVar' (_ps_attempts st) (Map.delete clientId)
124 pure (Right ())
125 case result of
126 Left err -> pure (Left err)
127 Right () -> do
128 tokenBytes <- CR.getRandomBytes (_pc_tokenBytes config)
129 let tokenHash = sha256Hash tokenBytes
130 atomically $ modifyTVar' (_ps_tokens st) (Set.insert tokenHash)
131 pure (Right (mkBearerToken tokenBytes))
132
133 -- | Verify a bearer token against stored hashes. Constant-time comparison.
134 verifyToken :: PairingState -> BearerToken -> IO Bool
135 verifyToken st token =
136 withBearerToken token $ \tokenBytes -> do
137 let tokenHash = sha256Hash tokenBytes
138 hashes <- readTVarIO (_ps_tokens st)
139 pure (Set.member tokenHash hashes)
140
141 -- | Revoke a bearer token.
142 revokeToken :: PairingState -> BearerToken -> IO ()
143 revokeToken st token =
144 withBearerToken token $ \tokenBytes -> do
145 let tokenHash = sha256Hash tokenBytes
146 atomically $ modifyTVar' (_ps_tokens st) (Set.delete tokenHash)
147
148 -- Internal: bump attempt counter for a client.
149 bumpAttempts :: PairingState -> Text -> UTCTime -> STM ()
150 bumpAttempts st clientId now =
151 modifyTVar' (_ps_attempts st) $ Map.alter bump clientId
152 where
153 bump Nothing = Just (AttemptInfo 1 now)
154 bump (Just info) = Just info { _ai_count = _ai_count info + 1, _ai_lastAttempt = now }