今回はServantのBasic 認証についてみます。

Docs » Cookbook » Basic Authentication
Servant.API.BasicAuth - servant: A family of combinators for defining webservices APIs

1. Baisc認証

まずはBasic認証の復習から。
Basic認証 - Wikipedia

クライアントは認証が必要なページをリクエストする。しかし、通常ここではユーザ名とパスワードを送っていない。なぜならばクライアントはそのページが認証を必要とするか否かを知らないためである。
サーバは401レスポンスコードを返し、認証領域 (authentication realm) や認証方式 (Basic認証) に関する情報をクライアントに知らせる。
それを受けたクライアントは、認証領域（通常は、アクセスしているコンピュータやシステムの簡単な説明）をユーザに提示して、ユーザ名とパスワードの入力を求める。ユーザはここでキャンセルすることもできる。
ユーザによりユーザ名とパスワードが入力されると、クライアントはリクエストに認証ヘッダを追加して再度送信する。
認証に成功すると、サーバは認証の必要なページのリクエストを処理する。一方、ユーザ名やパスワードが間違っていた時には、サーバは再び401レスポンスコードを返す。それによりクライアントは再びユーザにユーザ名とパスワードの入力を求める。

1-1. 今回のソースの実行例

リソース「mysite」へアクセスすることで、ブラウザに認証画面がポップアップします。

今回の例では、ユーザ名 = "foo"、パスワード = "bar" を入力することで、認証が成功しアクセスが許可されます。

リソースの画面です

2. 全ソース

Cookbookのプログラムを少し修正します。

Docs » Cookbook » Basic Authentication

BasicAuth.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}

module BasicAuth
    ( runServant
    ) where

import Control.Concurrent
import Control.Exception
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp
import Servant
import Servant.Client


type Username = T.Text
type Password = T.Text
type Website = T.Text

data User = User
  { user :: Username
  , pass :: Password
  , site :: Website
  } deriving (Eq, Show)

-- could be a postgres connection, a file, anything.
type UserDB = Map.Map Username User

-- create a "database" from a list of users
createUserDB :: [User] -> UserDB
createUserDB users = Map.fromList [ (user u, u) | u <- users ]

-- our test database
userDB :: UserDB
userDB = createUserDB
  [ User "john" "shhhh" "john.com"
  , User "foo" "bar" "foobar.net"
  ]


-- a 'GET /mysite' endpoint, protected by basic authentication
type API = BasicAuth "People's websites" User :> "mysite" :> Get '[JSON] Website

{- if there were more endpoints to be protected, one could write:
type API = BasicAuth "People's websites" User :>
    ( "foo" :> Get '[JSON] Foo
 :<|> "bar" :> Get '[JSON] Bar
    )
-}

api :: Proxy API
api = Proxy

server :: Server API
server usr = return (site usr)



-- provided we are given a user database, we can supply
-- a function that checks the basic auth credentials
-- against our database.
checkBasicAuth :: UserDB -> BasicAuthCheck User
checkBasicAuth db = BasicAuthCheck $ \basicAuthData ->
  let username = decodeUtf8 (basicAuthUsername basicAuthData)
      password = decodeUtf8 (basicAuthPassword basicAuthData)
  in
  case Map.lookup username db of
    Nothing -> return NoSuchUser
    Just u  -> if pass u == password
               then return (Authorized u)
               else return BadPassword


runApp :: UserDB -> IO ()
runApp db = run 8080 (serveWithContext api ctx server)

  where ctx = checkBasicAuth db :. EmptyContext


runServant :: IO ()
runServant = runApp userDB

メイン

Main.hs

module Main where

import qualified HtmlContent       as T1
import qualified PostData          as T2
import qualified CustomPostData    as T3
import qualified AnotherMonad      as T4
import qualified Sqlite            as T5
import qualified Client            as T6
import qualified BasicAuth         as T7

main :: IO ()
main = T7.runServant

