packages feed

servant-auth-server (empty) → 0.1.0.0

raw patch · 18 files changed

+1515/−0 lines, 18 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, base64-bytestring, blaze-builder, bytestring, case-insensitive, cookie, crypto-api, data-default-class, entropy, hspec, http-api-data, http-client, http-types, jose, lens, lens-aeson, markdown-unlit, monad-time, mtl, reflection, scrypt, servant-auth, servant-auth-server, servant-server, text, time, transformers, unordered-containers, wai, warp, wreq

Files

+ LICENSE view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ executables/README.lhs view
@@ -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++~~~
+ servant-auth-server.cabal view
@@ -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
+ src/Servant/Auth/Server.hs view
@@ -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
+ src/Servant/Auth/Server/Internal.hs view
@@ -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
+ src/Servant/Auth/Server/Internal/AddSetCookie.hs view
@@ -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
+ src/Servant/Auth/Server/Internal/BasicAuth.hs view
@@ -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
+ src/Servant/Auth/Server/Internal/Class.hs view
@@ -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
+ src/Servant/Auth/Server/Internal/ConfigTypes.hs view
@@ -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 <https://tools.ietf.org/html/draft-west-first-party-cookies-07 this document>+-- 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+-- }}}
+ src/Servant/Auth/Server/Internal/Cookie.hs view
@@ -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'
+ src/Servant/Auth/Server/Internal/FormLogin.hs view
@@ -0,0 +1,3 @@+module Servant.Auth.Server.Internal.FormLogin where++
+ src/Servant/Auth/Server/Internal/JWT.hs view
@@ -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)
+ src/Servant/Auth/Server/Internal/ThrowAll.hs view
@@ -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
+ src/Servant/Auth/Server/Internal/Types.hs view
@@ -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 = (<>)
+ test/Doctest.hs view
@@ -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)
+ test/Servant/Auth/ServerSpec.hs view
@@ -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++-- }}}
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}