module Database.Persist.TH.ProtocolBuffers (
derivePersistFieldPB
) where
import Database.Persist.Store
import Language.Haskell.TH.Syntax
import Text.ProtocolBuffers.WireMessage (messageGet, messagePut)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
strictify :: BSL.ByteString -> BS.ByteString
strictify x = BS.concat $ BSL.toChunks x
lazify :: BS.ByteString -> BSL.ByteString
lazify x = BSL.fromChunks [x]
derivePersistFieldPB :: String
-> Q [Dec]
derivePersistFieldPB typName = do
ss <- [|SqlBlob|]
tpv <- [|PersistByteString . strictify . messagePut|]
fpv <- [|\dt v ->
case fromPersistValue v of
Left e -> Left e
Right s' ->
case (messageGet . lazify) s' of
Left e ->
Left $ T.concat ["Invalid ", dt, ": ", T.pack e]
Right (_, x) | BSL.length x /= 0 ->
Left $ T.concat ["Invalid ", dt, ": excess input"]
Right (msg, _) ->
Right msg|]
return
[ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName typName))
[ FunD (mkName "sqlType")
[ Clause [WildP] (NormalB ss) []
]
, FunD (mkName "toPersistValue")
[ Clause [] (NormalB tpv) []
]
, FunD (mkName "fromPersistValue")
[ Clause [] (NormalB $ fpv `AppE` LitE (StringL typName)) []
]
]
]