Basic authentication stuff #117

Open
wants to merge 2 commits into
from
Jump to file or symbol
Failed to load files and symbols.
+44 −24
Split
View
@@ -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
@@ -90,6 +90,7 @@ module Snap.Core
, rqContextPath
, rqURI
, rqQueryString
+ , rqBasicAuthentication
, rqParams
, rqParam
, getParam
View
@@ -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
@@ -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
@@ -443,6 +444,20 @@ instance HasHeaders Response where
updateHeaders f r = r { rspHeaders = f (rspHeaders r) }
+------------------------------------------------------------------------------
+-- | 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