unified AuthToken type between webapp and tor

1 files changed, 99 insertions, 0 deletions

diff --git a/Utility/AuthToken.hs b/Utility/AuthToken.hs
new file mode 100644
index 000000000..191b4f5c9
--- /dev/null
+++ b/Utility/AuthToken.hs
@@ -0,0 +1,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