unified AuthToken type between webapp and tor

2 files changed, 101 insertions, 23 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
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
index 63ca33520..a90772b10 100644
--- a/Utility/WebApp.hs
+++ b/Utility/WebApp.hs
@@ -12,7 +12,7 @@ module Utility.WebApp where
 import Common
 import Utility.Tmp
 import Utility.FileMode
-import Utility.Hash
+import Utility.AuthToken
 
 import qualified Yesod
 import qualified Network.Wai as Wai
@@ -23,7 +23,6 @@ import qualified Data.CaseInsensitive as CI
 import Network.Socket
 import "crypto-api" Crypto.Random
 import qualified Web.ClientSession as CS
-import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString as B
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
@@ -31,8 +30,6 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText)
 import Blaze.ByteString.Builder (Builder)
 import Control.Arrow ((***))
 import Control.Concurrent
-import Data.SecureMem
-import Data.Byteable
 #ifdef __ANDROID__
 import Data.Endian
 #endif
@@ -159,24 +156,6 @@ webAppSessionBackend _ = do
 		Just . Yesod.clientSessionBackend key . fst
 			<$> Yesod.clientSessionDateCacher timeout
 
-type AuthToken = SecureMem
-
-toAuthToken :: T.Text -> AuthToken
-toAuthToken = secureMemFromByteString . TE.encodeUtf8
-
-fromAuthToken :: AuthToken -> T.Text
-fromAuthToken = TE.decodeLatin1 . toBytes
-
-{- Generates a random sha2_512 string, encapsulated in a SecureMem,
- - suitable to be used for an authentication secret. -}
-genAuthToken :: IO AuthToken
-genAuthToken = do
-	g <- newGenIO :: IO SystemRandom
-	return $
-		case genBytes 512 g of
-			Left e -> error $ "failed to generate auth token: " ++ show e
-			Right (s, _) -> toAuthToken $ T.pack $ show $ sha2_512 $ L.fromChunks [s]
-
 {- A Yesod isAuthorized method, which checks the auth cgi parameter
  - against a token extracted from the Yesod application.
  -
@@ -193,7 +172,7 @@ checkAuthToken extractAuthToken r predicate
 		webapp <- Yesod.getYesod
 		req <- Yesod.getRequest
 		let params = Yesod.reqGetParams req
-		if (toAuthToken <$> lookup "auth" params) == Just (extractAuthToken webapp)
+		if (toAuthToken =<< lookup "auth" params) == Just (extractAuthToken webapp)
 			then return Yesod.Authorized
 			else Yesod.sendResponseStatus unauthorized401 ()