カテゴリー: haskell sample

この記事は、スタートトゥデイ工務店 Advent Calendar 14日目の記事です。

wai（Haskell製のWebアプリケーション規格）に準拠し、warp（wai準拠のHaskell製Webサーバ）上で動作するWebアプリケーションの開発について紹介する。基本性能を際立たせるため、便利なフレームワークはあえて使用しない。

以前に非常に単純なサンプルを紹介した記事の続編となる。
今回は、本格的なWebアプリケーションに欠かせない、データベースとの連携を試してみた。
バックエンドにはMySQLを使用した。

ソースコードは https://github.com/mitsuji/wai-example-mysql にある。

1. サンプルアプリケーションの概要

下記のようなデータを扱うJSON-APIを実装した。
1件のコーディネートに対して、ジャンルが1つ、タグが複数(0..N)紐づくものとする。

オブジェクト図は下記のようになるだろう。

また、MySQLのCREATE文は下記のようになる。

CREATE TABLE genre (
        genre_id INT NOT NULL AUTO_INCREMENT
       ,genre_title nvarchar(31) NOT NULL
       ,PRIMARY KEY (genre_id)
);


CREATE TABLE tag (
        tag_id INT NOT NULL AUTO_INCREMENT
       ,tag_title nvarchar(31) NOT NULL
       ,PRIMARY KEY (tag_id)
);


CREATE TABLE look (
        look_id INT NOT NULL AUTO_INCREMENT
       ,look_create_dt DATETIME NOT NULL
       ,look_update_dt DATETIME NOT NULL
       ,look_title nvarchar(31) NOT NULL
       ,look_description nvarchar(400) NOT NULL
       ,look_genre_id INT NOT NULL
       ,PRIMARY KEY (look_id)
       ,FOREIGN KEY (look_genre_id) REFERENCES genre (genre_id)
);

CREATE TABLE look_has_tag (
        lht_look_id INT NOT NULL
       ,lht_tag_id INT NOT NULL
       ,PRIMARY KEY (lht_look_id,lht_tag_id)
       ,FOREIGN KEY (lht_look_id) REFERENCES look (look_id)
       ,FOREIGN KEY (lht_tag_id) REFERENCES tag (tag_id)
);

Haskellのデータ定義は下記のようになった。

data Genre = Genre GenreId Title [Look]
           deriving (Eq)

data Tag = Tag TagId Title [Look]
         deriving (Eq)

