Add simple authentication helpers

yesod-core/Yesod/Core/Authentication.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Core.Authentication where
+
+import Data.ByteString ( ByteString )
+import Data.ByteString.Base64 ( decodeLenient )
+import Data.Char ( toLower, isSpace )
+import Data.Text ( Text )
+import Yesod.Core.Class.Handler
+import Yesod.Core.Handler
+
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
+-- | Extract basic authentication data from __Authorization__ header
+-- value
+extractBasicAuth :: ByteString -> Maybe (Text, Text)
+extractBasicAuth bs =
+    let (atype, val) = BC.break isSpace bs in
+    case (BC.map toLower atype, BC.drop 1 val) of
+        ("basic", payload) -> Just $ extractBasic payload
+        _                  -> Nothing
+  where
+    extractBasic :: ByteString -> (Text, Text)
+    extractBasic payload = fmap (T.drop 1)
+                         . T.breakOn ":"
+                         . T.decodeUtf8
+                         $ decodeLenient payload
+
+-- | Extract bearer authentication data from __Authorization__ header
+-- value
+extractBearerAuth :: ByteString -> Maybe Text
+extractBearerAuth bs = do
+    let (atype, token) = BC.break isSpace bs
+    if BC.map toLower atype == "bearer"
+        then Just $ T.decodeUtf8 $ BC.drop 1 token
+        else Nothing
+
+lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))
+lookupBasicAuth = fmap (>>= extractBasicAuth)
+                  (lookupHeader "Authorization")
+
+lookupBearerAuth :: (MonadHandler m) => m (Maybe Text)
+lookupBearerAuth = fmap (>>= extractBearerAuth)
+                   (lookupHeader "Authorization")

yesod-core/yesod-core.cabal

@@ -27,6 +27,7 @@ library
                    , wai                   >= 3.0
                    , wai-extra             >= 3.0
                    , bytestring            >= 0.9.1.4
+                   , base64-bytestring
                    , text                  >= 0.7
                    , template-haskell
                    , path-pieces           >= 0.1.2    && < 0.2
@@ -70,6 +71,7 @@ library
                    , auto-update
 
     exposed-modules: Yesod.Core
+                     Yesod.Core.Authentication
                      Yesod.Core.Content
                      Yesod.Core.Dispatch
                      Yesod.Core.Handler