Merge pull request #1471 from akhesaCaro/monorepo_servant_auth

repatriation of servant-auth in the main servant repo

cabal.project

@@ -1,5 +1,11 @@
 packages:
   servant/
+  servant-auth/servant-auth
+  servant-auth/servant-auth-client
+  servant-auth/servant-auth-docs
+  servant-auth/servant-auth-server
+  servant-auth/servant-auth-swagger
+
   servant-client/
   servant-client-core/
   servant-http-streams/

servant-auth/README.md

@@ -0,0 +1 @@
+servant-auth-server/README.lhs

servant-auth/servant-auth-client/.ghci

@@ -0,0 +1 @@
+:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-client/CHANGELOG.md

@@ -0,0 +1,26 @@
+# Changelog
+
+All notable changes to this project will be documented in this file.
+
+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
+
+## [Unreleased]
+
+## [0.4.1.0] - 2020-10-06
+
+- Support generic Bearer token auth 
+
+## [0.4.0.0] - 2019-03-08
+
+## Changed
+
+- #145 Support servant-0.16 in tests @domenkozar
+- #145 Drop GHC 7.10 support @domenkozar
+
+## [0.3.3.0] - 2018-06-18
+
+### Added
+- Support for GHC 8.4 by @phadej
+- Support for servant-0.14 by @phadej
+- Changelog by @domenkozar

servant-auth/servant-auth-client/LICENSE

@@ -0,0 +1,31 @@
+Copyright Julian K. Arni (c) 2015
+
+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 Julian K. Arni 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.
+

servant-auth/servant-auth-client/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

servant-auth/servant-auth-client/servant-auth-client.cabal

@@ -0,0 +1,82 @@
+name:           servant-auth-client
+version:        0.4.1.0
+synopsis:       servant-client/servant-auth compatibility
+description:    This package provides instances that allow generating clients from
+                <https://hackage.haskell.org/package/servant servant>
+                APIs that use
+                <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
+                .
+                For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
+category:       Web, Servant, Authentication
+homepage:       http://github.com/haskell-servant/servant/servant-auth#readme
+bug-reports:    https://github.com/haskell-servant/servant/issues
+author:         Julian K. Arni
+maintainer:     jkarni@gmail.com
+copyright:      (c) Julian K. Arni
+license:        BSD3
+license-file:   LICENSE
+tested-with:    GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
+build-type:     Simple
+cabal-version:  >= 1.10
+extra-source-files:
+    CHANGELOG.md
+
+source-repository head
+  type: git
+  location: https://github.com/haskell-servant/servant
+
+library
+  hs-source-dirs:
+      src
+  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
+  ghc-options: -Wall
+  build-depends:
+      base                >= 4.10     && < 4.16
+    , bytestring          >= 0.10.6.0 && < 0.11
+    , containers          >= 0.5.6.2  && < 0.7
+    , servant-auth        == 0.4.*
+    , servant             >= 0.13     && < 0.19
+    , servant-client-core >= 0.13     && < 0.19
+
+  exposed-modules:
+      Servant.Auth.Client
+      Servant.Auth.Client.Internal
+  default-language: Haskell2010
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs:
+      test
+  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
+  ghc-options: -Wall
+  build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
+
+  -- dependencies with bounds inherited from the library stanza
+  build-depends:
+      base
+    , servant-client
+    , servant-auth
+    , servant
+    , servant-auth-client
+  if impl(ghc >= 9)
+    buildable: False
+
+  -- test dependencies
+  build-depends:
+      hspec                >= 2.5.5    && < 2.9
+    , QuickCheck           >= 2.11.3   && < 2.15
+    , aeson                >= 1.3.1.1  && < 1.6
+    , bytestring           >= 0.10.6.0 && < 0.11
+    , http-client          >= 0.5.13.1 && < 0.8
+    , http-types           >= 0.12.2   && < 0.13
+    , servant-auth-server  >= 0.4.2.0  && < 0.5
+    , servant-server       >= 0.13     && < 0.19
+    , time                 >= 1.5.0.1  && < 1.13
+    , transformers         >= 0.4.2.0  && < 0.6
+    , wai                  >= 3.2.1.2  && < 3.3
+    , warp                 >= 3.2.25   && < 3.4
+    , jose                 >= 0.7.0.0  && < 0.9
+  other-modules:
+      Servant.Auth.ClientSpec
+  default-language: Haskell2010

