Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Basic authentication stuff #117

Open
wants to merge 2 commits into from

3 participants

@carlssonia

To support user logging in snap-server (upcoming pull request).

@gregorycollins

Thanks for tackling this. First of all: I think this code should go into a new module Snap.Util.HttpAuthentication' rather than getting lumped intoSnap.Core`.

Secondly: I'm uncomfortable with providing basic authentication out of the box without any disclaimers/warning labels/restrictions on usage. Could you please change this API to:

withBasicAuthentication :: MonadSnap m => ((ByteString, ByteString) -> m a) -> m a

and check that rqIsSecure is True within the handler. I really don't think we want to make it easy for people to send cleartext passwords out over the internet in our public API. A suitable disclaimer in the comment (that we will only authenticate secure connections using this method).

If you really feel that cleartext basic authentication is something that needs to be in the API, then add the function as withUnsafeBasicAuthentication with a big disclaimer in the docstring. Personally I think we're better off just omitting it.

I think the thing we all would really like here (and I think hvr mentioned it also) is RFC 2617 digest authentication. Would you be interested in tackling that?

Restricting the API to secure connections is a good idea!

Would you be OK with skipping the continuation-passing style and simply have something like

getBasicAuthentication :: MonadSnap m => m (Maybe (ByteString, ByteString))

where the function would return Nothing in case of insecure connection, or missing/invalid header? That would be much easier to use, I think.

Regarding digest authentication: I'm afraid I don't have a need for that at the moment...

@gregorycollins

Hi,

Re: the continuation passing style -- I think it's cleaner to do it that way, personally. When implementing this stuff, you are always going to need a function like:

checkBasicAuthenticationCredentials :: MonadSnap m => (ByteString, ByteString) -> m ()

If you just make the type

getBasicAuthenticationCredentials :: MonadSnap m => m (ByteString, ByteString)

then you are still going to need to check what they gave you somehow anyways. One of the reasons I like "with" style here is that it's clear to the user what he's expected to provide to use the API.

Another thing I'd say is that if we do it your way, you don't want the return type to be a "Maybe" here, just use mzero if the authentication process fails.

@meiersi meiersi referenced this pull request from a commit in meiersi/snap-core
@meiersi meiersi Fix #117: compatible Eq and Ord instances for Method. 3cf5b9d
@meiersi

Hi @gregorycollins , I think this branch was accidentally closed because of my mistake in the in the issue number reference.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Jan 5, 2012
  1. @carlssonia
Commits on Jan 11, 2012
  1. @gregorycollins @carlssonia

    Fix debug code, which bitrotted somehow (?)

    gregorycollins authored carlssonia committed
This page is out of date. Refresh to see the latest.
View
1  snap-core.cabal
@@ -141,6 +141,7 @@ Library
attoparsec-enumerator >= 0.3 && <0.4,
base >= 4 && < 5,
base16-bytestring <= 0.2,
+ base64-bytestring <= 0.2,
blaze-builder >= 0.2.1.4 && <0.4,
blaze-builder-enumerator >= 0.2 && <0.3,
bytestring,
View
1  src/Snap/Core.hs
@@ -90,6 +90,7 @@ module Snap.Core
, rqContextPath
, rqURI
, rqQueryString
+ , rqBasicAuthentication
, rqParams
, rqParam
, getParam
View
51 src/Snap/Internal/Debug.hs
@@ -16,20 +16,21 @@
module Snap.Internal.Debug where
------------------------------------------------------------------------------
-import Control.Monad.Trans
+import Control.Monad.Trans
#ifndef NODEBUG
-import Control.Concurrent
-import Control.DeepSeq
-import Control.Exception
-import Data.Char
-import Data.List
-import Data.Maybe
-import Foreign.C.Error
-import System.Environment
-import System.IO
-import System.IO.Unsafe
-import Text.Printf
+import Control.Concurrent
+import Control.DeepSeq
+import Data.Either
+import Control.Exception
+import Data.Char
+import Data.List
+import Data.Maybe
+import Foreign.C.Error
+import System.Environment
+import System.IO
+import System.IO.Unsafe
+import Text.Printf
#endif
------------------------------------------------------------------------------
@@ -43,12 +44,13 @@ debug = let !x = unsafePerformIO $! do
!e <- try $ getEnv "DEBUG"
!f <- either (\(_::SomeException) -> return debugIgnore)
- (\y -> if y == "1" || y == "on"
- then return debugOn
- else if y == "testsuite"
- then return debugSeq
- else return debugIgnore)
- (fmap (map toLower) e)
+ (\y0 -> let y = map toLower y0
+ in if y == "1" || y == "on"
+ then return debugOn
+ else if y == "testsuite"
+ then return debugSeq
+ else return debugIgnore)
+ e
return $! f
in x
@@ -58,12 +60,13 @@ debugErrno = let !x = unsafePerformIO $ do
e <- try $ getEnv "DEBUG"
!f <- either (\(_::SomeException) -> return debugErrnoIgnore)
- (\y -> if y == "1" || y == "on"
- then return debugErrnoOn
- else if y == "testsuite"
- then return debugErrnoSeq
- else return debugErrnoIgnore)
- (fmap (map toLower) e)
+ (\y0 -> let y = map toLower y0
+ in if y == "1" || y == "on"
+ then return debugErrnoOn
+ else if y == "testsuite"
+ then return debugErrnoSeq
+ else return debugErrnoIgnore)
+ e
return $! f
in x
View
15 src/Snap/Internal/Http/Types.hs
@@ -21,6 +21,7 @@ module Snap.Internal.Http.Types where
import Blaze.ByteString.Builder
import Control.Monad (liftM)
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w,w2c)
import qualified Data.ByteString as S
@@ -444,6 +445,20 @@ instance HasHeaders Response where
------------------------------------------------------------------------------
+-- | Returns the authorization userid and password assuming Basic
+-- Authentication Scheme.
+rqBasicAuthentication :: Request -- ^ HTTP request
+ -> Maybe (ByteString, ByteString)
+rqBasicAuthentication rq = do
+ ("Basic ", d) <- B.splitAt 6 `fmap` getHeader "Authorization" rq
+ case B64.decode d of
+ Left _ -> Nothing
+ Right e -> case B.break (==':') e of
+ (u,pw) | B.take 1 pw == ":" -> return (u, B.drop 1 pw)
+ _ -> Nothing
+
+
+------------------------------------------------------------------------------
-- | Looks up the value(s) for the given named parameter. Parameters initially
-- come from the request's query string and any decoded POST body (if the
-- request's @Content-Type@ is @application\/x-www-form-urlencoded@).
Something went wrong with that request. Please try again.