Clojure勉強会clj-nakanoの課題として"situated-program-challenge"のClojureとHaskellによるREST APIサーバ/クライアントの実装にこれまで取り組んできました。

今回は、このREST APIに対する(テーブル変更を含む)仕様変更に対応してみた結果をご紹介します。

過去の実装とその紹介記事はこちら:

他の参加者によるversion 1の実装例はこちら:

仕様変更内容の検討

situated-program-challenge version 2での仕様変更の内容を確認し詳細に検討してみると、通常の「会場」(venue)とは別で新たに「オンライン会場」(online-venue)を扱うために、以下のような変更が必要になることが分かる。

  1. DBスキーマの変更

    • venue_type (会場の種別を表すPostgreSQLのenum type)を新規作成
    • venues テーブルに url(オンライン会場のURL)カラムを追加
    • venues テーブルに venue_type(会場種別 venue_type)カラムを追加
    • meetups テーブルに online_venue_id(オンライン会場のvenues.id)カラムを追加
  2. APIエンドポイントの追加

    • GET /groups/{group-id}/online-venues: オンライン会場一覧の取得
      • (通常の会場を含まない)オンライン会場(venues.venue_type = online)のみを抽出して取得
    • POST /groups/{group-id}/online-venues: オンライン会場の登録
      • オンライン会場(venues.venue_type = online)として登録
  3. 既存APIの変更

    • GET /groups/{group-id}/venues: 会場一覧の取得
      • (オンライン会場を含まない)通常の会場(venues.venue_type = physical)のみを抽出して取得
    • POST /groups/{group-id}/venues: 会場の登録
      • 通常の会場(venues.venue_type = physical)として登録
    • GET /groups/{group-id}/meetups: ミートアップイベント一覧情報の取得
      • レスポンスのJSONで通常の会場を "venue" 、オンライン会場を "online-venue" で返す ※ミートアップイベント情報を返す他のAPIも同様
    • POST /groups/{group-id}/meetups: ミートアップイベントの登録
      • リクエストのJSONで通常の会場のIDを "venue-id" 、オンライン会場のIDを "online-venue-id" で受け取る
    • GET /groups: グループ一覧の取得
      • レスポンスのJSONで通常の会場を "venues" 、オンライン会場を "online-venues" で返す ※グループ情報を返す他のAPIも同様

Clojure版

1. DBアクセス層の改修

まず最初に、DBスキーマの変更に関連してDBアクセス層を改修する。

ClojureでPostgreSQLのenum typeを扱うにはいくつか方法があるようだが、こちらのページ

Using PostgreSQL Enums in Clojure

を参考に、以下のように名前空間付きキーワードから org.postgresql.util.PGobject オブジェクトを作って利用できるようなユーティリティ関数を定義してみた。

 (ns rest-server.util
   (:require [camel-snake-kebab.core :refer [->kebab-case ->snake_case]]
-            [camel-snake-kebab.extras :refer [transform-keys]])
+            [camel-snake-kebab.extras :refer [transform-keys]]
+            [clojure.string :as str])
   (:import (java.sql Timestamp)
-           (java.time Instant)))
+           (java.time Instant)
+           (org.postgresql.util PGobject)))

 (defn transform-keys-to-kebab [m]
   (transform-keys #(->kebab-case % :separator \_) m))

 (defn transform-keys-to-snake [m]
   (transform-keys #(->snake_case % :separator \-) m))

+(defn kw->pgenum [enum-kw]
+  (doto (PGobject.)
+    (.setType (-> enum-kw
+                  namespace
+                  (str/replace \- \_)))
+    (.setValue (name enum-kw))))
+
 (defn string->timestamp [s]
   (some-> s
           Instant/parse
           Timestamp/from))

 (defn now []
   (Timestamp/from (Instant/now)))

ここで定義した kw->pgenum 関数を例えば :venue-type/physical というキーワードに適用すると、typeが "venue_type" 、valueが "physical"PGobject オブジェクトが得られる。

user> (rest-server.util/kw->pgenum :venue-type/physical)
#object[org.postgresql.util.PGobject 0x41fa9af7 "physical"]
user> (.getType *1)
"venue_type"
user> (.getValue *2)
"physical"

これを利用して venues テーブル情報の一覧取得時に venue_type の条件で絞り込み、登録時に venue_type を指定するように変更する。

 (ns rest-server.boundary.db.venue
   (:require [duct.database.sql]
             [honeysql.core :as sql]
-            [rest-server.boundary.db.core :as db]))
+            [rest-server.boundary.db.core :as db]
+            [rest-server.util :as util]))

 (defprotocol Venues
-  (list-venues [db group-id])
+  (list-venues [db group-id venue-type])
   (create-venue [db venue])
   (fetch-venue [db venue-id]))

 (extend-protocol Venues
   duct.database.sql.Boundary
-  (list-venues [db group-id]
+  (list-venues [db group-id venue-type]
     (db/select db (sql/build :select :*
                              :from :venues
-                             :where [:= :group_id group-id])))
+                             :where [:and
+                                     [:= :group_id group-id]
+                                     [:= :venue_type (util/kw->pgenum venue-type)]])))
   (create-venue [db venue]
-    (db/insert! db :venues venue))
+    (db/insert! db :venues (update venue :venue-type util/kw->pgenum)))
   (fetch-venue [db venue-id]
     (db/select-one db (sql/build :select :*
                                  :from :venues
                                  :where [:= :id venue-id]))))

