From c71182233b2ac8d4b2021dc4b506c0d787cbfd33 Mon Sep 17 00:00:00 2001 From: Martin Allen Date: Tue, 22 Nov 2016 20:14:29 -0500 Subject: [PATCH 1/6] first approx --- .../Servant/Auth/Server/Internal/FormLogin.hs | 32 +++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs index 5301640..6bf9d67 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs @@ -1,3 +1,35 @@ module Servant.Auth.Server.Internal.FormLogin where +import Control.Monad.Trans (liftIO) +import Data.Aeson (FromJSON, decode) +import qualified Data.ByteString.Lazy as BL +import GHC.Generics (Generic) +import Servant (ServantErr (..), + err401, err403) +import Network.Wai (Request, requestBody) + +import Servant.Server.Internal.RoutingApplication +import Servant.Auth.Server.Internal.Types + +type family LoginData + +newtype FormLoginCheck a = + FormLoginCheck {runFormLoginCheck :: LoginData -> IO (AuthResult a)} + deriving (Generic, Functor) + +-- | Run and check basic authentication, returning the appropriate http error per +-- the spec. +runFormLogin :: (LoginData ~ form, FromJSON form) + => Request -> FormLoginCheck a -> DelayedIO (AuthResult a) +runFormLogin req (FormLoginCheck fl) = do + bdy <- liftIO $ requestBody req + case decode $ BL.fromStrict bdy of + Nothing -> plzAuthenticate + Just f -> do + res <- liftIO $ fl f + case res of + BadPassword -> plzAuthenticate + NoSuchUser -> plzAuthenticate + Authenticated a -> return $ Authenticated a + where plzAuthenticate = delayedFailFatal err401 From 15200e4b0864e8c2083ca0efad9992c8aba762d2 Mon Sep 17 00:00:00 2001 From: Martin Allen Date: Tue, 22 Nov 2016 22:03:25 -0500 Subject: [PATCH 2/6] finish FormLogin --- .../src/Servant/Auth/Server.hs | 13 ++++++ .../src/Servant/Auth/Server/Internal/Class.hs | 9 +++++ .../Servant/Auth/Server/Internal/FormLogin.hs | 40 +++++++------------ 3 files changed, 37 insertions(+), 25 deletions(-) diff --git a/servant-auth-server/src/Servant/Auth/Server.hs b/servant-auth-server/src/Servant/Auth/Server.hs index d44d3cd..02084e4 100644 --- a/servant-auth-server/src/Servant/Auth/Server.hs +++ b/servant-auth-server/src/Servant/Auth/Server.hs @@ -89,6 +89,18 @@ module Servant.Auth.Server , BasicAuthData(..) , IsPasswordCorrect(..) + ---------------------------------------------------------------------------- + -- * FormLogin + -- ** Combinator + -- | Re-exported from 'servant-auth' + , FormLogin + + -- ** Classes + , FromFormLoginData(..) + + -- ** Related types + , FormLoginData + ---------------------------------------------------------------------------- -- * Utilies , ThrowAll(throwAll) @@ -107,6 +119,7 @@ import Servant.Auth.Server.Internal.BasicAuth import Servant.Auth.Server.Internal.Class import Servant.Auth.Server.Internal.ConfigTypes import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.FormLogin import Servant.Auth.Server.Internal.JWT import Servant.Auth.Server.Internal.ThrowAll import Servant.Auth.Server.Internal.Types diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs index 4385e64..c1f7d70 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs @@ -1,6 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Auth.Server.Internal.Class where +import Data.Aeson (FromJSON) import Servant.Auth import Data.Monoid import Servant hiding (BasicAuth) @@ -9,6 +10,7 @@ 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.FormLogin import Servant.Auth.Server.Internal.JWT -- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all @@ -30,6 +32,13 @@ instance FromBasicAuthData usr => IsAuth BasicAuth usr where type AuthArgs BasicAuth = '[BasicAuthCfg] runAuth _ _ = basicAuthCheck +instance (FromFormLoginData usr, + form ~ FormLoginData, + FromJSON form + ) => IsAuth (FormLogin form) usr where + type AuthArgs (FormLogin form) = '[] + runAuth _ _ = formLoginCheck + -- * Helper class AreAuths (as :: [*]) (ctxs :: [*]) v where diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs index 6bf9d67..d4ed12e 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs @@ -1,35 +1,25 @@ module Servant.Auth.Server.Internal.FormLogin where -import Control.Monad.Trans (liftIO) import Data.Aeson (FromJSON, decode) import qualified Data.ByteString.Lazy as BL -import GHC.Generics (Generic) -import Servant (ServantErr (..), - err401, err403) -import Network.Wai (Request, requestBody) +import Network.Wai (requestBody) -import Servant.Server.Internal.RoutingApplication import Servant.Auth.Server.Internal.Types -type family LoginData +type family FormLoginData -newtype FormLoginCheck a = - FormLoginCheck {runFormLoginCheck :: LoginData -> IO (AuthResult a)} - deriving (Generic, Functor) +class FromFormLoginData a where + -- | Represents an object that can be constructed from FormLoginData + -- inside the IO monad with possible failure. + fromLoginData :: FormLoginData -> IO (AuthResult a) --- | Run and check basic authentication, returning the appropriate http error per --- the spec. -runFormLogin :: (LoginData ~ form, FromJSON form) - => Request -> FormLoginCheck a -> DelayedIO (AuthResult a) -runFormLogin req (FormLoginCheck fl) = do - bdy <- liftIO $ requestBody req +-- | An AuthCheck for requests containing LoginFormData in the body. +formLoginCheck :: (FormLoginData ~ form, + FromJSON form, + FromFormLoginData a + ) => AuthCheck a +formLoginCheck = AuthCheck $ \req -> do + bdy <- requestBody req case decode $ BL.fromStrict bdy of - Nothing -> plzAuthenticate - Just f -> do - res <- liftIO $ fl f - case res of - BadPassword -> plzAuthenticate - NoSuchUser -> plzAuthenticate - Authenticated a -> return $ Authenticated a - where plzAuthenticate = delayedFailFatal err401 - + Nothing -> return Indefinite + Just f -> fromLoginData f From 74378f0c9cd5398d23f1efcc06a4465efd1f3461 Mon Sep 17 00:00:00 2001 From: Martin Allen Date: Tue, 22 Nov 2016 22:04:01 -0500 Subject: [PATCH 3/6] passing tests --- .../test/Servant/Auth/ServerSpec.hs | 54 +++++++++++++++++-- 1 file changed, 51 insertions(+), 3 deletions(-) diff --git a/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth-server/test/Servant/Auth/ServerSpec.hs index 41823c2..075d875 100644 --- a/servant-auth-server/test/Servant/Auth/ServerSpec.hs +++ b/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -23,19 +23,21 @@ 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.HTTP.Types (Status, status200, status401, status403) import Network.Wai.Handler.Warp (testWithApplication) import Network.Wreq (Options, auth, basicAuth, cookieExpiryTime, cookies, defaults, get, getWith, header, oauth2Bearer, responseBody, responseCookieJar, - responseStatus) + responseStatus, post, postWith) import Servant hiding (BasicAuth, IsSecure (..)) import Servant.Auth.Server import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.QuickCheck +import qualified Servant.Auth.Server.Internal.Types as AuthTypes + spec :: Spec spec = do authSpec @@ -43,6 +45,7 @@ spec = do jwtAuthSpec throwAllSpec basicAuthSpec + formLoginAuthSpec ------------------------------------------------------------------------------ -- * Auth {{{ @@ -232,6 +235,30 @@ basicAuthSpec = describe "The BasicAuth combinator" get (url port) `shouldHTTPErrorWith` status401 -- }}} +------------------------------------------------------------------------------ +-- * FormLogin {{{ + +formLoginAuthSpec :: Spec +formLoginAuthSpec = describe "The FormLogin combinator" + $ around (testWithApplication . return $ app formLoginApi) $ do + + it "succeeds with the correct password and username" $ \port -> do + resp <- postWith defaults (url port) (toJSON $ SimpleForm "ali" "Open sesame") + resp ^. responseStatus `shouldBe` status200 + + it "fails with non-existent user" $ \port -> do + postWith defaults (url port) (toJSON $ SimpleForm "jafar" "Open sesame") + `shouldHTTPErrorWith` status403 + + it "fails with incorrect password" $ \port -> do + postWith defaults (url port) (toJSON $ SimpleForm "ali" "???") + `shouldHTTPErrorWith` status403 + + it "fails with no auth header" $ \port -> do + post (url port) (toJSON ()) + `shouldHTTPErrorWith` status401 +-- }}} + ------------------------------------------------------------------------------ -- * ThrowAll {{{ @@ -254,6 +281,7 @@ throwAllSpec = describe "throwAll" $ do -- * API and Server {{{ type API auths = Auth auths User :> Get '[JSON] Int + :<|> Auth auths User :> Post '[JSON] Int jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) jwtOnlyApi = Proxy @@ -264,6 +292,9 @@ cookieOnlyApi = Proxy basicAuthApi :: Proxy (API '[BasicAuth]) basicAuthApi = Proxy +formLoginApi :: Proxy (API '[FormLogin SimpleForm]) +formLoginApi = Proxy + jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie]) jwtAndCookieApi = Proxy @@ -303,7 +334,7 @@ app api = serveWithContext api ctx server server :: Server (API auths) -server = getInt +server = getInt :<|> getInt where getInt :: AuthResult User -> Handler Int getInt (Authenticated usr) = return . length $ name usr @@ -368,4 +399,21 @@ instance ToJSON User instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary +data SimpleForm = SimpleForm + { username :: String + , password :: String + } deriving (Eq, Show, Read, Generic) + +instance ToJSON SimpleForm +instance FromJSON SimpleForm + +type instance FormLoginData = SimpleForm + +instance FromFormLoginData User where + fromLoginData (SimpleForm usr pwd) = if usr == "ali" && pwd == "Open sesame" + then return $ AuthTypes.Authenticated $ User "ali" "1" + else if usr == "ali" + then return AuthTypes.BadPassword + else return AuthTypes.NoSuchUser + -- }}} From beda1d643806b0105b97bb8a8fcfc306b649fc40 Mon Sep 17 00:00:00 2001 From: Martin Allen Date: Wed, 23 Nov 2016 19:34:22 -0500 Subject: [PATCH 4/6] use associated type --- servant-auth-server/src/Servant/Auth/Server.hs | 3 --- .../src/Servant/Auth/Server/Internal/Class.hs | 3 +-- .../src/Servant/Auth/Server/Internal/FormLogin.hs | 9 ++++----- servant-auth-server/test/Servant/Auth/ServerSpec.hs | 5 ++--- 4 files changed, 7 insertions(+), 13 deletions(-) diff --git a/servant-auth-server/src/Servant/Auth/Server.hs b/servant-auth-server/src/Servant/Auth/Server.hs index 02084e4..87f7815 100644 --- a/servant-auth-server/src/Servant/Auth/Server.hs +++ b/servant-auth-server/src/Servant/Auth/Server.hs @@ -98,9 +98,6 @@ module Servant.Auth.Server -- ** Classes , FromFormLoginData(..) - -- ** Related types - , FormLoginData - ---------------------------------------------------------------------------- -- * Utilies , ThrowAll(throwAll) diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs index c1f7d70..bb60b8c 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs @@ -33,8 +33,7 @@ instance FromBasicAuthData usr => IsAuth BasicAuth usr where runAuth _ _ = basicAuthCheck instance (FromFormLoginData usr, - form ~ FormLoginData, - FromJSON form + FromJSON (FormLoginData usr) ) => IsAuth (FormLogin form) usr where type AuthArgs (FormLogin form) = '[] runAuth _ _ = formLoginCheck diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs index d4ed12e..fea50e9 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs @@ -6,17 +6,16 @@ import Network.Wai (requestBody) import Servant.Auth.Server.Internal.Types -type family FormLoginData class FromFormLoginData a where -- | Represents an object that can be constructed from FormLoginData -- inside the IO monad with possible failure. - fromLoginData :: FormLoginData -> IO (AuthResult a) + type FormLoginData a :: * + fromLoginData :: FormLoginData a -> IO (AuthResult a) -- | An AuthCheck for requests containing LoginFormData in the body. -formLoginCheck :: (FormLoginData ~ form, - FromJSON form, - FromFormLoginData a +formLoginCheck :: (FromFormLoginData a, + FromJSON (FormLoginData a) ) => AuthCheck a formLoginCheck = AuthCheck $ \req -> do bdy <- requestBody req diff --git a/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth-server/test/Servant/Auth/ServerSpec.hs index 075d875..b3f9d79 100644 --- a/servant-auth-server/test/Servant/Auth/ServerSpec.hs +++ b/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -254,7 +254,7 @@ formLoginAuthSpec = describe "The FormLogin combinator" postWith defaults (url port) (toJSON $ SimpleForm "ali" "???") `shouldHTTPErrorWith` status403 - it "fails with no auth header" $ \port -> do + it "fails with no form in body" $ \port -> do post (url port) (toJSON ()) `shouldHTTPErrorWith` status401 -- }}} @@ -407,9 +407,8 @@ data SimpleForm = SimpleForm instance ToJSON SimpleForm instance FromJSON SimpleForm -type instance FormLoginData = SimpleForm - instance FromFormLoginData User where + type FormLoginData User = SimpleForm fromLoginData (SimpleForm usr pwd) = if usr == "ali" && pwd == "Open sesame" then return $ AuthTypes.Authenticated $ User "ali" "1" else if usr == "ali" From 836603ac1557df79e628547522498a75046c1e70 Mon Sep 17 00:00:00 2001 From: Martin Allen Date: Wed, 23 Nov 2016 19:45:14 -0500 Subject: [PATCH 5/6] form restriction --- servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs b/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs index bb60b8c..76a5bc0 100644 --- a/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs +++ b/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs @@ -33,7 +33,8 @@ instance FromBasicAuthData usr => IsAuth BasicAuth usr where runAuth _ _ = basicAuthCheck instance (FromFormLoginData usr, - FromJSON (FormLoginData usr) + FromJSON (FormLoginData usr), + FormLoginData usr ~ form ) => IsAuth (FormLogin form) usr where type AuthArgs (FormLogin form) = '[] runAuth _ _ = formLoginCheck From 9189481669339c0cd093b11df99bd84b8e78f414 Mon Sep 17 00:00:00 2001 From: Martin Allen Date: Wed, 23 Nov 2016 23:07:36 -0500 Subject: [PATCH 6/6] werror fix --- servant-auth-server/test/Servant/Auth/ServerSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth-server/test/Servant/Auth/ServerSpec.hs index b3f9d79..b7d57b4 100644 --- a/servant-auth-server/test/Servant/Auth/ServerSpec.hs +++ b/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -409,9 +409,9 @@ instance FromJSON SimpleForm instance FromFormLoginData User where type FormLoginData User = SimpleForm - fromLoginData (SimpleForm usr pwd) = if usr == "ali" && pwd == "Open sesame" + fromLoginData form = if username form == "ali" && password form == "Open sesame" then return $ AuthTypes.Authenticated $ User "ali" "1" - else if usr == "ali" + else if username form == "ali" then return AuthTypes.BadPassword else return AuthTypes.NoSuchUser