1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
{- 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
|
