diff --git a/servant-auth-server/src/Servant/Auth/Server.hs b/servant-auth-server/src/Servant/Auth/Server.hs index d44d3cd..87f7815 100644 --- a/servant-auth-server/src/Servant/Auth/Server.hs +++ b/servant-auth-server/src/Servant/Auth/Server.hs @@ -89,6 +89,15 @@ module Servant.Auth.Server , BasicAuthData(..) , IsPasswordCorrect(..) + ---------------------------------------------------------------------------- + -- * FormLogin + -- ** Combinator + -- | Re-exported from 'servant-auth' + , FormLogin + + -- ** Classes + , FromFormLoginData(..) + ---------------------------------------------------------------------------- -- * Utilies , ThrowAll(throwAll) @@ -107,6 +116,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..76a5bc0 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, + FromJSON (FormLoginData usr), + FormLoginData usr ~ 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 5301640..fea50e9 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,24 @@ module Servant.Auth.Server.Internal.FormLogin where +import Data.Aeson (FromJSON, decode) +import qualified Data.ByteString.Lazy as BL +import Network.Wai (requestBody) +import Servant.Auth.Server.Internal.Types + + +class FromFormLoginData a where + -- | Represents an object that can be constructed from FormLoginData + -- inside the IO monad with possible failure. + type FormLoginData a :: * + fromLoginData :: FormLoginData a -> IO (AuthResult a) + +-- | An AuthCheck for requests containing LoginFormData in the body. +formLoginCheck :: (FromFormLoginData a, + FromJSON (FormLoginData a) + ) => AuthCheck a +formLoginCheck = AuthCheck $ \req -> do + bdy <- requestBody req + case decode $ BL.fromStrict bdy of + Nothing -> return Indefinite + Just f -> fromLoginData f diff --git a/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth-server/test/Servant/Auth/ServerSpec.hs index 41823c2..b7d57b4 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 form in body" $ \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,20 @@ 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 + +instance FromFormLoginData User where + type FormLoginData User = SimpleForm + fromLoginData form = if username form == "ali" && password form == "Open sesame" + then return $ AuthTypes.Authenticated $ User "ali" "1" + else if username form == "ali" + then return AuthTypes.BadPassword + else return AuthTypes.NoSuchUser + -- }}}