data Look = Look { lookId :: LookId
                 , lookCreateDt :: CreateDT
                 , lookUpdateDt :: UpdateDT
                 , lookTitle :: Title
                 , lookDescription :: Description
                 , lookGenre :: Genre'
                 , lookTags :: [Tag']
                 }
          deriving (Eq)


newtype Genre' = Genre' Genre
               deriving (Eq)
                        
newtype Tag' = Tag' Tag
               deriving (Eq)

2. 実装の方針

下記の方針で実装した。
* mysql-simpleを使用してMySQLのデータをHaskellのデータに変換する。
* aesonを使用してHaskellのデータをJSONに変換する。
* waiを使用してWebのインターフェースを提供する。

また、実用的なサンプルとするため、下記を盛りこんだ。
* トランザクション処理
* コネクションプール
* N対Nのリレーション

3. MySQLのデータをHaskellのデータに変換する。

mysql-simple では QueryResult という型クラスが用意されており、
任意のデータ型をこの型クラスのインスタンスにすることで、
MySQLに投げたクエリの結果をHaskellのデータに変換することができる。
下記のように convertResults を実装すればよい。

instance QueryResults Genre' where
  convertResults [fa,fb] [va,vb] = Genre' $ Genre a b []
        where !a = convert fa va
              !b = convert fb vb
  convertResults fs vs  = convertError fs vs 2

上記を定義すると、下記のようにクエリを投げることができる。
結果は、関数の型からも分かるように Genre’ のリストとして取り出すことができる。

select_genre :: Connection -> IO [Genre']
select_genre conn =
  query_ conn [r|
    SELECT
       genre_id
      ,genre_title
    FROM genre
    ORDER BY genre_id
  |]

4. HaskellのデータをJSONに変換する。

aeson では ToJSON という型クラスが用意されており、
任意のデータ型をこの型クラスのインスタンスにすることで、
JSONへの変換を定義することができる。
下記のように toJSON を実装すればよい。

instance ToJSON Tag where
  toJSON (Tag id t ls) =
    object ["id" .= id
           ,"title" .= t
           ,"looks" .= ls
           ]

ソースコードのプロジェクトにREPLで入ると、
下記のようにaesonの動作を試すことができる。

*Main Data JSON MySQL> AE.encode $ Tag 100 "タグ100" []
"{\"looks\":[],\"id\":100,\"title\":\"\227\130\191\227\130\176\&100\"}"

5. コネクションプール

コネクションプールはresouce-poolというライブラリを使用して実装した。
このライブラリを使うと、DBの接続に限らず任意のリソースのプールを簡単に実装することができるようだ。

アプリケーション起動時に createPool でプールを作っておく。
createPool にはプールにリソースが確保されるときの処理、プールからリソースが開放されるときの処理と、プールのチューニングに関するいくつかのパラメータを設定する。

main :: IO ()
main = do
  host:port:_ <- getArgs
  cp <- createPool connect close 10 10 10
  Warp.runSettings (
    Warp.setHost (fromString host) $
    Warp.setPort (read port) $
    Warp.defaultSettings
    ) $ routerApp cp
  where
    connect :: IO MySQL.Connection
    connect = MySQL.connect MySQL.defaultConnectInfo {
       MySQL.connectHost = "localhost"
      ,MySQL.connectUser = "wai_exam_admin"
      ,MySQL.connectPassword = "abcd1234"
      ,MySQL.connectDatabase = "wai_exam"
      }
    close = MySQL.close

リソースプールの変数を引き渡しておけば、アプリケーションの任意の箇所で
withResource を使用して、プール内のリソースを使うことができる。
関数の呼び出しが深くなる場合は、リソースプールの共有に
Readerモナドなどを使うとよいだろう。

  -- GET /v1/genre
  (Right M.GET, [_,_]) -> do
    bs <- AE.encode <$> (withResource cp $ \conn -> select_genre conn)
    respond $ response200 bs

6. トランザクション処理

トランザクション処理は下記のように withTransaction を使うだけで実現されるようだ。

delete_look :: Connection -> LookId -> IO ()
delete_look conn id =
  withTransaction conn $ do
    execute conn
      "DELETE FROM look_has_tag WHERE lht_look_id = ?" (Only id)
    execute conn
      "DELETE FROM look WHERE look_id = ?" (Only id)
    return ()

7. ルーティング

URLのパスやHTTPメソッドの種類と、評価される関数をどのように紐づけるか。
wai が Text型のリストとしてURLのパスを提供してくれているので、
下記のようにパターンマッチを使ってルーティングを定義することができた。
フレームワークを使った場合ほどではないが、比較的簡潔にできた。

routerApp :: Pool MySQL.Connection -> Wai.Application
routerApp cp req respond = case Wai.pathInfo req of
  "v1" : _ -> (v1App cp req respond) `catch` onException -- /v1{var}
  _ -> staticApp req respond -- static html/js/css files
  where
    onException :: SomeException -> IO Wai.ResponseReceived
    onException (SomeException e) = respond $ responseNG 5000 "unknown error"
--    onException (SomeException e) = respond $ responseNG 5000 $ displayException e


v1App :: Pool MySQL.Connection -> Wai.Application
v1App cp req respond = case Wai.pathInfo req of
  _ : "genre"  : _ -> genreApp cp req respond -- /v1/genre{var}
  _ : "tag"    : _ -> tagApp cp req respond   -- /v1/tag{var}
  _ : "look"   : _ -> lookApp cp req respond  -- /v1/look{var}
  _ -> staticApp req respond -- static html/js/css files

HTTPメソッドも合わせてパターンマッチすれば、RESTっぽいことも簡単にできる。

genreApp :: Pool MySQL.Connection -> Wai.Application
genreApp cp req respond = case (M.parseMethod (Wai.requestMethod req), Wai.pathInfo req) of
  
  -- POST /v1/genre
  (Right M.POST, [_,_]) -> do
    ps <- parseForm req
    case lookupParam "title" ps of
      Nothing -> respond $ responseNG 5101 "invalid title"
      Just t -> do
        bs <- AE.encode <$> (withResource cp $ \conn -> create_genre conn t)
        respond $ response200 bs
             
  -- DELETE /v1/genre/{id}
  (Right M.DELETE, [_,_,id]) ->
    case readMaybe (T.unpack id) of
      Nothing -> respond $ responseNG 5102 "invalid id"
      Just id -> do
        withResource cp $ \conn -> delete_genre conn id
        respond responseOK
    

8. SQLインジェクション防止機能

mysql-simple では SQLインジェクションを防止するため、query や query_ には
文字列のリテラルでSQL文を渡さなければならないようにしてあるようだ。

文字列結合を使ってSQL文を組み立てることができないため、
条件を任意で指定するSELECT文が少し作りにくかったが、
下記のようにすることで対応できた。

-- [TODO] sanitize param of LIKE phrase 
select_look :: Connection -> Maybe Title -> Maybe Description -> Maybe GenreId -> Maybe TagId -> IO [Look]
select_look conn mt md mgid mtid = do

  (ft,t) <- case mt of
    Nothing -> return (1::Int,"%")
    Just t ->  return (0::Int,t)
    
  (fd,d) <- case md of
    Nothing -> return (1::Int,"%")
    Just d ->  return (0::Int,d)

  (fgid,gid) <- case mgid of
    Nothing ->  return (1::Int,0)
    Just gid -> return (0::Int,gid)

  (ftid,tid) <- case mtid of
    Nothing ->  return (1::Int,0)
    Just tid -> return (0::Int,tid)

  ls <- query conn [r|
    SELECT
       look_id
      ,look_create_dt
      ,look_update_dt
      ,look_title
      ,look_description
      ,genre_id
      ,genre_title
    FROM look
      LEFT OUTER JOIN genre ON look_genre_id = genre_id
    WHERE 1 = 1
      AND (1=? OR look_title LIKE ?)
      AND (1=? OR look_description LIKE ?)
      AND (1=? OR look_genre_id = ?)
      AND (1=? OR look_id IN
                  (SELECT lht_look_id FROM look_has_tag WHERE lht_tag_id =?))
    ORDER BY look_id
  |](ft,t,fd,d,fgid,gid,ftid,tid)

  tags <- select_tag_for_looks conn ls
  return $ merge_tags tags ls

9. まとめ

• mysql-simple などのライブラリを使えば DBのデータとHaskellのデータのマッピングは簡単。
• aeson を使えば Haskellのデータを JSON化するのは簡単。
• resource-pool を使えばコネクションプールの導入は簡単。
• mysql-simple のトランザクション処理は簡単確実。
• Webアプリケーションのパス/メソッドルーティングは単純なパターンマッチでもある程度可能。
• mysql-simple を使えば SQLインジェクションの危険性が低下。

10. 今後の課題

• mysql-simple 以外のDBライブラリもいろいろ試してみたい。
• 入力のバリデーションをもっとちゃんと実装してみたい。
• ファイルのアップロードも試してみたい。
• フロントエンドを実装して、実際に使ってみたい。