servant-auth/servant-auth-client/src/Servant/Auth/Client.hs

@@ -0,0 +1,3 @@
+module Servant.Auth.Client (Token(..), Bearer) where
+
+import Servant.Auth.Client.Internal (Bearer, Token(..))

servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+#if __GLASGOW_HASKELL__ == 800
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+#endif
+module Servant.Auth.Client.Internal where
+
+import qualified Data.ByteString    as BS
+import           Data.Monoid
+import           Data.Proxy         (Proxy (..))
+import           Data.String        (IsString)
+import           GHC.Exts           (Constraint)
+import           GHC.Generics       (Generic)
+import           Servant.API        ((:>))
+import           Servant.Auth
+
+import           Servant.Client.Core
+import           Data.Sequence ((<|))
+
+-- | A simple bearer token.
+newtype Token = Token { getToken :: BS.ByteString }
+  deriving (Eq, Show, Read, Generic, IsString)
+
+type family HasBearer xs :: Constraint where
+  HasBearer (Bearer ': xs) = ()
+  HasBearer (JWT ': xs) = ()
+  HasBearer (x ': xs)   = HasBearer xs
+  HasBearer '[]         = BearerAuthNotEnabled
+
+class BearerAuthNotEnabled
+
+-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not
+-- trying to send a token to an API that doesn't accept them.
+instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where
+  type Client m (Auth auths a :> api) = Token -> Client m api
+
+  clientWithRoute m _ req (Token token)
+    = clientWithRoute m (Proxy :: Proxy api)
+    $ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req  }
+      where
+        headerVal = "Bearer " <> token
+
+#if MIN_VERSION_servant_client_core(0,14,0)
+  hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl
+#endif
+
+
+-- * Authentication combinators
+
+-- | A Bearer token in the Authorization header:
+--
+--    @Authorization: Bearer <token>@
+--
+-- This can be any token recognized by the server, for example,
+-- a JSON Web Token (JWT).
+--
+-- Note that, since the exact way the token is validated is not specified,
+-- this combinator can only be used in the client. The server would not know
+-- how to validate it, while the client does not care.
+-- If you want to implement Bearer authentication in your server, you have to
+-- choose a specific combinator, such as 'JWT'.
+data Bearer

servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs

@@ -0,0 +1,161 @@
+{-# LANGUAGE CPP            #-}
+{-# LANGUAGE DeriveAnyClass #-}
+module Servant.Auth.ClientSpec (spec) where
+
+import           Crypto.JOSE              (JWK,
+                                           KeyMaterialGenParam (OctGenParam),
+                                           genJWK)
+import           Data.Aeson               (FromJSON (..), ToJSON (..))
+import qualified Data.ByteString.Lazy     as BSL
+import           Data.Time                (UTCTime, defaultTimeLocale,
+                                           parseTimeOrError)
+import           GHC.Generics             (Generic)
+import           Network.HTTP.Client      (Manager, defaultManagerSettings,
+                                           newManager)
+import           Network.HTTP.Types       (status401)
+import           Network.Wai.Handler.Warp (testWithApplication)
+import           Servant
+import           Servant.Client           (BaseUrl (..), Scheme (Http),
+                                           ClientError (FailureResponse),
+#if MIN_VERSION_servant_client(0,16,0)
+                                           ResponseF(..),
+#elif MIN_VERSION_servant_client(0,13,0)
+                                           GenResponse(..),
+#elif MIN_VERSION_servant_client(0,12,0)
+                                           Response(..),
+#endif
+                                           client)
+import           System.IO.Unsafe         (unsafePerformIO)
+import           Test.Hspec
+import           Test.QuickCheck
+
+#if MIN_VERSION_servant_client(0,13,0)
+import Servant.Client (mkClientEnv, runClientM)
+#elif MIN_VERSION_servant_client(0,9,0)
+import Servant.Client (ClientEnv (..), runClientM)
+#else
+import Control.Monad.Trans.Except (runExceptT)
+#endif
+#if !MIN_VERSION_servant_server(0,16,0)
+#define ClientError ServantError
+#endif
+
+import Servant.Auth.Client
+import Servant.Auth.Server
+import Servant.Auth.Server.SetCookieOrphan ()
+
+spec :: Spec
+spec = describe "The JWT combinator" $ do
+  hasClientSpec
+
+
+------------------------------------------------------------------------------
+-- * HasClient {{{
+
+hasClientSpec :: Spec
+hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do
+
+  let mkTok :: User -> Maybe UTCTime -> IO Token
+      mkTok user mexp = do
+        Right tok <- makeJWT user jwtCfg mexp
+        return $ Token $ BSL.toStrict tok
+
+  it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do
+    tok <- mkTok user Nothing
+    v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
+    v `shouldBe` Right (length $ name user)
+
+  it "succeeds when the token is not expired" $ \port -> property $ \user -> do
+    tok <- mkTok user (Just future)
+    v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
+    v `shouldBe` Right (length $ name user)
+
+  it "fails when token is expired" $ \port -> property $ \user -> do
+    tok <- mkTok user (Just past)
+#if MIN_VERSION_servant_client(0,16,0)
+    Left (FailureResponse _ (Response stat _ _ _))
+#elif MIN_VERSION_servant_client(0,12,0)
+    Left (FailureResponse (Response stat _ _ _))
+#elif MIN_VERSION_servant_client(0,11,0)
+    Left (FailureResponse _ stat _ _)
+#else
+    Left (FailureResponse stat _ _)
+#endif
+      <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
+    stat `shouldBe` status401
+
+
+getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int)
+#if MIN_VERSION_servant(0,13,0)
+getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl)
+#elif MIN_VERSION_servant(0,9,0)
+getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl)
+#else
+getIntClient tok m burl = runExceptT $ client api tok m burl
+#endif
+-- }}}
+------------------------------------------------------------------------------
+-- * API and Server {{{
+
+type API = Auth '[JWT] User :> Get '[JSON] Int
+
+api :: Proxy API
+api = Proxy
+
+theKey :: JWK
+theKey = unsafePerformIO . genJWK $ OctGenParam 256
+{-# NOINLINE theKey #-}
+
+mgr :: Manager
+mgr = unsafePerformIO $ newManager defaultManagerSettings
+{-# NOINLINE mgr #-}
+
+app :: Application
+app = serveWithContext api ctx server
+  where
+    ctx = cookieCfg :. jwtCfg :. EmptyContext
+
+jwtCfg :: JWTSettings
+jwtCfg = defaultJWTSettings theKey
+
+cookieCfg :: CookieSettings
+cookieCfg = defaultCookieSettings
+
+
+server :: Server API
+server = getInt
+  where
+    getInt :: AuthResult User -> Handler Int
+    getInt (Authenticated u) = return . length $ name  u
+    getInt _ = throwAll err401
+
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Utils {{{
+
+past :: UTCTime
+past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
+
+future :: UTCTime
+future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
+
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Types {{{
+
+data User = User
+  { name :: String
+  , _id  :: String
+  } deriving (Eq, Show, Read, Generic)
+
+instance FromJWT User
+instance ToJWT User
+instance FromJSON User
+instance ToJSON User
+
+instance Arbitrary User where
+  arbitrary = User <$> arbitrary <*> arbitrary
+
+-- }}}

servant-auth/servant-auth-client/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-docs/.ghci

@@ -0,0 +1 @@
+:set -isrc -itest -idoctest/ghci-wrapper/src