diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Christopher Reichert + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Christopher Reichert nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yesod/Auth/Http/Basic.hs b/Yesod/Auth/Http/Basic.hs new file mode 100644 --- /dev/null +++ b/Yesod/Auth/Http/Basic.hs @@ -0,0 +1,164 @@ +-- | A Yesod middleware for <> +-- +-- This middleware performs a single authentication lookup +-- per request and uses the Yesod request-local caching +-- mechanisms to store valid auth credentials found in the +-- Authorization header. +-- +-- +-- The recommended way to use this module is to override the +-- @maybeAuthId@ to @defaultMaybeBasicAuthId@ and supply a +-- lookup function. +-- +-- @ +-- instance YesodAuth App where +-- type AuthId App = Text +-- getAuthId = return . Just . credsIdent +-- maybeAuthId = defaultMaybeBasicAuthId checkCreds +-- where +-- checkCreds = \k s -> return $ (k == "user") +-- && (s == "secret") +-- @ +-- +-- +-- WWW-Authenticate challenges are currently not implemented. +-- The current workaround is to override the error handler: +-- +-- @ +-- instance Yesod App where +-- errorHandler NotAuthenticated = selectRep $ +-- provideRep $ do +-- addHeader "WWW-Authenticate" $ T.concat +-- [ "RedirectJSON realm=\"Realm\", param=\"myurl.com\"" ] +-- -- send error response here +-- ... +-- errorHandler e = defaultErrorHandler e +-- ... +-- @ +-- +-- +-- Proper response status on failed authentication is not implemented. +-- The current workaround is to override the 'Yesod' typeclass +-- @isAuthorized@ function to handle required auth routes. e.g. +-- +-- @ +-- instance Yesod App where +-- isAuthorized SecureR _ = +-- maybeAuthId >>= return . maybe AuthenticationRequired (const Authorized) +-- isAuthorized _ _ = Authorized +-- @ +-- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Yesod.Auth.Http.Basic + ( + -- * Drop in replace for maybeAuthId. + defaultMaybeBasicAuthId + + -- The AuthSettings will not be exported until + -- features are implemented which actually uses + -- them + -- + -- , AuthSettings + -- , authRealm + -- , defaultAuthSettings + ) where + +import Control.Applicative +import Control.Monad.Catch (MonadThrow) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Base64 (decodeLenient) +import Data.Text (Text) +import qualified Data.Text.Encoding as T +import Data.Typeable +import Data.Word8 (isSpace, toLower, _colon) +import Network.Wai +import Yesod hiding (Header) + + +-- | Authentication Settings +data AuthSettings = AuthSettings + { + authRealm :: Text + } + +-- | ready-to-go 'AuthSettings' which can be used +defaultAuthSettings :: AuthSettings +defaultAuthSettings = AuthSettings { authRealm = "Realm" } + + +-- | Cachable basic authentication credentials +newtype CachedBasicAuthId a + = CachedBasicAuthId { unCached :: Maybe a } + deriving Typeable + + +-- | A function to verify user credentials +type CheckCreds = ByteString + -> ByteString + -> IO Bool + + +-- | Retrieve the 'AuthId' using Authorization header. +-- +-- If valid credentials are found and authorized the +-- auth id is cached. +-- +-- TODO use more general type than Text to represent +-- the auth id +defaultMaybeBasicAuthId + :: (MonadIO m, MonadThrow m, MonadBaseControl IO m) + => CheckCreds + -> AuthSettings + -> HandlerT site m (Maybe Text) +defaultMaybeBasicAuthId auth cfg = + cachedAuth $ waiRequest >>= maybeBasicAuthId auth cfg + + +-- | Cached Authentication credentials +cachedAuth + :: (MonadIO m, MonadThrow m, MonadBaseControl IO m) + => HandlerT site m (Maybe Text) + -> HandlerT site m (Maybe Text) +cachedAuth = fmap unCached . cached . fmap CachedBasicAuthId + + +-- | Use the HTTP Basic _Authorization_ header to retrieve +-- the AuthId of request +-- +-- This function uses yesod 'cachedAuth' to cache the result of +-- the first succesful header lookup. +-- +-- Subsequent calls to 'maybeAuthId' do not require the 'CheckCreds' +-- function to be run again. +maybeBasicAuthId + :: MonadIO m + => CheckCreds + -> AuthSettings + -> Request + -> m (Maybe Text) +maybeBasicAuthId checkCreds AuthSettings{..} req = + case authorization of + Just (strategy, userpass) + | BS.map toLower strategy == "basic" -> + authorizeCredentials $ BS.dropWhile isSpace userpass + | otherwise -> return Nothing + _ -> return Nothing + where + authorization = BS.break isSpace + <$> lookup "Authorization" (requestHeaders req) + authorizeCredentials encoded = + let (username, password') = BS.breakByte _colon $ decodeLenient encoded + in case BS.uncons password' of + Nothing -> return Nothing + Just (_,password) -> do + authorized <- liftIO $ checkCreds username password + return $ if authorized + then Just $ T.decodeUtf8 username + else Nothing diff --git a/test/HLint.hs b/test/HLint.hs new file mode 100644 --- /dev/null +++ b/test/HLint.hs @@ -0,0 +1,19 @@ + +module Main (main) where + +import Language.Haskell.HLint (hlint) +import System.Exit (exitFailure, exitSuccess) + + +main :: IO () +main = do + hints <- hlint arguments + print hints + if null hints + then exitSuccess + else exitFailure + where + arguments = [ + "Yesod" + , "test" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/YesodAuthHttpBasicSpec.hs b/test/YesodAuthHttpBasicSpec.hs new file mode 100644 --- /dev/null +++ b/test/YesodAuthHttpBasicSpec.hs @@ -0,0 +1,41 @@ + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module YesodAuthHttpBasicSpec where + +import Data.Monoid ((<>)) +import Test.Hspec +import Yesod hiding (get) +import Yesod.Test + + +-- TODO create real tests + +spec :: SpecWith () +spec = describe "Yesod HTTP Basic Authentication" $ + yesodSpec app $ + ydescribe "Yesod HTTP Basic Authentication" $ + ydescribe "tests1" $ do + yit "Has Basic Auth" $ do + -- addRequestHeader (hUserAgent, "Chrome/41.0.2228.0") + get $ LiteAppRoute [] + statusIs 200 + yit "Denies Failed Basic Auth" $ do + get $ LiteAppRoute [] + statusIs 200 + -- statusIs 403 + + +instance RenderMessage LiteApp FormMessage where + renderMessage _ _ = defaultFormMessage + + +app :: LiteApp +app = liteApp $ + dispatchTo $ do + mfoo <- lookupGetParam "foo" + case mfoo of + Nothing -> return "Hello world!" + Just foo -> return $ "foo=" <> foo diff --git a/yesod-auth-basic.cabal b/yesod-auth-basic.cabal new file mode 100644 --- /dev/null +++ b/yesod-auth-basic.cabal @@ -0,0 +1,61 @@ + +name: yesod-auth-basic +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +author: Christopher Reichert +maintainer: creichert07@gmail.com +copyright: (c) 2015, Christopher Reichert +category: Web +build-type: Simple +cabal-version: >=1.10 +synopsis: Yesod Middleware for HTTP Basic Authentication +description: + An efficient Yesod middleware middleware for HTTP Basic + Authentication. + . + Utilizes Yesod request-local caching mechanisms to store valid auth + credentials found in the Authorization header. + + +source-repository head + type: git + location: git://github.com/creichert/yesod-auth-basic.git + + +library + exposed-modules: Yesod.Auth.Http.Basic + ghc-options: -Wall + default-language: Haskell2010 + build-depends: base == 4.* + , base64-bytestring + , bytestring + , exceptions + , text + , yesod + , wai + , word8 + + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test/ + other-modules: YesodAuthHttpBasicSpec + ghc-options: -Wall -Werror -threaded + default-language: Haskell2010 + build-depends: base == 4.* + , yesod + , yesod-auth-basic + , yesod-test + , hspec >= 1.3 + , text + + +test-suite hlint + main-is: test/HLint.hs + ghc-options: -Wall -Werror -threaded + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base + , hlint == 1.8.*