Haskell
scotty

Scotty による Web アプリ入門

More than 1 year has passed since last update.


アジェンダ

ToDoアプリを作る


  • ルーティングなど概観の確認

  • 機能の実装


    • タスクを追加できるようにする

    • ユーザー登録できるようにする

    • 認証機能を作る



Scotty というライトな Web フレームワークを使用します

ドキュメント : https://hackage.haskell.org/package/scotty-0.11.0/docs/Web-Scotty.html



準備

git clone git@github.com:ryota-ka/web-app-tutorial

cd web-app-tutorial
git checkout getting-started
stack setup
stack build
stack exec web-app-tutorial-exe

ブラウザで以下の URL にアクセス



app/Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.Monoid
import Network.HTTP.Types
import Web.Scotty
import qualified Data.Text.Lazy as T

main :: IO ()
main = do
scotty 8080 $ do
get "/" $ do
text "Hello, world!"

get "/hello/:name" $ do
name <- param "name"
text $ "Hello, " <> name <> "!"

get "/redirect/to/root" $ do
status status302
setHeader "X-Foo-Bar" "bazqux"
redirect "/"




エンドポイント

$ curl http://localhost:8080/

Hello, world!

$ curl http://localhost:8080/hello/Haskeller

Hello, Haskeller!

$ curl -D - http://localhost:8080/redirect/to/root

HTTP/1.1 302 Found
Transfer-Encoding: chunked
Date: Sat, 14 Jan 2017 05:53:47 GMT
Server: Warp/3.2.9
Location: /
X-Foo-Bar: bazqux



