compareware/Web/Controller/Items.hs

{-# LANGUAGE OverloadedStrings #-}
module Web.Controller.Items where

import Data.Aeson
import Data.Text (Text)
import Network.HTTP.Simple (httpJSON, getResponseBody, parseRequest)
import Control.Monad.IO.Class (liftIO)

import Web.Controller.Prelude
import Web.View.Items.Index
import Web.View.Items.New
import Web.View.Items.Edit
import Web.View.Items.Show


instance Controller ItemsController where
    action ItemsAction = do
        items <- query @Item |> fetch
                >>= collectionFetchRelated #tags
        render IndexView { .. }

    action NewItemAction = do
        let tags = [newRecord @Tag, newRecord @Tag]
        let item = newRecord @Item
                |> updateField @"tags" tags
        render NewView { .. }

    action ShowItemAction { itemId } = do
        item <- fetch itemId
        render ShowView { .. }

    action EditItemAction { itemId } = do
        item <- fetch itemId
                >>= fetchRelated #tags
        render EditView { .. }

    action UpdateItemAction { itemId } = do
        item <- fetch itemId

        let tagIds :: [Id Tag] = paramList "tags_id"
        let tagNames :: [Text] = paramList "tags_name"
        let tagValues :: [Text] = paramList "tags_value"
        originalTags <- fetch tagIds
        let tags = zip3 tagIds tagNames tagValues
                |> map (\(id, name, value) -> originalTags
                    |> find (\tag -> tag.id == id)
                    |> fromMaybe (newRecord |> set #itemId item.id)
                    |> \tag -> buildTag tag name value
                )

        item
            |> buildItem
            |> updateField @"tags" tags
            |> bubbleValidationResult #tags
            |> ifValid \case
                Left item -> do
                    render EditView { item }
                Right item -> do
                    (item, tags) <- withTransaction do
                        item <- item
                                |> clearTags
                                |> updateRecord
                        tags <- mapM updateOrCreateRecord tags
                        pure (item, tags)

                    setSuccessMessage "Item updated"
                    redirectTo EditItemAction { .. }

    action CreateItemAction = do
        let item = newRecord @Item
        let names :: [Text] = paramList "tags_name"
        let values :: [Text] = paramList "tags_value"
        let tags = zip names values |> map (\(name, value) -> buildTag newRecord name value)

        -- users <- fetchItems -- Assuming this is your function that returns [User]
        -- liftIO $ print users
        -- renderPlain "Check your console!"

        item
            |> buildItem
            |> updateField @"tags" tags
            |> bubbleValidationResult #tags
            |> ifValid \case
                Left item -> render NewView { item }
                Right itemAndTags -> do
                    (item, tags) <- withTransaction do
                        item <- itemAndTags |> clearTags |> createRecord
                        tags <- itemAndTags.tags
                            |> map (set #itemId item.id)
                            |> createMany

                        pure (item, tags)
                    
                    setSuccessMessage "Item and Tags created"
                    redirectTo ItemsAction

    action DeleteItemAction { itemId } = do
        item <- fetch itemId
        deleteRecord item
        setSuccessMessage "Item deleted"
        redirectTo ItemsAction

buildItem item = item
    |> fill @'["description"]
    |> fill @'["wikidataId"]
    |> validateField #wikidataId nonEmpty

buildTag :: Tag -> Text -> Text -> Tag
buildTag tag name value = tag
    |> set #name name
    |> set #value value
    |> validateField #name nonEmpty

-- | Adds a validation error to the record when any of the child records is invalid
bubbleValidationResult :: forall fieldName record childRecord.
    ( HasField "meta" record MetaBag
    , SetField "meta" record MetaBag
    , KnownSymbol fieldName
    , HasField fieldName record [childRecord]
    , HasField "meta" childRecord MetaBag
    , SetField "meta" childRecord MetaBag
    ) => Proxy fieldName -> record -> record
bubbleValidationResult field record =
        if isEmpty childAnnotations
            then record
            else record |> attachFailure field "Invalid records"
    where
        childAnnotations :: [(Text, Violation)]
        childAnnotations = get field record
            |> map (\record -> record.meta.annotations)
            |> concat

updateOrCreateRecord record | isNew record = createRecord record
updateOrCreateRecord record = updateRecord record

clearTags :: Include "tags" Item -> Item
clearTags item = updateField @"tags" (newRecord @Item).tags item


-- data ApiResponse = ApiResponse
--     { users :: [Item] }
--
-- instance FromJSON Item where
--     parseJSON = withObject "Item" $ \v -> do
--         let item = newRecord @Item
--         name <- v .: "name"
--         -- address <- v .: "address"
--         -- city <- address .: "city"
--         newRecord @Item
--               |> set #description name
--
-- instance FromJSON ApiResponse where
--     parseJSON = withObject "ApiResponse" $ \v -> ApiResponse
--         <$> v .: "users"

-- Example function to fetch and parse JSON
-- fetchItems :: [Item]
-- fetchItems = do
--     request <- parseRequest "GET https://www.wikidata.org/w/api.php?action=wbgetentities&ids=Q19675&languages=en&format=json" -- http://localhost:8000/Q19675.json
--     response <- httpJSON request
--     jsonData <- getResponseBody response
--     let maybeValue = decodeStrict (cs jsonData) :: Maybe Value
--     -- let apiResponse = getResponseBody response :: ApiResponse
--     -- users apiResponse
--     case maybeValue of
--         Just value -> do
--             case extractItemFromJson value of
--                 Just item -> do
--                     item <- item |> createRecord
--                     redirectTo ShowItemAction { itemId = get #id item }
--                 Nothing -> renderPlain "Failed to extract Item data from JSON"
--         Nothing -> renderPlain "Failed to parse JSON data"
--
--
-- extractItemFromJson :: Value -> Maybe Item
-- extractItemFromJson value = do
--     object <- case value of
--         Object obj -> Just obj
--         _ -> Nothing
--     itemId <- object .: "itemId"
--     itemName <- object .: "itemName" >>= parseJSON
--
--     pure Item { id = itemId, description = itemName }