Help us understand the problem. What is going on with this article?

【Servant】(12) Basic 認証

【Servant】(1) Wai - Qiita
【Servant】(2) Servantチュートリアル - Qiita
【Servant】(3) エンドポイントを増やす - Qiita
【Servant】(4) URLパラメータをハンドラの引数とする - Qiita
【Servant】(5) JSON - Qiita
【Servant】(6) HTML - Qiita
【Servant】(7) Post Data - Qiita
【Servant】(8) Another Monad - Qiita
【Servant】(9) Handlerモナド - Qiita
【Servant】(10) SQLite - Qiita
【Servant】(11) Servant-Client - Qiita
【Servant】(12) Basic 認証 - Qiita

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

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

1. Baisc認証

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

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

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

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

image.png

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

image.png

リソースの画面です

image.png

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

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

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"

今回は以上です。

Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
No comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
ユーザーは見つかりませんでした