Basic authentication stuff

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,

src/Snap/Core.hs

@@ -90,6 +90,7 @@ module Snap.Core
   , rqContextPath
   , rqURI
   , rqQueryString
+  , rqBasicAuthentication
   , rqParams
   , rqParam
   , getParam

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
 

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