zgo-backend/src/Item.hs

102 lines
2.3 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Item where
import Data.Aeson
import qualified Data.Bson as B
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Clock
import Database.MongoDB
import GHC.Generics
import Test.QuickCheck
-- | Type to represent a ZGo item
data Item =
Item
{ i_id :: Maybe ObjectId
, iname :: T.Text
, idescription :: T.Text
, iowner :: T.Text
, icost :: Double
}
deriving (Eq, Show, Generic)
instance ToJSON Item where
toJSON (Item i n d o c) =
case i of
Just oid ->
object
[ "_id" .= show oid
, "name" .= n
, "description" .= d
, "owner" .= o
, "cost" .= c
]
Nothing ->
object
[ "_id" .= ("" :: String)
, "name" .= n
, "description" .= d
, "owner" .= o
, "cost" .= c
]
instance FromJSON Item where
parseJSON =
withObject "Item" $ \obj -> do
i <- obj .: "_id"
n <- obj .: "name"
d <- obj .: "description"
o <- obj .: "owner"
c <- obj .: "cost"
pure $
Item
(if not (null i)
then Just (read i)
else Nothing)
n
d
o
c
instance Val Item where
val (Item i n d o c) =
if isJust i
then Doc
[ "_id" =: i
, "name" =: n
, "description" =: d
, "owner" =: o
, "cost" =: c
]
else Doc ["name" =: n, "description" =: d, "owner" =: o, "cost" =: c]
cast' (Doc d) = do
i <- B.lookup "_id" d
n <- B.lookup "name" d
d' <- B.lookup "description" d
o <- B.lookup "owner" d
c <- B.lookup "cost" d
Just (Item i n d' o c)
cast' _ = Nothing
-- Database actions
findItems :: T.Text -> Action IO [Document]
findItems a =
rest =<< find (select ["owner" =: a] "items") {sort = ["name" =: (1 :: Int)]}
upsertItem :: Item -> Action IO ()
upsertItem i = do
let item = val i
case item of
Doc d ->
if isJust (i_id i)
then upsert (select ["_id" =: i_id i] "items") d
else insert_ "items" d
_ -> return ()
deleteItem :: String -> Action IO ()
deleteItem i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "items")