Gogol Datastore Generic Record Serializer

GenericGogolDatastore.hs

{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module GenericDatastore where

import           Control.Lens             hiding (from)
import qualified Control.Lens             as L
import qualified Data.HashMap.Lazy        as HM
import           Data.List.NonEmpty
import           Data.Proxy
import           Data.String
import           Data.Text
import           Data.Text1
import           GHC.Generics
import           Network.Google.Datastore

data EntityTransform
  = Entity Text [(Text, Value)]
  | EntityP [(Text, Value)]
  | V Value
  | None
  deriving (Eq, Show)

class Datastore a where
  entity' :: a -> EntityTransform
  default entity' :: (Generic a, GDatastore (Rep a)) => a -> EntityTransform
  entity' = gentity' . from

class GDatastore f where
  gentity' :: f a -> EntityTransform

instance GDatastore U1 where
  gentity' _ = None

-- | Sum - can't encode sum types easily - perhaps map to string rep?
instance (GDatastore a, GDatastore b) => GDatastore (a :+: b) where
  gentity' (L1 x) = gentity' x
  gentity' (R1 x) = gentity' x

-- | Product
instance (GDatastore a, GDatastore b) => GDatastore (a :*: b) where
  gentity' (a :*: b) = case (gentity' a, gentity' b) of
    (EntityP xs, EntityP ys) -> EntityP $ xs ++ ys
    _                        -> None

-- | Datatype
instance GDatastore f => GDatastore (M1 D d f) where
  gentity' = gentity' . unM1

-- | Constructor Metadata - for entity key
instance (GDatastore f, Constructor c) => GDatastore (M1 C c f) where
  gentity' x
    | conIsRecord x = case gentity' $ unM1 x of
        EntityP xs -> Entity (pack (conName x)) xs
        _          -> None
    | otherwise = gentity' $ unM1 x

-- | Selector Metadata
instance (GDatastore f, Selector c) => GDatastore (M1 S c f) where
  gentity' s@(M1 x) = case gentity' x of
    V v        -> EntityP [(pack (selName s), v)]
    EntityP xs -> EntityP $ (\(x, y) -> (pack (selName s), y)) <$> xs
    x          -> None

-- | Selector values
instance Datastore a => GDatastore (K1 i a) where
  gentity' = entity' . unK1

-- | Value serializers

instance Datastore Text where
  entity' x = V $ value & vStringValue ?~ x

instance Datastore Text1 where
  entity' x = V $ value & vStringValue ?~ review _Text1 x

instance Datastore Bool where
  entity' b = V $ value & vBooleanValue ?~ b

instance Datastore Int where
  entity' i = V $ value & vIntegerValue ?~ fromIntegral i

data Colour = Red | Green | Blue deriving (Eq, Show)

instance Datastore Colour where
  entity' b = V $ value & vStringValue ?~ pack (show b)

instance Datastore a => Datastore [a] where
  entity' xs = V $ value & vArrayValue ?~ (arrayValue & avValues .~ (xs >>= indiv))
    where indiv x = case entity' x of
            V v -> [v]
            _   -> []

instance Datastore a => Datastore (NonEmpty a) where
  entity' xs = V $ value & vArrayValue ?~ (arrayValue & avValues .~ (toList xs >>= indiv))
    where indiv x = case entity' x of
            V v -> [v]
            _   -> []

instance Datastore a => Datastore (Maybe a) where
  entity' (Just x) = entity' x
  entity' Nothing  = V $ value & vNullValue ?~ NullValue

instance Datastore b => Datastore (Either a b) where
  entity' (Right x) = entity' x
  entity' (Left _)  = V $ value & vNullValue ?~ NullValue

-- | This stuff should be in a separate module

_AsDatastore :: Datastore a => Getter a (Maybe Entity)
_AsDatastore = L.to (toEntity . entity')
    where toEntity (Entity k params) =
            pure $ entity & eKey ?~ (key & kPath .~ [pathElement & peKind ?~ k])
                          & eProperties ?~ entityProperties (HM.fromList params)
          toEntity _                 = Nothing

data RecordTest
  = RecordTest
  { foo :: Text
  , bar :: Bool
  , baz :: Int
  }
  | SumTest
  { quux    :: Text
  , colours :: [Colour]
  }
  deriving (Eq, Show, Generic, Datastore)

This is a WIP - not yet handling nested record types!