diff --git a/snap-core.cabal b/snap-core.cabal index 85d5746d..4693bfca 100644 --- a/snap-core.cabal +++ b/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, diff --git a/src/Snap/Core.hs b/src/Snap/Core.hs index 4cf225dd..30aee41b 100644 --- a/src/Snap/Core.hs +++ b/src/Snap/Core.hs @@ -90,6 +90,7 @@ module Snap.Core , rqContextPath , rqURI , rqQueryString + , rqBasicAuthentication , rqParams , rqParam , getParam diff --git a/src/Snap/Internal/Debug.hs b/src/Snap/Internal/Debug.hs index 2f1edb3d..c61a0c3b 100644 --- a/src/Snap/Internal/Debug.hs +++ b/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 diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs index 5a888450..b3ab99eb 100644 --- a/src/Snap/Internal/Http/Types.hs +++ b/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 @@ -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