100 lines
3 KiB
Haskell
100 lines
3 KiB
Haskell
|
{- authentication tokens
|
||
|
|
-
|
||
|
|
- Copyright 2016 Joey Hess <id@joeyh.name>
|
||
|
|
-
|
||
|
|
- License: BSD-2-clause
|
||
|
|
-}
|
||
|
|
|
||
|
|
module Utility.AuthToken (
|
||
|
|
AuthToken,
|
||
|
|
toAuthToken,
|
||
|
|
fromAuthToken,
|
||
|
|
nullAuthToken,
|
||
|
|
genAuthToken,
|
||
|
|
AllowedAuthTokens,
|
||
|
|
allowedAuthTokens,
|
||
|
|
isAllowedAuthToken,
|
||
|
|
) where
|
||
|
|
|
||
|
|
import qualified Utility.SimpleProtocol as Proto
|
||
|
|
import Utility.Hash
|
||
|
|
|
||
|
|
import Data.SecureMem
|
||
|
|
import Data.Maybe
|
||
|
|
import Data.Char
|
||
|
|
import Data.Byteable
|
||
|
|
import qualified Data.Text as T
|
||
|
|
import qualified Data.Text.Encoding as TE
|
||
|
|
import qualified Data.ByteString.Lazy as L
|
||
|
|
import "crypto-api" Crypto.Random
|
||
|
|
|
||
|
|
-- | An AuthToken is stored in secue memory, with constant time comparison.
|
||
|
|
--
|
||
|
|
-- It can have varying length, depending on the security needs of the
|
||
|
|
-- application.
|
||
|
|
--
|
||
|
|
-- To avoid decoding issues, and presentation issues, the content
|
||
|
|
-- of an AuthToken is limited to ASCII characters a-z, and 0-9.
|
||
|
|
-- This is enforced by all exported AuthToken constructors.
|
||
|
|
newtype AuthToken = AuthToken SecureMem
|
||
|
|
deriving (Show, Eq)
|
||
|
|
|
||
|
|
allowedChar :: Char -> Bool
|
||
|
|
allowedChar c = isAsciiUpper c || isAsciiLower c || isDigit c
|
||
|
|
|
||
|
|
instance Proto.Serializable AuthToken where
|
||
|
|
serialize = T.unpack . fromAuthToken
|
||
|
|
deserialize = toAuthToken . T.pack
|
||
|
|
|
||
|
|
fromAuthToken :: AuthToken -> T.Text
|
||
|
|
fromAuthToken (AuthToken t ) = TE.decodeLatin1 (toBytes t)
|
||
|
|
|
||
|
|
-- | Upper-case characters are lower-cased to make them fit in the allowed
|
||
|
|
-- character set. This allows AuthTokens to be compared effectively
|
||
|
|
-- case-insensitively.
|
||
|
|
--
|
||
|
|
-- Returns Nothing if any disallowed characters are present.
|
||
|
|
toAuthToken :: T.Text -> Maybe AuthToken
|
||
|
|
toAuthToken t
|
||
|
|
| all allowedChar s = Just $ AuthToken $
|
||
|
|
secureMemFromByteString $ TE.encodeUtf8 $ T.pack s
|
||
|
|
| otherwise = Nothing
|
||
|
|
where
|
||
|
|
s = map toLower $ T.unpack t
|
||
|
|
|
||
|
|
-- | The empty AuthToken, for those times when you don't want any security.
|
||
|
|
nullAuthToken :: AuthToken
|
||
|
|
nullAuthToken = AuthToken $ secureMemFromByteString $ TE.encodeUtf8 T.empty
|
||
|
|
|
||
|
|
-- | Generates an AuthToken of a specified length. This is done by
|
||
|
|
-- generating a random bytestring, hashing it with sha2 512, and truncating
|
||
|
|
-- to the specified length.
|
||
|
|
--
|
||
|
|
-- That limits the maximum length to 128, but with 512 bytes of entropy,
|
||
|
|
-- that should be sufficient for any application.
|
||
|
|
genAuthToken :: Int -> IO AuthToken
|
||
|
|
genAuthToken len = do
|
||
|
|
g <- newGenIO :: IO SystemRandom
|
||
|
|
return $
|
||
|
|
case genBytes 512 g of
|
||
|
|
Left e -> error $ "failed to generate auth token: " ++ show e
|
||
|
|
Right (s, _) -> fromMaybe (error "auth token encoding failed") $
|
||
|
|
toAuthToken $ T.pack $ take len $
|
||
|
|
show $ sha2_512 $ L.fromChunks [s]
|
||
|
|
|
||
|
|
-- | For when several AuthTokens are allowed to be used.
|
||
|
|
newtype AllowedAuthTokens = AllowedAuthTokens [AuthToken]
|
||
|
|
|
||
|
|
allowedAuthTokens :: [AuthToken] -> AllowedAuthTokens
|
||
|
|
allowedAuthTokens = AllowedAuthTokens
|
||
|
|
|
||
|
|
-- | Note that every item in the list is checked, even if the first one
|
||
|
|
-- is allowed, so that comparison is constant-time.
|
||
|
|
isAllowedAuthToken :: AuthToken -> AllowedAuthTokens -> Bool
|
||
|
|
isAllowedAuthToken t (AllowedAuthTokens l) = go False l
|
||
|
|
where
|
||
|
|
go ok [] = ok
|
||
|
|
go ok (i:is)
|
||
|
|
| t == i = go True is
|
||
|
|
| otherwise = go ok is
|