Support types

1 files changed, 14 insertions, 7 deletions

diff --git a/Handler/ReferenceListing.hs b/Handler/ReferenceListing.hs
index 0f777ee..0b89a20 100644
--- a/Handler/ReferenceListing.hs
+++ b/Handler/ReferenceListing.hs
@@ -9,19 +9,26 @@ getReferenceListingR = postReferenceListingR
 postReferenceListingR = do
   ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ referenceForm Nothing
 
-  mapM_ (addMessage "formError" . toHtml) =<< case insertResult of 
-    FormSuccess newReference -> [] <$ runDB (insert newReference)
-    FormFailure errors -> return errors
-    _ -> return []
+  case insertResult of 
+    FormSuccess (Reference{..} `WithType` t) -> runDB $ do
+      upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind t) [ KindType =. t ]
+      insert Reference{..}
+      return ()
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
 
-  reference <- runDB $ selectList [] [Asc ReferenceKind]
+  reference <- runDB $ mapM withType =<< selectList [] [Asc ReferenceKind]
 
   selectRep $ do
-    provideJson (reference :: [Entity Reference])
+    provideJson (reference :: [WithType (Entity Reference)])
     provideRep . defaultLayout $ referenceListing ReferenceState
       { refFormState = Just InsertForm{..}
       , ..
       }
 
 putReferenceListingR :: Handler Value
-putReferenceListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Reference)
+putReferenceListingR = do
+  (Reference{..} `WithType` referenceType) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind referenceType) [ KindType =. referenceType ]
+    withType =<< insertEntity Reference{..}