2. ルーティングの改修

次に、APIエンドポイントの追加に伴い、オンライン会場の一覧/登録APIのためのルーティング定義を追加する。

内容的には既存の会場一覧/登録APIとほぼ同じものになる。

 {:duct.core/project-ns  rest-server
  :duct.core/environment :production

  :duct.module/logging {}
  :duct.module.web/api {}
  :duct.module/sql
  {:database-url "jdbc:postgresql://localhost:5432/meetup?user=meetup&password=password123"}

  :duct.module/ataraxy
  {"/members"
   {:get [:member/list]
    [:post {member :body-params}] [:member/create member]
    ["/" member-id]
    {:get [:member/fetch ^int member-id]
     "/meetups"
     {["/" meetup-id]
      {:post [:meetup/join ^int member-id ^int meetup-id]}}
     "/groups"
     {["/" group-id]
      {[:post {group-member :body-params}] [:group/join ^int member-id ^int group-id group-member]}}}}
   "/groups"
   {:get [:group/list]
    [:post {group :body-params}] [:group/create group]
    ["/" group-id]
    {"/meetups"
     {:get [:meetup/list ^int group-id]
      [:post {meetup :body-params}] [:meetup/create ^int group-id meetup]
      ["/" meetup-id]
      {:get [:meetup/fetch ^int group-id ^int meetup-id]}}
     "/venues"
     {:get [:venue/list ^int group-id]
-     [:post {venue :body-params}] [:venue/create ^int group-id venue]}}}}
+     [:post {venue :body-params}] [:venue/create ^int group-id venue]}
+    "/online-venues"
+    {:get [:online-venue/list ^int group-id]
+     [:post {venue :body-params}] [:online-venue/create ^int group-id venue]}}}}

  :rest-server.handler.meetup/list {:db #ig/ref :duct.database/sql}
  :rest-server.handler.meetup/create {:db #ig/ref :duct.database/sql}
  :rest-server.handler.meetup/fetch {:db #ig/ref :duct.database/sql}
  :rest-server.handler.meetup/join {:db #ig/ref :duct.database/sql}
  :rest-server.handler.member/list {:db #ig/ref :duct.database/sql}
  :rest-server.handler.member/create {:db #ig/ref :duct.database/sql}
  :rest-server.handler.member/fetch {:db #ig/ref :duct.database/sql}
  :rest-server.handler.venue/list {:db #ig/ref :duct.database/sql}
  :rest-server.handler.venue/create {:db #ig/ref :duct.database/sql}
+ :rest-server.handler.online-venue/list {:db #ig/ref :duct.database/sql}
+ :rest-server.handler.online-venue/create {:db #ig/ref :duct.database/sql}
  :rest-server.handler.group/list {:db #ig/ref :duct.database/sql}
  :rest-server.handler.group/create {:db #ig/ref :duct.database/sql}
  :rest-server.handler.group/join {:db #ig/ref :duct.database/sql}}

3. ハンドラーの改修

最後に、ハンドラーを仕様変更内容に沿うように改修する。

オンライン会場の一覧/登録APIのためのハンドラー関数を新たに作成する。

ここでは、一覧取得時の検索条件、登録時の設定値としてvenue-typeに :venue-type/online を指定する。

(ns rest-server.handler.online-venue
  (:require [ataraxy.response :as response]
            [integrant.core :as ig]
            [rest-server.boundary.db.venue :as db.venue]))

(defn online-venue-with-id [{:keys [id name url] :as online-venue}]
  (when online-venue
    {:online-venue-id id
     :venue-name name
     :url url}))

(defmethod ig/init-key ::list [_ {:keys [db]}]
  (fn [{[_ group-id] :ataraxy/result}]
    [::response/ok (map online-venue-with-id
                        (db.venue/list-venues db
                                              group-id
                                              :venue-type/online))]))

(defmethod ig/init-key ::create [_ {:keys [db]}]
  (fn [{[_ group-id {:keys [venue-name url]}] :ataraxy/result}]
    (let [venue {:name venue-name
                 :group-id group-id
                 :url url
                 :venue-type :venue-type/online}
          id (db.venue/create-venue db venue)]
      [::response/ok (-> venue
                         (assoc :id id)
                         online-venue-with-id)])))

既存の会場APIについては、そもそも通常の会場が未登録の状況がありうるためレスポンスのJSONデータを組み立てる venue-with-address 関数で会場情報がない場合にはnilを返すように変更する。

また、オンライン会場APIに準じて、一覧取得時の検索条件、登録時の設定値としてvenue-typeに :venue-type/physical を指定する。

 (ns rest-server.handler.venue
   (:require [ataraxy.response :as response]
             [integrant.core :as ig]
             [rest-server.boundary.db.venue :as db.venue]))

-(defn venue-with-address [{:keys [id name postal-code prefecture city street1 street2]}]
-  {:venue-id id
-   :venue-name name
-   :address {:postal-code postal-code
-             :prefecture prefecture
-             :city city
-             :address1 street1
-             :address2 street2}})
+(defn venue-with-address [{:keys [id name postal-code prefecture city street1 street2] :as venue}]
+  (when venue
+    {:venue-id id
+     :venue-name name
+     :address {:postal-code postal-code
+               :prefecture prefecture
+               :city city
+               :address1 street1
+               :address2 street2}}))

 (defmethod ig/init-key ::list [_ {:keys [db]}]
   (fn [{[_ group-id] :ataraxy/result}]
     [::response/ok (map venue-with-address
-                        (db.venue/list-venues db group-id))]))
+                        (db.venue/list-venues db
+                                              group-id
+                                              :venue-type/physical))]))

 (defmethod ig/init-key ::create [_ {:keys [db]}]
   (fn [{[_ group-id {:keys [address] :as venue}] :ataraxy/result}]
     (let [venue' {:name (:venue-name venue)
                   :postal-code (:postal-code address)
                   :prefecture (:prefecture address)
                   :city (:city address)
                   :street1 (:address1 address)
                   :street2 (:address2 address)
-                  :group-id group-id}
+                  :group-id group-id
+                  :venue-type :venue-type/physical}
           id (db.venue/create-venue db venue')]
       [::response/ok (-> venue'
                          (assoc :id id)
                          venue-with-address)])))

ミートアップAPIでは、レスポンスのJSONに :online-venue を追加してミートアップに紐付いたオンライン会場情報を返せるように変更する。

 (ns rest-server.handler.meetup
   (:require [ataraxy.response :as response]
             [integrant.core :as ig]
             [rest-server.boundary.db.meetup :as db.meetup]
             [rest-server.boundary.db.venue :as db.venue]
             [rest-server.handler.member :as member]
+            [rest-server.handler.online-venue :as online-venue]
             [rest-server.handler.venue :as venue]
             [rest-server.util :as util]))

-(defn meetup-with-venue-and-members [{:keys [id title start-at end-at]} venue members]
+(defn meetup-with-venue-and-members [{:keys [id title start-at end-at]} venue online-venue members]
   {:event-id id
    :title title
    :start-at start-at
    :end-at end-at
    :venue (venue/venue-with-address venue)
+   :online-venue (online-venue/online-venue-with-id online-venue)
    :members (map member/member-with-id members)})

-(defn fetch-meetup-detail [db {:keys [id venue-id] :as meetup}]
+(defn fetch-meetup-detail [db {:keys [id venue-id online-venue-id] :as meetup}]
   (let [venue (db.venue/fetch-venue db venue-id)
+        online-venue (db.venue/fetch-venue db online-venue-id)
         members (db.meetup/fetch-meetup-members db id)]
-    (meetup-with-venue-and-members meetup venue members)))
+    (meetup-with-venue-and-members meetup venue online-venue members)))

 (defn get-meetup [db meetup-id]
   (when-let [meetup (db.meetup/fetch-meetup db meetup-id)]
     (fetch-meetup-detail db meetup)))

 (defmethod ig/init-key ::list [_ {:keys [db]}]
   (fn [{[_ group-id] :ataraxy/result}]
     [::response/ok (map (partial fetch-meetup-detail db)
                         (db.meetup/list-meetups db group-id))]))

 (defmethod ig/init-key ::create [_ {:keys [db]}]
   (fn [{[_ group-id {:keys [start-at end-at] :as meetup}] :ataraxy/result}]
     (let [meetup' (assoc meetup
                          :start-at (util/string->timestamp start-at)
                          :end-at (util/string->timestamp end-at)
                          :group-id group-id)
           id (db.meetup/create-meetup db meetup')]
       [::response/ok (-> meetup'
                          (assoc :id id)
                          ((partial fetch-meetup-detail db)))])))

 (defmethod ig/init-key ::fetch [_ {:keys [db]}]
   (fn [{[_ _ meetup-id] :ataraxy/result}]
     (when-let [meetup (get-meetup db meetup-id)]
       [::response/ok meetup])))

 (defmethod ig/init-key ::join [_ {:keys [db]}]
   (fn [{[_ member-id meetup-id] :ataraxy/result}]
     (db.meetup/create-meetup-member db {:meetup-id meetup-id
                                         :member-id member-id})
     [::response/ok (get-meetup db meetup-id)]))

グループAPIについても、レスポンスのJSONに :online-venues を追加してグループに紐付いた複数のオンライン会場情報を返せるように変更する(同時に、既存の :venues には通常の会場のみが含まれるようにする)。

 (ns rest-server.handler.group
   (:require [ataraxy.response :as response]
             [integrant.core :as ig]
             [rest-server.boundary.db.group :as db.group]
             [rest-server.boundary.db.meetup :as db.meetup]
             [rest-server.boundary.db.member :as db.member]
             [rest-server.boundary.db.venue :as db.venue]
             [rest-server.handler.meetup :as meetup]
             [rest-server.handler.member :as member]
+            [rest-server.handler.online-venue :as online-venue]
             [rest-server.handler.venue :as venue]
             [rest-server.util :as util]))

 (defn group-with-admin [{:keys [id name]} admins]
   {:group-id id
    :group-name name
    :admin (map member/member-with-id admins)})

 (defn fetch-group-detail [db {:keys [id] :as group}]
   (let [admins (db.group/fetch-group-admin-members db id)
-        venues (db.venue/list-venues db id)
+        venues (db.venue/list-venues db id :venue-type/physical)
+        online-venues (db.venue/list-venues db id :venue-type/online)
         meetups (db.meetup/list-meetups db id)]
     (assoc (group-with-admin group admins)
            :venues (map venue/venue-with-address venues)
+           :online-venues (map online-venue/online-venue-with-id online-venues)
            :meetups (map (partial meetup/fetch-meetup-detail db) meetups))))

 (defmethod ig/init-key ::list [_ {:keys [db]}]
   (fn [_] [::response/ok (map (partial fetch-group-detail db)
                               (db.group/list-groups db))]))

 (defmethod ig/init-key ::create [_ {:keys [db]}]
   (fn [{[_ {:keys [group-name admin-member-ids]}] :ataraxy/result}]
     (let [group {:name group-name
                  :created-at (util/now)}
           id (db.group/create-group db group)
           admins (db.member/fetch-members db admin-member-ids)]
       (db.group/create-group-members db (map (fn [member-id]
                                                {:group-id id
                                                 :member-id member-id
                                                 :admin true})
                                              admin-member-ids))
       [::response/ok (-> group
                          (assoc :id id)
                          (group-with-admin admins))])))

 (defmethod ig/init-key ::join [_ {:keys [db]}]
   (fn [{[_ member-id group-id {:keys [admin]}] :ataraxy/result}]
     (db.group/create-group-members db [{:group-id group-id
                                         :member-id member-id
                                         :admin admin}])
     (when-let [group (db.group/fetch-group db group-id)]
       [::response/ok (fetch-group-detail db group)])))

以上でClojure/Duct版RESTサーバの仕様変更対応は完了(*> ᴗ •*)ゞ

Haskell版

1. モデルの改修

Clojure版と同様に、まずはDBスキーマの変更に対応するため、モデルの定義に手を加える。

HaskellのPersistentでPostgreSQLのenum typeをいかに扱うべきか、いろいろ検討し試行錯誤した(Haskell版での作業の大半の時間をここに費やした:sweat_smile:)結果、最終的にはこちらのページ

How to use UUID values with Persistent and Yesod

などを参考に、 venue_type を表すデータ型を定義し、それをPersistentのフィールドとして扱えるように必要な型クラスのインスタンス実装を与えることにした。

{-# LANGUAGE OverloadedStrings #-}
module CustomField.VenueType where

import qualified Data.ByteString.Char8 as BC
import           Database.Persist.Sql

data VenueType = Physical | Online deriving (Eq, Ord, Enum, Bounded)

instance Show VenueType where
    show Physical = "physical"
    show Online   = "online"

instance Read VenueType where
    readsPrec _ "physical" = [(Physical, [])]
    readsPrec _ "online"   = [(Online, [])]
    readsPrec _ _          = []

instance PersistField VenueType where
    toPersistValue = PersistDbSpecific . BC.pack . show
    fromPersistValue (PersistDbSpecific bs) = Right . read $ BC.unpack bs
    fromPersistValue _                      = Left "Not PersistDBSpecific"

instance PersistFieldSql VenueType where
    sqlType _ = SqlOther "venue_type"

ここで定義した VenueType も利用して、新たにテーブルに追加されたカラムをモデルの定義に反映する。

 Group sql=groups
     name Text sqltype=text Maybe
     createdAt UTCTime Maybe
     deriving Eq
     deriving Show

 GroupMember sql=groups_members
     groupId GroupId
     memberId MemberId
     Primary groupId memberId
     admin Bool default=false Maybe
     deriving Eq
     deriving Show

 Meetup sql=meetups
     title Text sqltype=text
     startAt UTCTime Maybe
     endAt UTCTime Maybe
     venueId VenueId Maybe
     groupId GroupId Maybe
+    onlineVenueId VenueId Maybe
     deriving Eq
     deriving Show

 MeetupMember sql=meetups_members
     meetupId MeetupId
     memberId MemberId
     Primary meetupId memberId
     deriving Eq
     deriving Show

 Member sql=members
     firstName Text sqltype=text Maybe
     lastName Text sqltype=text Maybe
     email Text sqltype=text Maybe
     deriving Eq
     deriving Show

 Venue sql=venues
     name Text sqltype=text Maybe
     postalCode Text sqltype=text Maybe
     prefecture Text sqltype=text Maybe
     city Text sqltype=text Maybe
     street1 Text sqltype=text Maybe
     street2 Text sqltype=text Maybe
     groupId GroupId Maybe
+    url Text sqltype=text Maybe
+    venueType VenueType Maybe default="physical"
     deriving Eq
     deriving Show

モデルの設定ファイルで CustomField.VenueType が利用できるようにimportしておき、また、 venueType フィールドが追加された Venue エンティティを直接JSONと相互変換する必要はないため deriveJSON しないようにしておく。

 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE EmptyDataDecls             #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
 module Model where

 import           ClassyPrelude.Yesod
 import           Data.Aeson.TH
 import           Database.Persist.Quasi

 import qualified Data.Aeson.Casing      as Casing
 import qualified Text.Casing            as Casing

+import           CustomField.VenueType
+
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:
 -- http://www.yesodweb.com/book/persistent/
 share [mkPersist sqlSettings, mkMigrate "migrateAll"]
     $(persistFileWith lowerCaseSettings "config/models")

 deriveJSON (Casing.aesonPrefix Casing.kebab) ''Group
 deriveJSON (Casing.aesonPrefix Casing.kebab) ''Meetup
 deriveJSON (Casing.aesonPrefix Casing.kebab) ''Member
-deriveJSON (Casing.aesonPrefix Casing.kebab) ''Venue

2. ルーティングの改修

次に、APIエンドポイントの追加に対応するため、オンライン会場APIのルーティング定義を追加する(stack exec -- yesod add-handler を利用すると、関連する設定も自動生成されて簡単:ideograph_advantage:)。

 /members MembersR GET POST
 /members/#MemberId MemberR GET
 /members/#MemberId/meetups/#MeetupId MeetupMemberR POST
 /members/#MemberId/groups/#GroupId GroupMemberR POST
 /groups GroupsR GET POST
 /groups/#GroupId/venues VenuesR GET POST
 /groups/#GroupId/meetups MeetupsR GET POST
 /groups/#GroupId/meetups/#MeetupId MeetupR GET
+/groups/#GroupId/online-venues OnlineVenuesR GET POST

3. ハンドラーの改修

最後に、APIの仕様変更内容通りにハンドラーを改修する。

改修の方針も内容もほとんどClojure版と同じなので特筆すべき点はなさそう。

強いて言えば、Clojureでは一貫してマップ(associativeなもの)としてデータを扱うのに対して、Haskellでは目的によってレコードやaesonといった異なるデータ表現に変換しているため、必然的に扱い方に違いが見られる。

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
module Handler.OnlineVenues where

import           Import

import           Data.Aeson.TH

import qualified Data.Aeson.Casing     as Casing
import qualified Text.Casing           as Casing

import qualified CustomField.VenueType as VenueType

getOnlineVenuesR :: GroupId -> Handler Value
getOnlineVenuesR groupId = do
    vs <- runDB $ selectList [VenueGroupId ==. Just groupId, VenueVenueType ==. Just VenueType.Online] []
    returnJson $ map onlineVenueValueWithId vs

postOnlineVenuesR :: GroupId -> Handler Value
postOnlineVenuesR groupId = do
    PostVenue{..} <- requireJsonBody :: Handler PostVenue
    let v = Venue { venueName = postVenueName
                  , venuePostalCode = Nothing
                  , venuePrefecture = Nothing
                  , venueCity = Nothing
                  , venueStreet1 = Nothing
                  , venueStreet2 = Nothing
                  , venueGroupId = Just groupId
                  , venueUrl = postUrl
                  , venueVenueType = Just VenueType.Online
                  }
    vid <- runDB $ insert v
    returnJson . onlineVenueValueWithId $ Entity vid v

onlineVenueValueWithId :: Entity Venue -> Value
onlineVenueValueWithId (Entity vid Venue{..}) =
    object [ "online-venue-id" .= vid
           , "venue-name" .= venueName
           , "url" .= venueUrl
           ]

data PostVenue = PostVenue
    { postVenueName :: Maybe Text
    , postUrl       :: Maybe Text
    }

deriveJSON (Casing.aesonPrefix Casing.kebab) ''PostVenue
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TemplateHaskell   #-}
 module Handler.Venues where

 import           Import

 import           Data.Aeson.TH

-import qualified Data.Aeson.Casing as Casing
-import qualified Text.Casing       as Casing
+import qualified Data.Aeson.Casing     as Casing
+import qualified Text.Casing           as Casing
+
+import qualified CustomField.VenueType as VenueType

 getVenuesR :: GroupId -> Handler Value
 getVenuesR groupId = do
-    vs <- runDB $ selectList [VenueGroupId ==. Just groupId] []
+    vs <- runDB $ selectList [VenueGroupId ==. Just groupId, VenueVenueType ==. Just VenueType.Physical] []
     returnJson $ map venueValueWithAddress vs

 postVenuesR :: GroupId -> Handler Value
 postVenuesR groupId = do
     PostVenue{..} <- requireJsonBody :: Handler PostVenue
     let PostAddress{..} = postAddress
         v = Venue { venueName = postVenueName
                   , venuePostalCode = postPostalCode
                   , venuePrefecture = postPrefecture
                   , venueCity = postCity
                   , venueStreet1 = postAddress1
                   , venueStreet2 = postAddress2
                   , venueGroupId = Just groupId
+                  , venueUrl = Nothing
+                  , venueVenueType = Just VenueType.Physical
                   }
     vid <- runDB $ insert v
     returnJson . venueValueWithAddress $ Entity vid v

 venueValueWithAddress :: Entity Venue -> Value
 venueValueWithAddress (Entity vid Venue{..}) =
     object [ "venue-id" .= vid
            , "venue-name" .= venueName
            , "address" .= object [ "postal-code" .= venuePostalCode
                                  , "prefecture" .= venuePrefecture
                                  , "city" .= venueCity
                                  , "address1" .= venueStreet1
                                  , "address2" .= venueStreet2
                                  ]
            ]

 data PostVenue = PostVenue
     { postVenueName :: Maybe Text
     , postAddress   :: PostAddress
     }

 data PostAddress = PostAddress
     { postPostalCode :: Maybe Text
     , postPrefecture :: Maybe Text
     , postCity       :: Maybe Text
     , postAddress1   :: Maybe Text
     , postAddress2   :: Maybe Text
     }

 deriveJSON (Casing.aesonPrefix Casing.kebab) ''PostVenue
 deriveJSON (Casing.aesonPrefix Casing.kebab) ''PostAddress
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 module Handler.Meetups where

 import           Import

-import           Database.Esqueleto ((^.))
-import qualified Database.Esqueleto as E
+import           Database.Esqueleto   ((^.))
+import qualified Database.Esqueleto   as E

-import           Handler.Members    (memberValueWithId)
-import           Handler.Venues     (venueValueWithAddress)
+import           Handler.Members      (memberValueWithId)
+import           Handler.OnlineVenues (onlineVenueValueWithId)
+import           Handler.Venues       (venueValueWithAddress)

 getMeetupsR :: GroupId -> Handler Value
 getMeetupsR groupId = do
     ms <- runDB $ selectList [MeetupGroupId ==. Just groupId] []
     meetupDetails <- mapM fetchMeetupDetail ms
     returnJson meetupDetails

 postMeetupsR :: GroupId -> Handler Value
 postMeetupsR groupId = do
     m <- requireJsonBody :: Handler Meetup
     let m' = m { meetupGroupId = Just groupId }
     mid <- runDB $ insert m'
     meetupDetail <- fetchMeetupDetail $ Entity mid m'
     returnJson meetupDetail

 getMeetupR :: GroupId -> MeetupId -> Handler Value
 getMeetupR _ = getMeetup

 postMeetupMemberR :: MemberId -> MeetupId -> Handler Value
 postMeetupMemberR memberId meetupId = do
     _ <- runDB . insert $ MeetupMember { meetupMemberMeetupId = meetupId
                                        , meetupMemberMemberId = memberId
                                        }
     getMeetup meetupId

 fetchMeetupDetail :: Entity Meetup -> Handler Value
 fetchMeetupDetail em@(Entity mid Meetup{..}) = do
     v <- maybe (return Nothing) (runDB . getEntity) meetupVenueId
+    ov <- maybe (return Nothing) (runDB . getEntity) meetupOnlineVenueId
     ms <- runDB $ E.select
                 $ E.from $ \(member' `E.InnerJoin` meetupMember') -> do
                     E.on $ member' ^. MemberId E.==. meetupMember' ^. MeetupMemberMemberId
                     E.where_ $ meetupMember' ^. MeetupMemberMeetupId E.==. E.val mid
                     return member'
-    return $ meetupWithVenueAndMembers em v ms
+    return $ meetupWithVenueAndMembers em v ov ms

 getMeetup :: MeetupId -> Handler Value
 getMeetup mid = do
     m <- runDB $ get404 mid
     meetupDetail <- fetchMeetupDetail $ Entity mid m
     returnJson meetupDetail

-meetupWithVenueAndMembers :: Entity Meetup -> Maybe (Entity Venue) -> [Entity Member] -> Value
-meetupWithVenueAndMembers (Entity mid Meetup{..}) venue members =
+meetupWithVenueAndMembers :: Entity Meetup -> Maybe (Entity Venue) -> Maybe (Entity Venue) -> [Entity Member] -> Value
+meetupWithVenueAndMembers (Entity mid Meetup{..}) venue onlineVenue members =
     object [ "event-id" .= mid
            , "title" .= meetupTitle
            , "start-at" .= meetupStartAt
            , "end-at" .= meetupEndAt
            , "venue" .= fmap venueValueWithAddress venue
+           , "online-venue" .= fmap onlineVenueValueWithId onlineVenue
            , "members" .= fmap memberValueWithId members
            ]
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TemplateHaskell   #-}
 module Handler.Groups where

 import           Import

 import           Data.Aeson.TH

-import           Control.Lens       hiding ((.=), (^.))
-import qualified Data.Aeson.Casing  as Casing
+import           Control.Lens          hiding ((.=), (^.))
+import qualified Data.Aeson.Casing     as Casing
 import           Data.Aeson.Lens
-import           Database.Esqueleto ((^.))
-import qualified Database.Esqueleto as E
-import qualified Text.Casing        as Casing
+import           Database.Esqueleto    ((^.))
+import qualified Database.Esqueleto    as E
+import qualified Text.Casing           as Casing

-import           Handler.Meetups    (fetchMeetupDetail)
-import           Handler.Members    (memberValueWithId)
-import           Handler.Venues     (venueValueWithAddress)
+import qualified CustomField.VenueType as VenueType
+import           Handler.Meetups       (fetchMeetupDetail)
+import           Handler.Members       (memberValueWithId)
+import           Handler.OnlineVenues  (onlineVenueValueWithId)
+import           Handler.Venues        (venueValueWithAddress)

 getGroupsR :: Handler Value
 getGroupsR = do
     gs <- runDB $ selectList [] [] :: Handler [Entity Group]
     groupDetails <- mapM fetchGroupDetail gs
     returnJson groupDetails

 postGroupsR :: Handler Value
 postGroupsR = do
     PostGroup{..} <- requireJsonBody :: Handler PostGroup
     now <- liftIO getCurrentTime
     let g = Group { groupName = postGroupName
                   , groupCreatedAt = Just now
                   }
     gid <- runDB $ insert g
     _ <- runDB . insertMany $ map (\mid -> GroupMember { groupMemberGroupId = gid
                                                        , groupMemberMemberId = mid
                                                        , groupMemberAdmin = Just True
                                                        }) postAdminMemberIds
     ms <- runDB $ selectList [MemberId <-. postAdminMemberIds] []
     returnJson $ groupValueWithAdmin (Entity gid g) ms

 postGroupMemberR :: MemberId -> GroupId -> Handler Value
 postGroupMemberR memberId groupId = do
     PostGroupMember{..} <- requireJsonBody :: Handler PostGroupMember
     _ <- runDB $ insert GroupMember { groupMemberGroupId = groupId
                                     , groupMemberMemberId = memberId
                                     , groupMemberAdmin = postAdmin
                                     }
     g <- runDB $ get404 groupId
     groupDetail <- fetchGroupDetail $ Entity groupId g
     returnJson groupDetail

 fetchGroupDetail :: Entity Group -> Handler Value
 fetchGroupDetail eg@(Entity gid Group{..}) = do
     admins <- runDB $ E.select
                     $ E.from $ \(member' `E.InnerJoin` groupMember') -> do
                         E.on $ member' ^. MemberId E.==. groupMember' ^. GroupMemberMemberId
                         E.where_ $ (groupMember' ^. GroupMemberGroupId E.==. E.val gid)
                             E.&&. (groupMember' ^. GroupMemberAdmin E.==. E.val (Just True))
                         return member'
-    vs <- runDB $ selectList [VenueGroupId ==. Just gid] []
+    vs <- runDB $ selectList [VenueGroupId ==. Just gid, VenueVenueType ==. Just VenueType.Physical] []
     let venueDetails = map venueValueWithAddress vs
+    ovs <- runDB $ selectList [VenueGroupId ==. Just gid, VenueVenueType ==. Just VenueType.Online] []
+    let onlineVenueDetails = map onlineVenueValueWithId ovs
     ms <- runDB $ selectList [MeetupGroupId ==. Just gid] []
     meetupDetails <- mapM fetchMeetupDetail ms
     return $ toJSON (groupValueWithAdmin eg admins)
              & _Object . at "venues" ?~ toJSON venueDetails
+             & _Object . at "online-venues" ?~ toJSON onlineVenueDetails
              & _Object . at "meetups" ?~ toJSON meetupDetails

 groupValueWithAdmin :: Entity Group -> [Entity Member] -> Value
 groupValueWithAdmin (Entity gid Group{..}) ms =
     object [ "group-id" .= gid
            , "group-name" .= groupName
            , "admin" .= map memberValueWithId ms
            ]

 data PostGroup = PostGroup
     { postGroupName      :: Maybe Text
     , postAdminMemberIds :: [Key Member]
     }

 newtype PostGroupMember = PostGroupMember
     { postAdmin :: Maybe Bool
     }

 deriveJSON (Casing.aesonPrefix Casing.kebab) ''PostGroup
 deriveJSON (Casing.aesonPrefix Casing.kebab) ''PostGroupMember

以上でHaskell/Yesod版RESTサーバの仕様変更対応も無事に完了(*> ᴗ •*)ゞ

まとめ

  • ClojureでもHaskellでも既存実装に大きく手を入れることなく必要最小限の改修でAPI変更を実現できた
  • 特定のミドルウェアの独自機能が関わるような問題はライブラリ/フレームワークの標準機能でカバーしきれないことがある(カスタマイズしやすさが問われる)
  • 既存のユニットテストから始めてテスト駆動開発を実践してみても良かったかも
  • Clojure楽しい>ω</
  • Haskell楽しい>ω</

Further Reading


  1. READMEとテストコードを除いた、プロダクトコードの変更行数。 

Sign up for free and join this conversation.
Sign Up
If you already have a Qiita account log in.