306 lines
11 KiB
Haskell
306 lines
11 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module ChuSQL.Interface.Auth (
|
|
Credential (..),
|
|
defaultIterations,
|
|
hashPassword,
|
|
hashPasswordWith,
|
|
hashLooksValid,
|
|
verifyPassword,
|
|
SessionPolicy (..),
|
|
defaultSessionPolicy,
|
|
SessionStore,
|
|
newSessionStore,
|
|
sessionPolicy,
|
|
setSessionPolicy,
|
|
createSession,
|
|
createVersionedSession,
|
|
lookupVersionedSession,
|
|
lookupSession,
|
|
deleteSession,
|
|
sessionToken,
|
|
PayloadStore,
|
|
newPayloadStore,
|
|
payloadPolicy,
|
|
setPayloadPolicy,
|
|
createPayloadSession,
|
|
lookupPayload,
|
|
putPayload,
|
|
dropPayload,
|
|
sweepPayloads,
|
|
) where
|
|
|
|
import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar)
|
|
import Crypto.Hash (SHA256 (..))
|
|
import qualified Crypto.KDF.PBKDF2 as PBKDF2
|
|
import Crypto.Random (getRandomBytes)
|
|
import qualified Data.ByteString as BS
|
|
import Data.ByteArray (constEq)
|
|
import Data.ByteArray.Encoding (Base (Base16), convertFromBase, convertToBase)
|
|
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (isJust)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
|
|
import Text.Read (readMaybe)
|
|
|
|
-- 口令哈希与会话仓库，服务端与 Web 管理端共用。
|
|
|
|
-- | 一条账号凭据：账号名 + 编码串
|
|
data Credential = Credential
|
|
{ credUser :: Text
|
|
, credEncoded :: Text
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
-- | 默认迭代次数（10 万次）
|
|
defaultIterations :: Int
|
|
defaultIterations = 100000
|
|
|
|
-- | 派生密钥长度（字节）
|
|
keyLength :: Int
|
|
keyLength = 32
|
|
|
|
-- | 盐长度（字节）
|
|
saltLength :: Int
|
|
saltLength = 16
|
|
|
|
-- | 迭代次数的上界：配置串被人改坏时不至于把自己算死
|
|
maxIterations :: Int
|
|
maxIterations = 10000000
|
|
|
|
-- | PBKDF2-HMAC-SHA256 派生
|
|
deriveKey :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString
|
|
deriveKey iters salt password =
|
|
PBKDF2.generate (PBKDF2.prfHMAC SHA256) (PBKDF2.Parameters iters keyLength) password salt
|
|
|
|
-- | 字节转十六进制
|
|
hexEncode :: BS.ByteString -> Text
|
|
hexEncode = TE.decodeUtf8 . convertToBase Base16
|
|
|
|
-- | 十六进制转字节（长度不对/有非法字符就给 Nothing）
|
|
hexDecode :: Text -> Maybe BS.ByteString
|
|
hexDecode t = case convertFromBase Base16 (TE.encodeUtf8 t) of
|
|
Left _ -> Nothing
|
|
Right bs -> Just bs
|
|
|
|
-- | 编码成 `pbkdf2-sha256$次数$盐$哈希`
|
|
encodeHash :: Int -> BS.ByteString -> BS.ByteString -> Text
|
|
encodeHash iters salt digest =
|
|
T.intercalate "$" ["pbkdf2-sha256", T.pack (show iters), hexEncode salt, hexEncode digest]
|
|
|
|
-- | 解回 (次数, 盐, 哈希)，坏格式给 Nothing
|
|
parseHash :: Text -> Maybe (Int, BS.ByteString, BS.ByteString)
|
|
parseHash t = case T.splitOn "$" t of
|
|
[alg, itersT, saltT, digestT]
|
|
| alg == "pbkdf2-sha256" -> do
|
|
iters <- readMaybe (T.unpack itersT) :: Maybe Int
|
|
salt <- hexDecode saltT
|
|
digest <- hexDecode digestT
|
|
if iters < 1000 || iters > maxIterations || BS.null salt || BS.length digest /= keyLength
|
|
then Nothing
|
|
else Just (iters, salt, digest)
|
|
_ -> Nothing
|
|
|
|
-- | 用给定盐生成编码串（给定盐是为了能写确定性测试）
|
|
hashPasswordWith :: Int -> BS.ByteString -> Text -> Text
|
|
hashPasswordWith iters salt password =
|
|
encodeHash iters salt (deriveKey iters salt (TE.encodeUtf8 password))
|
|
|
|
-- | 给一个口令配随机盐，生成编码串
|
|
hashPassword :: Text -> IO Text
|
|
hashPassword password = do
|
|
salt <- getRandomBytes saltLength
|
|
pure (hashPasswordWith defaultIterations salt password)
|
|
|
|
-- | 恒定时间校验口令是否匹配
|
|
verifyPassword :: Text -> Text -> Bool
|
|
verifyPassword encoded candidate = case parseHash encoded of
|
|
Nothing -> False
|
|
Just (iters, salt, digest) -> constEq digest (deriveKey iters salt (TE.encodeUtf8 candidate))
|
|
|
|
-- | 编码串本身是否合法（不看口令）
|
|
hashLooksValid :: Text -> Bool
|
|
hashLooksValid = isJust . parseHash
|
|
|
|
-- | 一条会话：账号、创建/最后活动时间与账号版本号
|
|
data Session = Session
|
|
{ sessUser :: Text
|
|
, sessCreated :: UTCTime
|
|
, sessSeen :: UTCTime
|
|
, sessRevision :: Maybe Integer
|
|
}
|
|
|
|
-- | 会话过期策略：空闲上限与绝对上限
|
|
data SessionPolicy = SessionPolicy
|
|
{ spIdleSeconds :: NominalDiffTime
|
|
, spAbsoluteSeconds :: NominalDiffTime
|
|
}
|
|
|
|
-- | 默认：空闲 8 小时、绝对 24 小时
|
|
defaultSessionPolicy :: SessionPolicy
|
|
defaultSessionPolicy = SessionPolicy (8 * 3600) (24 * 3600)
|
|
|
|
-- | 会话仓库：令牌表、时钟与策略
|
|
data SessionStore = SessionStore
|
|
{ storeMap :: MVar (Map.Map Text Session)
|
|
, storeClock :: IO UTCTime
|
|
, storePolicy :: IORef SessionPolicy
|
|
}
|
|
|
|
-- | 造一个空仓库
|
|
newSessionStore :: IO UTCTime -> SessionPolicy -> IO SessionStore
|
|
newSessionStore clock policy = do
|
|
ref <- newMVar Map.empty
|
|
policyRef <- newIORef policy
|
|
pure (SessionStore ref clock policyRef)
|
|
|
|
-- | 现在用的是哪套过期策略
|
|
sessionPolicy :: SessionStore -> IO SessionPolicy
|
|
sessionPolicy = readIORef . storePolicy
|
|
|
|
-- | 换一套过期策略（设置页热改）
|
|
setSessionPolicy :: SessionStore -> SessionPolicy -> IO ()
|
|
setSessionPolicy store = writeIORef (storePolicy store)
|
|
|
|
-- | 这条会话过期了吗
|
|
expired :: UTCTime -> SessionPolicy -> Session -> Bool
|
|
expired now pol s =
|
|
diffUTCTime now (sessSeen s) > spIdleSeconds pol
|
|
|| diffUTCTime now (sessCreated s) > spAbsoluteSeconds pol
|
|
|
|
-- | 清掉过期会话
|
|
prune :: UTCTime -> SessionPolicy -> Map.Map Text Session -> Map.Map Text Session
|
|
prune now pol = Map.filter (not . expired now pol)
|
|
|
|
-- | 随机令牌：32 字节，十六进制 64 个字符
|
|
sessionToken :: IO Text
|
|
sessionToken = hexEncode <$> getRandomBytes 32
|
|
|
|
-- | 开一条会话，返回令牌
|
|
createSession :: SessionStore -> Text -> IO Text
|
|
createSession store user = createVersionedSession store user Nothing
|
|
|
|
-- | 开一条会话并记下账号版本号，返回令牌
|
|
createVersionedSession :: SessionStore -> Text -> Maybe Integer -> IO Text
|
|
createVersionedSession store user revision = do
|
|
token <- sessionToken
|
|
now <- storeClock store
|
|
pol <- sessionPolicy store
|
|
modifyMVar_ (storeMap store) $ \m ->
|
|
pure (Map.insert token (Session user now now revision) (prune now pol m))
|
|
pure token
|
|
|
|
-- | 查令牌并刷新最后活动时间
|
|
lookupSession :: SessionStore -> Text -> IO (Maybe Text)
|
|
lookupSession store token = fmap (fmap fst) (lookupVersionedSession store token)
|
|
|
|
-- | 查令牌拿回账号名与账号版本号，并刷新最后活动时间
|
|
lookupVersionedSession :: SessionStore -> Text -> IO (Maybe (Text, Maybe Integer))
|
|
lookupVersionedSession store token = do
|
|
now <- storeClock store
|
|
pol <- sessionPolicy store
|
|
modifyMVar (storeMap store) $ \m -> do
|
|
let kept = prune now pol m
|
|
pure $ case Map.lookup token kept of
|
|
Nothing -> (kept, Nothing)
|
|
Just s -> (Map.insert token s{sessSeen = now} kept, Just (sessUser s, sessRevision s))
|
|
|
|
-- | 删掉一条会话（退出登录）
|
|
deleteSession :: SessionStore -> Text -> IO ()
|
|
deleteSession store token = modifyMVar_ (storeMap store) (pure . Map.delete token)
|
|
|
|
-- | 一条带载荷的会话：账号、时间与载荷
|
|
data StoredSession a = StoredSession
|
|
{ psUser :: Text
|
|
, psCreated :: UTCTime
|
|
, psSeen :: UTCTime
|
|
, psPayload :: a
|
|
}
|
|
|
|
-- | 带载荷的会话仓库：令牌表、时钟与策略
|
|
data PayloadStore a = PayloadStore
|
|
{ psStoreMap :: MVar (Map.Map Text (StoredSession a))
|
|
, psClock :: IO UTCTime
|
|
, psPolicy :: IORef SessionPolicy
|
|
}
|
|
|
|
-- | 造一个空的带载荷仓库
|
|
newPayloadStore :: IO UTCTime -> SessionPolicy -> IO (PayloadStore a)
|
|
newPayloadStore clock policy = do
|
|
ref <- newMVar Map.empty
|
|
policyRef <- newIORef policy
|
|
pure (PayloadStore ref clock policyRef)
|
|
|
|
-- | 现在用的是哪套过期策略
|
|
payloadPolicy :: PayloadStore a -> IO SessionPolicy
|
|
payloadPolicy = readIORef . psPolicy
|
|
|
|
-- | 换一套过期策略
|
|
setPayloadPolicy :: PayloadStore a -> SessionPolicy -> IO ()
|
|
setPayloadPolicy store = writeIORef (psPolicy store)
|
|
|
|
-- | 这条带载荷的会话过期了吗
|
|
payloadExpired :: UTCTime -> SessionPolicy -> StoredSession a -> Bool
|
|
payloadExpired now pol s =
|
|
diffUTCTime now (psSeen s) > spIdleSeconds pol
|
|
|| diffUTCTime now (psCreated s) > spAbsoluteSeconds pol
|
|
|
|
-- | 清掉过期的带载荷会话
|
|
prunePayloads :: UTCTime -> SessionPolicy -> Map.Map Text (StoredSession a) -> Map.Map Text (StoredSession a)
|
|
prunePayloads now pol = Map.filter (not . payloadExpired now pol)
|
|
|
|
-- | 上线一条带载荷的会话，返回令牌
|
|
createPayloadSession :: PayloadStore a -> Text -> a -> IO Text
|
|
createPayloadSession store user payload = do
|
|
token <- sessionToken
|
|
now <- psClock store
|
|
pol <- payloadPolicy store
|
|
modifyMVar_ (psStoreMap store) $ \m ->
|
|
pure (Map.insert token (StoredSession user now now payload) (prunePayloads now pol m))
|
|
pure token
|
|
|
|
-- | 查令牌并刷新最后活动时间，拿回账号名与载荷
|
|
lookupPayload :: PayloadStore a -> Text -> IO (Maybe (Text, a))
|
|
lookupPayload store token = do
|
|
now <- psClock store
|
|
pol <- payloadPolicy store
|
|
modifyMVar (psStoreMap store) $ \m -> do
|
|
let kept = prunePayloads now pol m
|
|
pure $ case Map.lookup token kept of
|
|
Nothing -> (kept, Nothing)
|
|
Just s -> (Map.insert token s{psSeen = now} kept, Just (psUser s, psPayload s))
|
|
|
|
-- | 换掉载荷；会话已没了就返回 False
|
|
putPayload :: PayloadStore a -> Text -> a -> IO Bool
|
|
putPayload store token payload = do
|
|
now <- psClock store
|
|
pol <- payloadPolicy store
|
|
modifyMVar (psStoreMap store) $ \m -> do
|
|
let kept = prunePayloads now pol m
|
|
pure $ case Map.lookup token kept of
|
|
Nothing -> (kept, False)
|
|
Just s -> (Map.insert token s{psSeen = now, psPayload = payload} kept, True)
|
|
|
|
-- | 摘掉会话并把载荷交还
|
|
dropPayload :: PayloadStore a -> Text -> IO (Maybe a)
|
|
dropPayload store token = do
|
|
now <- psClock store
|
|
pol <- payloadPolicy store
|
|
modifyMVar (psStoreMap store) $ \m -> do
|
|
let kept = prunePayloads now pol m
|
|
pure $ case Map.lookup token kept of
|
|
Nothing -> (kept, Nothing)
|
|
Just s -> (Map.delete token kept, Just (psPayload s))
|
|
|
|
-- | 清掉过期会话并把它们的载荷交还；调用者负责关掉这些载荷
|
|
sweepPayloads :: PayloadStore a -> IO [a]
|
|
sweepPayloads store = do
|
|
now <- psClock store
|
|
pol <- payloadPolicy store
|
|
modifyMVar (psStoreMap store) $ \m -> do
|
|
let (gone, kept) = Map.partition (payloadExpired now pol) m
|
|
pure (kept, map psPayload (Map.elems gone))
|