From 119e54a800d0943b4752cfbc2c3569d09920750d Mon Sep 17 00:00:00 2001 From: akhesacaro Date: Tue, 26 Oct 2021 16:08:30 +0200 Subject: [PATCH] repatriation of servant-auth in the main servant repo --- cabal.project | 6 + servant-auth/README.md | 1 + servant-auth/RELEASE.md | 7 + servant-auth/servant-auth-client/.ghci | 1 + servant-auth/servant-auth-client/CHANGELOG.md | 26 + servant-auth/servant-auth-client/LICENSE | 31 + servant-auth/servant-auth-client/Setup.hs | 2 + .../servant-auth-client.cabal | 80 +++ .../src/Servant/Auth/Client.hs | 3 + .../src/Servant/Auth/Client/Internal.hs | 64 ++ .../test/Servant/Auth/ClientSpec.hs | 161 +++++ servant-auth/servant-auth-client/test/Spec.hs | 1 + servant-auth/servant-auth-docs/.ghci | 1 + servant-auth/servant-auth-docs/CHANGELOG.md | 14 + servant-auth/servant-auth-docs/LICENSE | 31 + servant-auth/servant-auth-docs/Setup.hs | 33 + .../servant-auth-docs/servant-auth-docs.cabal | 84 +++ .../src/Servant/Auth/Docs.hs | 96 +++ servant-auth/servant-auth-docs/test/Spec.hs | 1 + .../servant-auth-docs/test/doctests.hs | 12 + servant-auth/servant-auth-server/.ghci | 1 + servant-auth/servant-auth-server/CHANGELOG.md | 130 ++++ servant-auth/servant-auth-server/LICENSE | 31 + servant-auth/servant-auth-server/README.lhs | 293 +++++++++ servant-auth/servant-auth-server/README.md | 1 + servant-auth/servant-auth-server/Setup.hs | 2 + .../servant-auth-server.cabal | 129 ++++ .../src/Servant/Auth/Server.hs | 180 ++++++ .../src/Servant/Auth/Server/Internal.hs | 70 ++ .../Auth/Server/Internal/AddSetCookie.hs | 94 +++ .../Servant/Auth/Server/Internal/BasicAuth.hs | 59 ++ .../src/Servant/Auth/Server/Internal/Class.hs | 72 +++ .../Auth/Server/Internal/ConfigTypes.hs | 127 ++++ .../Servant/Auth/Server/Internal/Cookie.hs | 182 ++++++ .../Servant/Auth/Server/Internal/FormLogin.hs | 3 + .../src/Servant/Auth/Server/Internal/JWT.hs | 71 +++ .../Servant/Auth/Server/Internal/ThrowAll.hs | 49 ++ .../src/Servant/Auth/Server/Internal/Types.hs | 112 ++++ .../Servant/Auth/Server/SetCookieOrphan.hs | 3 + .../test/Servant/Auth/ServerSpec.hs | 600 ++++++++++++++++++ servant-auth/servant-auth-server/test/Spec.hs | 1 + servant-auth/servant-auth-swagger/.ghci | 1 + .../servant-auth-swagger/CHANGELOG.md | 24 + servant-auth/servant-auth-swagger/LICENSE | 31 + servant-auth/servant-auth-swagger/Setup.hs | 2 + .../servant-auth-swagger.cabal | 70 ++ .../src/Servant/Auth/Swagger.hs | 87 +++ .../test/Servant/Auth/SwaggerSpec.hs | 38 ++ .../servant-auth-swagger/test/Spec.hs | 1 + servant-auth/servant-auth.project | 6 + servant-auth/servant-auth/.ghci | 1 + servant-auth/servant-auth/CHANGELOG.md | 20 + servant-auth/servant-auth/LICENSE | 31 + servant-auth/servant-auth/Setup.hs | 2 + servant-auth/servant-auth/servant-auth.cabal | 46 ++ servant-auth/servant-auth/src/Servant/Auth.hs | 54 ++ .../servant-auth/src/Servant/Auth/JWT.hs | 33 + servant-auth/servant-auth/test/Spec.hs | 1 + servant-auth/stack-lts16.yaml | 7 + servant-auth/stack-lts17.yaml | 7 + servant-auth/stack.yaml | 7 + 61 files changed, 3334 insertions(+) create mode 120000 servant-auth/README.md create mode 100644 servant-auth/RELEASE.md create mode 100644 servant-auth/servant-auth-client/.ghci create mode 100644 servant-auth/servant-auth-client/CHANGELOG.md create mode 100644 servant-auth/servant-auth-client/LICENSE create mode 100644 servant-auth/servant-auth-client/Setup.hs create mode 100644 servant-auth/servant-auth-client/servant-auth-client.cabal create mode 100644 servant-auth/servant-auth-client/src/Servant/Auth/Client.hs create mode 100644 servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs create mode 100644 servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs create mode 100644 servant-auth/servant-auth-client/test/Spec.hs create mode 100644 servant-auth/servant-auth-docs/.ghci create mode 100644 servant-auth/servant-auth-docs/CHANGELOG.md create mode 100644 servant-auth/servant-auth-docs/LICENSE create mode 100644 servant-auth/servant-auth-docs/Setup.hs create mode 100644 servant-auth/servant-auth-docs/servant-auth-docs.cabal create mode 100644 servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs create mode 100644 servant-auth/servant-auth-docs/test/Spec.hs create mode 100644 servant-auth/servant-auth-docs/test/doctests.hs create mode 100644 servant-auth/servant-auth-server/.ghci create mode 100644 servant-auth/servant-auth-server/CHANGELOG.md create mode 100644 servant-auth/servant-auth-server/LICENSE create mode 100644 servant-auth/servant-auth-server/README.lhs create mode 120000 servant-auth/servant-auth-server/README.md create mode 100644 servant-auth/servant-auth-server/Setup.hs create mode 100644 servant-auth/servant-auth-server/servant-auth-server.cabal create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs create mode 100644 servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs create mode 100644 servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs create mode 100644 servant-auth/servant-auth-server/test/Spec.hs create mode 100644 servant-auth/servant-auth-swagger/.ghci create mode 100644 servant-auth/servant-auth-swagger/CHANGELOG.md create mode 100644 servant-auth/servant-auth-swagger/LICENSE create mode 100644 servant-auth/servant-auth-swagger/Setup.hs create mode 100644 servant-auth/servant-auth-swagger/servant-auth-swagger.cabal create mode 100644 servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs create mode 100644 servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs create mode 100644 servant-auth/servant-auth-swagger/test/Spec.hs create mode 100644 servant-auth/servant-auth.project create mode 100644 servant-auth/servant-auth/.ghci create mode 100644 servant-auth/servant-auth/CHANGELOG.md create mode 100644 servant-auth/servant-auth/LICENSE create mode 100644 servant-auth/servant-auth/Setup.hs create mode 100644 servant-auth/servant-auth/servant-auth.cabal create mode 100644 servant-auth/servant-auth/src/Servant/Auth.hs create mode 100644 servant-auth/servant-auth/src/Servant/Auth/JWT.hs create mode 100644 servant-auth/servant-auth/test/Spec.hs create mode 100644 servant-auth/stack-lts16.yaml create mode 100644 servant-auth/stack-lts17.yaml create mode 100644 servant-auth/stack.yaml diff --git a/cabal.project b/cabal.project index 3e57f34d..e25a87bb 100644 --- a/cabal.project +++ b/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/ diff --git a/servant-auth/README.md b/servant-auth/README.md new file mode 120000 index 00000000..2cc807b6 --- /dev/null +++ b/servant-auth/README.md @@ -0,0 +1 @@ +servant-auth-server/README.lhs \ No newline at end of file diff --git a/servant-auth/RELEASE.md b/servant-auth/RELEASE.md new file mode 100644 index 00000000..303e4cf3 --- /dev/null +++ b/servant-auth/RELEASE.md @@ -0,0 +1,7 @@ +- update changelog +- bump version in cabal file +- stack sdist servant-auth-server +- git commit -m "v0.4.0.0" +- git tag -s servant-auth-server-0.4.0.0 +- git push --tags +- stack upload servant-auth-server diff --git a/servant-auth/servant-auth-client/.ghci b/servant-auth/servant-auth-client/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth-client/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth-client/CHANGELOG.md b/servant-auth/servant-auth-client/CHANGELOG.md new file mode 100644 index 00000000..2ce9f585 --- /dev/null +++ b/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 diff --git a/servant-auth/servant-auth-client/LICENSE b/servant-auth/servant-auth-client/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/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. + diff --git a/servant-auth/servant-auth-client/Setup.hs b/servant-auth/servant-auth-client/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-auth/servant-auth-client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth/servant-auth-client/servant-auth-client.cabal b/servant-auth/servant-auth-client/servant-auth-client.cabal new file mode 100644 index 00000000..b385eeb8 --- /dev/null +++ b/servant-auth/servant-auth-client/servant-auth-client.cabal @@ -0,0 +1,80 @@ +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 + + APIs that use + @Auth@ combinator. + . + For a quick overview of the usage, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant-auth/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-auth + +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 + + -- 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 diff --git a/servant-auth/servant-auth-client/src/Servant/Auth/Client.hs b/servant-auth/servant-auth-client/src/Servant/Auth/Client.hs new file mode 100644 index 00000000..71e1ad89 --- /dev/null +++ b/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(..)) diff --git a/servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs b/servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs new file mode 100644 index 00000000..4cdc9dd9 --- /dev/null +++ b/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 @ +-- +-- 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 diff --git a/servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs b/servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs new file mode 100644 index 00000000..fdd22ab2 --- /dev/null +++ b/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 + +-- }}} diff --git a/servant-auth/servant-auth-client/test/Spec.hs b/servant-auth/servant-auth-client/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth-client/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/servant-auth-docs/.ghci b/servant-auth/servant-auth-docs/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth-docs/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth-docs/CHANGELOG.md b/servant-auth/servant-auth-docs/CHANGELOG.md new file mode 100644 index 00000000..0a255fb1 --- /dev/null +++ b/servant-auth/servant-auth-docs/CHANGELOG.md @@ -0,0 +1,14 @@ +# 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.2.10.0] - 2018-06-18 + +### Added +- Support for GHC 8.4 by @phadej +- Changelog by @domenkozar diff --git a/servant-auth/servant-auth-docs/LICENSE b/servant-auth/servant-auth-docs/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth-docs/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. + diff --git a/servant-auth/servant-auth-docs/Setup.hs b/servant-auth/servant-auth-docs/Setup.hs new file mode 100644 index 00000000..8ec54a08 --- /dev/null +++ b/servant-auth/servant-auth-docs/Setup.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +import Distribution.Simple + +main :: IO () +main = defaultMain + +#endif diff --git a/servant-auth/servant-auth-docs/servant-auth-docs.cabal b/servant-auth/servant-auth-docs/servant-auth-docs.cabal new file mode 100644 index 00000000..f00cc575 --- /dev/null +++ b/servant-auth/servant-auth-docs/servant-auth-docs.cabal @@ -0,0 +1,84 @@ +name: servant-auth-docs +version: 0.2.10.0 +synopsis: servant-docs/servant-auth compatibility +description: This package provides instances that allow generating docs from + + APIs that use + @Auth@ combinator. + . + For a quick overview of the usage, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant-auth/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: Custom +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + +custom-setup + setup-depends: + base, Cabal, cabal-doctest >=1.0.6 && <1.1 + +source-repository head + type: git + location: https://github.com/haskell-servant/servant-auth + +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 + , servant-docs >= 0.11.2 && < 0.12 + , servant >= 0.13 && < 0.19 + , servant-auth == 0.4.* + , lens >= 4.16.1 && <5.1 + exposed-modules: + Servant.Auth.Docs + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + build-depends: + base, + servant-auth-docs, + doctest >= 0.16 && < 0.19, + QuickCheck >= 2.11.3 && < 2.15, + template-haskell + ghc-options: -Wall -threaded + hs-source-dirs: test + 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 + , text + , servant-docs + , servant + , servant-auth + , lens + + -- test dependencies + build-depends: + servant-auth-docs + , hspec >= 2.5.5 && < 2.9 + , QuickCheck >= 2.11.3 && < 2.15 + + default-language: Haskell2010 diff --git a/servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs b/servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs new file mode 100644 index 00000000..da507990 --- /dev/null +++ b/servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs @@ -0,0 +1,96 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Auth.Docs + ( + -- | The purpose of this package is provide the instance for 'servant-auth' + -- combinators needed for 'servant-docs' documentation generation. + -- + -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int + -- >>> putStr $ markdown $ docs (Proxy :: Proxy API) + -- ## GET / + -- ... + -- ... Authentication + -- ... + -- This part of the API is protected by the following authentication mechanisms: + -- ... + -- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token)) + -- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie) + -- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication) + -- ... + -- Clients must supply the following data + -- ... + -- One of the following: + -- ... + -- * A JWT Token signed with this server's key + -- * Cookies automatically set by browsers, plus a header + -- * Cookies automatically set by browsers, plus a header + -- ... + + -- * Re-export + JWT + , BasicAuth + , Cookie + , Auth + ) where + +import Control.Lens ((%~), (&), (|>)) +import Data.List (intercalate) +import Data.Monoid +import Data.Proxy (Proxy (Proxy)) +import Servant.API hiding (BasicAuth) +import Servant.Auth +import Servant.Docs hiding (pretty) +import Servant.Docs.Internal (DocAuthentication (..), authInfo) + +instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where + docsFor _ (endpoint, action) = + docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info)) + where + (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths) + info = DocAuthentication intro reqData + + +pretty :: [(String, String)] -> (String, String) +pretty [] = error "shouldn't happen" +pretty [(i, d)] = + ( "This part of the API is protected by " <> i + , d + ) +pretty rs = + ( "This part of the API is protected by the following authentication mechanisms:\n\n" + ++ " * " <> intercalate "\n * " (fst <$> rs) + , "\nOne of the following:\n\n" + ++ " * " <> intercalate "\n * " (snd <$> rs) + ) + + +class AllDocs (x :: [*]) where + allDocs :: proxy x + -- intro, req + -> [(String, String)] + +instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where + allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as) + +instance AllDocs '[] where + allDocs _ = [] + +class OneDoc a where + oneDoc :: proxy a -> (String, String) + +instance OneDoc JWT where + oneDoc _ = + ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))" + , "A JWT Token signed with this server's key") + +instance OneDoc Cookie where + oneDoc _ = + ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)" + , "Cookies automatically set by browsers, plus a header") + +instance OneDoc BasicAuth where + oneDoc _ = + ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)" + , "Cookies automatically set by browsers, plus a header") + +-- $setup +-- >>> instance ToSample Int where toSamples _ = singleSample 1729 diff --git a/servant-auth/servant-auth-docs/test/Spec.hs b/servant-auth/servant-auth-docs/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth-docs/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/servant-auth-docs/test/doctests.hs b/servant-auth/servant-auth-docs/test/doctests.hs new file mode 100644 index 00000000..aff961f5 --- /dev/null +++ b/servant-auth/servant-auth-docs/test/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources diff --git a/servant-auth/servant-auth-server/.ghci b/servant-auth/servant-auth-server/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth-server/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth-server/CHANGELOG.md b/servant-auth/servant-auth-server/CHANGELOG.md new file mode 100644 index 00000000..34b137d2 --- /dev/null +++ b/servant-auth/servant-auth-server/CHANGELOG.md @@ -0,0 +1,130 @@ +# 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.6.0] - 2020-10-06 + +## Changed + +- expose verifyJWT and use it in two places [@domenkozar] +- support GHC 8.10 [@domenkozar] +- move ToJWT/FromJWT to servant-auth [@erewok] +- #165 fix AnySite with Cookie 3.5.0 [@odr] + +## [0.4.5.1] - 2020-02-06 + +## Changed + +- #158 servant 0.17 support [@phadej] + +## [0.4.5.0] - 2019-12-28 + +## Changed +- #144 servant 0.16 support and drop GHC 7.10 support [@domenkozar] +- #148 removed unused constaint in HasServer instance for Auth +- #154 GHC 8.8 support [@phadej] + +### Added +- #141 Support Stream combinator [@domenkozar] +- #143 Allow servant-0.16 [@phadej] + +## [0.4.4.0] - 2019-03-02 + +### Added +- #141 Support Stream combinator [@domenkozar] +- #143 Allow servant-0.16 [@phadej] + +## [0.4.3.0] - 2019-01-17 + +## Changed +- #117 Avoid running auth checks unnecessarily [@sopvop] +- #110 Get rid of crypto-api dependency [@domenkozar] +- #130 clearSession: improve cross-browser compatibility [@domenkozar] +- #136 weed out bytestring-conversion [@stephenirl] + +## [0.4.2.0] - 2018-11-05 + +### Added +- `Headers hs a` instance for AddSetCookieApi [@domenkozar] +- GHC 8.6.x support [@domenkozar] + +## [0.4.1.0] - 2018-10-05 + +### Added +- #125 Allow setting domain name for a cookie [@domenkozar] + +## Changed +- bump http-api-data to 0.3.10 that includes Cookie orphan instances previously located in servant-auth-server [@phadej] +- #114 Export `HasSecurity` typeclass [@rockbmb] + +## [0.4.0.1] - 2018-09-23 + +### Security +- #123 Session cookie did not apply SameSite attribute [@domenkozar] + +### Added +- #112 HasLink instance for Auth combinator [@adetokunbo] +- #111 Documentation for using hoistServer [@mschristiansen] +- #107 Add utility functions for reading and writing a key to a file [@mschristiansen] + +## [0.4.0.0] - 2018-06-17 + +### Added +- Support GHC 8.4 by @phadej and @domenkozar +- Support for servant-0.14 by @phadej +- #96 Support for jose-0.7 by @xaviershay +- #92 add `clearSession` for logout by @plredmond and @3noch +- #95 makeJWT: allow setting Alg via defaultJWTSettings by @domenkozar +- #89 Validate JWT against a JWKSet instead of JWK by @sopvop + +### Changed +- #92 Rename CSRF to XSRF by @plredmond and @3noch +- #92 extract 'XsrfCookieSettings' from 'CookieSettings' and make XSRF checking optional + by @plredmond and @3noch +- #69 export SameSite by @domenkozar +- #102 Reuse Servant.Api.IsSecure instead of duplicating ADT by @domenkozar + +### Deprecated +- #92 Renamed 'makeCsrfCookie' to 'makeXsrfCookie' and marked the former as deprecated + by @plredmond and @3noc +- #92 Made several changes to the structure of 'CookieSettings' which will require + attention by users who have modified the XSRF settings by @plredmond and @3noch + +### Security +- #94 Force cookie expiration on serverside by @karshan + +## [0.3.2.0] - 2018-02-21 + +### Added +- #76 Export wwwAuthenticatedErr and elaborate its annotation by @defanor +- Support for servant-0.14 by @phadej + +### Changed +- Disable the readme executable for ghcjs builds by @hamishmack +- #84 Make AddSetCookieApi type family open by @qnikst +- #79 Make CSRF checks optional for GET requests by @harendra-kumar + +## [0.3.1.0] - 2017-11-08 + +### Added +- Support for servant-0.12 by @phadej + +## [0.3.0.0] - 2017-11-07 + +### Changed +- #47 'cookiePath' and 'xsrfCookiePath' added to 'CookieSettings' by @mchaver + +## [0.2.8.0] - 2017-05-26 + +### Added +- #45 Support for servant-0.11 by @phadej + +## [0.2.7.0] - 2017-02-11 + +### Changed +- #27 #41 'acceptLogin' and 'makeCsrfCookie' functions by @bts diff --git a/servant-auth/servant-auth-server/LICENSE b/servant-auth/servant-auth-server/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth-server/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. + diff --git a/servant-auth/servant-auth-server/README.lhs b/servant-auth/servant-auth-server/README.lhs new file mode 100644 index 00000000..9dba4acc --- /dev/null +++ b/servant-auth/servant-auth-server/README.lhs @@ -0,0 +1,293 @@ +# servant-auth + +[![build status](https://img.shields.io/github/workflow/status/haskell-servant/servant-auth/CI/master?style=flat-square&logo=github&label=build%20status)](https://github.com/haskell-servant/servant-auth/actions?query=workflow%3ACI) + +These packages provides safe and easy-to-use authentication options for +`servant`. The same API can be protected via: +- basicauth +- cookies +- JWT tokens + + +| Package | Hackage | +| -------------------- | ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | +| servant-auth | [![servant-auth](https://img.shields.io/hackage/v/servant-auth?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth) | +| servant-auth-server | [![servant-auth-server](https://img.shields.io/hackage/v/servant-auth-server.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-server) | +| servant-auth-client | [![servant-auth-client](https://img.shields.io/hackage/v/servant-auth-client.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-client) | +| servant-auth-swagger | [![servant-auth-swagger](https://img.shields.io/hackage/v/servant-auth-swagger.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-swagger) | +| servant-auth-docs | [![servant-auth-docs](https://img.shields.io/hackage/v/servant-auth-docs.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-docs) | + +## How it works + +First some imports: + +~~~ haskell +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +import Control.Concurrent (forkIO) +import Control.Monad (forever) +import Control.Monad.Trans (liftIO) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) +import Network.Wai.Handler.Warp (run) +import System.Environment (getArgs) +import Servant +import Servant.Auth.Server +import Servant.Auth.Server.SetCookieOrphan () +~~~ + +`servant-auth` library introduces a combinator `Auth`: + +~~~ haskell +data Auth (auths :: [*]) val +~~~ + +What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by +*either* `Auth1` *or* `Auth2`, and the result of authentication will be of type +`AuthResult Something`, where : + +~~~ haskell +data AuthResult val + = BadPassword + | NoSuchUser + | Authenticated val + | Indefinite +~~~ + +Your handlers will get a value of type `AuthResult Something`, and can decide +what to do with it. + +~~~ haskell + +data User = User { name :: String, email :: String } + deriving (Eq, Show, Read, Generic) + +instance ToJSON User +instance ToJWT User +instance FromJSON User +instance FromJWT User + +data Login = Login { username :: String, password :: String } + deriving (Eq, Show, Read, Generic) + +instance ToJSON Login +instance FromJSON Login + +type Protected + = "name" :> Get '[JSON] String + :<|> "email" :> Get '[JSON] String + + +-- | 'Protected' will be protected by 'auths', which we still have to specify. +protected :: Servant.Auth.Server.AuthResult User -> Server Protected +-- If we get an "Authenticated v", we can trust the information in v, since +-- it was signed by a key we trust. +protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user) +-- Otherwise, we return a 401. +protected _ = throwAll err401 + +type Unprotected = + "login" + :> ReqBody '[JSON] Login + :> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) + :<|> Raw + +unprotected :: CookieSettings -> JWTSettings -> Server Unprotected +unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static" + +type API auths = (Servant.Auth.Server.Auth auths User :> Protected) :<|> Unprotected + +server :: CookieSettings -> JWTSettings -> Server (API auths) +server cs jwts = protected :<|> unprotected cs jwts + +~~~ + +The code is common to all authentications. In order to pick one or more specific +authentication methods, all we need to do is provide the expect configuration +parameters. + +## API tokens + +The following example illustrates how to protect an API with tokens. + + +~~~ haskell +-- In main, we fork the server, and allow new tokens to be created in the +-- command line for the specified user name and email. +mainWithJWT :: IO () +mainWithJWT = do + -- We generate the key for signing tokens. This would generally be persisted, + -- and kept safely + myKey <- generateKey + -- Adding some configurations. All authentications require CookieSettings to + -- be in the context. + let jwtCfg = defaultJWTSettings myKey + cfg = defaultCookieSettings :. jwtCfg :. EmptyContext + --- Here we actually make concrete + api = Proxy :: Proxy (API '[JWT]) + _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) + + putStrLn "Started server on localhost:7249" + putStrLn "Enter name and email separated by a space for a new token" + + forever $ do + xs <- words <$> getLine + case xs of + [name', email'] -> do + etoken <- makeJWT (User name' email') jwtCfg Nothing + case etoken of + Left e -> putStrLn $ "Error generating token:t" ++ show e + Right v -> putStrLn $ "New token:\t" ++ show v + _ -> putStrLn "Expecting a name and email separated by spaces" + +~~~ + +And indeed: + +~~~ bash + +./readme JWT + + Started server on localhost:7249 + Enter name and email separated by a space for a new token + alice alice@gmail.com + New token: "eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" + +curl localhost:7249/name -v + + * Hostname was NOT found in DNS cache + * Trying 127.0.0.1... + * Connected to localhost (127.0.0.1) port 7249 (#0) + > GET /name HTTP/1.1 + > User-Agent: curl/7.35.0 + > Host: localhost:7249 + > Accept: */* + > + < HTTP/1.1 401 Unauthorized + < Transfer-Encoding: chunked + < Date: Wed, 07 Sep 2016 20:17:17 GMT + * Server Warp/3.2.7 is not blacklisted + < Server: Warp/3.2.7 + < + * Connection #0 to host localhost left intact + +curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \ + localhost:7249/name -v + + * Hostname was NOT found in DNS cache + * Trying 127.0.0.1... + * Connected to localhost (127.0.0.1) port 7249 (#0) + > GET /name HTTP/1.1 + > User-Agent: curl/7.35.0 + > Host: localhost:7249 + > Accept: */* + > Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE + > + < HTTP/1.1 200 OK + < Transfer-Encoding: chunked + < Date: Wed, 07 Sep 2016 20:16:11 GMT + * Server Warp/3.2.7 is not blacklisted + < Server: Warp/3.2.7 + < Content-Type: application/json + < Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure + < Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure + < + * Connection #0 to host localhost left intact + "alice"% + + +~~~ + +## Cookies + +What if, in addition to API tokens, we want to expose our API to browsers? All +we need to do is say so! + +~~~ haskell +mainWithCookies :: IO () +mainWithCookies = do + -- We *also* need a key to sign the cookies + myKey <- generateKey + -- Adding some configurations. 'Cookie' requires, in addition to + -- CookieSettings, JWTSettings (for signing), so everything is just as before + let jwtCfg = defaultJWTSettings myKey + cfg = defaultCookieSettings :. jwtCfg :. EmptyContext + --- Here is the actual change + api = Proxy :: Proxy (API '[Cookie]) + run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) + +-- Here is the login handler +checkCreds :: CookieSettings + -> JWTSettings + -> Login + -> Handler (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) +checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do + -- Usually you would ask a database for the user info. This is just a + -- regular servant handler, so you can follow your normal database access + -- patterns (including using 'enter'). + let usr = User "Ali Baba" "ali@email.com" + mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr + case mApplyCookies of + Nothing -> throwError err401 + Just applyCookies -> return $ applyCookies NoContent +checkCreds _ _ _ = throwError err401 +~~~ + +### XSRF and the frontend + +XSRF protection works by requiring that there be a header of the same value as +a distinguished cookie that is set by the server on each request. What the +cookie and header name are can be configured (see `xsrfCookieName` and +`xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and +"X-XSRF-TOKEN". This means that, if your client is a browser and you're using +cookies, Javascript on the client must set the header of each request by +reading the cookie. For jQuery, and with the default values, that might be: + +~~~ javascript + +var token = (function() { + r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)')) + if (r) return r[1]; +})(); + + +$.ajaxPrefilter(function(opts, origOpts, xhr) { + xhr.setRequestHeader('X-XSRF-TOKEN', token); + } + +~~~ + +I *believe* nothing at all needs to be done if you're using Angular's `$http` +directive, but I haven't tested this. + +XSRF protection can be disabled just for `GET` requests by setting +`xsrfExcludeGet = False`. You might want this if you're relying on the browser +to navigate between pages that require cookie authentication. + +XSRF protection can be completely disabled by setting `cookieXsrfSetting = +Nothing` in `CookieSettings`. This is not recommended! If your cookie +authenticated web application runs any javascript, it's recommended to send the +XSRF header. However, if your web application runs no javascript, disabling +XSRF entirely may be required. + +# Note on this README + +This README is a literate haskell file. Here is 'main', allowing you to pick +between the examples above. + +~~~ haskell + +main :: IO () +main = do + args <- getArgs + let usage = "Usage: readme (JWT|Cookie)" + case args of + ["JWT"] -> mainWithJWT + ["Cookie"] -> mainWithCookies + e -> putStrLn $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage + +~~~ diff --git a/servant-auth/servant-auth-server/README.md b/servant-auth/servant-auth-server/README.md new file mode 120000 index 00000000..4e381b2e --- /dev/null +++ b/servant-auth/servant-auth-server/README.md @@ -0,0 +1 @@ +README.lhs \ No newline at end of file diff --git a/servant-auth/servant-auth-server/Setup.hs b/servant-auth/servant-auth-server/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-auth/servant-auth-server/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth/servant-auth-server/servant-auth-server.cabal b/servant-auth/servant-auth-server/servant-auth-server.cabal new file mode 100644 index 00000000..a657e97d --- /dev/null +++ b/servant-auth/servant-auth-server/servant-auth-server.cabal @@ -0,0 +1,129 @@ +name: servant-auth-server +version: 0.4.6.0 +synopsis: servant-server/servant-auth compatibility +description: This package provides the required instances for using the @Auth@ combinator + in your 'servant' server. + . + Both cookie- and token- (REST API) based authentication is provided. + . + For a quick overview of the usage, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant-auth/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-auth + +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 + , aeson >= 1.3.1.1 && < 1.6 + , base64-bytestring >= 1.0.0.1 && < 1.2 + , blaze-builder >= 0.4.1.0 && < 0.5 + , bytestring >= 0.10.6.0 && < 0.11 + , case-insensitive >= 1.2.0.11 && < 1.3 + , cookie >= 0.4.4 && < 0.5 + , data-default-class >= 0.1.2.0 && < 0.2 + , entropy >= 0.4.1.3 && < 0.5 + , http-types >= 0.12.2 && < 0.13 + , jose >= 0.7.0.0 && < 0.9 + , lens >= 4.16.1 && < 5.1 + , memory >= 0.14.16 && < 0.17 + , monad-time >= 0.3.1.0 && < 0.4 + , mtl >= 2.2.2 && < 2.3 + , servant >= 0.13 && < 0.19 + , servant-auth == 0.4.* + , servant-server >= 0.13 && < 0.19 + , tagged >= 0.8.4 && < 0.9 + , text >= 1.2.3.0 && < 1.3 + , time >= 1.5.0.1 && < 1.10 + , unordered-containers >= 0.2.9.0 && < 0.3 + , wai >= 3.2.1.2 && < 3.3 + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.18.5 && <0.20 + exposed-modules: + Servant.Auth.Server + Servant.Auth.Server.Internal + Servant.Auth.Server.Internal.AddSetCookie + Servant.Auth.Server.Internal.BasicAuth + Servant.Auth.Server.Internal.Class + Servant.Auth.Server.Internal.ConfigTypes + Servant.Auth.Server.Internal.Cookie + Servant.Auth.Server.Internal.FormLogin + Servant.Auth.Server.Internal.JWT + Servant.Auth.Server.Internal.ThrowAll + Servant.Auth.Server.Internal.Types + Servant.Auth.Server.SetCookieOrphan + default-language: Haskell2010 + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall -pgmL markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit + build-depends: + base + , servant-auth + , servant-auth-server + , servant-server + , aeson + , mtl + , warp + default-language: Haskell2010 + if impl(ghcjs) + buildable: False + +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.8 + + -- dependencies with bounds inherited from the library stanza + build-depends: + base + , aeson + , bytestring + , case-insensitive + , jose + , lens + , mtl + , time + , http-types + , wai + , servant + , servant-server + , transformers + + -- test dependencies + build-depends: + servant-auth-server + , hspec >= 2.5.5 && < 2.8 + , QuickCheck >= 2.11.3 && < 2.15 + , http-client >= 0.5.13.1 && < 0.8 + , lens-aeson >= 1.0.2 && < 1.2 + , warp >= 3.2.25 && < 3.4 + , wreq >= 0.5.2.1 && < 0.6 + other-modules: + Servant.Auth.ServerSpec + default-language: Haskell2010 diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server.hs new file mode 100644 index 00000000..d163fc26 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server.hs @@ -0,0 +1,180 @@ +module Servant.Auth.Server + ( + -- | This package provides implementations for some common authentication + -- methods. Authentication yields a trustworthy (because generated by the + -- server) value of an some arbitrary type: + -- + -- > type MyApi = Protected + -- > + -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails + -- > + -- > server :: Server Protected + -- > server (Authenticated usr) = ... -- here we know the client really is + -- > -- who she claims to be + -- > server _ = throwAll err401 + -- + -- Additional configuration happens via 'Context'. + -- + -- == Example for Custom Handler + -- To use a custom 'Servant.Server.Handler' it is necessary to use + -- 'Servant.Server.hoistServerWithContext' instead of + -- 'Servant.Server.hoistServer' and specify the 'Context'. + -- + -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the + -- 'Context' to create a specialized function equivalent to + -- 'Servant.Server.hoistServer' for an API that includes cookie + -- authentication. + -- + -- > hoistServerWithAuth + -- > :: HasServer api '[CookieSettings, JWTSettings] + -- > => Proxy api + -- > -> (forall x. m x -> n x) + -- > -> ServerT api m + -- > -> ServerT api n + -- > hoistServerWithAuth api = + -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings]) + + ---------------------------------------------------------------------------- + -- * Auth + -- | Basic types + Auth + , AuthResult(..) + , AuthCheck(..) + + ---------------------------------------------------------------------------- + -- * JWT + -- | JSON Web Tokens (JWT) are a compact and secure way of transferring + -- information between parties. In this library, they are signed by the + -- server (or by some other party posessing the relevant key), and used to + -- indicate the bearer's identity or authorization. + -- + -- Arbitrary information can be encoded - just declare instances for the + -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that + -- usually you'll be trasmitting this information on each request (and + -- response!). + -- + -- Note that, while the tokens are signed, they are not encrypted. Do not put + -- any information you do not wish the client to know in them! + + -- ** Combinator + -- | Re-exported from 'servant-auth' + , JWT + + -- ** Classes + , FromJWT(..) + , ToJWT(..) + + -- ** Related types + , IsMatch(..) + + -- ** Settings + , JWTSettings(..) + , defaultJWTSettings + + -- ** Create check + , jwtAuthCheck + + + ---------------------------------------------------------------------------- + -- * Cookie + -- | Cookies are also a method of identifying and authenticating a user. They + -- are particular common when the client is a browser + + -- ** Combinator + -- | Re-exported from 'servant-auth' + , Cookie + + -- ** Settings + , CookieSettings(..) + , XsrfCookieSettings(..) + , defaultCookieSettings + , defaultXsrfCookieSettings + , makeSessionCookie + , makeSessionCookieBS + , makeXsrfCookie + , makeCsrfCookie + , makeCookie + , makeCookieBS + , acceptLogin + , clearSession + + + -- ** Related types + , IsSecure(..) + , SameSite(..) + , AreAuths + + ---------------------------------------------------------------------------- + -- * BasicAuth + -- ** Combinator + -- | Re-exported from 'servant-auth' + , BasicAuth + + -- ** Classes + , FromBasicAuthData(..) + + -- ** Settings + , BasicAuthCfg + + -- ** Related types + , BasicAuthData(..) + , IsPasswordCorrect(..) + + -- ** Authentication request + , wwwAuthenticatedErr + + ---------------------------------------------------------------------------- + -- * Utilies + , ThrowAll(throwAll) + , generateKey + , generateSecret + , fromSecret + , writeKey + , readKey + , makeJWT + , verifyJWT + + -- ** Re-exports + , Default(def) + , SetCookie + ) where + +import Prelude hiding (readFile, writeFile) +import Data.ByteString (ByteString, writeFile, readFile) +import Data.Default.Class (Default (def)) +import Servant.Auth +import Servant.Auth.JWT +import Servant.Auth.Server.Internal () +import Servant.Auth.Server.Internal.BasicAuth +import Servant.Auth.Server.Internal.Class +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.JWT +import Servant.Auth.Server.Internal.ThrowAll +import Servant.Auth.Server.Internal.Types + +import Crypto.JOSE as Jose +import Servant (BasicAuthData (..)) +import Web.Cookie (SetCookie) + +-- | Generate a key suitable for use with 'defaultConfig'. +generateKey :: IO Jose.JWK +generateKey = Jose.genJWK $ Jose.OctGenParam 256 + +-- | Generate a bytestring suitable for use with 'fromSecret'. +generateSecret :: MonadRandom m => m ByteString +generateSecret = Jose.getRandomBytes 256 + +-- | Restores a key from a bytestring. +fromSecret :: ByteString -> Jose.JWK +fromSecret = Jose.fromOctets + +-- | Writes a secret to a file. Can for instance be used from the REPL +-- to persist a key to a file, which can then be included with the +-- application. Restore the key using 'readKey'. +writeKey :: FilePath -> IO () +writeKey fp = writeFile fp =<< generateSecret + +-- | Reads a key from a file. +readKey :: FilePath -> IO Jose.JWK +readKey fp = fromSecret <$> readFile fp diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs new file mode 100644 index 00000000..2e825c0a --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.Auth.Server.Internal where + +import Control.Monad.Trans (liftIO) +import Servant ((:>), Handler, HasServer (..), + Proxy (..), + HasContextEntry(getContextEntry)) +import Servant.Auth +import Servant.Auth.JWT (ToJWT) + +import Servant.Auth.Server.Internal.AddSetCookie +import Servant.Auth.Server.Internal.Class +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.JWT +import Servant.Auth.Server.Internal.Types + +import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest) + +instance ( n ~ 'S ('S 'Z) + , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v + , HasServer api ctxs -- this constraint is needed to implement hoistServer + , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler) + , ToJWT v + , HasContextEntry ctxs CookieSettings + , HasContextEntry ctxs JWTSettings + ) => HasServer (Auth auths v :> api) ctxs where + type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m + +#if MIN_VERSION_servant_server(0,12,0) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s +#endif + + route _ context subserver = + route (Proxy :: Proxy (AddSetCookiesApi n api)) + context + (fmap go subserver `addAuthCheck` authCheck) + + where + authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))) + authCheck = withRequest $ \req -> liftIO $ do + authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req + cookies <- makeCookies authResult + return (authResult, cookies) + + jwtSettings :: JWTSettings + jwtSettings = getContextEntry context + + cookieSettings :: CookieSettings + cookieSettings = getContextEntry context + + makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z))) + makeCookies authResult = do + xsrf <- makeXsrfCookie cookieSettings + fmap (Just xsrf `SetCookieCons`) $ + case authResult of + (Authenticated v) -> do + ejwt <- makeSessionCookie cookieSettings jwtSettings v + case ejwt of + Nothing -> return $ Nothing `SetCookieCons` SetCookieNil + Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil + _ -> return $ Nothing `SetCookieCons` SetCookieNil + + go :: (AuthResult v -> ServerT api Handler) + -> (AuthResult v, SetCookieList n) + -> ServerT (AddSetCookiesApi n api) Handler + go fn (authResult, cookies) = addSetCookies cookies $ fn authResult diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs new file mode 100644 index 00000000..32857ebe --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} + +module Servant.Auth.Server.Internal.AddSetCookie where + +import Blaze.ByteString.Builder (toByteString) +import qualified Data.ByteString as BS +import Data.Tagged (Tagged (..)) +import qualified Network.HTTP.Types as HTTP +import Network.Wai (mapResponseHeaders) +import Servant +import Web.Cookie + +-- What are we doing here? Well, the idea is to add headers to the response, +-- but the headers come from the authentication check. In order to do that, we +-- tweak a little the general theme of recursing down the API tree; this time, +-- we recurse down a variation of it that adds headers to all the endpoints. +-- This involves the usual type-level checks. +-- +-- TODO: If the endpoints already have headers, this will not work as is. + +data Nat = Z | S Nat + +type family AddSetCookiesApi (n :: Nat) a where + AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a + AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a) + +type family AddSetCookieApiVerb a where + AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a + AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a + +type family AddSetCookieApi a :: * +type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b +type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b +type instance AddSetCookieApi (Verb method stat ctyps a) + = Verb method stat ctyps (AddSetCookieApiVerb a) +type instance AddSetCookieApi Raw = Raw +#if MIN_VERSION_servant_server(0,15,0) +type instance AddSetCookieApi (Stream method stat framing ctyps a) + = Stream method stat framing ctyps (AddSetCookieApiVerb a) +#endif +type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a) + +data SetCookieList (n :: Nat) :: * where + SetCookieNil :: SetCookieList 'Z + SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n) + +class AddSetCookies (n :: Nat) orig new where + addSetCookies :: SetCookieList n -> orig -> new + +instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb + => AddSetCookies ('S n) (a -> oldb) (a -> newb) where + addSetCookies cookies oldfn = addSetCookies cookies . oldfn + +instance AddSetCookies 'Z orig orig where + addSetCookies _ = id + +instance {-# OVERLAPPABLE #-} + ( Functor m + , AddSetCookies n (m old) (m cookied) + , AddHeader "Set-Cookie" SetCookie cookied new + ) => AddSetCookies ('S n) (m old) (m new) where + addSetCookies (mCookie `SetCookieCons` rest) oldVal = + case mCookie of + Nothing -> noHeader <$> addSetCookies rest oldVal + Just cookie -> addHeader cookie <$> addSetCookies rest oldVal + +instance {-# OVERLAPS #-} + (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b') + => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where + addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b + +-- | for @servant <0.11@ +instance + AddSetCookies ('S n) Application Application where + addSetCookies cookies r request respond + = r request $ respond . mapResponseHeaders (++ mkHeaders cookies) + +-- | for @servant >=0.11@ +instance + AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where + addSetCookies cookies r = Tagged $ \request respond -> + unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies) + +mkHeaders :: SetCookieList x -> [HTTP.Header] +mkHeaders x = ("Set-Cookie",) <$> mkCookies x + where + mkCookies :: forall y. SetCookieList y -> [BS.ByteString] + mkCookies SetCookieNil = [] + mkCookies (SetCookieCons Nothing rest) = mkCookies rest + mkCookies (SetCookieCons (Just y) rest) + = toByteString (renderSetCookie y) : mkCookies rest diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs new file mode 100644 index 00000000..f35eb6f7 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.Server.Internal.BasicAuth where + +#if !MIN_VERSION_servant_server(0,16,0) +#define ServerError ServantErr +#endif + +import qualified Data.ByteString as BS +import Servant (BasicAuthData (..), + ServerError (..), err401) +import Servant.Server.Internal.BasicAuth (decodeBAHdr, + mkBAChallengerHdr) + +import Servant.Auth.Server.Internal.Types + +-- | A 'ServerError' that asks the client to authenticate via Basic +-- Authentication, should be invoked by an application whenever +-- appropriate. The argument is the realm. +wwwAuthenticatedErr :: BS.ByteString -> ServerError +wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] } + +-- | A type holding the configuration for Basic Authentication. +-- It is defined as a type family with no arguments, so that +-- it can be instantiated to whatever type you need to +-- authenticate your users (use @type instance BasicAuthCfg = ...@). +-- +-- Note that the instantiation is application-wide, +-- i.e. there can be only one instance. +-- As a consequence, it should not be instantiated in a library. +-- +-- Basic Authentication expects an element of type 'BasicAuthCfg' +-- to be in the 'Context'; that element is then passed automatically +-- to the instance of 'FromBasicAuthData' together with the +-- authentication data obtained from the client. +-- +-- If you do not need a configuration for Basic Authentication, +-- you can use just @BasicAuthCfg = ()@, and recall to also +-- add @()@ to the 'Context'. +-- A basic but more interesting example is to take as 'BasicAuthCfg' +-- a list of authorised username/password pairs: +-- +-- > deriving instance Eq BasicAuthData +-- > type instance BasicAuthCfg = [BasicAuthData] +-- > instance FromBasicAuthData User where +-- > fromBasicAuthData authData authCfg = +-- > if elem authData authCfg then ... +type family BasicAuthCfg + +class FromBasicAuthData a where + -- | Whether the username exists and the password is correct. + -- Note that, rather than passing a 'Pass' to the function, we pass a + -- function that checks an 'EncryptedPass'. This is to make sure you don't + -- accidentally do something untoward with the password, like store it. + fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a) + +basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr +basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of + Nothing -> return Indefinite + Just baData -> fromBasicAuthData baData cfg diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs new file mode 100644 index 00000000..2f13bbc3 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.Class where + +import Servant.Auth +import Data.Monoid +import Servant hiding (BasicAuth) + +import Servant.Auth.JWT +import Servant.Auth.Server.Internal.Types +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.BasicAuth +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.JWT (jwtAuthCheck) + +-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all +-- elements of @ctx@ to be the in the Context and whose authentication check +-- returns an @AuthCheck v@. +class IsAuth a v where + type family AuthArgs a :: [*] + runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) + +instance FromJWT usr => IsAuth Cookie usr where + type AuthArgs Cookie = '[CookieSettings, JWTSettings] + runAuth _ _ = cookieAuthCheck + +instance FromJWT usr => IsAuth JWT usr where + type AuthArgs JWT = '[JWTSettings] + runAuth _ _ = jwtAuthCheck + +instance FromBasicAuthData usr => IsAuth BasicAuth usr where + type AuthArgs BasicAuth = '[BasicAuthCfg] + runAuth _ _ = basicAuthCheck + +-- * Helper + +class AreAuths (as :: [*]) (ctxs :: [*]) v where + runAuths :: proxy as -> Context ctxs -> AuthCheck v + +instance AreAuths '[] ctxs v where + runAuths _ _ = mempty + +instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) + , IsAuth a v + , AreAuths as ctxs v + , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) + ) => AreAuths (a ': as) ctxs v where + runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs + where + go = appCtx (Proxy :: Proxy (AuthArgs a)) + ctxs + (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v)) + +type family Unapp ls res where + Unapp '[] res = res + Unapp (arg1 ': rest) res = arg1 -> Unapp rest res + +type family App ls res where + App '[] res = res + App (arg1 ': rest) (arg1 -> res) = App rest res + +-- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the +-- values from the Context provided. +class AppCtx ctx ls res where + appCtx :: proxy ls -> Context ctx -> res -> App ls res + +instance ( HasContextEntry ctxs ctx + , AppCtx ctxs rest res + ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where + appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx + +instance AppCtx ctx '[] res where + appCtx _ _ r = r diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs new file mode 100644 index 00000000..83e5784d --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs @@ -0,0 +1,127 @@ +module Servant.Auth.Server.Internal.ConfigTypes + ( module Servant.Auth.Server.Internal.ConfigTypes + , Servant.API.IsSecure(..) + ) where + +import Crypto.JOSE as Jose +import Crypto.JWT as Jose +import qualified Data.ByteString as BS +import Data.Default.Class +import Data.Time +import GHC.Generics (Generic) +import Servant.API (IsSecure(..)) + +data IsMatch = Matches | DoesNotMatch + deriving (Eq, Show, Read, Generic, Ord) + +data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect + deriving (Eq, Show, Read, Generic, Ord) + +-- The @SameSite@ attribute of cookies determines whether cookies will be sent +-- on cross-origin requests. +-- +-- See +-- for more information. +data SameSite = AnySite | SameSiteStrict | SameSiteLax + deriving (Eq, Show, Read, Generic, Ord) + +-- | @JWTSettings@ are used to generate cookies, and to verify JWTs. +data JWTSettings = JWTSettings + { + -- | Key used to sign JWT. + signingKey :: Jose.JWK + -- | Algorithm used to sign JWT. + , jwtAlg :: Maybe Jose.Alg + -- | Keys used to validate JWT. + , validationKeys :: Jose.JWKSet + -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the + -- intended recipient of the JWT. + , audienceMatches :: Jose.StringOrURI -> IsMatch + } deriving (Generic) + +-- | A @JWTSettings@ where the audience always matches. +defaultJWTSettings :: Jose.JWK -> JWTSettings +defaultJWTSettings k = JWTSettings + { signingKey = k + , jwtAlg = Nothing + , validationKeys = Jose.JWKSet [k] + , audienceMatches = const Matches } + +-- | The policies to use when generating cookies. +-- +-- If *both* 'cookieMaxAge' and 'cookieExpires' are @Nothing@, browsers will +-- treat the cookie as a *session cookie*. These will be deleted when the +-- browser is closed. +-- +-- Note that having the setting @Secure@ may cause testing failures if you are +-- not testing over HTTPS. +data CookieSettings = CookieSettings + { + -- | 'Secure' means browsers will only send cookies over HTTPS. Default: + -- @Secure@. + cookieIsSecure :: !IsSecure + -- | How long from now until the cookie expires. Default: @Nothing@. + , cookieMaxAge :: !(Maybe DiffTime) + -- | At what time the cookie expires. Default: @Nothing@. + , cookieExpires :: !(Maybe UTCTime) + -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@. + , cookiePath :: !(Maybe BS.ByteString) + -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@. + , cookieDomain :: !(Maybe BS.ByteString) + -- | 'SameSite' settings. Default: @SameSiteLax@. + , cookieSameSite :: !SameSite + -- | What name to use for the cookie used for the session. + , sessionCookieName :: !BS.ByteString + -- | The optional settings to use for XSRF protection. Default: @Just def@. + , cookieXsrfSetting :: !(Maybe XsrfCookieSettings) + } deriving (Eq, Show, Generic) + +instance Default CookieSettings where + def = defaultCookieSettings + +defaultCookieSettings :: CookieSettings +defaultCookieSettings = CookieSettings + { cookieIsSecure = Secure + , cookieMaxAge = Nothing + , cookieExpires = Nothing + , cookiePath = Just "/" + , cookieDomain = Nothing + , cookieSameSite = SameSiteLax + , sessionCookieName = "JWT-Cookie" + , cookieXsrfSetting = Just def + } + +-- | The policies to use when generating and verifying XSRF cookies +data XsrfCookieSettings = XsrfCookieSettings + { + -- | What name to use for the cookie used for XSRF protection. + xsrfCookieName :: !BS.ByteString + -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@. + , xsrfCookiePath :: !(Maybe BS.ByteString) + -- | What name to use for the header used for XSRF protection. + , xsrfHeaderName :: !BS.ByteString + -- | Exclude GET request method from XSRF protection. + , xsrfExcludeGet :: !Bool + } deriving (Eq, Show, Generic) + +instance Default XsrfCookieSettings where + def = defaultXsrfCookieSettings + +defaultXsrfCookieSettings :: XsrfCookieSettings +defaultXsrfCookieSettings = XsrfCookieSettings + { xsrfCookieName = "XSRF-TOKEN" + , xsrfCookiePath = Just "/" + , xsrfHeaderName = "X-XSRF-TOKEN" + , xsrfExcludeGet = False + } + +------------------------------------------------------------------------------ +-- Internal {{{ + +jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings +jwtSettingsToJwtValidationSettings s + = defaultJWTValidationSettings (toBool <$> audienceMatches s) + where + toBool Matches = True + toBool DoesNotMatch = False +-- }}} diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs new file mode 100644 index 00000000..a91b42de --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.Server.Internal.Cookie where + +import Blaze.ByteString.Builder (toByteString) +import Control.Monad.Except +import Control.Monad.Reader +import qualified Crypto.JOSE as Jose +import qualified Crypto.JWT as Jose +import Data.ByteArray (constEq) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS64 +import qualified Data.ByteString.Lazy as BSL +import Data.CaseInsensitive (mk) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day(..)) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime) +import Network.HTTP.Types (methodGet) +import Network.HTTP.Types.Header(hCookie) +import Network.Wai (Request, requestHeaders, requestMethod) +import Servant (AddHeader, addHeader) +import System.Entropy (getEntropy) +import Web.Cookie + +import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT) +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT) +import Servant.Auth.Server.Internal.Types + + +cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr +cookieAuthCheck ccfg jwtSettings = do + req <- ask + jwtCookie <- maybe mempty return $ do + cookies' <- lookup hCookie $ requestHeaders req + let cookies = parseCookies cookies' + -- Apply the XSRF check if enabled. + guard $ fromMaybe True $ do + xsrfCookieCfg <- xsrfCheckRequired ccfg req + return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies + -- session cookie *must* be HttpOnly and Secure + lookup (sessionCookieName ccfg) cookies + verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie + case verifiedJWT of + Nothing -> mzero + Just v -> return v + +xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings +xsrfCheckRequired cookieSettings req = do + xsrfCookieCfg <- cookieXsrfSetting cookieSettings + let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet + guard $ not disableForGetReq + return xsrfCookieCfg + +xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool +xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do + xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies + xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req + return $ xsrfCookie `constEq` xsrfHeader + +-- | Makes a cookie to be used for XSRF. +makeXsrfCookie :: CookieSettings -> IO SetCookie +makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of + Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings + Nothing -> return $ noXsrfTokenCookie cookieSettings + where + makeRealCookie xsrfCookieSettings = do + xsrfValue <- BS64.encode <$> getEntropy 32 + return + $ applyXsrfCookieSettings xsrfCookieSettings + $ applyCookieSettings cookieSettings + $ def{ setCookieValue = xsrfValue } + + +-- | Alias for 'makeXsrfCookie'. +makeCsrfCookie :: CookieSettings -> IO SetCookie +makeCsrfCookie = makeXsrfCookie +{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-} + + +-- | Makes a cookie with session information. +makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie) +makeSessionCookie cookieSettings jwtSettings v = do + ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings) + case ejwt of + Left _ -> return Nothing + Right jwt -> return + $ Just + $ applySessionCookieSettings cookieSettings + $ applyCookieSettings cookieSettings + $ def{ setCookieValue = BSL.toStrict jwt } + +noXsrfTokenCookie :: CookieSettings -> SetCookie +noXsrfTokenCookie cookieSettings = + applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" } + +applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie +applyCookieSettings cookieSettings setCookie = setCookie + { setCookieMaxAge = cookieMaxAge cookieSettings + , setCookieExpires = cookieExpires cookieSettings + , setCookiePath = cookiePath cookieSettings + , setCookieDomain = cookieDomain cookieSettings + , setCookieSecure = case cookieIsSecure cookieSettings of + Secure -> True + NotSecure -> False + } + +applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie +applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie + { setCookieName = xsrfCookieName xsrfCookieSettings + , setCookiePath = xsrfCookiePath xsrfCookieSettings + , setCookieHttpOnly = False + } + +applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie +applySessionCookieSettings cookieSettings setCookie = setCookie + { setCookieName = sessionCookieName cookieSettings + , setCookieSameSite = case cookieSameSite cookieSettings of + AnySite -> anySite + SameSiteStrict -> Just sameSiteStrict + SameSiteLax -> Just sameSiteLax + , setCookieHttpOnly = True + } + where +#if MIN_VERSION_cookie(0,4,5) + anySite = Just sameSiteNone +#else + anySite = Nothing +#endif + +-- | For a JWT-serializable session, returns a function that decorates a +-- provided response object with XSRF and session cookies. This should be used +-- when a user successfully authenticates with credentials. +acceptLogin :: ( ToJWT session + , AddHeader "Set-Cookie" SetCookie response withOneCookie + , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) + => CookieSettings + -> JWTSettings + -> session + -> IO (Maybe (response -> withTwoCookies)) +acceptLogin cookieSettings jwtSettings session = do + mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session + case mSessionCookie of + Nothing -> pure Nothing + Just sessionCookie -> do + xsrfCookie <- makeXsrfCookie cookieSettings + return $ Just $ addHeader sessionCookie . addHeader xsrfCookie + +-- | Arbitrary cookie expiry time set back in history after unix time 0 +expireTime :: UTCTime +expireTime = UTCTime (ModifiedJulianDay 50000) 0 + +-- | Adds headers to a response that clears all session cookies +-- | using max-age and expires cookie attributes. +clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie + , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) + => CookieSettings + -> response + -> withTwoCookies +clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie + where + -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both + cookieSettingsExpires = cookieSettings + { cookieExpires = Just expireTime + , cookieMaxAge = Just (secondsToDiffTime 0) + } + clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def + clearedXsrfCookie = case cookieXsrfSetting cookieSettings of + Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def + Nothing -> noXsrfTokenCookie cookieSettingsExpires + +makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) +makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c + +-- | Alias for 'makeSessionCookie'. +makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie) +makeCookie = makeSessionCookie +{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-} + +-- | Alias for 'makeSessionCookieBS'. +makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) +makeCookieBS = makeSessionCookieBS +{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-} diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs new file mode 100644 index 00000000..5301640c --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs @@ -0,0 +1,3 @@ +module Servant.Auth.Server.Internal.FormLogin where + + diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs new file mode 100644 index 00000000..57c0630c --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs @@ -0,0 +1,71 @@ +module Servant.Auth.Server.Internal.JWT where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Reader +import qualified Crypto.JOSE as Jose +import qualified Crypto.JWT as Jose +import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, + toJSON) +import Data.ByteArray (constEq) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Network.Wai (requestHeaders) + +import Servant.Auth.JWT (FromJWT(..), ToJWT(..)) +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.Types + + +-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you +-- are protecting a @Raw@ endpoint. +jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr +jwtAuthCheck jwtSettings = do + req <- ask + token <- maybe mempty return $ do + authHdr <- lookup "Authorization" $ requestHeaders req + let bearer = "Bearer " + (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr + guard (mbearer `constEq` bearer) + return rest + verifiedJWT <- liftIO $ verifyJWT jwtSettings token + case verifiedJWT of + Nothing -> mzero + Just v -> return v + +-- | Creates a JWT containing the specified data. The data is stored in the +-- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the +-- token expires. +makeJWT :: ToJWT a + => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString) +makeJWT v cfg expiry = runExceptT $ do + bestAlg <- Jose.bestJWSAlg $ signingKey cfg + let alg = fromMaybe bestAlg $ jwtAlg cfg + ejwt <- Jose.signClaims (signingKey cfg) + (Jose.newJWSHeader ((), alg)) + (addExp $ encodeJWT v) + + return $ Jose.encodeCompact ejwt + where + addExp claims = case expiry of + Nothing -> claims + Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e + + +verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a) +verifyJWT jwtCfg input = do + verifiedJWT <- liftIO $ runExceptT $ do + unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input) + Jose.verifyClaims + (jwtSettingsToJwtValidationSettings jwtCfg) + (validationKeys jwtCfg) + unverifiedJWT + return $ case verifiedJWT of + Left (_ :: Jose.JWTError) -> Nothing + Right v -> case decodeJWT v of + Left _ -> Nothing + Right v' -> Just v' \ No newline at end of file diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs new file mode 100644 index 00000000..956af6b8 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.ThrowAll where + +#if !MIN_VERSION_servant_server(0,16,0) +#define ServerError ServantErr +#endif + +import Control.Monad.Error.Class +import Data.Tagged (Tagged (..)) +import Servant ((:<|>) (..), ServerError(..)) +import Network.HTTP.Types +import Network.Wai + +import qualified Data.ByteString.Char8 as BS + +class ThrowAll a where + -- | 'throwAll' is a convenience function to throw errors across an entire + -- sub-API + -- + -- + -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c + -- > == throwError err400 :<|> throwError err400 :<|> err400 + throwAll :: ServerError -> a + +instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where + throwAll e = throwAll e :<|> throwAll e + +-- Really this shouldn't be necessary - ((->) a) should be an instance of +-- MonadError, no? +instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where + throwAll e = const $ throwAll e + +instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where + throwAll = throwError + +-- | for @servant <0.11@ +instance {-# OVERLAPPING #-} ThrowAll Application where + throwAll e _req respond + = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) + (errHeaders e) + (errBody e) + +-- | for @servant >=0.11@ +instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where + throwAll e = Tagged $ \_req respond -> + respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) + (errHeaders e) + (errBody e) diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs new file mode 100644 index 00000000..8e9e91f1 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.Server.Internal.Types where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.Time +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Time (getCurrentTime) +import GHC.Generics (Generic) +import Network.Wai (Request) + +import qualified Control.Monad.Fail as Fail + +-- | The result of an authentication attempt. +data AuthResult val + = BadPassword + | NoSuchUser + -- | Authentication succeeded. + | Authenticated val + -- | If an authentication procedure cannot be carried out - if for example it + -- expects a password and username in a header that is not present - + -- @Indefinite@ is returned. This indicates that other authentication + -- methods should be tried. + | Indefinite + deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable) + +instance Semigroup (AuthResult val) where + Indefinite <> y = y + x <> _ = x + +instance Monoid (AuthResult val) where + mempty = Indefinite + mappend = (<>) + +instance Applicative AuthResult where + pure = return + (<*>) = ap + +instance Monad AuthResult where + return = Authenticated + Authenticated v >>= f = f v + BadPassword >>= _ = BadPassword + NoSuchUser >>= _ = NoSuchUser + Indefinite >>= _ = Indefinite + +instance Alternative AuthResult where + empty = mzero + (<|>) = mplus + +instance MonadPlus AuthResult where + mzero = mempty + mplus = (<>) + + +-- | An @AuthCheck@ is the function used to decide the authentication status +-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a +-- Monoid or Alternative; the semantics of this is that the *first* +-- non-'Indefinite' result from left to right is used and the rest are ignored. +newtype AuthCheck val = AuthCheck + { runAuthCheck :: Request -> IO (AuthResult val) } + deriving (Generic, Functor) + +instance Semigroup (AuthCheck val) where + AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do + fx <- f x + case fx of + Indefinite -> g x + r -> pure r + +instance Monoid (AuthCheck val) where + mempty = AuthCheck $ const $ return mempty + mappend = (<>) + +instance Applicative AuthCheck where + pure = return + (<*>) = ap + +instance Monad AuthCheck where + return = AuthCheck . return . return . return + AuthCheck ac >>= f = AuthCheck $ \req -> do + aresult <- ac req + case aresult of + Authenticated usr -> runAuthCheck (f usr) req + BadPassword -> return BadPassword + NoSuchUser -> return NoSuchUser + Indefinite -> return Indefinite + +#if !MIN_VERSION_base(4,13,0) + fail = Fail.fail +#endif + +instance Fail.MonadFail AuthCheck where + fail _ = AuthCheck . const $ return Indefinite + +instance MonadReader Request AuthCheck where + ask = AuthCheck $ \x -> return (Authenticated x) + local f (AuthCheck check) = AuthCheck $ \req -> check (f req) + +instance MonadIO AuthCheck where + liftIO action = AuthCheck $ const $ Authenticated <$> action + +instance MonadTime AuthCheck where + currentTime = liftIO getCurrentTime + +instance Alternative AuthCheck where + empty = mzero + (<|>) = mplus + +instance MonadPlus AuthCheck where + mzero = mempty + mplus = (<>) diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs new file mode 100644 index 00000000..de87ad27 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs @@ -0,0 +1,3 @@ +module Servant.Auth.Server.SetCookieOrphan + {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-} + () where diff --git a/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs new file mode 100644 index 00000000..75257f34 --- /dev/null +++ b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -0,0 +1,600 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.ServerSpec (spec) where + +#if !MIN_VERSION_servant_server(0,16,0) +#define ServerError ServantErr +#endif + +import Control.Lens +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (liftIO) +import Crypto.JOSE (Alg (HS256, None), Error, + JWK, JWSHeader, + KeyMaterialGenParam (OctGenParam), + ToCompact, encodeCompact, + genJWK, newJWSHeader) +import Crypto.JWT (Audience (..), ClaimsSet, + NumericDate (NumericDate), + SignedJWT, + claimAud, claimNbf, + signClaims, + emptyClaimsSet, + unregisteredClaims) +import Data.Aeson (FromJSON, ToJSON, Value, + toJSON, encode) +import Data.Aeson.Lens (_JSON) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.CaseInsensitive (mk) +import Data.Foldable (find) +import Data.Monoid +import Data.Time +import Data.Time.Clock (getCurrentTime) +import GHC.Generics (Generic) +import Network.HTTP.Client (cookie_http_only, + cookie_name, cookie_value, + cookie_expiry_time, + destroyCookieJar) +import Network.HTTP.Types (Status, status200, + status401) +import Network.Wai (responseLBS) +import Network.Wai.Handler.Warp (testWithApplication) +import Network.Wreq (Options, auth, basicAuth, + cookieExpiryTime, cookies, + defaults, get, getWith, postWith, + header, oauth2Bearer, + responseBody, + responseCookieJar, + responseHeader, + responseStatus) +import Network.Wreq.Types (Postable(..)) +import Servant hiding (BasicAuth, + IsSecure (..), header) +import Servant.Auth.Server +import Servant.Auth.Server.Internal.Cookie (expireTime) +import Servant.Auth.Server.SetCookieOrphan () +#if MIN_VERSION_servant_server(0,15,0) +import qualified Servant.Types.SourceT as S +#endif +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec +import Test.QuickCheck +import qualified Network.HTTP.Client as HCli + + + +spec :: Spec +spec = do + authSpec + cookieAuthSpec + jwtAuthSpec + throwAllSpec + basicAuthSpec + +------------------------------------------------------------------------------ +-- * Auth {{{ + +authSpec :: Spec +authSpec + = describe "The Auth combinator" + $ around (testWithApplication . return $ app jwtAndCookieApi) $ do + + it "returns a 401 if all authentications are Indefinite" $ \port -> do + get (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if one authentication suceeds" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "fails (403) if one authentication fails" $ const $ + pendingWith "Authentications don't yet fail, only are Indefinite" + + it "doesn't clobber pre-existing response headers" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/header") + resp ^. responseHeader "Blah" `shouldBe` "1797" + resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") + + context "Raw" $ do + + it "gets the response body" $ \port -> property $ \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/raw") + resp ^. responseBody `shouldBe` "how are you?" + + it "doesn't clobber pre-existing reponse headers" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/raw") + resp ^. responseHeader "hi" `shouldBe` "there" + resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") + + + context "Setting cookies" $ do + + it "sets cookies that it itself accepts" $ \port -> property $ \user -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) + $ destroyCookieJar cookieJar + opts2 = defaults + & cookies .~ Just cookieJar + & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf] + resp2 <- getWith opts2 (url port) + resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) + $ destroyCookieJar cookieJar + xxsrf ^. cookieExpiryTime `shouldBe` future + + it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg) + $ destroyCookieJar cookieJar + cookie_http_only token `shouldBe` True + + + +-- }}} +------------------------------------------------------------------------------ +-- * Cookie Auth {{{ + +cookieAuthSpec :: Spec +cookieAuthSpec + = describe "The Auth combinator" $ do + describe "With XSRF check" $ + around (testWithApplication . return $ app cookieOnlyApi) $ do + + it "fails if XSRF header and cookie don't match" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blerg") + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "fails with no XSRF header or cookie" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfg jwt + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "sets and clears the right cookies" $ \port -> property + $ \(user :: User) -> do + let optsFromResp resp = + let jar = resp ^. responseCookieJar + Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar) + in defaults + & cookies .~ Just jar -- real cookie jars aren't updated by being replaced + & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue] + + resp <- postWith defaults (url port ++ "/login") user + (resp ^. responseCookieJar) `shouldMatchCookieNames` + [ sessionCookieName cookieCfg + , xsrfField xsrfCookieName cookieCfg + ] + let loggedInOpts = optsFromResp resp + + resp <- getWith loggedInOpts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + -- logout + resp <- getWith loggedInOpts (url port ++ "/logout") + + -- assert cookies were expired + now <- getCurrentTime + let assertCookie c = now >= cookie_expiry_time c + all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True + + let loggedOutOpts = optsFromResp resp + getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 + + describe "With no XSRF check for GET requests" $ let + noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True } + cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg } + in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do + + it "succeeds with no XSRF header or cookie for GET" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrfGet jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "fails with no XSRF header or cookie for POST" $ \port -> property + $ \(user :: User) number -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrfGet jwt + postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401 + + describe "With no XSRF check at all" $ let + cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing } + in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do + + it "succeeds with no XSRF header or cookie for GET" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrf jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "succeeds with no XSRF header or cookie for POST" $ \port -> property + $ \(user :: User) number -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrf jwt + resp <- postWith opts (url port) $ toJSON (number :: Int) + resp ^? responseBody . _JSON `shouldBe` Just number + + it "sets and clears the right cookies" $ \port -> property + $ \(user :: User) -> do + let optsFromResp resp = defaults + & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced + + resp <- postWith defaults (url port ++ "/login") user + (resp ^. responseCookieJar) `shouldMatchCookieNames` + [ sessionCookieName cookieCfg + , "NO-XSRF-TOKEN" + ] + let loggedInOpts = optsFromResp resp + + resp <- getWith (loggedInOpts) (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + resp <- getWith loggedInOpts (url port ++ "/logout") + (resp ^. responseCookieJar) `shouldMatchCookieNameValues` + [ (sessionCookieName cookieCfg, "value") + , ("NO-XSRF-TOKEN", "") + ] + + -- assert cookies were expired + now <- getCurrentTime + let assertCookie c = now >= cookie_expiry_time c + all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True + + let loggedOutOpts = optsFromResp resp + + getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 + +-- }}} +------------------------------------------------------------------------------ +-- * JWT Auth {{{ + +jwtAuthSpec :: Spec +jwtAuthSpec + = describe "The JWT combinator" + $ around (testWithApplication . return $ app jwtOnlyApi) $ do + + it "fails if 'aud' does not match predicate" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimAud .~ Just (Audience ["boo"])) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if 'aud' does match predicate" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"])) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + resp <- getWith opts (url port) + resp ^. responseStatus `shouldBe` status200 + + it "fails if 'nbf' is set to a future date" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimNbf .~ Just (NumericDate future)) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "fails if 'exp' is set to a past date" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg (Just past) + opts <- addJwtToHeader jwt + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if 'exp' is set to a future date" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg (Just future) + opts <- addJwtToHeader jwt + resp <- getWith opts (url port) + resp ^. responseStatus `shouldBe` status200 + + it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), None)) + (claims $ toJSON user) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "fails if JWT does not use expected algorithm" $ const $ + pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19" + + it "fails if data is not valid JSON" $ \port -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{") + opts <- addJwtToHeader (jwt >>= (return .encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims $ toJSON user) + resp <- case jwt >>= (return . encodeCompact) of + Left (e :: Error) -> fail $ show e + Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port) + resp ^. responseStatus `shouldBe` status200 + +-- }}} +------------------------------------------------------------------------------ +-- * Basic Auth {{{ + +basicAuthSpec :: Spec +basicAuthSpec = describe "The BasicAuth combinator" + $ around (testWithApplication . return $ app basicAuthApi) $ do + + it "succeeds with the correct password and username" $ \port -> do + resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port) + resp ^. responseStatus `shouldBe` status200 + + it "fails with non-existent user" $ \port -> do + getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port) + `shouldHTTPErrorWith` status401 + + it "fails with incorrect password" $ \port -> do + getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port) + `shouldHTTPErrorWith` status401 + + it "fails with no auth header" $ \port -> do + get (url port) `shouldHTTPErrorWith` status401 + +-- }}} +------------------------------------------------------------------------------ +-- * ThrowAll {{{ + +throwAllSpec :: Spec +throwAllSpec = describe "throwAll" $ do + + it "works for plain values" $ do + let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String + t = throwAll err401 + t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401 + + it "works for function types" $ property $ \i -> do + let t :: Int -> (Either ServerError Bool :<|> Either ServerError String) + t = throwAll err401 + expected _ = throwError err401 :<|> throwError err401 + t i `shouldBe` expected i + +-- }}} +------------------------------------------------------------------------------ +-- * API and Server {{{ + +type API auths + = Auth auths User :> + ( Get '[JSON] Int + :<|> ReqBody '[JSON] Int :> Post '[JSON] Int + :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int) +#if MIN_VERSION_servant_server(0,15,0) + :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) +#endif + :<|> "raw" :> Raw + ) + :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie ] NoContent) + :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie ] NoContent) + +jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) +jwtOnlyApi = Proxy + +cookieOnlyApi :: Proxy (API '[Cookie]) +cookieOnlyApi = Proxy + +basicAuthApi :: Proxy (API '[BasicAuth]) +basicAuthApi = Proxy + +jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie]) +jwtAndCookieApi = Proxy + +theKey :: JWK +theKey = unsafePerformIO . genJWK $ OctGenParam 256 +{-# NOINLINE theKey #-} + + +cookieCfg :: CookieSettings +cookieCfg = def + { cookieExpires = Just future + , cookieIsSecure = NotSecure + , sessionCookieName = "RuncibleSpoon" + , cookieXsrfSetting = pure $ def + { xsrfCookieName = "TheyDinedOnMince" + , xsrfHeaderName = "AndSlicesOfQuince" + } + } +xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a +xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting + +jwtCfg :: JWTSettings +jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x -> + if x == "boo" then DoesNotMatch else Matches } + +instance FromBasicAuthData User where + fromBasicAuthData (BasicAuthData usr pwd) _ + = return $ if usr == "ali" && pwd == "Open sesame" + then Authenticated $ User "ali" "ali@the-thieves-den.com" + else Indefinite + +-- Could be anything, really, but since this is already in the cfg we don't +-- have to add it +type instance BasicAuthCfg = JWK + +appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User + => Proxy (API auths) -> CookieSettings -> Application +appWithCookie api ccfg = serveWithContext api ctx $ server ccfg + where + ctx = ccfg :. jwtCfg :. theKey :. EmptyContext + +-- | Takes a proxy parameter indicating which authentication systems to enable. +app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User + => Proxy (API auths) -> Application +app api = appWithCookie api cookieCfg + +server :: CookieSettings -> Server (API auths) +server ccfg = + (\authResult -> case authResult of + Authenticated usr -> getInt usr + :<|> postInt usr + :<|> getHeaderInt +#if MIN_VERSION_servant_server(0,15,0) + :<|> return (S.source ["bytestring"]) +#endif + :<|> raw + Indefinite -> throwAll err401 + _ -> throwAll err403 + ) + :<|> getLogin + :<|> getLogout + where + getInt :: User -> Handler Int + getInt usr = return . length $ name usr + + postInt :: User -> Int -> Handler Int + postInt _ = return + + getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int) + getHeaderInt = return $ addHeader 1797 17 + + getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie ] NoContent) + getLogin user = do + maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user + case maybeApplyCookies of + Just applyCookies -> return $ applyCookies NoContent + Nothing -> error "cookies failed to apply" + + getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie ] NoContent) + getLogout = return $ clearSession ccfg NoContent + + raw :: Server Raw + raw = +#if MIN_VERSION_servant_server(0,11,0) + Tagged $ +#endif + \_req respond -> + respond $ responseLBS status200 [("hi", "there")] "how are you?" + +-- }}} +------------------------------------------------------------------------------ +-- * 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" + +addJwtToHeader :: Either Error BSL.ByteString -> IO Options +addJwtToHeader jwt = case jwt of + Left e -> fail $ show e + Right v -> return + $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v] + +createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT) +createJWT k a b = runExceptT $ signClaims k a b + +addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options +addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of + Left e -> fail $ show e + Right v -> return + $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v] + +addCookie :: Options -> BS.ByteString -> Options +addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of + [h] -> [cookie' <> "; " <> h] + [] -> [cookie'] + _ -> error "expecting single cookie header" + + +shouldHTTPErrorWith :: IO a -> Status -> Expectation +shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of +#if MIN_VERSION_http_client(0,5,0) + HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _) + -> HCli.responseStatus resp == stat +#else + HCli.StatusCodeException x _ _ -> x == stat +#endif + _ -> False + +shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation +shouldMatchCookieNames cj patterns + = fmap cookie_name (destroyCookieJar cj) + `shouldMatchList` patterns + +shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation +shouldMatchCookieNameValues cj patterns + = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj) + `shouldMatchList` patterns + +url :: Int -> String +url port = "http://localhost:" <> show port + +claims :: Value -> ClaimsSet +claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val +-- }}} +------------------------------------------------------------------------------ +-- * 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 + +instance Postable User where + postPayload user request = return $ request + { HCli.requestBody = HCli.RequestBodyLBS $ encode user + , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request + } + + +-- }}} diff --git a/servant-auth/servant-auth-server/test/Spec.hs b/servant-auth/servant-auth-server/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth-server/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/servant-auth-swagger/.ghci b/servant-auth/servant-auth-swagger/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth-swagger/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth-swagger/CHANGELOG.md b/servant-auth/servant-auth-swagger/CHANGELOG.md new file mode 100644 index 00000000..7c14608a --- /dev/null +++ b/servant-auth/servant-auth-swagger/CHANGELOG.md @@ -0,0 +1,24 @@ +# 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.2.10.1] - 2020-10-06 + +### Changed + +- Support GHC 8.10 @domenkozar +- Fix build with swagger 2.5.x @domenkozar + +## [0.2.10.0] - 2018-06-18 + +### Added + +- Support for GHC 8.4 by @phadej +- Changelog by @domenkozar +- #93: Add Cookie in SwaggerSpec API by @domenkozar +- #42: Add dummy AllHasSecurity Cookie instance by @sordina diff --git a/servant-auth/servant-auth-swagger/LICENSE b/servant-auth/servant-auth-swagger/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth-swagger/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. + diff --git a/servant-auth/servant-auth-swagger/Setup.hs b/servant-auth/servant-auth-swagger/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-auth/servant-auth-swagger/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal b/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal new file mode 100644 index 00000000..fcc9b43b --- /dev/null +++ b/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal @@ -0,0 +1,70 @@ +name: servant-auth-swagger +version: 0.2.10.1 +synopsis: servant-swagger/servant-auth compatibility +description: This package provides instances that allow generating swagger2 schemas from + + APIs that use + @Auth@ combinator. + . + For a quick overview of the usage, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant-auth/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-auth + +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 + , text >= 1.2.3.0 && < 1.3 + , servant-swagger >= 1.1.5 && < 1.8 + , swagger2 >= 2.2.2 && < 2.7 + , servant >= 0.13 && < 0.19 + , servant-auth == 0.4.* + , lens >= 4.16.1 && < 5.1 + exposed-modules: + Servant.Auth.Swagger + 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 + , text + , servant-swagger + , swagger2 + , servant + , servant-auth + , lens + + -- test dependencies + build-depends: + servant-auth-swagger + , hspec >= 2.5.5 && < 2.9 + , QuickCheck >= 2.11.3 && < 2.15 + other-modules: + Servant.Auth.SwaggerSpec + default-language: Haskell2010 diff --git a/servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs b/servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs new file mode 100644 index 00000000..ec6314ca --- /dev/null +++ b/servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +module Servant.Auth.Swagger + ( + -- | The purpose of this package is provide the instance for 'servant-auth' + -- combinators needed for 'servant-swagger' documentation generation. + -- + -- Currently only JWT and BasicAuth are supported. + + -- * Re-export + JWT + , BasicAuth + , Auth + + -- * Needed to define instances of @HasSwagger@ + , HasSecurity (..) + ) where + +import Control.Lens ((&), (<>~)) +import Data.Proxy (Proxy (Proxy)) +import Data.Swagger (ApiKeyLocation (..), ApiKeyParams (..), + SecurityRequirement (..), SecurityScheme (..), +#if MIN_VERSION_swagger2(2,6,0) + SecurityDefinitions(..), +#endif + SecuritySchemeType (..), allOperations, security, + securityDefinitions) +import GHC.Exts (fromList) +import Servant.API hiding (BasicAuth) +import Servant.Auth +import Servant.Swagger + +import qualified Data.Text as T + +instance (AllHasSecurity xs, HasSwagger api) => HasSwagger (Auth xs r :> api) where + toSwagger _ + = toSwagger (Proxy :: Proxy api) + & securityDefinitions <>~ mkSec (fromList secs) + & allOperations.security <>~ secReqs + where + secs = securities (Proxy :: Proxy xs) + secReqs = [ SecurityRequirement (fromList [(s,[])]) | (s,_) <- secs] + mkSec = +#if MIN_VERSION_swagger2(2,6,0) + SecurityDefinitions +#else + id +#endif + + +class HasSecurity x where + securityName :: Proxy x -> T.Text + securityScheme :: Proxy x -> SecurityScheme + +instance HasSecurity BasicAuth where + securityName _ = "BasicAuth" + securityScheme _ = SecurityScheme type_ (Just desc) + where + type_ = SecuritySchemeBasic + desc = "Basic access authentication" + +instance HasSecurity JWT where + securityName _ = "JwtSecurity" + securityScheme _ = SecurityScheme type_ (Just desc) + where + type_ = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader) + desc = "JSON Web Token-based API key" + +class AllHasSecurity (x :: [*]) where + securities :: Proxy x -> [(T.Text,SecurityScheme)] + +instance {-# OVERLAPPABLE #-} (HasSecurity x, AllHasSecurity xs) => AllHasSecurity (x ': xs) where + securities _ = (securityName px, securityScheme px) : securities pxs + where + px :: Proxy x + px = Proxy + pxs :: Proxy xs + pxs = Proxy + +instance {-# OVERLAPPING #-} AllHasSecurity xs => AllHasSecurity (Cookie ': xs) where + securities _ = securities pxs + where + pxs :: Proxy xs + pxs = Proxy + +instance AllHasSecurity '[] where + securities _ = [] diff --git a/servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs b/servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs new file mode 100644 index 00000000..1bfda413 --- /dev/null +++ b/servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.SwaggerSpec (spec) where + +import Control.Lens +import Data.Proxy +import Servant.API +import Servant.Auth +import Servant.Auth.Swagger +import Data.Swagger +import Servant.Swagger +import Test.Hspec + +spec :: Spec +spec = describe "HasSwagger instance" $ do + + let swag = toSwagger (Proxy :: Proxy API) + + it "adds security definitions at the top level" $ do +#if MIN_VERSION_swagger2(2,6,0) + let (SecurityDefinitions secDefs) = swag ^. securityDefinitions +#else + let secDefs = swag ^. securityDefinitions +#endif + length secDefs `shouldSatisfy` (> 0) + + it "adds security at sub-apis" $ do + swag ^. security `shouldBe` [] + show (swag ^. paths . at "/secure") `shouldContain` "JwtSecurity" + show (swag ^. paths . at "/insecure") `shouldNotContain` "JwtSecurity" + +-- * API + +type API = "secure" :> Auth '[JWT, Cookie] Int :> SecureAPI + :<|> "insecure" :> InsecureAPI + +type SecureAPI = Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int + +type InsecureAPI = SecureAPI diff --git a/servant-auth/servant-auth-swagger/test/Spec.hs b/servant-auth/servant-auth-swagger/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth-swagger/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/servant-auth.project b/servant-auth/servant-auth.project new file mode 100644 index 00000000..64ef7535 --- /dev/null +++ b/servant-auth/servant-auth.project @@ -0,0 +1,6 @@ +packages: + servant-auth + servant-auth-client + servant-auth-docs + servant-auth-server + servant-auth-swagger diff --git a/servant-auth/servant-auth/.ghci b/servant-auth/servant-auth/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth/CHANGELOG.md b/servant-auth/servant-auth/CHANGELOG.md new file mode 100644 index 00000000..cb1d5b8f --- /dev/null +++ b/servant-auth/servant-auth/CHANGELOG.md @@ -0,0 +1,20 @@ +# 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.0.0] - 2020-10-06 + +- Support for GHC 8.10 by @domenkozar +- Support servant 0.18 by @domenkozar +- Move `ToJWT/FromJWT` from servant-auth-server + +## [0.3.2.0] - 2018-06-18 + +### Added +- Support for GHC 8.4 by @phadej +- Changelog by @domenkozar diff --git a/servant-auth/servant-auth/LICENSE b/servant-auth/servant-auth/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth/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. + diff --git a/servant-auth/servant-auth/Setup.hs b/servant-auth/servant-auth/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-auth/servant-auth/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth/servant-auth/servant-auth.cabal b/servant-auth/servant-auth/servant-auth.cabal new file mode 100644 index 00000000..b0b03733 --- /dev/null +++ b/servant-auth/servant-auth/servant-auth.cabal @@ -0,0 +1,46 @@ +name: servant-auth +version: 0.4.0.0 +synopsis: Authentication combinators for servant +description: This package provides an @Auth@ combinator for 'servant'. This combinator + allows using different authentication schemes in a straightforward way, + and possibly in conjunction with one another. + . + 'servant-auth' additionally provides concrete authentication schemes, such + as Basic Access Authentication, JSON Web Tokens, and Cookies. + . + For more details on how to use this, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant-auth/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-auth + +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 + , aeson >= 1.3.1.1 && < 1.6 + , jose >= 0.7.0.0 && < 0.9 + , lens >= 4.16.1 && < 5.1 + , servant >= 0.15 && < 0.19 + , text >= 1.2.3.0 && < 1.3 + , unordered-containers >= 0.2.9.0 && < 0.3 + exposed-modules: + Servant.Auth + Servant.Auth.JWT + default-language: Haskell2010 diff --git a/servant-auth/servant-auth/src/Servant/Auth.hs b/servant-auth/servant-auth/src/Servant/Auth.hs new file mode 100644 index 00000000..1ada6fe2 --- /dev/null +++ b/servant-auth/servant-auth/src/Servant/Auth.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Auth where + +import Data.Proxy (Proxy(..)) +import Servant.API ((:>)) +import Servant.Links (HasLink (..)) + +-- * Authentication + +-- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by +-- @auth1@ or @auth2@ +data Auth (auths :: [*]) val + +-- | A @HasLink@ instance for @Auth@ +instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where +#if MIN_VERSION_servant(0,14,0) + type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a + toLink toA _ = toLink toA (Proxy :: Proxy sub) +#else + type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) +#endif + +-- ** Combinators + +-- | A JSON Web Token (JWT) in the the Authorization header: +-- +-- @Authorization: Bearer \@ +-- +-- Note that while the token is signed, it is not encrypted. Therefore do not +-- keep in it any information you would not like the client to know. +-- +-- JWTs are described in IETF's +data JWT + +-- | A cookie. The content cookie itself is a JWT. Another cookie is also used, +-- the contents of which are expected to be send back to the server in a +-- header, for XSRF protection. +data Cookie + + +-- We could use 'servant''s BasicAuth, but then we don't get control over the +-- documentation, and we'd have to polykind everything. (Also, we don't +-- currently depend on servant!) +-- +-- | Basic Auth. +data BasicAuth + +-- | Login via a form. +data FormLogin form diff --git a/servant-auth/servant-auth/src/Servant/Auth/JWT.hs b/servant-auth/servant-auth/src/Servant/Auth/JWT.hs new file mode 100644 index 00000000..f02494ba --- /dev/null +++ b/servant-auth/servant-auth/src/Servant/Auth/JWT.hs @@ -0,0 +1,33 @@ +module Servant.Auth.JWT where + +import Control.Lens ((^.)) +import qualified Crypto.JWT as Jose +import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, + toJSON) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + + +-- This should probably also be from ClaimSet +-- +-- | How to decode data from a JWT. +-- +-- The default implementation assumes the data is stored in the unregistered +-- @dat@ claim, and uses the @FromJSON@ instance to decode value from there. +class FromJWT a where + decodeJWT :: Jose.ClaimsSet -> Either T.Text a + default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a + decodeJWT m = case HM.lookup "dat" (m ^. Jose.unregisteredClaims) of + Nothing -> Left "Missing 'dat' claim" + Just v -> case fromJSON v of + Error e -> Left $ T.pack e + Success a -> Right a + +-- | How to encode data from a JWT. +-- +-- The default implementation stores data in the unregistered @dat@ claim, and +-- uses the type's @ToJSON@ instance to encode the data. +class ToJWT a where + encodeJWT :: a -> Jose.ClaimsSet + default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet + encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet \ No newline at end of file diff --git a/servant-auth/servant-auth/test/Spec.hs b/servant-auth/servant-auth/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/stack-lts16.yaml b/servant-auth/stack-lts16.yaml new file mode 100644 index 00000000..448ecd42 --- /dev/null +++ b/servant-auth/stack-lts16.yaml @@ -0,0 +1,7 @@ +resolver: lts-16.31 +packages: +- servant-auth +- servant-auth-server +- servant-auth-client +- servant-auth-docs +- servant-auth-swagger diff --git a/servant-auth/stack-lts17.yaml b/servant-auth/stack-lts17.yaml new file mode 100644 index 00000000..ff877145 --- /dev/null +++ b/servant-auth/stack-lts17.yaml @@ -0,0 +1,7 @@ +resolver: lts-17.5 +packages: +- servant-auth +- servant-auth-server +- servant-auth-client +- servant-auth-docs +- servant-auth-swagger diff --git a/servant-auth/stack.yaml b/servant-auth/stack.yaml new file mode 100644 index 00000000..1d386554 --- /dev/null +++ b/servant-auth/stack.yaml @@ -0,0 +1,7 @@ +resolver: nightly-2021-06-01 +packages: +- servant-auth +- servant-auth-server +- servant-auth-client +- servant-auth-docs +- servant-auth-swagger