Data.Aesonで複数バージョンのJSONをあつかう小手先テクニック

フロントエンドと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って会社がいいって聞いたよ（ステま！）。