summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
Diffstat (limited to 'Utility')
-rw-r--r--Utility/AuthToken.hs99
-rw-r--r--Utility/WebApp.hs25
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 ()