@@ -8,21 +8,14 @@ module Distribution.Server.Features.LegacyPasswds.Auth (
8
8
import Distribution.Server.Framework.AuthTypes
9
9
import Distribution.Server.Framework.Error
10
10
import Distribution.Server.Framework.MemSize
11
- import Distribution.Server.Users.Types (UserId , UserName ( .. ), UserInfo )
11
+ import Distribution.Server.Users.Types (UserId , UserInfo )
12
12
import qualified Distribution.Server.Users.Users as Users
13
- import Distribution.Server.Framework.AuthCrypt (BasicAuthInfo (.. ))
14
13
15
14
import Happstack.Server
16
15
17
- import qualified Data.ByteString.Base64 as Base64
18
- import Control.Monad
19
16
import Data.SafeCopy (base , deriveSafeCopy )
20
17
import Data.Typeable (Typeable )
21
18
22
- import Foreign.C.String
23
- import System.IO.Unsafe (unsafePerformIO )
24
- import Control.Concurrent.MVar (MVar , newMVar , withMVar )
25
-
26
19
import qualified Data.ByteString.Char8 as BS -- TODO: Verify that we don't need to worry about UTF8 here
27
20
28
21
---------------------------
@@ -42,24 +35,6 @@ newtype HtPasswdHash = HtPasswdHash String
42
35
43
36
$ (deriveSafeCopy 0 'base ''HtPasswdHash)
44
37
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
-
63
38
--------------------
64
39
-- HTTP Basic auth
65
40
--
@@ -83,32 +58,12 @@ guardAuthenticated realm users getHtPasswdHash = do
83
58
| otherwise
84
59
= Nothing
85
60
61
+ -- basic auth is deprecated:
62
+ -- https://github.com/haskell/hackage-server/issues/1153#issuecomment-1370308832
86
63
checkBasicAuth :: Users. Users -> (UserId -> Maybe HtPasswdHash ) -> RealmName -> BS. ByteString
87
64
-> 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
112
67
113
68
setBasicAuthChallenge :: RealmName -> ServerPartE ()
114
69
setBasicAuthChallenge (RealmName realmName) = do
0 commit comments