Form login

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

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

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

servant-auth-server/test/Servant/Auth/ServerSpec.hs

@@ -23,26 +23,29 @@ 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
   cookieAuthSpec
   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
+
 -- }}}