happstack-server 7.5.3 → 7.5.4

raw patch · 2 files changed

+41/−11 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• happstack-server.cabal +1/−1
• src/Happstack/Server/Auth.hs +40/−10

@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             7.5.3+Version:             7.5.4 Synopsis:            Web related tools and services. Description:         Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course <http://happstack.com/docs/crashcourse/index.html> License:             BSD3

@@ -25,26 +25,56 @@    -> M.Map String String -- ^ the username password map    -> m a -- ^ the part to guard    -> m a-basicAuth realmName authMap xs = basicAuthImpl `mplus` xs+basicAuth realmName authMap = basicAuthBy (validLoginPlaintext authMap) realmName+++-- | Generalized version of 'basicAuth'.+--+-- The function that checks the username password combination must be+-- supplied as first argument.+--+-- example:+--+-- > main = simpleHTTP nullConf $+-- >  msum [ basicAuth' (validLoginPlaintext (fromList [("happstack","rocks")])) "127.0.0.1" $ ok "You are in the secret club"+-- >       , ok "You are not in the secret club."+-- >       ]+--+basicAuthBy :: (Happstack m) =>+   (B.ByteString -> B.ByteString -> Bool) -- ^ function that returns true if the name password combination is valid+   -> String -- ^ the realm name+   -> m a -- ^ the part to guard+   -> m a+basicAuthBy validLogin realmName xs = basicAuthImpl `mplus` xs   where     basicAuthImpl = do         aHeader <- getHeaderM "authorization"         case aHeader of             Nothing -> err-            Just x -> -                do r <- parseHeader x -                   case r of-                     (name, ':':password) | validLogin name password -> mzero-                                          | otherwise -> err-                     _  -> err-    validLogin name password = M.lookup name authMap == Just password-    parseHeader h = +            Just x ->+                do (name, password) <- parseHeader x+                   if B.length password > 0+                      && B.head password == ':'+                      && validLogin name (B.tail password)+                     then mzero+                     else err+    parseHeader h =       case Base64.decode . B.drop 6 $ h of         (Left _)   -> err-        (Right bs) -> return (break (':'==) (B.unpack bs))+        (Right bs) -> return (B.break (':'==) bs)     headerName  = "WWW-Authenticate"     headerValue = "Basic realm=\"" ++ realmName ++ "\""     err :: (Happstack m) => m a     err = escape $ do             setHeaderM headerName headerValue             unauthorized $ toResponse "Not authorized"+++-- | Function that looks up the plain text password for username in a+-- Map and returns True if it matches with the given password.+validLoginPlaintext ::+  M.Map String String -- ^ the username password map+  -> B.ByteString -- ^ the username+  -> B.ByteString -- ^ the password+  -> Bool+validLoginPlaintext authMap name password = M.lookup (B.unpack name) authMap == Just (B.unpack password)