使用するパッケージ

package.yaml

dependencies:
- base >= 4.7 && < 5
- servant
- servant-server
- servant-client
- aeson
- time
- wai
- warp
- http-media
- http-client
- bytestring
- mtl
- sqlite-simple
- containers
- text

3.説明

Servant.API.BasicAuth - servant: A family of combinators for defining webservices APIs

3-1. APIでのBasicAuth

API

-- a 'GET /mysite' endpoint, protected by basic authentication
type API = BasicAuth "People's websites" User :> "mysite" :> Get '[JSON] Website

これの意味するところは、エンドポイント「"mysite" :> Get '[JSON] Website」へのアクセスを、ベーシック認証「BasicAuth "People's websites" User」で保護するということです。BasicAuthの引数は以下の通りです。

"People's websites"はレルムと呼ばれるもので、保護リソースの識別子となる任意の文字列です。
Userは認証対象のユーザを表現するdata型です。

APIでのBasicAuth認証に成功した場合、serverには指定した型(User)の引数が渡されます。

server

server :: Server API
server usr = return (site usr)

3-2. 認証関数

BasicAuth認証の仕組みは以下の通りです。

runApp

runApp :: UserDB -> IO ()
runApp db = run 8080 (serveWithContext api ctx server)

  where ctx = checkBasicAuth db :. EmptyContext

serveWithContext の型は以下の通りですが、ここでは実際の認証の実装であるcheckBasicAuthをContextに包んでいます。

serveWithContext

serveWithContext :: HasServer api context =>
                    Proxy api -> Context context -> Server api -> Application

まずBasicAuthDataの定義を確認します。

BasicAuthData

-- | A simple datatype to hold data required to decorate a request
data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString
                                   , basicAuthPassword :: !ByteString
                                   }

認証関数のcheckBasicAuthは以下のように実装しています。クライアントから渡されたBasicAuthData型データに対応するデータをDBから探し出しパスワードを比較するだけです。

checkBasicAuth

checkBasicAuth :: UserDB -> BasicAuthCheck User
checkBasicAuth db = BasicAuthCheck $ \basicAuthData ->
  let username = decodeUtf8 (basicAuthUsername basicAuthData)
      password = decodeUtf8 (basicAuthPassword basicAuthData)
  in
  case Map.lookup username db of
    Nothing -> return NoSuchUser
    Just u  -> if pass u == password
               then return (Authorized u)
               else return BadPassword

ここでBasicAuthResultとBasicAuthCheckの定義は以下のようになっています。型を注意深く確認しましょう。大丈夫ですね。

BasicAuthResult-BasicAuthCheck

-- | The result of authentication/authorization
data BasicAuthResult usr
  = Unauthorized
  | BadPassword
  | NoSuchUser
  | Authorized usr
  deriving (Eq, Show, Read, Generic, Typeable, Functor)

-- | Datatype wrapping a function used to check authentication.
newtype BasicAuthCheck usr = BasicAuthCheck
  { unBasicAuthCheck :: BasicAuthData
                     -> IO (BasicAuthResult usr)
  }
  deriving (Generic, Typeable, Functor)

3-3. Client

runServant を書き換えて、Servant Clientを使います。

runServant

{--
runServant :: IO ()
runServant = runApp userDB
--}

getSite :: BasicAuthData -> ClientM Website
getSite = client api


runServant :: IO ()
runServant = do
  mgr <- newManager defaultManagerSettings
  bracket (forkIO $ runApp userDB) killThread $ \_ ->
    runClientM (getSite u) (mkClientEnv mgr (BaseUrl Http "localhost" 8080 ""))
      >>= print

  where u = BasicAuthData "foo" "bar"

以下のコマンドで実行します。

stack build && stack exec first-project-exe

コンソールに以下の結果が出力されます。

Right "foobar.net"

今回は以上です。

【Servant】(12) Basic 認証