{-# 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 }