Scotty による Web アプリ入門

# アジェンダ

ToDoアプリを作る

- ルーティングなど概観の確認
- 機能の実装
  - タスクを追加できるようにする
  - ユーザー登録できるようにする
  - 認証機能を作る

Scotty というライトな Web フレームワークを使用します
ドキュメント : https://hackage.haskell.org/package/scotty-0.11.0/docs/Web-Scotty.html

---

# 準備

```sh
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 にアクセス

- http://localhost:8080/

---

```haskell: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 "/"
```

---

# エンドポイント

```sh
$ curl http://localhost:8080/

Hello, world!
```

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

Hello, Haskeller!
```

```sh
$ 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` になる

```haskell
class IsString a where
    fromString :: String -> a
```

---

# Haskell の文字列事情

Haskell の `String` はただの `Char` のリストのため，効率がよくない
文字列を効率よく扱うデータ型をライブラリが提供

以下では文字列表現として `Data.Text.Lazy` の `Text` を多く使用する
(Scotty がこの型を要求するため)

`Text` は `IsString` のインスタンスになっているので
`OverloadedStrings` 拡張を使えばリテラルで書ける

---

```haskell: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` なのかを考える

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

---

```haskell: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 "/"
```

```haskell
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
```
---

```haskell: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 "/"
```

```haskell
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` 構文なしで書くと

```haskell
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`

```sh
git checkout get-tasks && stack build && stack exec web-app-tutorial-exe
curl http://localhost:8080/tasks | jq
```

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

---

# `Task` 型の定義

```haskell
data Task = Task {
    taskId :: Int
  , title  :: T.Text
  } deriving (Eq, Generic, Show)
```

以下の関数が定義される

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

---

# `POST /tasks`

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

```sh
git checkout add-tasks
```

変更可能な状態を扱う
簡単のため今回は `IORef` を用いる

---

## `IORef` とは？

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

```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

---

```haskell: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!"
```

`readIORef` は `IO` であって `ActionM` ではない

`liftIO :: MonadIO m => IO a -> m a` を使って型を調整
`m` が `ActionM`, `a` が `[Task]` だと思うと

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

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

---

# `addTask`

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

- `ref` とタスクのタイトルを受け取り
- リストの先頭にタスクを追加するよう参照を変更し
- `IO ()` を返す

関数 `addTask` を `modifyIORef` を用いて実装してください
ただし，`taskId` は連番になるようにしてください

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

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

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

---

# `addTask` (cont'd)

```haskell
addTask :: IORef [Task] -> T.Text -> IO ()
addTask ref title = modifyIORef ref transform
  where
    transform :: [Task] -> [Task]
    transform tasks = ...
```

---

# 解答例

```haskell
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` を実装してください

```sh
$ 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` が取得できます

---

# 解答例

```haskell
post "/tasks" $ do
  title <- param "title"
  liftIO $ addTask ref title
  tasks <- liftIO $ readIORef ref
  let newTask = head tasks
  status status201
  json newTask
```

---

# `modifyIORef` は atomic でない

```sh
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.IORef` に `modifyIORef` を atomic に行う関数が提供されています

---

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

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

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

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

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

---

# 解答例

```haskell
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)
```

```haskell
post "/tasks" $ do
  title <- param "title"
  newTask <- liftIO $ addTask ref title -- addTask ref title :: IO [Task]
  status status201
  json newTask
```

---

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

```sh
git checkout login
```

```haskell
type Username = T.Text
type Password = T.Text

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

---

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

```haskell
post "/login" $ do
  maybeUser <- currentUser
  case maybeUser of
    Nothing -> status status401 >> text "authentication required"
    Just user -> text $ "Hello, " <> username user <> "!"
```

```haskell
currentUser :: ActionM (Maybe User)
```

---

# `currentUser` の実装

リクエストパラメータで渡されたユーザーIDとパスワードに一致するユーザーを `defaultUsers` から探し，
ユーザーが存在すれば `Just` に入れて返し，
存在しなければ `Nothing` を返す `currentUser` を定義してください

```haskell
currentUser :: ActionM (Maybe User)
currentUser = do
  ...
```

ヒント :

- `ActionM` の `do` の中では，`ActionM` を返す他の関数も使用できます
- `Data.List` に `find :: (a -> Bool) -> [a] -> Maybe a` という便利な関数があります

---

# 解答例

```haskell
currentUser :: ActionM (Maybe User)
currentUser = do
  u <- param "username"
  p <- param "password"
  return $ find (== User u p) defaultUsers
```

```sh
$ curl -X POST -d username=alice -d password=password http://localhost:8080/login
Hello, alice!
```

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

---

# 安全な `param` 関数

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

```sh
$ curl -X POST -d username=alice http://localhost:8080/login
<h1>500 Internal Server Error</h1>Param: password not found!
```

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

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

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

---

# 安全な `param` 関数 (cont'd)

ドキュメントから

```haskell
type Param = (Text, Text)

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

であることがわかる

```haskell
data Either a b = Left a | Right b
```

```haskell
fst :: (a, b) -> a
snd :: (a, b) -> b
```

---

# 解答例

```haskell
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` の定義を修正してください

---

# 解答例

```haskell
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
```

---

# ユーザーの追加

ユーザーは現状リードオンリーですが，
タスクの他にユーザーも追加できるようにしてください

```sh
git checkout app-state
```

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

## 方針

- `IORef [Task]` を `IORef AppState` に変更する
- `addTask` の型を `IORef AppState -> T.Text -> IO Task` に変更する
- `addUser` を書く
- `POST /users` を実装する

---

# ユーザー認証

- `Task` に `user` フィールドを追加してしてください
- `GET /tasks` `POST /tasks` でも認証情報を要求するように変更してください
- 毎回 `case ~ of ...` を書くのが面倒な方は，ヘルパー関数を用意してください

---

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

```haskell
get "/tasks" $ do
  authenticateUser $ \user -> do
  something <- doSomethingWith user
  json something
```

ログインしていなかったら 401 で `{ "error": "unauthorized" }` を返すと便利そう
(`Error` 型を定義してあります)

---

# ヘルパー関数の実装

```haskell
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` を実装してください

- `username` と `password` を要求する
- 以下の場合には 404 で `{ "error": "not found" }`
    - `id` に対応するタスクが存在しない
    - `id` に対応するタスクが他人のものである