Handler/ReferenceListing.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

module Handler.ReferenceListing where

import Import

import Handler.Common

getReferenceListingR, postReferenceListingR :: Handler TypedContent
getReferenceListingR = postReferenceListingR
postReferenceListingR = do
  ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ referenceForm Nothing

  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 ()

  (referenceSort -> reference) <- runDB $ withTypes =<< selectList [] [Asc ReferenceKind]

  selectRep $ do
    provideJson (reference :: [WithType (Entity Reference)])
    provideRep . defaultLayout $ referenceListing ReferenceState
      { refFormState = Just InsertForm{..}
      , ..
      }

putReferenceListingR :: Handler Value
putReferenceListingR = do
  (Reference{..} `WithType` referenceType) <- requireCheckJsonBody
  returnJson <=< runDB $ do
    upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind referenceType) [ KindType =. referenceType ]
    withType =<< insertEntity Reference{..}