servant-auth-client (empty) → 0.1.0.0

raw patch · 8 files changed

+331/−0 lines, 8 filesdep +Globdep +QuickCheckdep +aesonsetup-changed

Dependencies added: Glob, QuickCheck, aeson, base, bytestring, doctest, hspec, http-client, http-types, jose, servant, servant-auth, servant-auth-client, servant-auth-server, servant-client, servant-server, text, time, transformers, wai, warp, yaml

Files

• LICENSE +31/−0
• Setup.hs +2/−0
• servant-auth-client.cabal +93/−0
• src/Servant/Auth/Client.hs +3/−0
• src/Servant/Auth/Client/Internal.hs +46/−0
• test/Doctest.hs +26/−0
• test/Servant/Auth/ClientSpec.hs +129/−0
• test/Spec.hs +1/−0

@@ -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.+

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

@@ -0,0 +1,93 @@+-- This file has been generated from package.yaml by hpack version 0.14.0.+--+-- see: https://github.com/sol/hpack++name:           servant-auth-client+version:        0.1.0.0+description:    Please see README.md+homepage:       http://github.com/jkarni/servant-auth-client#readme+bug-reports:    https://github.com/jkarni/servant-auth-client/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-client++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+    , bytestring+    , servant-client+    , servant-auth+    , servant+  exposed-modules:+      Servant.Auth.Client+      Servant.Auth.Client.Internal+  default-language: Haskell2010++test-suite doctest+  type: exitcode-stdio-1.0+  main-is: Doctest.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+    , bytestring+    , servant-client+    , servant-auth+    , servant+    , doctest >= 0.9 && < 0.12+    , Glob >= 0.7 && < 0.8+    , yaml == 0.8.*+  other-modules:+      Servant.Auth.ClientSpec+      Spec+  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+    , bytestring+    , servant-client+    , servant-auth+    , servant+    , servant-auth-client+    , hspec > 2 && < 3+    , QuickCheck >= 2.8 && < 2.9+    , aeson+    , bytestring+    , http-client+    , http-types+    , servant-auth-server+    , servant-server+    , time+    , transformers+    , wai+    , warp+    , jose+  other-modules:+      Doctest+      Servant.Auth.ClientSpec+  default-language: Haskell2010

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

@@ -0,0 +1,46 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+#endif+module Servant.Auth.Client.Internal where++import qualified Data.ByteString    as BS+import           Data.Monoid+import           Data.Proxy         (Proxy (..))+import           Data.String        (IsString)+import qualified Data.Text.Encoding as T+import           GHC.Exts           (Constraint)+import           GHC.Generics       (Generic)+import           Servant.API        ((:>))+import           Servant.Auth+import           Servant.Client+import           Servant.Common.Req (Req (..))++-- | A compact JWT Token.+newtype Token = Token { getToken :: BS.ByteString }+  deriving (Eq, Show, Read, Generic, IsString)+++    -- HasJWT auths is nominally a redundant constraint, but ensures we're not+    -- trying to send a token to an API that doesn't accept them.+instance (HasJWT auths, HasClient api) => HasClient (Auth auths a :> api) where++  type Client (Auth auths a :> api) = Token -> Client api++  clientWithRoute _ req (Token token)+   = clientWithRoute (Proxy :: Proxy api)+   $ req { headers = ("Authorization", headerVal):headers req  }+     where+       -- 'servant-client' shouldn't be using a Text here; it should be using a+       -- ByteString.+       headerVal = "Bearer " <> T.decodeLatin1 token++type family HasJWT xs :: Constraint where+  HasJWT (JWT ': xs) = ()+  HasJWT (x ': xs)   = HasJWT xs+  HasJWT '[]         = JWTAuthNotEnabled++class JWTAuthNotEnabled

@@ -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)

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

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