@@ -8,21 +8,14 @@ module Distribution.Server.Features.LegacyPasswds.Auth (
88import Distribution.Server.Framework.AuthTypes
99import Distribution.Server.Framework.Error
1010import Distribution.Server.Framework.MemSize
11- import Distribution.Server.Users.Types (UserId , UserName ( .. ), UserInfo )
11+ import Distribution.Server.Users.Types (UserId , UserInfo )
1212import qualified Distribution.Server.Users.Users as Users
13- import Distribution.Server.Framework.AuthCrypt (BasicAuthInfo (.. ))
1413
1514import Happstack.Server
1615
17- import qualified Data.ByteString.Base64 as Base64
18- import Control.Monad
1916import Data.SafeCopy (base , deriveSafeCopy )
2017import Data.Typeable (Typeable )
2118
22- import Foreign.C.String
23- import System.IO.Unsafe (unsafePerformIO )
24- import Control.Concurrent.MVar (MVar , newMVar , withMVar )
25-
2619import qualified Data.ByteString.Char8 as BS -- TODO: Verify that we don't need to worry about UTF8 here
2720
2821---------------------------
@@ -42,24 +35,6 @@ newtype HtPasswdHash = HtPasswdHash String
4235
4336$ (deriveSafeCopy 0 'base ''HtPasswdHash)
4437
45- checkCryptAuthInfo :: HtPasswdHash -> BasicAuthInfo -> Bool
46- checkCryptAuthInfo (HtPasswdHash hash) (BasicAuthInfo _ _ (PasswdPlain passwd))
47- = crypt passwd hash == hash
48-
49- foreign import ccall unsafe " crypt" cCrypt :: CString -> CString -> CString
50-
51- crypt :: String -- ^ Payload
52- -> String -- ^ Salt
53- -> String -- ^ Hash
54- crypt key seed = unsafePerformIO $ withMVar cryptMVar $ \ _ -> do
55- k <- newCAString key
56- s <- newCAString seed
57- peekCAString $ cCrypt k s
58-
59- cryptMVar :: MVar ()
60- cryptMVar = unsafePerformIO $ newMVar ()
61- {-# NOINLINE cryptMVar #-}
62-
6338--------------------
6439-- HTTP Basic auth
6540--
@@ -83,32 +58,12 @@ guardAuthenticated realm users getHtPasswdHash = do
8358 | otherwise
8459 = Nothing
8560
61+ -- basic auth is deprecated:
62+ -- https://github.com/haskell/hackage-server/issues/1153#issuecomment-1370308832
8663checkBasicAuth :: Users. Users -> (UserId -> Maybe HtPasswdHash ) -> RealmName -> BS. ByteString
8764 -> Either AuthError (UserId , UserInfo , PasswdPlain )
88- checkBasicAuth users getHtPasswdHash realm ahdr = do
89- authInfo <- getBasicAuthInfo realm ahdr ?! UnrecognizedAuthError
90- let uname = basicUsername authInfo
91- (uid, uinfo) <- Users. lookupUserName uname users ?! NoSuchUserError
92- passwdhash <- getHtPasswdHash uid ?! NoSuchUserError
93- guard (checkCryptAuthInfo passwdhash authInfo) ?! PasswordMismatchError
94- return (uid, uinfo, basicPasswd authInfo)
95-
96- getBasicAuthInfo :: RealmName -> BS. ByteString -> Maybe BasicAuthInfo
97- getBasicAuthInfo realm authHeader
98- | Just (username, pass) <- splitHeader authHeader
99- = Just BasicAuthInfo {
100- basicRealm = realm,
101- basicUsername = UserName username,
102- basicPasswd = PasswdPlain pass
103- }
104- | otherwise = Nothing
105- where
106- splitHeader h = case Base64. decode h of
107- Left _ -> Nothing
108- Right xs ->
109- case break (' :' == ) $ BS. unpack xs of
110- (username, ' :' : pass) -> Just (username, pass)
111- _ -> Nothing
65+ checkBasicAuth _ _ _ _ =
66+ Left UnrecognizedAuthError
11267
11368setBasicAuthChallenge :: RealmName -> ServerPartE ()
11469setBasicAuthChallenge (RealmName realmName) = do
0 commit comments