unified AuthToken type between webapp and tor

Assistant/Threads/WebApp.hs

@@ -39,6 +39,7 @@ import Assistant.WebApp.OtherRepos
 import Assistant.WebApp.Repair
 import Assistant.Types.ThreadedMonad
 import Utility.WebApp
+import Utility.AuthToken
 import Utility.Tmp
 import Utility.FileMode
 import Git
@@ -75,7 +76,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
 #endif
 	webapp <- WebApp
 		<$> pure assistantdata
-		<*> genAuthToken
+		<*> genAuthToken 512
 		<*> getreldir
 		<*> pure staticRoutes
 		<*> pure postfirstrun

Assistant/WebApp.hs

@@ -14,7 +14,7 @@ import Assistant.WebApp.Types
 import Assistant.Common
 import Utility.NotificationBroadcaster
 import Utility.Yesod
-import Utility.WebApp
+import Utility.AuthToken
 
 import Data.Text (Text)
 import Control.Concurrent

Assistant/WebApp/Notifications.hs

@@ -17,6 +17,7 @@ import Assistant.Types.Buddies
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 import Utility.WebApp
+import Utility.AuthToken
 
 import Data.Text (Text)
 import qualified Data.Text as T

Assistant/WebApp/Types.hs

@@ -20,6 +20,7 @@ import Assistant.Ssh
 import Assistant.Pairing
 import Assistant.Types.Buddies
 import Utility.NotificationBroadcaster
+import Utility.AuthToken
 import Utility.WebApp
 import Utility.Yesod
 import Types.Transfer

CmdLine/GitRemoteTorAnnex.hs

@@ -14,6 +14,7 @@ import Remote.Helper.P2P
 import Remote.Helper.P2P.IO
 import Remote.Helper.Tor
 import Utility.Tor
+import Utility.AuthToken
 import Annex.UUID
 
 run :: [String] -> IO ()
@@ -53,7 +54,7 @@ connectService address port service = do
 	state <- Annex.new =<< Git.CurrentRepo.get
 	Annex.eval state $ do
 		authtoken <- fromMaybe nullAuthToken
-			<$> getTorAuthToken address
+			<$> getTorAuthTokenFor address
 		myuuid <- getUUID
 		g <- Annex.gitRepo
 		h <- liftIO $ torHandle =<< connectHiddenService address port

Remote/Helper/P2P.hs

@@ -12,6 +12,7 @@ module Remote.Helper.P2P where
 import qualified Utility.SimpleProtocol as Proto
 import Types.Key
 import Types.UUID
+import Utility.AuthToken
 import Utility.Applicative
 import Utility.PartialPrelude
 
@@ -23,15 +24,6 @@ import System.Exit (ExitCode(..))
 import System.IO
 import qualified Data.ByteString.Lazy as L
 
-newtype AuthToken = AuthToken String
-	deriving (Show)
-
-mkAuthToken :: String -> Maybe AuthToken
-mkAuthToken = fmap AuthToken . headMaybe . lines
-
-nullAuthToken :: AuthToken
-nullAuthToken = AuthToken ""
-
 newtype Offset = Offset Integer
 	deriving (Show)
 
@@ -111,10 +103,6 @@ instance Proto.Serializable Len where
 	serialize (Len n) = show n
 	deserialize = Len <$$> readish
 
-instance Proto.Serializable AuthToken where
-	serialize (AuthToken s) = s
-	deserialize = Just . AuthToken
-
 instance Proto.Serializable Service where
 	serialize UploadPack = "git-upload-pack"
 	serialize ReceivePack = "git-receive-pack"

Remote/Helper/Tor.hs

@@ -8,19 +8,23 @@
 module Remote.Helper.Tor where
 
 import Annex.Common
-import Remote.Helper.P2P (mkAuthToken, AuthToken)
+import Utility.AuthToken
 import Creds
 import Utility.Tor
 import Utility.Env
 
 import Network.Socket
+import qualified Data.Text as T
 
-getTorAuthToken :: OnionAddress -> Annex (Maybe AuthToken)
+-- Read the first line of the creds file. Environment variable overrides.
-getTorAuthToken (OnionAddress onionaddress) =
+getTorAuthTokenFor :: OnionAddress -> Annex (Maybe AuthToken)
-	maybe Nothing mkAuthToken <$> getM id 
+getTorAuthTokenFor (OnionAddress onionaddress) =
+	maybe Nothing mk <$> getM id 
 		[ liftIO $ getEnv torAuthTokenEnv
 		, readCacheCreds onionaddress
 		]
+  where
+	mk = toAuthToken . T.pack . takeWhile (/= '\n')
 
 torAuthTokenEnv :: String
 torAuthTokenEnv = "GIT_ANNEX_TOR_AUTHTOKEN"

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

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 ()
 

git-annex.cabal

@@ -368,7 +368,8 @@ Executable git-annex
    unordered-containers,
    feed,
    regex-tdfa,
-   socks
+   socks,
+   securemem
   CC-Options: -Wall
   GHC-Options: -Wall -fno-warn-tabs
   Extensions: PackageImports
@@ -472,7 +473,6 @@ Executable git-annex
      clientsession,
      template-haskell,
      shakespeare (>= 2.0.0),
-     securemem,
      byteable
     CPP-Options: -DWITH_WEBAPP
 
@@ -989,6 +989,7 @@ Executable git-annex
     Upgrade.V4
     Upgrade.V5
     Utility.Applicative
+    Utility.AuthToken
     Utility.Base64
     Utility.Batch
     Utility.Bloom