diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/executables/README.lhs b/executables/README.lhs new file mode 100644 --- /dev/null +++ b/executables/README.lhs @@ -0,0 +1,250 @@ +# servant-auth + +[![Build Status](https://travis-ci.org/plow-technologies/servant-auth.svg?branch=master)](https://travis-ci.org/plow-technologies/servant-auth) + +This package provides safe and easy-to-use authentication options for +`servant`. The same API can be protected via login and cookies, or API tokens, +without much extra work. + + +## How it works + +This library introduces a combinator `Auth`: + +~~~ {.haskell ignore} +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 ignore} +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} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +import Control.Concurrent (forkIO) +import Control.Monad (forever) +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 + +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 + :<|> "login" :> ReqBody '[JSON] Login :> PostNoContent '[JSON] NoContent + + +-- | 'Protected' will be protected by 'auths', which we still have to specify. +protected :: 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 (Authenticated user) = + return (name user) :<|> return (email user) :<|> const (return NoContent) +-- Otherwise, if the user is logging in, we check the credentials. If not, +-- we reject the requests as unauthenticated. +protected _ = throwError err401 :<|> throwError err401 :<|> checkCreds + +type Unprotected = Get '[JSON] () + +unprotected :: Server Unprotected +unprotected = return () + +type API auths = (Auth auths User :> Protected) :<|> Unprotected + +server :: Server (API auths) +server = protected :<|> unprotected + +~~~ + +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 + + 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 '[JWT]) + run 7249 $ serveWithContext api cfg server + + +-- Here is the login handler +checkCreds :: Login -> Handler NoContent +checkCreds (Login "Ali Baba" "Open Sesame") = return NoContent +checkCreds _ = throwError err401 +~~~ + +### CSRF and the frontend + +CSRF 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 your are 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. + +# 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 -> error $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage + +~~~ diff --git a/servant-auth-server.cabal b/servant-auth-server.cabal new file mode 100644 --- /dev/null +++ b/servant-auth-server.cabal @@ -0,0 +1,149 @@ +-- This file has been generated from package.yaml by hpack version 0.14.0. +-- +-- see: https://github.com/sol/hpack + +name: servant-auth-server +version: 0.1.0.0 +description: Please see README.md +homepage: http://github.com/jkarni/servant-auth-server#readme +bug-reports: https://github.com/jkarni/servant-auth-server/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD3 +license-file: LICENSE +tested-with: GHC == 7.10.2, GHC == 8.0.1 +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/jkarni/servant-auth-server + +library + hs-source-dirs: + src + default-extensions: AutoDeriveTypeable 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.7 && < 4.10 + , text + , servant-auth + , cookie >= 0.4 && < 0.5 + , wai + , mtl + , bytestring + , case-insensitive + , jose + , monad-time + , time + , servant-server + , base64-bytestring + , blaze-builder + , reflection + , unordered-containers + , aeson + , lens + , entropy + , scrypt + , crypto-api + , data-default-class + , http-api-data + 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 + default-language: Haskell2010 + +executable readme + main-is: README.lhs + hs-source-dirs: + executables + default-extensions: AutoDeriveTypeable 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-depends: + base >= 4.7 && < 4.10 + , text + , servant-auth + , cookie >= 0.4 && < 0.5 + , wai + , mtl + , bytestring + , case-insensitive + , jose + , monad-time + , time + , servant-server + , base64-bytestring + , blaze-builder + , reflection + , unordered-containers + , aeson + , lens + , entropy + , scrypt + , crypto-api + , data-default-class + , http-api-data + , servant-auth + , servant-auth-server + , servant-server + , warp + , markdown-unlit + , transformers + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable 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.7 && < 4.10 + , text + , servant-auth + , cookie >= 0.4 && < 0.5 + , wai + , mtl + , bytestring + , case-insensitive + , jose + , monad-time + , time + , servant-server + , base64-bytestring + , blaze-builder + , reflection + , unordered-containers + , aeson + , lens + , entropy + , scrypt + , crypto-api + , data-default-class + , http-api-data + , servant-auth-server + , hspec > 2 && < 3 + , QuickCheck >= 2.8 && < 2.9 + , aeson + , wai + , lens + , lens-aeson + , warp + , wreq + , http-types + , http-client + other-modules: + Doctest + Servant.Auth.ServerSpec + default-language: Haskell2010 diff --git a/src/Servant/Auth/Server.hs b/src/Servant/Auth/Server.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server.hs @@ -0,0 +1,114 @@ +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'. + + ---------------------------------------------------------------------------- + -- * Auth + -- | Basic types + Auth + , AuthResult(..) + + ---------------------------------------------------------------------------- + -- * 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 + + + ---------------------------------------------------------------------------- + -- * 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(..) + , defaultCookieSettings + + -- ** Related types + , IsSecure(..) + + , AreAuths + + ---------------------------------------------------------------------------- + -- * BasicAuth + -- ** Combinator + -- | Re-exported from 'servant-auth' + , BasicAuth + + -- ** Classes + , FromBasicAuthData(..) + + -- ** Settings + , BasicAuthCfg + + -- ** Related types + , BasicAuthData(..) + , IsPasswordCorrect(..) + + ---------------------------------------------------------------------------- + -- * Utilies + , ThrowAll(throwAll) + , generateKey + , makeJWT + + -- ** Re-exports + , Default(def) + ) where + +import Data.Default.Class (Default (def)) +import Servant.Auth +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.JWT +import Servant.Auth.Server.Internal.ThrowAll +import Servant.Auth.Server.Internal.Types + +import Servant (BasicAuthData(..)) +import Crypto.JOSE as Jose + +-- | Generate a key suitable for use with 'defaultConfig'. +generateKey :: IO Jose.JWK +generateKey = Jose.genJWK $ Jose.OctGenParam 256 diff --git a/src/Servant/Auth/Server/Internal.hs b/src/Servant/Auth/Server/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Auth.Server.Internal where + +import Control.Monad.Trans (liftIO) +import qualified Crypto.JOSE as Jose +import qualified Crypto.JWT as Jose +import qualified Data.ByteString.Lazy as BSL +import Servant ((:>), Handler, HasServer (..), + Proxy (..), HasContextEntry(getContextEntry)) +import Servant.Auth +import qualified Web.Cookie as Cookie + +import Servant.Auth.Server.Internal.AddSetCookie +import Servant.Auth.Server.Internal.Class +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.JWT +import Servant.Auth.Server.Internal.Types + +import Servant.Server.Internal.RoutingApplication + +instance ( HasServer (AddSetCookieApi api) ctxs, AreAuths auths ctxs v + , AddSetCookie (ServerT api Handler) (ServerT (AddSetCookieApi 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 + + route _ context subserver = + route (Proxy :: Proxy (AddSetCookieApi api)) + context + (fmap go subserver `addAuthCheck` authCheck) + + where + authCheck :: DelayedIO (AuthResult v, [Cookie.SetCookie]) + authCheck = withRequest $ \req -> liftIO $ do + authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req + csrf' <- csrfCookie + let csrf = Cookie.def + { Cookie.setCookieName = xsrfCookieName cookieSettings + , Cookie.setCookieValue = csrf' + , Cookie.setCookieMaxAge = cookieMaxAge cookieSettings + , Cookie.setCookieExpires = cookieExpires cookieSettings + , Cookie.setCookieSecure = case cookieIsSecure cookieSettings of + Secure -> True + NotSecure -> False + } + cookies <- makeCookies authResult + return (authResult, csrf : cookies ) + + jwtSettings :: JWTSettings + jwtSettings = getContextEntry context + + cookieSettings :: CookieSettings + cookieSettings = getContextEntry context + + makeCookies :: AuthResult v -> IO [Cookie.SetCookie] + makeCookies (Authenticated v) = do + ejwt <- Jose.createJWSJWT (key jwtSettings) + (Jose.newJWSHeader (Jose.Protected, Jose.HS256)) + (encodeJWT v) + case ejwt >>= Jose.encodeCompact of + Left _ -> return [] + Right jwt -> return [Cookie.def + { Cookie.setCookieName = "JWT-Cookie" + , Cookie.setCookieValue = BSL.toStrict jwt + , Cookie.setCookieHttpOnly = True + , Cookie.setCookieMaxAge = cookieMaxAge cookieSettings + , Cookie.setCookieExpires = cookieExpires cookieSettings + , Cookie.setCookieSecure = case cookieIsSecure cookieSettings of + Secure -> True + NotSecure -> False + }] + makeCookies _ = return [] + + + -- See note in AddSetCookie.hs about what this is doing. + go :: (old ~ ServerT api Handler + , new ~ ServerT (AddSetCookieApi api) Handler + ) => (AuthResult v -> ServerT api Handler) + -> (AuthResult v, [Cookie.SetCookie]) -> new + go fn (authResult, csrf) = addSetCookie csrf $ fn authResult diff --git a/src/Servant/Auth/Server/Internal/AddSetCookie.hs b/src/Servant/Auth/Server/Internal/AddSetCookie.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/AddSetCookie.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.AddSetCookie where + +import Blaze.ByteString.Builder (toByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS64 +import Data.Monoid +import Servant +import System.Entropy (getEntropy) +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. + + +type family AddSetCookieApi a where + AddSetCookieApi (a :> b) = a :> AddSetCookieApi b + AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b + AddSetCookieApi (Verb method stat ctyps a) + = Verb method stat ctyps (Headers '[Header "Set-Cookie" BS.ByteString] a) + AddSetCookieApi (Headers ls a) = Headers ((Header "Set-Cookie" BS.ByteString) ': ls) a + + +class AddSetCookie orig new where + addSetCookie :: [SetCookie] -> orig -> new + +instance {-# OVERLAPS #-} AddSetCookie oldb newb + => AddSetCookie (a -> oldb) (a -> newb) where + addSetCookie cookie oldfn = \val -> addSetCookie cookie $ oldfn val + +instance {-# OVERLAPPABLE #-} + ( Functor m + ) => AddSetCookie (m a) (m (Headers '[Header "Set-Cookie" BS.ByteString] a)) where + addSetCookie cookie v = addSetCookie cookie <$> v + +instance {-# OVERLAPS #-} + (AddSetCookie a a', AddSetCookie b b') + => AddSetCookie (a :<|> b) (a' :<|> b') where + addSetCookie cookie (a :<|> b) = addSetCookie cookie a :<|> addSetCookie cookie b + +instance {-# OVERLAPPABLE #-} + (AddHeader "Set-Cookie" BS.ByteString old new) + => AddSetCookie old new where + addSetCookie cookie val + -- What is happening here is sheer awfulness. Look the other way. + = addHeader (foldr1 go $ toByteString . renderSetCookie <$> cookie) val + where + go new old = old <> "\r\nSet-Cookie: " <> new + + +csrfCookie :: IO BS.ByteString +csrfCookie = BS64.encode <$> getEntropy 32 diff --git a/src/Servant/Auth/Server/Internal/BasicAuth.hs b/src/Servant/Auth/Server/Internal/BasicAuth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/BasicAuth.hs @@ -0,0 +1,29 @@ +module Servant.Auth.Server.Internal.BasicAuth where + +import qualified Data.ByteString as BS +import Servant (BasicAuthData (..), + ServantErr (..), err401) +import Servant.Server.Internal.BasicAuth (decodeBAHdr, + mkBAChallengerHdr) + + +import Servant.Auth.Server.Internal.Types + +-- | A 'ServantErr' that asks the client to authenticated via Basic +-- Authentication. The argument is the realm. +wwwAuthenticatedErr :: BS.ByteString -> ServantErr +wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] } + +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/src/Servant/Auth/Server/Internal/Class.hs b/src/Servant/Auth/Server/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/Class.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.Class where + +import Servant.Auth +import Data.Monoid +import Servant hiding (BasicAuth) + +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 + +-- | @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/src/Servant/Auth/Server/Internal/ConfigTypes.hs b/src/Servant/Auth/Server/Internal/ConfigTypes.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/ConfigTypes.hs @@ -0,0 +1,89 @@ +module Servant.Auth.Server.Internal.ConfigTypes where + +import Control.Lens +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) + +data IsMatch = Matches | DoesNotMatch + deriving (Eq, Show, Read, Generic, Ord) + +data IsSecure = Secure | NotSecure + 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 :: Jose.JWK + -- | 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 { key = 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 + -- | 'SameSite' settings. Default: @SameSiteLax@. + , cookieSameSite :: SameSite + -- | What name to use for the cookie used for CSRF protection. + , xsrfCookieName :: BS.ByteString + -- | What name to use for the header used for CSRF protection. + , xsrfHeaderName :: BS.ByteString + } deriving (Eq, Show, Generic) + +instance Default CookieSettings where + def = defaultCookieSettings + +defaultCookieSettings :: CookieSettings +defaultCookieSettings = CookieSettings + { cookieIsSecure = Secure + , cookieMaxAge = Nothing + , cookieExpires = Nothing + , cookieSameSite = SameSiteLax + , xsrfCookieName = "XSRF-TOKEN" + , xsrfHeaderName = "X-XSRF-TOKEN" + } + + +------------------------------------------------------------------------------ +-- Internal {{{ + +jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings +jwtSettingsToJwtValidationSettings s + = defaultJWTValidationSettings + & audiencePredicate .~ (toBool <$> audienceMatches s) + where + toBool Matches = True + toBool DoesNotMatch = False +-- }}} diff --git a/src/Servant/Auth/Server/Internal/Cookie.hs b/src/Servant/Auth/Server/Internal/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/Cookie.hs @@ -0,0 +1,39 @@ +module Servant.Auth.Server.Internal.Cookie where + +import Control.Monad.Except +import Control.Monad.Reader +import qualified Crypto.JOSE as Jose +import qualified Crypto.JWT as Jose +import Crypto.Util (constTimeEq) +import qualified Data.ByteString.Lazy as BSL +import Data.CaseInsensitive (mk) +import Network.Wai (requestHeaders) +import Web.Cookie + +import Servant.Auth.Server.Internal.JWT (FromJWT (decodeJWT)) +import Servant.Auth.Server.Internal.Types +import Servant.Auth.Server.Internal.ConfigTypes + + +cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr +cookieAuthCheck ccfg jwtCfg = do + req <- ask + jwtCookie <- maybe mempty return $ do + cookies' <- lookup "Cookie" $ requestHeaders req + let cookies = parseCookies cookies' + xsrfCookie <- lookup (xsrfCookieName ccfg) cookies + xsrfHeader <- lookup (mk $ xsrfHeaderName ccfg) $ requestHeaders req + guard $ xsrfCookie `constTimeEq` xsrfHeader + -- JWT-Cookie *must* be HttpOnly and Secure + lookup "JWT-Cookie" cookies + verifiedJWT <- liftIO $ runExceptT $ do + unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict jwtCookie + Jose.validateJWSJWT (jwtSettingsToJwtValidationSettings jwtCfg) + (key jwtCfg) + unverifiedJWT + return unverifiedJWT + case verifiedJWT of + Left (_ :: Jose.JWTError) -> mzero + Right v -> case decodeJWT v of + Left _ -> mzero + Right v' -> return v' diff --git a/src/Servant/Auth/Server/Internal/FormLogin.hs b/src/Servant/Auth/Server/Internal/FormLogin.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/FormLogin.hs @@ -0,0 +1,3 @@ +module Servant.Auth.Server.Internal.FormLogin where + + diff --git a/src/Servant/Auth/Server/Internal/JWT.hs b/src/Servant/Auth/Server/Internal/JWT.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/JWT.hs @@ -0,0 +1,82 @@ +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 Crypto.Util (constTimeEq) +import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, + toJSON) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Data.Time (UTCTime) +import Network.Wai (requestHeaders) + +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.Types + +-- 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.JWT -> Either T.Text a + default decodeJWT :: FromJSON a => Jose.JWT -> Either T.Text a + decodeJWT m = case HM.lookup "dat" (Jose._unregisteredClaims $ Jose.jwtClaimsSet m ) 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 + +jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr +jwtAuthCheck config = 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 `constTimeEq` bearer) + return rest + verifiedJWT <- liftIO $ runExceptT $ do + unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict token + Jose.validateJWSJWT (jwtSettingsToJwtValidationSettings config) + (key config) + unverifiedJWT + return unverifiedJWT + case verifiedJWT of + Left (_ :: Jose.JWTError) -> mzero + Right v -> case decodeJWT v of + Left _ -> mzero + Right 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 = do + ejwt <- Jose.createJWSJWT (key cfg) + (Jose.newJWSHeader (Jose.Protected, Jose.HS256)) + (addExp $ encodeJWT v) + + return $ ejwt >>= Jose.encodeCompact + where + addExp claims = case expiry of + Nothing -> claims + Just e -> claims & Jose.claimExp .~ Just (Jose.NumericDate e) diff --git a/src/Servant/Auth/Server/Internal/ThrowAll.hs b/src/Servant/Auth/Server/Internal/ThrowAll.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/ThrowAll.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.ThrowAll where + +import Control.Monad.Error.Class +import Servant ((:<|>) (..), ServantErr) + +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 :: ServantErr -> 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 {-# OVERLAPS #-} ThrowAll b => ThrowAll (a -> b) where + throwAll e = const $ throwAll e + +instance {-# OVERLAPPABLE #-} (MonadError ServantErr m) => ThrowAll (m a) where + throwAll = throwError diff --git a/src/Servant/Auth/Server/Internal/Types.hs b/src/Servant/Auth/Server/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Server/Internal/Types.hs @@ -0,0 +1,95 @@ +module Servant.Auth.Server.Internal.Types where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.Time +import Data.Monoid +import Data.Time (getCurrentTime) +import GHC.Generics (Generic) +import Network.Wai (Request) + +-- | 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 Monoid (AuthResult val) where + mempty = Indefinite + Indefinite `mappend` x = x + x `mappend` _ = x + +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. +newtype AuthCheck val = AuthCheck + { runAuthCheck :: Request -> IO (AuthResult val) } + deriving (Generic, Functor) + +instance Monoid (AuthCheck val) where + mempty = AuthCheck $ const $ return mempty + AuthCheck f `mappend` AuthCheck g = AuthCheck $ \x -> do + fx <- f x + gx <- g x + return $ fx <> gx + +instance Applicative AuthCheck where + pure = return + (<*>) = ap + +instance Monad AuthCheck where + return = AuthCheck . return . return . return + fail _ = AuthCheck . const $ return Indefinite + 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 + +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/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,26 @@ +module Main (main) where + +-- Runs doctest on all files in "src" dir. Assumes: +-- (a) You are using hpack +-- (b) The top-level "default-extensions" are the only extensions besides the +-- ones in the files. + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) +import Data.Yaml + +newtype Exts = Exts { getExts :: [String] } + deriving (Eq, Show, Read) + +instance FromJSON Exts where + parseJSON (Object v) = Exts <$> v .: "default-extensions" + parseJSON _ = fail "expecting object" + +main :: IO () +main = do + hpack' <- decodeFile "package.yaml" + hpack <- case hpack' of + Nothing -> return $ Exts [] + Just v -> return v + files <- glob "src/**/*.hs" + doctest $ files ++ fmap ("-X" ++) (getExts hpack) diff --git a/test/Servant/Auth/ServerSpec.hs b/test/Servant/Auth/ServerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Auth/ServerSpec.hs @@ -0,0 +1,368 @@ +module Servant.Auth.ServerSpec (spec) where + +import Control.Lens +import Crypto.JOSE (Alg (HS256, None), Error, JWK, + KeyMaterialGenParam (OctGenParam), + Protection (Protected), ToCompact, + encodeCompact, genJWK, newJWSHeader) +import Crypto.JWT (Audience (..), ClaimsSet, + NumericDate (NumericDate), claimAud, + claimNbf, createJWSJWT, + emptyClaimsSet, unregisteredClaims) +import Data.Aeson (FromJSON, ToJSON, Value, toJSON) +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 GHC.Generics (Generic) +import Network.HTTP.Client (HttpException (StatusCodeException), + cookie_http_only, cookie_name, + cookie_value, destroyCookieJar) +import Network.HTTP.Types (Status, status200, status401) +import Network.Wai (Application) +import Network.Wai.Handler.Warp (testWithApplication) +import Network.Wreq (Options, auth, basicAuth, + cookieExpiryTime, cookies, defaults, + get, getWith, header, oauth2Bearer, + responseBody, responseCookieJar, + responseStatus) +import Servant hiding (BasicAuth, IsSecure (..)) +import Servant.Auth.Server +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec +import Test.QuickCheck + +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 -- (newJWSHeader (Protected, HS256)) + {-(claims $ toJSON user)-} + 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" + + context "Setting cookies" $ do + + it "sets cookies that it itself accepts" $ \port -> property $ \user -> do + jwt <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie jwt + let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just xxsrf = find (\x -> cookie_name x == xsrfCookieName cookieCfg) + $ destroyCookieJar cookieJar + opts2 = defaults + & cookies .~ Just cookieJar + & header (mk (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 <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie jwt + let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just xxsrf = find (\x -> cookie_name x == xsrfCookieName cookieCfg) + $ destroyCookieJar cookieJar + xxsrf ^. cookieExpiryTime `shouldBe` future + + it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do + jwt <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie jwt + let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just token = find (\x -> cookie_name x == "JWT-Cookie") + $ destroyCookieJar cookieJar + cookie_http_only token `shouldBe` True + + + +-- }}} +------------------------------------------------------------------------------ +-- * Cookie Auth {{{ + +cookieAuthSpec :: Spec +cookieAuthSpec + = describe "The Auth combinator" + $ around (testWithApplication . return $ app cookieOnlyApi) $ do + + it "fails if CSRF header and cookie don't match" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie jwt + let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfCookieName cookieCfg <> "=blerg") + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "fails if there is no CSRF header and cookie" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) (claims $ toJSON user) + opts <- addJwtToCookie jwt + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if CSRF header and cookie match, and JWT is valid" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie jwt + let opts = addCookie (opts' & header (mk (xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + +-- }}} +------------------------------------------------------------------------------ +-- * 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 <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) + (claims (toJSON user) & claimAud .~ Just (Audience ["boo"])) + opts <- addJwtToHeader (jwt >>= encodeCompact) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if 'aud' does match predicate" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) + (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"])) + opts <- addJwtToHeader (jwt >>= 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 <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) + (claims (toJSON user) & claimNbf .~ Just (NumericDate future)) + opts <- addJwtToHeader (jwt >>= 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 <- createJWSJWT theKey (newJWSHeader (Protected, None)) + (claims $ toJSON user) + opts <- addJwtToHeader (jwt >>= 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 <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) (claims "{{") + opts <- addJwtToHeader (jwt >>= encodeCompact) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do + jwt <- createJWSJWT theKey (newJWSHeader (Protected, HS256)) + (claims $ toJSON user) + resp <- case jwt >>= 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 ServantErr Int :<|> Either ServantErr Bool :<|> Either ServantErr String + t = throwAll err401 + t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401 + + it "works for function types" $ property $ \i -> do + let t :: Int -> (Either ServantErr Bool :<|> Either ServantErr 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 + +jwtOnlyApi :: Proxy (API '[JWT]) +jwtOnlyApi = Proxy + +cookieOnlyApi :: Proxy (API '[Cookie]) +cookieOnlyApi = Proxy + +basicAuthApi :: Proxy (API '[BasicAuth]) +basicAuthApi = Proxy + +jwtAndCookieApi :: Proxy (API '[JWT, Cookie]) +jwtAndCookieApi = Proxy + +theKey :: JWK +theKey = unsafePerformIO . genJWK $ OctGenParam 256 +{-# NOINLINE theKey #-} + + +cookieCfg :: CookieSettings +cookieCfg = def + { xsrfCookieName = "TheyDinedOnMince" + , xsrfHeaderName = "AndSlicesOfQuince" + , cookieExpires = Just future + , cookieIsSecure = NotSecure + } + +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 + +-- | Takes a proxy parameter indicating which authentication systems to enable. +app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User + => Proxy (API auths) -> Application +app api = serveWithContext api ctx server + where + ctx = cookieCfg :. jwtCfg :. theKey :. EmptyContext + + +server :: Server (API auths) +server = getInt + where + getInt :: AuthResult User -> Handler Int + getInt (Authenticated usr) = return . length $ name usr + getInt Indefinite = throwError err401 + getInt _ = throwError err403 + +-- }}} +------------------------------------------------------------------------------ +-- * 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] + +addJwtToCookie :: ToCompact a => Either Error a -> IO Options +addJwtToCookie jwt = case jwt >>= encodeCompact of + Left e -> fail $ show e + Right v -> return + $ defaults & header "Cookie" .~ ["JWT-Cookie=" <> 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 + StatusCodeException x _ _ -> x == stat + _ -> False + +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 + +-- }}} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}