Support types

1 files changed, 81 insertions, 9 deletions

diff --git a/Model.hs b/Model.hs
index 7b33f6e..a345f2f 100644
--- a/Model.hs
+++ b/Model.hs
@@ -10,7 +10,10 @@ import Control.Monad.Writer
 import           Data.Text   (Text)
 import qualified Data.Text as Text
 
+import qualified Data.HashMap.Lazy as HashMap
+
 import Data.Aeson
+import Data.Aeson.Types (Parser, Value(..))
 
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
@@ -19,6 +22,28 @@ import Data.Aeson
 share [mkPersist sqlSettings, mkMigrate "migrateAll"]
     $(persistFileWith lowerCaseSettings "config/models")
 
+class HasType a where
+  getType :: ( BaseBackend backend ~ SqlBackend
+             , MonadIO m
+             , PersistStoreRead backend
+             ) => a -> ReaderT backend m Kind
+
+instance HasType Item where
+  getType = belongsToJust itemFkType
+
+instance HasType Reference where
+  getType = belongsToJust referenceFkType
+
+instance HasType a => HasType (Entity a) where
+  getType Entity{..} = getType entityVal
+
+withType :: ( BaseBackend backend ~ SqlBackend
+            , MonadIO m
+            , PersistStoreRead backend
+            , HasType a
+            ) => a -> ReaderT backend m (WithType a)
+withType val = (val `WithType`) . kindType <$> getType val
+
 instance Ord Item where
   x `compare` y = mconcat
                   [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y)
@@ -71,6 +96,7 @@ normalizeKind :: Text -> Text
 normalizeKind = Text.strip . Text.toCaseFold
 
 data ItemDiff = DiffKind Text
+              | DiffType Text
               | DiffBought (Maybe Day)
               | DiffExpires (Maybe Day)
               | DiffOpened (Maybe Day)
@@ -80,17 +106,63 @@ newtype ItemDiffs = ItemDiffs [ItemDiff]
 instance FromJSON ItemDiffs where
   parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do
     tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind")
+    tell =<< maybe [] (pure . DiffType) <$> lift (obj .:? "type")
     tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought")
     tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires")
     tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened")
 
-toUpdate :: ItemDiffs -> [Update Item]
-toUpdate (ItemDiffs ds) = do
+toUpdate :: ItemDiffs -> ([Update Item], [Update Kind])
+toUpdate (ItemDiffs ds) = mconcat $ do
   x <- ds
-  case x of
-    DiffKind t    -> [ ItemKind =. t
-                     , ItemNormKind =. normalizeKind t
-                     ]
-    DiffBought d  -> [ ItemBought =. d ]
-    DiffExpires d -> [ ItemExpires =. d ]
-    DiffOpened d  -> [ ItemOpened =. d ]
+  return $ case x of
+    DiffKind t    -> (, []) [ ItemKind =. t
+                            , ItemNormKind =. normalizeKind t
+                            ]
+    DiffType t    -> ([], ) [ KindType =. t ]
+    DiffBought d  -> (, []) [ ItemBought =. d ]
+    DiffExpires d -> (, []) [ ItemExpires =. d ]
+    DiffOpened d  -> (, []) [ ItemOpened =. d ]
+
+data WithType a = WithType { typedVal :: a, valType :: Text }
+  deriving (Eq, Ord)
+
+typeToJSON :: ToJSON a
+           => Text -- ^ Key for value, if needed
+           -> WithType a -> Value
+typeToJSON valKey (record `WithType` t) = Object $ HashMap.insert "type" (toJSON t) o
+  where
+    o
+      | Object o' <- toJSON record = o'
+      | otherwise = HashMap.singleton valKey $ toJSON record
+
+typeFromJSON :: FromJSON a
+             => Maybe Text -- ^ Key for value, if needed
+             -> Value -> Parser (WithType a)
+typeFromJSON valKey = withObject "value with type" $ \obj -> do
+  t <- obj .: "type"
+  value <- case valKey of
+    Just key -> parseJSON =<< obj .: key
+    Nothing  -> parseJSON $ Object obj
+  return $ value `WithType` t
+
+instance ToJSON (WithType Item) where
+  toJSON = typeToJSON $ error "Item is not serializing correctly"
+
+instance ToJSON (WithType (Entity Item)) where
+  toJSON = typeToJSON $ error "Entity Item is not serializing correctly"
+
+instance ToJSON (WithType Reference) where
+  toJSON = typeToJSON "kind"
+
+instance ToJSON (WithType (Entity Reference)) where
+  toJSON ((Entity eId ref) `WithType` t) = object
+    [ "id" .= eId
+    , "type" .= t
+    , "kind" .= referenceKind ref
+    ]
+
+instance FromJSON (WithType Item) where
+  parseJSON = typeFromJSON Nothing
+
+instance FromJSON (WithType Reference) where
+  parseJSON = typeFromJSON $ Just "kind"