フロントエンドとJSON形式のWeb APIを通してやりとりするWebアプリケーションなどで、
JSONの仕様変更に対して対応が容易なプログラムを書きたい。
そしてどうせなら、DeriveGenericの便利さを活かしながら複数バージョンのJSONを並行してあつかえるようにしたい。
もしUser01型とUser02みたいに独立したデータ型を下記のように宣言すると、Multiple declarationsエラーになってしまう。
-- コンパイルできないやつ
{-# LANGUAGE DeriveGeneric #-}
import Data.Aeson
import GHC.Generics
import Data.Text (Text)
data User01 = User01 -- User data for ver 0.1
{ name :: Text
, age :: Int -- This column is removed from ver 0.2
, email :: Text
}
deriving (Show, Read, Eq, Generic)
instance FromJSON User01
instance ToJSON User01
data User02 = User02 -- User data for ver 0.2
{ name :: Text
, address :: Text -- This column is added from ver 0.2
, email :: Text
}
deriving (Show, Read, Eq, Generic)
instance FromJSON User02
instance ToJSON User02
仕方ないので個別にparseJSONとtoJSONを定義するが、めんどくさいしお昼寝する時間が減ってしまう。
-- お昼寝できないやつ
import Data.Aeson
import Data.Text (Text)
data User01 = User01 -- User data for ver 0.1
{ name01 :: Text
, age01 :: Int -- This column is removed from ver 0.2
, email01 :: Text
}
deriving (Show, Read, Eq)
instance FromJSON User01 where
parseJSON (Object v) = User01 <$>
v .: "name" <*>
v .: "age" <*>
v .: "email"
parseJSON _ = mzero
instance ToJSON User01 where
toJSON (User01 name age email) = object ["name" .= name, "age" .= age, "email" .= email]
data User02 = User02 -- User data for ver 0.2
{ name02 :: Text
, address02 :: Text -- This column is added from ver 0.2
, email02 :: Text
}
deriving (Show, Read, Eq)
instance FromJSON User02 where
parseJSON (Object v) = User02 <$>
v .: "name" <*>
v .: "address" <*>
v .: "email"
parseJSON _ = mzero
instance ToJSON User02 where
toJSON (User02 name address email) = object ["name" .= name, "address" .= address, "email" .= email]
instance FromJSON Coord where
parseJSON (Object v) = Person <$>
v .: "name" <*>
v .: "age"
-- A non-Object value is of the wrong type, so fail.
parseJSON _ = mzero
ということでこうする。
-- お昼寝とコンパイルができるやつ
{-# LANGUAGE DeriveGeneric #-}
import Data.Aeson
import Data.Text (Text)
import GHC.Generics
data User = User01 -- User data for ver 0.1
{ name :: Text
, age :: Int -- This column is removed from ver 0.2
, email :: Text
}
| User02 -- User data for ver 0.2
{ name :: Text
, address :: Text -- This column is added from ver 0.2
, email :: Text
}
deriving (Show, Read, Eq, Generic)
instance FromJSON User
instance ToJSON User
ただ、このままだと与えられたJSONがUser01の方なのかUser02の方なのかHaskellちゃんが判断に困るので、JSONにtagキーを追加して教えてあげるようにする。
jsonInput01 :: LBS.ByteString
jsonInput01 = "{\"name\": \"me\", \"age\": 17, \"email\": \"me@domain.com\", \"tag\": \"User01\"}"
jsonInput02 :: LBS.ByteString
jsonInput02 = "{\"name\": \"me\", \"address\": \"Tokyo\", \"email\": \"me@domain.com\", \"tag\": \"User02\"}"
ということで、この小手先テクニックを使ったWebサーバもどき。
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Exception
import Data.Aeson
import Data.Maybe (fromJust)
import Data.Text (Text)
import GHC.Generics
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T hiding (Text)
import qualified Data.Text.IO as T
data User = User01 -- User data for ver 0.1
{ name :: Text
, age :: Int -- This column is removed from ver 0.2
, email :: Text
}
| User02 -- User data for ver 0.2
{ name :: Text
, address :: Text -- This column is added from ver 0.2
, email :: Text
}
deriving (Show, Read, Eq, Generic)
instance FromJSON User
instance ToJSON User
type Routing = String
-- ====================
-- Sample API Handler
-- ====================
-- |
-- >>> main
-- me is 17 years old.
-- me lives in Tokyo.
-- Error: No match in record selector age
-- Error: No match in record selector address
-- me is 17 years old.
-- me lives in Tokyo.
main :: IO ()
main = do
handleErr $ routing "/api/0.1/getUserMsg" jsonInput01
handleErr $ routing "/api/0.2/getUserMsg" jsonInput02
handleErr $ routing "/api/0.1/getUserMsg" jsonInput02
handleErr $ routing "/api/0.2/getUserMsg" jsonInput01
handleErr $ routing "/api/getUserMsg" jsonInput01
handleErr $ routing "/api/getUserMsg" jsonInput02
-- | 単にエラーのときにエラー内容を標準出力に表示して処理を続けるだけ
handleErr :: IO () -> IO ()
handleErr = handle errToMsg
where
errToMsg :: SomeException -> IO ()
errToMsg e = putStrLn $ "Error: " ++ show e
-- =================
-- Sample routing
-- =================
-- | ルーティングっぽいやつ
routing :: Routing -> LBS.ByteString -> IO ()
routing "/api/0.1/getUserMsg" = T.putStrLn . getUserMsg01 . fromJust . decode
routing "/api/0.2/getUserMsg" = T.putStrLn . getUserMsg02 . fromJust . decode
routing "/api/getUserMsg" = T.putStrLn . getUserMsg . fromJust . decode
routing _ = error "Not Found"
-- ====================
-- Main task
-- ====================
getUserMsg01 :: User -> Text
getUserMsg01 u = T.concat [name u, " is ", T.pack . show $ age u, " years old."]
getUserMsg02 :: User -> Text
getUserMsg02 u = T.concat [name u, " lives in ", address u, "."]
getUserMsg :: User -> Text
getUserMsg u@User01{} = getUserMsg01 u
getUserMsg u@User02{} = getUserMsg02 u
-- =====================
-- Sample JSON request
-- =====================
jsonInput01 :: LBS.ByteString
jsonInput01 = "{\"name\": \"me\", \"age\": 17, \"email\": \"me@domain.com\", \"tag\": \"User01\"}"
jsonInput02 :: LBS.ByteString
jsonInput02 = "{\"name\": \"me\", \"address\": \"Tokyo\", \"email\": \"me@domain.com\", \"tag\": \"User02\"}"
もちろん、同じデータ型で複数のバージョンを吸収するより、多少手間でも型を分けたほうが健全な構成になるアプリケーションも存在するとは思う。
あ、Haskellとか好きなおもしろい技術で仕事してお昼寝もしたいなら株式会社ARoWって会社がいいって聞いたよ（ステま！）。