{-# LANGUAGE OverloadedStrings #-}

GHCの言語拡張 (Node.js の --harmony オプションのようなもの)

フラグによって Haskell の言語を拡張できる


OverloadedStrings

文字列リテラル "str" の型が String ([Char]) ではなく IsString a => a になる

class IsString a where

fromString :: String -> a



Haskell の文字列事情

Haskell の String はただの Char のリストのため,効率がよくない

文字列を効率よく扱うデータ型をライブラリが提供

以下では文字列表現として Data.Text.LazyText を多く使用する

(Scotty がこの型を要求するため)

TextIsString のインスタンスになっているので

OverloadedStrings 拡張を使えばリテラルで書ける



app/Main.hs

main :: IO ()

main = do
scotty 8080 $ do
get "/" $ do
text "Hello, world!"

get "/hello/:name" $ do
name <- param "name"
text $ "Hello, " <> name <> "!"

get "/redirect/to/root" $ do
status status302
setHeader "X-Foo-Bar" "bazqux"
redirect "/"


do を見つけたらそれがどのモナドの do なのかを考える

同じモナドの値が並んでいるはず



app/Main.hs

main :: IO ()

main = do
scotty 8080 $ do
get "/" $ do
text "Hello, world!"

get "/hello/:name" $ do
name <- param "name"
text $ "Hello, " <> name <> "!"

get "/redirect/to/root" $ do
status status302
setHeader "X-Foo-Bar" "bazqux"
redirect "/"


scotty    :: Network.Wai.Handler.Warp.Types.Port -- Int のエイリアス

-> ScottyM () -> IO ()
get :: RoutePattern -> ActionM () -> ScottyM ()
param :: Parsable a => T.Text -> ActionM a
text :: T.Text -> ActionM ()
status :: Status -> ActionM ()
setHeader :: T.Text -> T.Text -> ActionM ()
redirect :: T.Text -> ActionM a



app/Main.hs

main :: IO ()

main = do -- IO の do
scotty 8080 $ do -- ScottyM の do
get "/" $ do -- ActionM の do
text "Hello, world!"

get "/hello/:name" $ do -- ActionM の do
name <- param "name"
text $ "Hello, " <> name <> "!"

get "/redirect/to/root" $ do -- ActionM の do
status status302
setHeader "X-Foo-Bar" "bazqux"
redirect "/"


scotty    :: Network.Wai.Handler.Warp.Types.Port -- Int のエイリアス

-> ScottyM () -> IO ()
get :: RoutePattern -> ActionM () -> ScottyM ()
param :: Parsable a => T.Text -> ActionM a
text :: T.Text -> ActionM ()
status :: Status -> ActionM ()
setHeader :: T.Text -> T.Text -> ActionM ()
redirect :: T.Text -> ActionM a



参考 : do 構文なしで書くと

main :: IO ()

main =
scotty 8080 $ get "/" (
text "Hello, world!"
) >>= \_ ->
get "/hello/:name" (
param "name" >>= \name ->
text $ "Hello, " <> name <> "!"
) >>= \_ ->
get "/redirect/to/root" (
status status302 >>= \_ ->
setHeader "X-Foo-Bar" "bazqux" >>= \_ ->
redirect "/"
)



GET /tasks

git checkout get-tasks && stack build && stack exec web-app-tutorial-exe

curl http://localhost:8080/tasks | jq

[

{
"taskId": 1,
"title": "Haskellの勉強会を探す"
},
{
"taskId": 2,
"title": "CAMPHOR- BASEの場所を調べる"
},
{
"taskId": 3,
"title": "Haskellの文法を勉強する"
},
{
"taskId": 4,
"title": "ScottyでWebアプリケーションを作る"
}
]



Task 型の定義

data Task = Task {

taskId :: Int
, title :: T.Text
} deriving (Eq, Generic, Show)

以下の関数が定義される

Task   :: Int -> T.Text -> Task

taskId :: Task -> Int
title :: Task -> T.Text



POST /tasks

タスクを追加できるようにしていく

git checkout add-tasks

変更可能な状態を扱う

簡単のため今回は IORef を用いる



IORef とは?

IOモナドの中で変更可能なリファレンス (Haskell でも例外的に副作用を扱える)

newIORef :: a -> IO (IORef a)

-- 新しい IORef を作成

readIORef :: IORef a -> IO a
-- リファレンスの読み出し

writeIORef :: IORef a -> a -> IO ()
-- リファレンスの書き込み

modifyIORef :: IORef a -> (a -> a) -> IO ()
-- 関数を用いたリファレンスの変更

ドキュメント : https://hackage.haskell.org/package/base-4.9.0.0/docs/Data-IORef.html



app/Main.hs

main :: IO ()

main = do
ref <- newIORef defaultTasks -- 新しい IORef を作成して ref に入れる
scotty 8080 $ do
-- 中略
get "/tasks" $ do -- ActionM の do (≠ IO の do)
tasks <- liftIO $ readIORef ref -- readIORef :: IORef a -> IO a
json tasks

post "/tasks" $ do
text "change me to add tasks!"


readIORefIO であって ActionM ではない

liftIO :: MonadIO m => IO a -> m a を使って型を調整

mActionM, a[Task] だと思うと

liftIO :: IO [Task] -> ActionM [Task]

(詳しくは中級者になってから)



addTask

ref :: IORef [Task] の参照は Task のリストを指しています



  • ref とタスクのタイトルを受け取り

  • リストの先頭にタスクを追加するよう参照を変更し


  • IO () を返す

関数 addTaskmodifyIORef を用いて実装してください

ただし,taskId は連番になるようにしてください

ヒント : まずは引数や関数全体の型を考えましょう

modifyIORef -> IORef a -> (a -> a) -> IO ()

-- a が [Task] だと思うと
modifyIORef :: IORef [Task] -> ([Task] -> [Task]) -> IO ()



addTask (cont'd)

addTask :: IORef [Task] -> T.Text -> IO ()

addTask ref title = modifyIORef ref transform
where
transform :: [Task] -> [Task]
transform tasks = ...



解答例

addTask :: IORef [Task] -> T.Text -> IO ()

addTask ref title = modifyIORef ref transform
where
transform :: [Task] -> [Task]
transform tasks =
let newTask = Task (length tasks + 1) title
in newTask:tasks



POST /tasks の実装

先程定義した addTasks を用いて,エンドポイント POST /tasks を実装してください

$ curl -X POST -d title='a new task' -D - http://localhost:8080/tasks

HTTP/1.1 201 Created
Transfer-Encoding: chunked
Date: Fri, 13 Jan 2017 15:15:15 GMT
Server: Warp/3.2.9
Content-Type: application/json; charset=utf-8

{"taskId":5,"title":"a new task"}

ヒント : param "title" でリクエストボディから title が取得できます



解答例

post "/tasks" $ do

title <- param "title"
liftIO $ addTask ref title
tasks <- liftIO $ readIORef ref
let newTask = head tasks
status status201
json newTask



modifyIORef は atomic でない

for i in `seq 1 1000`; do

curl -X POST -d title=$i http://localhost:8080/tasks &
done

curl http://localhost:8080/tasks | jq length



atomic な関数への修正

タスクの追加が atomic 行われるように修正してください

Data.IORefmodifyIORef を atomic に行う関数が提供されています



atomic な関数への修正 (cont'd)

atomicModifyIORef  :: IORef a -> (a -> (a, b)) -> IO b -- lazy

atomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b -- strict

空間計算量の肥大化(スペースリーク)を防ぐため,atomicModifyIORef' を使いましょう

戻り値の型の b は任意なので,追加したタスクを返すと便利そう

addTask :: IORef [Task] -> T.Text -> IO Task



解答例

addTask :: IORef [Task] -> T.Text -> IO Task

addTask ref title = atomicModifyIORef' ref transform
where
transform :: [Task] -> ([Task], Task)
transform tasks =
let newTask = Task (length tasks + 1) title
in (newTask:tasks, newTask)

post "/tasks" $ do

title <- param "title"
newTask <- liftIO $ addTask ref title -- addTask ref title :: IO [Task]
status status201
json newTask



ごく単純な認証機能の作成

git checkout login

type Username = T.Text

type Password = T.Text

data User = User {
username :: Username
, password :: Password
} deriving (Eq, Generic, Show)



ごく単純な認証機能の作成 (cont'd)

post "/login" $ do

maybeUser <- currentUser
case maybeUser of
Nothing -> status status401 >> text "authentication required"
Just user -> text $ "Hello, " <> username user <> "!"

currentUser :: ActionM (Maybe User)



currentUser の実装

リクエストパラメータで渡されたユーザーIDとパスワードに一致するユーザーを defaultUsers から探し,

ユーザーが存在すれば Just に入れて返し,

存在しなければ Nothing を返す currentUser を定義してください

currentUser :: ActionM (Maybe User)

currentUser = do
...

ヒント :



  • ActionMdo の中では,ActionM を返す他の関数も使用できます


  • Data.Listfind :: (a -> Bool) -> [a] -> Maybe a という便利な関数があります



解答例

currentUser :: ActionM (Maybe User)

currentUser = do
u <- param "username"
p <- param "password"
return $ find (== User u p) defaultUsers

$ curl -X POST -d username=alice -d password=password http://localhost:8080/login

Hello, alice!

$ curl -X POST -d username=alice -d password=1234 http://localhost:8080/login

authorization required



安全な param 関数

期待するパラメータがリクエストに含まれていない場合,param はエラーを吐きます

$ curl -X POST -d username=alice http://localhost:8080/login

<h1>500 Internal Server Error</h1>Param: password not found!

params :: ActionM [Param] を用いて,安全にパラメータを取得する関数 safeParam を実装してください

param     :: Parsable a => T.Text -> ActionM a

safeParam :: Parsable a => T.Text -> ActionM (Maybe a)

ヒント : まずは型や型クラスについて調べましょう



安全な param 関数 (cont'd)

ドキュメントから

type Param = (Text, Text)

class Parsable a where Source
parseParam :: Text -> Either Text a

であることがわかる

data Either a b = Left a | Right b

fst :: (a, b) -> a

snd :: (a, b) -> b



解答例

safeParam :: Parsable a => T.Text -> ActionM (Maybe a)

safeParam key = do
params' <- params
let value = snd <$> find ((== key) . fst) params'
let parsedValue = case value of
Nothing -> Nothing
Just value -> case parseParam value of
Left _ -> Nothing
Right v -> Just v
return parsedValue



安全な currentUser

先程定義した safeParam を用いて currentUser の定義を修正してください



解答例

currentUser :: ActionM (Maybe User)

currentUser = do
maybeUsername <- safeParam "username"
maybePassword <- safeParam "password"
let maybeUser =
case (maybeUsername, maybePassword) of
(Just u, Just p) -> find (== User u p) defaultUsers
(_, _) -> Nothing
return maybeUser



ユーザーの追加

ユーザーは現状リードオンリーですが,

タスクの他にユーザーも追加できるようにしてください

git checkout app-state

type AppState = ([Task], [User])


方針



  • IORef [Task]IORef AppState に変更する


  • addTask の型を IORef AppState -> T.Text -> IO Task に変更する


  • addUser を書く


  • POST /users を実装する



ユーザー認証



  • Taskuser フィールドを追加してしてください


  • GET /tasks POST /tasks でも認証情報を要求するように変更してください

  • 毎回 case ~ of ... を書くのが面倒な方は,ヘルパー関数を用意してください



ヘルパー関数のインターフェース

get "/tasks" $ do

authenticateUser $ \user -> do
something <- doSomethingWith user
json something

ログインしていなかったら 401 で { "error": "unauthorized" } を返すと便利そう

(Error 型を定義してあります)



ヘルパー関数の実装

authenticateUser :: (User -> ActionM ()) -> ActionM ()

authenticateUser f = do
maybeUser <- currentUser
case maybeUser of
Nothing -> status status401 >> json (Error "unauthorized")
Just user -> f user



GET /tasks/:id

余裕のある方は GET /tasks/:id を実装してください



  • usernamepassword を要求する

  • 以下の場合には 404 で { "error": "not found" }



    • id に対応するタスクが存在しない


    • id に対応するタスクが他人のものである