cd544e548b
giveup changed to filter out control characters. (It is too low level to make it use StringContainingQuotedPath.) error still does not, but it should only be used for internal errors, where the message is not attacker-controlled. Changed a lot of existing error to giveup when it is not strictly an internal error. Of course, other exceptions can still be thrown, either by code in git-annex, or a library, that include some attacker-controlled value. This does not guard against those. Sponsored-by: Noam Kremen on Patreon
102 lines
3.1 KiB
Haskell
102 lines
3.1 KiB
Haskell
{- authentication tokens
|
|
-
|
|
- Copyright 2016 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
{-# LANGUAGE PackageImports #-}
|
|
|
|
module Utility.AuthToken (
|
|
AuthToken,
|
|
toAuthToken,
|
|
fromAuthToken,
|
|
nullAuthToken,
|
|
genAuthToken,
|
|
AllowedAuthTokens,
|
|
allowedAuthTokens,
|
|
isAllowedAuthToken,
|
|
) where
|
|
|
|
import qualified Utility.SimpleProtocol as Proto
|
|
import Utility.Hash
|
|
import Utility.Exception
|
|
|
|
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 secure 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 -> giveup $ "failed to generate auth token: " ++ show e
|
|
Right (s, _) -> fromMaybe (giveup "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
|