Clojure勉強会clj-nakanoの課題として"situated-program-challenge"のClojureとHaskellによるREST APIサーバ/クライアントの実装にこれまで取り組んできました。
今回は、このREST APIに対する(テーブル変更を含む)仕様変更に対応してみた結果をご紹介します。
過去の実装とその紹介記事はこちら:
-
Clojure/Duct版RESTサーバ(version 1): lagenorhynque/situated-program-challenge/rest-server at clj-version1
-
Haskell/Yesod版RESTサーバ(version 1): lagenorhynque/situated-program-challenge/rest-server at hs-version1
Clojure版RESTクライアント(version 1): lagenorhynque/situated-program-challenge/rest-client at clj-version1
-
Haskell版RESTクライアント(version 1): lagenorhynque/situated-program-challenge/rest-client at hs-version1
他の参加者によるversion 1の実装例はこちら:
- Clojure版 by @iku000888 さん: iku000888/situated-program-challenge at clj-solution
- Scala版 by @shinichy さん: shinichy/situated-program-challenge at version1
- Common Lisp版 by @masatoi0 さん: masatoi/situated-program-challenge at cl-version1
- Ruby版 by @toku345 さん: toku345/situated-program-challenge at rb-version1
仕様変更内容の検討
situated-program-challenge version 2での仕様変更の内容を確認し詳細に検討してみると、通常の「会場」(venue)とは別で新たに「オンライン会場」(online-venue)を扱うために、以下のような変更が必要になることが分かる。
-
DBスキーマの変更
-
venue_type(会場の種別を表すPostgreSQLのenum type)を新規作成 -
venuesテーブルにurl(オンライン会場のURL)カラムを追加 -
venuesテーブルにvenue_type(会場種別venue_type)カラムを追加 -
meetupsテーブルにonline_venue_id(オンライン会場のvenues.id)カラムを追加
-
-
APIエンドポイントの追加
-
GET /groups/{group-id}/online-venues: オンライン会場一覧の取得- (通常の会場を含まない)オンライン会場(
venues.venue_type = online)のみを抽出して取得
- (通常の会場を含まない)オンライン会場(
-
POST /groups/{group-id}/online-venues: オンライン会場の登録- オンライン会場(
venues.venue_type = online)として登録
- オンライン会場(
-
-
既存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も同様
- レスポンスのJSONで通常の会場を
-
POST /groups/{group-id}/meetups: ミートアップイベントの登録- リクエストのJSONで通常の会場のIDを
"venue-id"、オンライン会場のIDを"online-venue-id"で受け取る
- リクエストのJSONで通常の会場のIDを
-
GET /groups: グループ一覧の取得- レスポンスのJSONで通常の会場を
"venues"、オンライン会場を"online-venues"で返す ※グループ情報を返す他のAPIも同様
- レスポンスのJSONで通常の会場を
-
Clojure版
- Clojure/Duct版RESTサーバ(version 2): lagenorhynque/situated-program-challenge/rest-server at clj-version2
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版
- Haskell/Yesod版RESTサーバ(version 2): lagenorhynque/situated-program-challenge/rest-server at hs-version2
1. モデルの改修
Clojure版と同様に、まずはDBスキーマの変更に対応するため、モデルの定義に手を加える。
HaskellのPersistentでPostgreSQLのenum typeをいかに扱うべきか、いろいろ検討し試行錯誤した(Haskell版での作業の大半の時間をここに費やした
)結果、最終的にはこちらのページ
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 を利用すると、関連する設定も自動生成されて簡単
)。
/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版のdiff 1: 7ファイル + 75行 -22行
- Haskell版のdiff 1: 9ファイル +111行 -20行
- 特定のミドルウェアの独自機能が関わるような問題はライブラリ/フレームワークの標準機能でカバーしきれないことがある(カスタマイズしやすさが問われる)
- 既存のユニットテストから始めてテスト駆動開発を実践してみても良かったかも
- Clojure楽しい＞ω＜/
- Haskell楽しい＞ω＜/
Further Reading
- bevuta - Blog - Using PostgreSQL Enums in Clojure
- bitemyapp - How to use UUID values with Persistent and Yesod
-
READMEとテストコードを除いた、プロダクトコードの変更行数。 ↩