From ba9eee8e534f0cd7b39f89c7e2ab04523b1ae0ad Mon Sep 17 00:00:00 2001 From: willbasky Date: Thu, 29 Aug 2019 17:51:06 +0500 Subject: [PATCH 01/13] Change schema, implement functions --- back/src/Guide/Database/Import.hs | 2 +- back/src/Guide/Database/Queries/Insert.hs | 48 ++++++++ back/src/Guide/Database/Queries/Select.hs | 20 +++ back/src/Guide/Database/Queries/Update.hs | 16 +++ back/src/Guide/Database/Schema.hs | 143 ++++++++++++---------- back/src/Guide/Database/Utils.hs | 1 + back/src/Guide/Markdown.hs | 42 ++++++- back/src/Guide/Types/Core.hs | 70 ++++++++++- 8 files changed, 269 insertions(+), 73 deletions(-) diff --git a/back/src/Guide/Database/Import.hs b/back/src/Guide/Database/Import.hs index e0c3e5e4..63138d00 100644 --- a/back/src/Guide/Database/Import.hs +++ b/back/src/Guide/Database/Import.hs @@ -56,7 +56,7 @@ postgresLoader logger globalState = do let checked = checkedCat && checkedCatDeleted logDebugIO logger $ format "AcidState == Postgres: {}" checked - unless checked $ exitFailure + unless checked exitFailure where -- Insert all categories from AcidState either deleted or not. -- Categories be normilised before insertion. See 'normalizeUTC'. diff --git a/back/src/Guide/Database/Queries/Insert.hs b/back/src/Guide/Database/Queries/Insert.hs index 4be3a596..c461e9da 100644 --- a/back/src/Guide/Database/Queries/Insert.hs +++ b/back/src/Guide/Database/Queries/Insert.hs @@ -3,6 +3,8 @@ module Guide.Database.Queries.Insert ( -- * Category insertCategory, + insertCategory2, + insertCategoryWithCategory, insertCategoryWithCategoryRow, -- * Item insertItem, @@ -23,6 +25,7 @@ import qualified Hasql.Transaction as HT import Guide.Database.Queries.Update import Guide.Database.Types import Guide.Database.Utils (execute) +import Guide.Markdown (toMarkdownBlock) import Guide.Types.Core import Guide.Uid @@ -100,6 +103,51 @@ insertCategoryWithCategoryRow categoryRow = do |] lift $ HT.statement categoryRow statement +insertCategory2 + :: Uid Category -- ^ New category's id + -> "title" :! Text + -> "group" :! Text + -> "created" :! UTCTime + -> "status" :! CategoryStatus + -> "enabledSections" :! Set ItemSection + -> ExceptT DatabaseError Transaction () +insertCategory2 + catId + (arg #title -> title) + (arg #group -> group_) + (arg #created -> created) + (arg #status -> status) + (arg #enabledSections -> enabledSections) + = + do + let category = Category + { categoryUid = catId + , categoryTitle = title + , categoryCreated = created + , categoryGroup = group_ + , categoryStatus = status + , categoryNotes = toMarkdownBlock "" + , categoryItems = [] + , categoryItemsDeleted = [] + , categoryEnabledSections = enabledSections + } + insertCategoryWithCategory category + +-- | Create category passing 'Category'. +insertCategoryWithCategory :: Category -> ExceptT DatabaseError Transaction () +insertCategoryWithCategory category = do + let statement :: Statement (Uid Category, Category) () + statement = + [execute| + INSERT INTO categories + ( uid + , data + ) + VALUES ($1,$2) + |] + lift $ HT.statement (categoryUid category, category) statement + + ---------------------------------------------------------------------------- -- Item ---------------------------------------------------------------------------- diff --git a/back/src/Guide/Database/Queries/Select.hs b/back/src/Guide/Database/Queries/Select.hs index bef5f06f..63dc055e 100644 --- a/back/src/Guide/Database/Queries/Select.hs +++ b/back/src/Guide/Database/Queries/Select.hs @@ -6,7 +6,9 @@ module Guide.Database.Queries.Select ( -- * Category selectCategoryRow, + selectCategory, selectCategoryRowMaybe, + selectCategoryMaybe, selectCategoryRows, selectCategoryRowByItemMaybe, selectCategoryIds, @@ -46,6 +48,24 @@ import Guide.Uid -- Categories ---------------------------------------------------------------------------- +selectCategoryMaybe :: Uid Category -> ExceptT DatabaseError Transaction (Maybe Category) +selectCategoryMaybe catId = do + let statement :: Statement (Uid Category) (Maybe Category) + statement = dimap SingleParam (fmap fromSingleColumn) $ + [queryRowMaybe| + SELECT data + FROM categories + WHERE uid = $1 + |] + lift $ HT.statement catId statement + +selectCategory :: Uid Category -> ExceptT DatabaseError Transaction Category +selectCategory catId = do + mCatRow <- selectCategoryMaybe catId + case mCatRow of + Nothing -> throwError $ CategoryNotFound catId + Just catRow -> pure catRow + -- | Get a 'CategoryRow'. selectCategoryRowMaybe :: Uid Category -> ExceptT DatabaseError Transaction (Maybe CategoryRow) selectCategoryRowMaybe catId = do diff --git a/back/src/Guide/Database/Queries/Update.hs b/back/src/Guide/Database/Queries/Update.hs index f5dde445..ba3f1dd2 100644 --- a/back/src/Guide/Database/Queries/Update.hs +++ b/back/src/Guide/Database/Queries/Update.hs @@ -2,6 +2,7 @@ module Guide.Database.Queries.Update ( -- * Category updateCategoryRow, + updateCategory, -- * Item updateItemRow, -- * Trait @@ -28,6 +29,21 @@ import Guide.Utils (fieldsPrefixed) -- Categories ---------------------------------------------------------------------------- +updateCategory + :: Uid Category + -> (Category -> Category) + -> ExceptT DatabaseError Transaction () +updateCategory catId update = do + old_category <- selectCategory catId + let new_category = update old_category + when (old_category /= new_category) $ do + let statement :: Statement (Uid Category, Category) () + statement = [execute| + UPDATE categories + SET data = $2 + WHERE uid = $1|] + lift $ HT.statement (catId, new_category) statement + -- | Fetch a row corresponding to a category, apply a function and write it -- back. You can break database invariants with this function, so be -- careful. diff --git a/back/src/Guide/Database/Schema.hs b/back/src/Guide/Database/Schema.hs index e0745e3a..f39d61b9 100644 --- a/back/src/Guide/Database/Schema.hs +++ b/back/src/Guide/Database/Schema.hs @@ -103,86 +103,95 @@ setSchemaVersion version = do -- | Schema version 0: initial schema. v0 :: Session () v0 = do - v0_createTypeProCon v0_createTableCategories - v0_createTableItems - v0_createTableTraits v0_createTableUsers v0_createTablePendingEdits --- | Create an enum type for trait type ("pro" or "con"). -v0_createTypeProCon :: Session () -v0_createTypeProCon = HS.statement () $ - [execute| - CREATE TYPE trait_type AS ENUM ('pro', 'con'); - |] - --- | Create table @traits@, corresponding to 'Guide.Types.Core.Trait'. -v0_createTableTraits :: Session () -v0_createTableTraits = HS.statement () $ - [execute| - CREATE TABLE traits ( - uid text PRIMARY KEY, -- Unique trait ID - content text NOT NULL, -- Trait content as Markdown - deleted boolean -- Whether the trait is deleted - NOT NULL, - type_ trait_type NOT NULL, -- Trait type (pro or con) - item_uid text -- Item that the trait belongs to - REFERENCES items (uid) - ON DELETE CASCADE - ); - |] - --- | Create table @items@, corresponding to 'Guide.Types.Core.Item'. -v0_createTableItems :: Session () -v0_createTableItems = HS.statement () $ - [execute| - CREATE TABLE items ( - uid text PRIMARY KEY, -- Unique item ID - name text NOT NULL, -- Item title - created timestamptz NOT NULL, -- When the item was created - link text, -- Optional URL - hackage text, -- Package name on Hackage - summary text NOT NULL, -- Item summary as Markdown - ecosystem text NOT NULL, -- The ecosystem section - notes text NOT NULL, -- The notes section - deleted boolean -- Whether the item is deleted - NOT NULL, - category_uid text -- Category that the item belongs to - REFERENCES categories (uid) - ON DELETE CASCADE, - pros_order text[] -- Uids of item's pro traits; this list specifies - NOT NULL, -- in what order they should be displayed, and - -- is necessary to allow moving traits up and - -- down - cons_order text[] -- Uids of item's con traits - NOT NULL - ); - |] - -- | Create table @categories@, corresponding to 'Guide.Types.Core.Category'. +-- +-- Contains items and traits inside as jsonb v0_createTableCategories :: Session () v0_createTableCategories = HS.statement () $ [execute| CREATE TABLE categories ( uid text PRIMARY KEY, -- Unique category ID - title text NOT NULL, -- Category title - created timestamptz NOT NULL, -- When the category was created - group_ text NOT NULL, -- "Grandcategory" - status text NOT NULL, -- Category status ("in progress", etc); the list - -- of possible statuses is defined by backend - notes text NOT NULL, -- Category notes as Markdown - enabled_sections text[] -- Item sections to show to users; the list of - NOT NULL, -- possible section names is defined by backend - items_order text[] -- Uids of items in the category; this list - NOT NULL, -- specifies in what order they should be - -- displayed, and is necessary to allow moving - -- items up and down - deleted boolean -- Whether the category is deleted - NOT NULL + data jsonb NOT NULL -- Single category with all items and raits belong to it ); |] +-- -- | Create an enum type for trait type ("pro" or "con"). +-- v0_createTypeProCon :: Session () +-- v0_createTypeProCon = HS.statement () $ +-- [execute| +-- CREATE TYPE trait_type AS ENUM ('pro', 'con'); +-- |] + +-- -- | Create table @traits@, corresponding to 'Guide.Types.Core.Trait'. +-- v0_createTableTraits :: Session () +-- v0_createTableTraits = HS.statement () $ +-- [execute| +-- CREATE TABLE traits ( +-- uid text PRIMARY KEY, -- Unique trait ID +-- content text NOT NULL, -- Trait content as Markdown +-- deleted boolean -- Whether the trait is deleted +-- NOT NULL, +-- type_ trait_type NOT NULL, -- Trait type (pro or con) +-- item_uid text -- Item that the trait belongs to +-- REFERENCES items (uid) +-- ON DELETE CASCADE +-- ); +-- |] + +-- -- | Create table @items@, corresponding to 'Guide.Types.Core.Item'. +-- v0_createTableItems :: Session () +-- v0_createTableItems = HS.statement () $ +-- [execute| +-- CREATE TABLE items ( +-- uid text PRIMARY KEY, -- Unique item ID +-- name text NOT NULL, -- Item title +-- created timestamptz NOT NULL, -- When the item was created +-- link text, -- Optional URL +-- hackage text, -- Package name on Hackage +-- summary text NOT NULL, -- Item summary as Markdown +-- ecosystem text NOT NULL, -- The ecosystem section +-- notes text NOT NULL, -- The notes section +-- deleted boolean -- Whether the item is deleted +-- NOT NULL, +-- category_uid text -- Category that the item belongs to +-- REFERENCES categories (uid) +-- ON DELETE CASCADE, +-- pros_order text[] -- Uids of item's pro traits; this list specifies +-- NOT NULL, -- in what order they should be displayed, and +-- -- is necessary to allow moving traits up and +-- -- down +-- cons_order text[] -- Uids of item's con traits +-- NOT NULL +-- ); +-- |] + +-- -- | Create table @categories@, corresponding to 'Guide.Types.Core.Category'. +-- v0_createTableCategories :: Session () +-- v0_createTableCategories = HS.statement () $ +-- [execute| +-- CREATE TABLE categories ( +-- uid text PRIMARY KEY, -- Unique category ID +-- title text NOT NULL, -- Category title +-- created timestamptz NOT NULL, -- When the category was created +-- group_ text NOT NULL, -- "Grandcategory" +-- status text NOT NULL, -- Category status ("in progress", etc); the list +-- -- of possible statuses is defined by backend +-- notes text NOT NULL, -- Category notes as Markdown +-- enabled_sections text[] -- Item sections to show to users; the list of +-- NOT NULL, -- possible section names is defined by backend +-- items_order text[] -- Uids of items in the category; this list +-- NOT NULL, -- specifies in what order they should be +-- -- displayed, and is necessary to allow moving +-- -- items up and down +-- deleted boolean -- Whether the category is deleted +-- NOT NULL +-- ); +-- |] + -- | Create table @users@, storing user data. v0_createTableUsers :: Session () v0_createTableUsers = HS.statement () $ diff --git a/back/src/Guide/Database/Utils.hs b/back/src/Guide/Database/Utils.hs index c72f8718..c32a08af 100644 --- a/back/src/Guide/Database/Utils.hs +++ b/back/src/Guide/Database/Utils.hs @@ -28,6 +28,7 @@ module Guide.Database.Utils where import Imports + import Hasql.Statement import Data.Functor.Contravariant ((>$<)) import Data.Functor.Contravariant.Divisible (divided, lost, chosen) diff --git a/back/src/Guide/Markdown.hs b/back/src/Guide/Markdown.hs index 945de1d9..1832930b 100644 --- a/back/src/Guide/Markdown.hs +++ b/back/src/Guide/Markdown.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} -- | Everything concerning rendering and processing Markdown. @@ -46,6 +46,9 @@ import ShortcutLinks.All (hackage) -- acid-state import Data.SafeCopy +import Data.Functor.Contravariant ((>$<)) + +import Guide.Database.Utils (FromPostgres (..), ToPostgres (..)) import Guide.Utils import qualified CMark as MD @@ -53,6 +56,8 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.Set as S import qualified Data.Text as T +import qualified Hasql.Decoders as HD +import qualified Hasql.Encoders as HE data MarkdownInline = MarkdownInline { @@ -77,7 +82,7 @@ data MarkdownTree = MarkdownTree { -- | Table-of-contents heading data Heading = Heading { headingMarkdown :: MarkdownInline - , headingSlug :: Text + , headingSlug :: Text } deriving (Generic, Data, Eq) makeClassWithLenses ''MarkdownInline @@ -320,6 +325,19 @@ instance Aeson.ToJSON MarkdownTree where toJSON md = Aeson.object [ "text" Aeson..= markdownTreeSource md ] +instance Aeson.FromJSON MarkdownInline where + parseJSON = Aeson.withObject "MarkdownInline" $ \o -> do + txt <- o Aeson..: "text" + pure $ toMarkdownInline txt +instance Aeson.FromJSON MarkdownBlock where + parseJSON = Aeson.withObject "MarkdownBlock" $ \o -> do + txt <- o Aeson..: "text" + pure $ toMarkdownBlock txt +instance Aeson.FromJSON MarkdownTree where + parseJSON = Aeson.withObject "MarkdownTree" $ \o -> do + txt <- o Aeson..: "text" + pure $ toMarkdownTree "" txt + instance ToHtml MarkdownInline where toHtmlRaw = toHtml toHtml = toHtmlRaw . markdownInlineHtml @@ -362,3 +380,21 @@ instance SafeCopy MarkdownTree where safePut (markdownTreeSource md) getCopy = contain $ toMarkdownTree <$> safeGet <*> safeGet + +instance ToPostgres MarkdownInline where + toPostgres = markdownInlineSource >$< HE.text + +instance ToPostgres MarkdownBlock where + toPostgres = markdownBlockSource >$< HE.text + +instance ToPostgres MarkdownTree where + toPostgres = markdownTreeSource >$< HE.text + +instance FromPostgres MarkdownInline where + fromPostgres = toMarkdownInline <$> HD.text + +instance FromPostgres MarkdownBlock where + fromPostgres = toMarkdownBlock <$> HD.text + +instance FromPostgres MarkdownTree where + fromPostgres = toMarkdownTree "" <$> HD.text diff --git a/back/src/Guide/Types/Core.hs b/back/src/Guide/Types/Core.hs index 85d85a5b..4d9c31e1 100644 --- a/back/src/Guide/Types/Core.hs +++ b/back/src/Guide/Types/Core.hs @@ -27,15 +27,16 @@ where import Imports +import Data.Functor.Contravariant ((>$<)) -- acid-state import Data.SafeCopy hiding (kind) import Data.SafeCopy.Migrate +import Guide.Database.Utils (ToPostgres (..), FromPostgres (..), ToPostgresParams (..), FromPostgresRow (..)) import Guide.Markdown import Guide.Types.Hue -import Guide.Utils import Guide.Uid -import Guide.Database.Utils (ToPostgres (..), FromPostgres (..)) +import Guide.Utils import qualified Data.Aeson as Aeson import qualified Data.Text as T @@ -74,6 +75,20 @@ instance Aeson.ToJSON Trait where toJSON = Aeson.genericToJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = over _head toLower . drop (T.length "trait") } +instance Aeson.FromJSON Trait where + parseJSON = Aeson.withObject "Trait" $ \o -> do + traitUid <- o Aeson..: "uid" + content <- o Aeson..: "content" + traitContent <- toMarkdownInline <$> content Aeson..: "text" + pure Trait{..} + +instance ToPostgres Trait where + toPostgres = toByteString . Aeson.encode >$< HE.jsonbBytes + +instance FromPostgres Trait where + fromPostgres = HD.jsonbBytes $ + either (Left . toText) (Right . id) . Aeson.eitherDecodeStrict + -- | ADT for trait type. Traits can be pros (positive traits) and cons -- (negative traits). data TraitType = TraitTypePro | TraitTypeCon @@ -216,6 +231,33 @@ instance Aeson.ToJSON Item where toJSON = Aeson.genericToJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = over _head toLower . drop (T.length "item") } +instance Aeson.FromJSON Item where + parseJSON = Aeson.withObject "Item" $ \o -> do + itemUid <- o Aeson..: "uid" + itemName <- o Aeson..: "name" + itemCreated <- o Aeson..: "created" + itemHackage <- o Aeson..:? "hackage" + summary <- o Aeson..: "summary" + itemSummary <- toMarkdownBlock <$> summary Aeson..: "text" + itemPros <- o Aeson..: "pros" + itemProsDeleted <- o Aeson..: "prosDeleted" + itemCons <- o Aeson..: "cons" + itemConsDeleted <- o Aeson..: "consDeleted" + ecosystem <- o Aeson..: "ecosystem" + itemEcosystem <- toMarkdownBlock <$> ecosystem Aeson..: "text" + notes <- o Aeson..: "notes" + let prefix = "item-notes-" <> uidToText itemUid <> "-" + itemNotes <- toMarkdownTree prefix <$> notes Aeson..: "text" + itemLink <- o Aeson..:? "link" + pure Item{..} + +instance ToPostgres Item where + toPostgres = toByteString . Aeson.encode >$< HE.jsonbBytes + +instance FromPostgres Item where + fromPostgres = HD.jsonbBytes $ + either (Left . toText) (Right . id) . Aeson.eitherDecodeStrict + ---------------------------------------------------------------------------- -- Category ---------------------------------------------------------------------------- @@ -319,6 +361,30 @@ instance Aeson.ToJSON Category where toJSON = Aeson.genericToJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = over _head toLower . drop (T.length "category") } +instance Aeson.FromJSON Category where + parseJSON = Aeson.withObject "Category" $ \o -> do + categoryUid <- o Aeson..: "uid" + categoryTitle <- o Aeson..: "title" + categoryCreated <- o Aeson..: "created" + categoryGroup <- o Aeson..: "group" + categoryStatus <- o Aeson..: "status" + notes <- o Aeson..: "notes" + categoryNotes <- toMarkdownBlock <$> notes Aeson..: "text" + categoryItems <- o Aeson..: "items" + categoryItemsDeleted <- o Aeson..: "itemsDeleted" + categoryEnabledSections <- o Aeson..: "enabledSections" + pure Category{..} + +instance ToPostgres Category where + toPostgres = toByteString . Aeson.encode >$< HE.jsonbBytes + +instance FromPostgres Category where + fromPostgres = HD.jsonbBytes $ + either (Left . toText) (Right . id) . Aeson.eitherDecodeStrict + +instance ToPostgresParams Category +instance FromPostgresRow Category + -- | Category identifier (used in URLs). E.g. for a category with title -- “Performance optimization” and UID “t3c9hwzo” the slug would be -- @performance-optimization-t3c9hwzo@. From 77ffda61878fe0f1dc5cb2809422f1a4db5fde91 Mon Sep 17 00:00:00 2001 From: willbasky Date: Thu, 29 Aug 2019 19:47:30 +0500 Subject: [PATCH 02/13] Add benchmarks --- back/benchmarks/Main.hs | 49 ++++++++++++++++++++++++++++++++++++ back/package.yaml | 17 +++++++++++++ back/src/Guide/Markdown.hs | 22 +++++++++++++--- back/src/Guide/Types/Core.hs | 15 +++++------ back/src/Guide/Uid.hs | 3 ++- 5 files changed, 95 insertions(+), 11 deletions(-) create mode 100644 back/benchmarks/Main.hs diff --git a/back/benchmarks/Main.hs b/back/benchmarks/Main.hs new file mode 100644 index 00000000..921e6ed5 --- /dev/null +++ b/back/benchmarks/Main.hs @@ -0,0 +1,49 @@ +-- | Module contains all stuff to migrate from AcidState to Postgres. +module Main + ( + main + ) where + +import Imports + +import Gauge +import Hasql.Transaction.Sessions (Mode (..)) + +import Guide.Database.Queries.Update +import Guide.Database.Queries.Select +import Guide.Types.Core +import Guide.Database.Connection + + +main :: IO () +main = do + conn <- connect + defaultMain [databaseBenchmark conn] + where + databaseBenchmark conn = + bgroup + "Database" + [ bench "select" $ nfIO $ + runTransactionExceptT conn Read $ selectCategory "category1111" + , bench "updete" $ nfIO $ + runTransactionExceptT conn Write $ updateCategory "category1111" update + ] + update :: Category -> Category + update = _categoryTitle .~ "title10" + +{- +benchmarked Database/select +time 496.1 μs (429.1 μs .. 551.4 μs) + 0.932 R² (0.868 R² .. 0.976 R²) +mean 590.7 μs (502.5 μs .. 939.6 μs) +std dev 508.6 μs (51.75 μs .. 1.065 ms) +variance introduced by outliers: 97% (severely inflated) + +benchmarked Database/updete +time 497.4 μs (429.4 μs .. 542.0 μs) + 0.900 R² (0.825 R² .. 0.948 R²) +mean 1.429 ms (520.2 μs .. 5.048 ms) +std dev 6.175 ms (104.7 μs .. 13.21 ms) +variance introduced by outliers: 98% (severely inflated) + +-} diff --git a/back/package.yaml b/back/package.yaml index 019f593d..3e83b67f 100644 --- a/back/package.yaml +++ b/back/package.yaml @@ -60,6 +60,8 @@ library: # You don't need to add modules here, all modules will be exposed automatically. # # exposed-modules: + ghc-options: + - -O dependencies: - acid-state - aeson @@ -161,6 +163,7 @@ executables: # See https://github.com/sol/hpack/issues/182#issuecomment-310434881 for # the explanation of the quoting situation here. - '"-with-rtsopts=-T -N"' + - -O dependencies: - base - guide @@ -197,3 +200,17 @@ tests: - temporary - webdriver - yaml + +benchmarks: + benchmarks: + main: Main.hs + source-dirs: benchmarks + dependencies: + - base <5 + - guide + - gauge + - hasql + - hasql-transaction + + ghc-options: + - -O diff --git a/back/src/Guide/Markdown.hs b/back/src/Guide/Markdown.hs index 1832930b..36cbdf11 100644 --- a/back/src/Guide/Markdown.hs +++ b/back/src/Guide/Markdown.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -64,20 +65,35 @@ data MarkdownInline = MarkdownInline { markdownInlineSource :: Text, markdownInlineHtml :: ByteString, markdownInlineMarkdown :: ![MD.Node] } - deriving (Generic, Data, Eq) + deriving (Generic, Data, Eq, NFData) data MarkdownBlock = MarkdownBlock { markdownBlockSource :: Text, markdownBlockHtml :: ByteString, markdownBlockMarkdown :: ![MD.Node] } - deriving (Generic, Data, Eq) + deriving (Generic, Data, Eq, NFData) data MarkdownTree = MarkdownTree { markdownTreeSource :: Text, markdownTreeStructure :: !(Document Text ByteString), markdownTreeIdPrefix :: Text, markdownTreeTOC :: Forest Heading } - deriving (Generic, Data, Eq) + deriving (Generic, Data, Eq, NFData) + +deriving instance NFData MD.Node +deriving instance NFData MD.NodeType +deriving instance NFData MD.ListAttributes +deriving instance NFData MD.DelimType +deriving instance NFData MD.ListType +deriving instance NFData MD.PosInfo +deriving instance NFData (WithSource [MD.Node]) +deriving instance (NFData b, NFData t) => NFData (Document t b) +deriving instance (NFData b, NFData t) => NFData (Section t b) +deriving instance NFData Heading +-- instance NFData (Node a f) where +-- rnf tree = foldl1 (seq . rnf) tree `seq` rnf (measure tree) + -- rnf = (`seq` ()) + -- rnf (Node info nodeType nodes) = Node (rnf info) (rnf nodeType) (map rnf nodes) -- | Table-of-contents heading data Heading = Heading diff --git a/back/src/Guide/Types/Core.hs b/back/src/Guide/Types/Core.hs index 4d9c31e1..1d4c7249 100644 --- a/back/src/Guide/Types/Core.hs +++ b/back/src/Guide/Types/Core.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} -- | Core types for content. @@ -63,7 +64,7 @@ For an explanation of deriveSafeCopySorted, see Note [acid-state]. data Trait = Trait { traitUid :: Uid Trait, traitContent :: MarkdownInline } - deriving (Show, Generic, Data, Eq) + deriving (Show, Generic, Data, Eq, NFData) deriveSafeCopySorted 4 'extension ''Trait makeClassWithLenses ''Trait @@ -161,7 +162,7 @@ data ItemSection = ItemProsConsSection | ItemEcosystemSection | ItemNotesSection - deriving (Eq, Ord, Show, Generic, Data) + deriving (Eq, Ord, Show, Generic, Data, NFData) deriveSafeCopySimple 0 'base ''ItemSection @@ -203,7 +204,7 @@ data Item = Item { itemNotes :: MarkdownTree, -- ^ The notes section itemLink :: Maybe Url -- ^ Link to homepage or something } - deriving (Generic, Data, Eq, Show) + deriving (Generic, Data, Eq, Show, NFData) deriveSafeCopySorted 13 'extension ''Item makeClassWithLenses ''Item @@ -267,7 +268,7 @@ data CategoryStatus = CategoryStub -- ^ “Stub” = just created | CategoryWIP -- ^ “WIP” = work in progress | CategoryFinished -- ^ “Finished” = complete or nearly complete - deriving (Eq, Show, Generic, Data) + deriving (Eq, Show, Generic, Data, NFData) deriveSafeCopySimple 2 'extension ''CategoryStatus @@ -324,7 +325,7 @@ data Category = Category { -- 'ItemNotesSection', then notes will be shown for each item categoryEnabledSections :: Set ItemSection } - deriving (Generic, Data, Eq, Show) + deriving (Generic, Data, Eq, Show, NFData) deriveSafeCopySorted 13 'extension ''Category makeClassWithLenses ''Category diff --git a/back/src/Guide/Uid.hs b/back/src/Guide/Uid.hs index 917ed0d6..0a7a5806 100644 --- a/back/src/Guide/Uid.hs +++ b/back/src/Guide/Uid.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} -- | A type for unique identifiers. module Guide.Uid @@ -24,7 +25,7 @@ newtype Uid a = Uid {uidToText :: Text} deriving stock (Generic, Eq, Ord, Data) deriving newtype (Read, Show, IsString, Buildable, ToHttpApiData, FromHttpApiData, - Hashable, ToJSON, FromJSON) + Hashable, ToJSON, FromJSON, NFData) ---------------------------------------------------------------------------- -- Instances From b136aa458b8a3e3ce4f2d56a2ee50a484d6b3e74 Mon Sep 17 00:00:00 2001 From: willbasky Date: Sun, 1 Sep 2019 20:26:09 +0500 Subject: [PATCH 03/13] Update import module. Comment legaxy code --- .travis.yml | 6 +- back/benchmarks/Main.hs | 54 +-- back/package.yaml | 3 - back/src/Guide/Database/Import.hs | 169 +++++---- back/src/Guide/Database/Queries/Delete.hs | 66 ++-- back/src/Guide/Database/Queries/Insert.hs | 390 +++++++++---------- back/src/Guide/Database/Queries/Select.hs | 426 +++++++++++---------- back/src/Guide/Database/Queries/Update.hs | 443 +++++++++++----------- back/src/Guide/Database/Schema.hs | 4 +- back/src/Guide/Database/Types.hs | 388 +++++++++---------- back/src/Guide/Uid.hs | 1 - 11 files changed, 1004 insertions(+), 946 deletions(-) diff --git a/.travis.yml b/.travis.yml index 87b19c1a..76aa6194 100644 --- a/.travis.yml +++ b/.travis.yml @@ -53,8 +53,8 @@ jobs: - git remote set-url origin git@github.com:aelve/guide.git script: # Build - - stack --no-terminal build --test --no-run-tests --dependencies-only - - stack --no-terminal build --test --no-run-tests + - stack --no-terminal build --test --no-run-tests --bench --no-run-benchmarks --dependencies-only + - stack --no-terminal build --test --no-run-tests --bench --no-run-benchmarks # Regenerate Swagger and push to the same branch, even if the branch # is already ahead (which may happen if the previous build in the # pipeline also pushed to it) @@ -87,7 +87,7 @@ jobs: # from scratch, then we build haddocks and count the lines for # "missing documentation". - stack --no-terminal exec -- ghc-pkg unregister guide - - stack --no-terminal build --test --no-run-tests --haddock --no-haddock-deps --haddock-arguments='--no-warnings' 2> haddock.log + - stack --no-terminal build --test --no-run-tests --bench --no-run-benchmarks --haddock --no-haddock-deps --haddock-arguments='--no-warnings' 2> haddock.log - export undocumented=$(awk '/\(src\// {count++} END{print count}' haddock.log) - | echo "Undocumented definitions: $undocumented" diff --git a/back/benchmarks/Main.hs b/back/benchmarks/Main.hs index 921e6ed5..e4c92874 100644 --- a/back/benchmarks/Main.hs +++ b/back/benchmarks/Main.hs @@ -1,4 +1,4 @@ --- | Module contains all stuff to migrate from AcidState to Postgres. +-- | Benchmarks to check time of jsonb query. module Main ( main @@ -8,6 +8,7 @@ import Imports import Gauge import Hasql.Transaction.Sessions (Mode (..)) +import Hasql.Connection (Connection) import Guide.Database.Queries.Update import Guide.Database.Queries.Select @@ -17,33 +18,32 @@ import Guide.Database.Connection main :: IO () main = do - conn <- connect - defaultMain [databaseBenchmark conn] - where - databaseBenchmark conn = - bgroup - "Database" - [ bench "select" $ nfIO $ - runTransactionExceptT conn Read $ selectCategory "category1111" - , bench "updete" $ nfIO $ - runTransactionExceptT conn Write $ updateCategory "category1111" update - ] - update :: Category -> Category - update = _categoryTitle .~ "title10" + conn <- connect + defaultMain [databaseBenchmark conn] + +databaseBenchmark :: Connection -> Benchmark +databaseBenchmark conn = + let update :: Category -> Category + update = _categoryTitle <>~ " +" + in bgroup "Database" + [ bench "select" $ nfIO $ + runTransactionExceptT conn Read $ selectCategory "category1111" + , bench "update" $ nfIO $ + runTransactionExceptT conn Write $ updateCategory "category1111" update + ] {- benchmarked Database/select -time 496.1 μs (429.1 μs .. 551.4 μs) - 0.932 R² (0.868 R² .. 0.976 R²) -mean 590.7 μs (502.5 μs .. 939.6 μs) -std dev 508.6 μs (51.75 μs .. 1.065 ms) -variance introduced by outliers: 97% (severely inflated) - -benchmarked Database/updete -time 497.4 μs (429.4 μs .. 542.0 μs) - 0.900 R² (0.825 R² .. 0.948 R²) -mean 1.429 ms (520.2 μs .. 5.048 ms) -std dev 6.175 ms (104.7 μs .. 13.21 ms) -variance introduced by outliers: 98% (severely inflated) - +time 843.9 μs (812.4 μs .. 879.6 μs) + 0.987 R² (0.978 R² .. 0.993 R²) +mean 846.1 μs (823.0 μs .. 864.6 μs) +std dev 69.75 μs (58.01 μs .. 87.73 μs) +variance introduced by outliers: 53% (severely inflated) + +benchmarked Database/update +time 2.435 ms (2.388 ms .. 2.480 ms) + 0.995 R² (0.992 R² .. 0.998 R²) +mean 2.358 ms (2.313 ms .. 2.396 ms) +std dev 148.0 μs (117.9 μs .. 194.6 μs) +variance introduced by outliers: 39% (moderately inflated) -} diff --git a/back/package.yaml b/back/package.yaml index 3e83b67f..7b641cb4 100644 --- a/back/package.yaml +++ b/back/package.yaml @@ -60,8 +60,6 @@ library: # You don't need to add modules here, all modules will be exposed automatically. # # exposed-modules: - ghc-options: - - -O dependencies: - acid-state - aeson @@ -163,7 +161,6 @@ executables: # See https://github.com/sol/hpack/issues/182#issuecomment-310434881 for # the explanation of the quoting situation here. - '"-with-rtsopts=-T -N"' - - -O dependencies: - base - guide diff --git a/back/src/Guide/Database/Import.hs b/back/src/Guide/Database/Import.hs index 63138d00..7e97107e 100644 --- a/back/src/Guide/Database/Import.hs +++ b/back/src/Guide/Database/Import.hs @@ -20,12 +20,11 @@ import Guide.Database.Schema import Guide.Database.Types import Guide.State import Guide.Types.Core -import Guide.Uid import Guide.Config import Guide.Logger --- | Load categories and deleted categories from acid state to postgres +-- | Load categories and archives categories from acid state to postgres -- and check if they are equal. -- -- NOTE: It loads categories and categoriesDeleted fields of GlobalState only. @@ -43,28 +42,30 @@ postgresLoader logger globalState = do conn <- connect runTransactionExceptT conn Write $ insertCategories globalState -- Download from Postgres - (catPostgres, catDeletedPostgres) - <- runTransactionExceptT conn Read getCategories + catPostgres <- runTransactionExceptT conn Read $ + selectCategories (#archived False) + catarchivedPostgres <- runTransactionExceptT conn Read $ + selectCategories (#archived True) -- Check identity of available categories let checkedCat = sortOn categoryUid catPostgres == sortOn categoryUid (categories globalState) - -- Check identity of deleted categories + -- Check identity of archived categories let checkedCatDeleted = - sortOn categoryUid catDeletedPostgres == + sortOn categoryUid catarchivedPostgres == sortOn categoryUid (categoriesDeleted globalState) let checked = checkedCat && checkedCatDeleted logDebugIO logger $ format "AcidState == Postgres: {}" checked unless checked exitFailure where - -- Insert all categories from AcidState either deleted or not. + -- Insert all categories from AcidState either archived or not. -- Categories be normilised before insertion. See 'normalizeUTC'. insertCategories :: GlobalState -> ExceptT DatabaseError Transaction () insertCategories GlobalState{..} = do - mapM_ (insertCategoryWhole (#deleted False) . normalizeUTC) + mapM_ (insertCategoryWithCategory (#archived False) . normalizeUTC) categories - mapM_ (insertCategoryWhole (#deleted True) . normalizeUTC) + mapM_ (insertCategoryWithCategory (#archived True) . normalizeUTC) categoriesDeleted ---------------------------------------------------------------------------- @@ -97,98 +98,98 @@ cutUTCTime UTCTime{..} = UTCTime{utctDay, utctDayTime = utctDayTimeCut} ---------------------------------------------------------------------------- -- | Insert category at whole (with items and traits). -insertCategoryWhole - :: "deleted" :! Bool - -> Category - -> ExceptT DatabaseError Transaction () -insertCategoryWhole (arg #deleted -> deleted) category@Category{..} = do - insertCategoryByRow category (#deleted deleted) - insertItemsOfCategory category - mapM_ insertTraitsOfItem categoryItems - mapM_ insertTraitsOfItem categoryItemsDeleted +-- insertCategoryWhole +-- :: "deleted" :! Bool +-- -> Category +-- -> ExceptT DatabaseError Transaction () +-- insertCategoryWhole (arg #deleted -> deleted) category@Category{..} = do +-- insertCategoryByRow category (#deleted deleted) +-- insertItemsOfCategory category +-- mapM_ insertTraitsOfItem categoryItems +-- mapM_ insertTraitsOfItem categoryItemsDeleted -- | Insert to postgres all items of Category. -insertItemsOfCategory :: Category -> ExceptT DatabaseError Transaction () -insertItemsOfCategory Category{..} = do - mapM_ (insertItemByRow categoryUid (#deleted False)) categoryItems - mapM_ (insertItemByRow categoryUid (#deleted True)) categoryItemsDeleted +-- insertItemsOfCategory :: Category -> ExceptT DatabaseError Transaction () +-- insertItemsOfCategory Category{..} = do +-- mapM_ (insertItemByRow categoryUid (#deleted False)) categoryItems +-- mapM_ (insertItemByRow categoryUid (#deleted True)) categoryItemsDeleted -- | Insert to postgres all traits of Item. -insertTraitsOfItem :: Item -> ExceptT DatabaseError Transaction () -insertTraitsOfItem Item{..} = do - mapM_ (insertTraitByRow itemUid (#deleted False) TraitTypePro) itemPros - mapM_ (insertTraitByRow itemUid (#deleted True) TraitTypePro) itemProsDeleted - mapM_ (insertTraitByRow itemUid (#deleted False) TraitTypeCon) itemCons - mapM_ (insertTraitByRow itemUid (#deleted True) TraitTypeCon) itemConsDeleted +-- insertTraitsOfItem :: Item -> ExceptT DatabaseError Transaction () +-- insertTraitsOfItem Item{..} = do +-- mapM_ (insertTraitByRow itemUid (#deleted False) TraitTypePro) itemPros +-- mapM_ (insertTraitByRow itemUid (#deleted True) TraitTypePro) itemProsDeleted +-- mapM_ (insertTraitByRow itemUid (#deleted False) TraitTypeCon) itemCons +-- mapM_ (insertTraitByRow itemUid (#deleted True) TraitTypeCon) itemConsDeleted -- | Insert category passing 'Category'. -insertCategoryByRow - :: Category - -> "deleted" :! Bool - -> ExceptT DatabaseError Transaction () -insertCategoryByRow category (arg #deleted -> deleted) = do - let categoryRow = categoryToRowCategory category (#deleted deleted) - insertCategoryWithCategoryRow categoryRow +-- insertCategoryByRow +-- :: Category +-- -> "deleted" :! Bool +-- -> ExceptT DatabaseError Transaction () +-- insertCategoryByRow category (arg #deleted -> deleted) = do +-- let categoryRow = categoryToRowCategory category (#deleted deleted) +-- insertCategoryWithCategoryRow categoryRow -- | Insert item passing 'Item'. -insertItemByRow - :: Uid Category - -> "deleted" :! Bool - -> Item - -> ExceptT DatabaseError Transaction () -insertItemByRow catId (arg #deleted -> deleted) item = do - let itemRow = itemToRowItem catId (#deleted deleted) item - insertItemWithItemRow itemRow +-- insertItemByRow +-- :: Uid Category +-- -> "deleted" :! Bool +-- -> Item +-- -> ExceptT DatabaseError Transaction () +-- insertItemByRow catId (arg #deleted -> deleted) item = do +-- let itemRow = itemToRowItem catId (#deleted deleted) item +-- insertItemWithItemRow itemRow -- | Insert trait passing 'Trait'. -insertTraitByRow - :: Uid Item - -> "deleted" :! Bool - -> TraitType - -> Trait - -> ExceptT DatabaseError Transaction () -insertTraitByRow itemId (arg #deleted -> deleted) traitType trait = do - let traitRow = traitToTraitRow itemId (#deleted deleted) traitType trait - insertTraitWithTraitRow traitRow +-- insertTraitByRow +-- :: Uid Item +-- -> "deleted" :! Bool +-- -> TraitType +-- -> Trait +-- -> ExceptT DatabaseError Transaction () +-- insertTraitByRow itemId (arg #deleted -> deleted) traitType trait = do +-- let traitRow = traitToTraitRow itemId (#deleted deleted) traitType trait +-- insertTraitWithTraitRow traitRow ---------------------------------------------------------------------------- -- Get helpers ---------------------------------------------------------------------------- -- | Get all categories and categoriesDeleted. -getCategories :: ExceptT DatabaseError Transaction ([Category], [Category]) -getCategories = do - categoryRowsAll <- selectCategoryRows - let (categoryRowsDeleted, categoryRows) = - partition categoryRowDeleted categoryRowsAll - categories <- traverse getCategoryByRow categoryRows - categoriesDeleted <- traverse getCategoryByRow categoryRowsDeleted - pure (categories, categoriesDeleted) +-- getCategories :: ExceptT DatabaseError Transaction ([Category], [Category]) +-- getCategories = do +-- categoryRowsAll <- selectCategoryRows +-- let (categoryRowsDeleted, categoryRows) = +-- partition categoryRowDeleted categoryRowsAll +-- categories <- traverse getCategoryByRow categoryRows +-- categoriesDeleted <- traverse getCategoryByRow categoryRowsDeleted +-- pure (categories, categoriesDeleted) -- | Get category by CategoryRow -getCategoryByRow :: CategoryRow -> ExceptT DatabaseError Transaction Category -getCategoryByRow categoryRow@CategoryRow{..} = do - itemRows <- selectItemRowsByCategory categoryRowUid - items <- traverse getItemByRow itemRows - itemRowsDeleted <- selectDeletedItemRowsByCategory categoryRowUid - itemsDeleted <- traverse getItemByRow itemRowsDeleted - pure $ categoryRowToCategory (#items items) - (#itemsDeleted itemsDeleted) categoryRow +-- getCategoryByRow :: CategoryRow -> ExceptT DatabaseError Transaction Category +-- getCategoryByRow categoryRow@CategoryRow{..} = do +-- itemRows <- selectItemRowsByCategory categoryRowUid +-- items <- traverse getItemByRow itemRows +-- itemRowsDeleted <- selectDeletedItemRowsByCategory categoryRowUid +-- itemsDeleted <- traverse getItemByRow itemRowsDeleted +-- pure $ categoryRowToCategory (#items items) +-- (#itemsDeleted itemsDeleted) categoryRow -- | Get Item by ItemRow -getItemByRow :: ItemRow -> ExceptT DatabaseError Transaction Item -getItemByRow itemRow@ItemRow{..} = do - proTraitRows <- selectTraitRowsByItem itemRowUid TraitTypePro - let proTraits = map traitRowToTrait proTraitRows - proDeletedTraitRows <- selectDeletedTraitRowsByItem itemRowUid TraitTypePro - let proDeletedTraits = map traitRowToTrait proDeletedTraitRows - conTraitRows <- selectTraitRowsByItem itemRowUid TraitTypeCon - let conTraits = map traitRowToTrait conTraitRows - conDeletedTraitRows <- selectDeletedTraitRowsByItem itemRowUid TraitTypeCon - let conDeletedTraits = map traitRowToTrait conDeletedTraitRows - pure $ itemRowToItem - (#proTraits proTraits) - (#proDeletedTraits proDeletedTraits) - (#conTraits conTraits) - (#conDeletedTraits conDeletedTraits) - itemRow +-- getItemByRow :: ItemRow -> ExceptT DatabaseError Transaction Item +-- getItemByRow itemRow@ItemRow{..} = do +-- proTraitRows <- selectTraitRowsByItem itemRowUid TraitTypePro +-- let proTraits = map traitRowToTrait proTraitRows +-- proDeletedTraitRows <- selectDeletedTraitRowsByItem itemRowUid TraitTypePro +-- let proDeletedTraits = map traitRowToTrait proDeletedTraitRows +-- conTraitRows <- selectTraitRowsByItem itemRowUid TraitTypeCon +-- let conTraits = map traitRowToTrait conTraitRows +-- conDeletedTraitRows <- selectDeletedTraitRowsByItem itemRowUid TraitTypeCon +-- let conDeletedTraits = map traitRowToTrait conDeletedTraitRows +-- pure $ itemRowToItem +-- (#proTraits proTraits) +-- (#proDeletedTraits proDeletedTraits) +-- (#conTraits conTraits) +-- (#conDeletedTraits conDeletedTraits) +-- itemRow diff --git a/back/src/Guide/Database/Queries/Delete.hs b/back/src/Guide/Database/Queries/Delete.hs index 3c6874a5..1930add7 100644 --- a/back/src/Guide/Database/Queries/Delete.hs +++ b/back/src/Guide/Database/Queries/Delete.hs @@ -2,8 +2,8 @@ module Guide.Database.Queries.Delete ( deleteCategory, - deleteItem, - deleteTrait, + -- deleteItem, + -- deleteTrait, ) where @@ -32,41 +32,39 @@ deleteCategory catId = do WHERE uid = $1 |] lift $ HT.statement catId statement - -- Items belonging to the category will be deleted automatically because - -- of "ON DELETE CASCADE" in the table schema. -- | Delete an item completly. -deleteItem :: Uid Item -> ExceptT DatabaseError Transaction () -deleteItem itemId = do - catId <- selectCategoryIdByItem itemId - let statement :: Statement (Uid Item) () - statement = lmap SingleParam $ - [execute| - DELETE FROM items - WHERE uid = $1 - |] - lift $ HT.statement itemId statement - updateCategoryRow catId $ - _categoryRowItemsOrder %~ delete itemId +-- deleteItem :: Uid Item -> ExceptT DatabaseError Transaction () +-- deleteItem itemId = do +-- catId <- selectCategoryIdByItem itemId +-- let statement :: Statement (Uid Item) () +-- statement = lmap SingleParam $ +-- [execute| +-- DELETE FROM items +-- WHERE uid = $1 +-- |] +-- lift $ HT.statement itemId statement +-- updateCategoryRow catId $ +-- _categoryRowItemsOrder %~ delete itemId -- Traits belonging to the item will be deleted automatically because of -- "ON DELETE CASCADE" in the table schema. -- | Delete a trait completly. -deleteTrait :: Uid Trait -> ExceptT DatabaseError Transaction () -deleteTrait traitId = do - itemId <- selectItemIdByTrait traitId - traitType <- traitRowType <$> selectTraitRow traitId - let statement :: Statement (Uid Trait) () - statement = lmap SingleParam $ - [execute| - DELETE FROM traits - WHERE uid = $1 - |] - lift $ HT.statement traitId statement - case traitType of - TraitTypePro -> - updateItemRow itemId $ - _itemRowProsOrder %~ delete traitId - TraitTypeCon -> - updateItemRow itemId $ - _itemRowConsOrder %~ delete traitId +-- deleteTrait :: Uid Trait -> ExceptT DatabaseError Transaction () +-- deleteTrait traitId = do +-- itemId <- selectItemIdByTrait traitId +-- traitType <- traitRowType <$> selectTraitRow traitId +-- let statement :: Statement (Uid Trait) () +-- statement = lmap SingleParam $ +-- [execute| +-- DELETE FROM traits +-- WHERE uid = $1 +-- |] +-- lift $ HT.statement traitId statement +-- case traitType of +-- TraitTypePro -> +-- updateItemRow itemId $ +-- _itemRowProsOrder %~ delete traitId +-- TraitTypeCon -> +-- updateItemRow itemId $ +-- _itemRowConsOrder %~ delete traitId diff --git a/back/src/Guide/Database/Queries/Insert.hs b/back/src/Guide/Database/Queries/Insert.hs index c461e9da..c4c12b22 100644 --- a/back/src/Guide/Database/Queries/Insert.hs +++ b/back/src/Guide/Database/Queries/Insert.hs @@ -3,15 +3,14 @@ module Guide.Database.Queries.Insert ( -- * Category insertCategory, - insertCategory2, insertCategoryWithCategory, - insertCategoryWithCategoryRow, + -- insertCategoryWithCategoryRow, -- * Item - insertItem, - insertItemWithItemRow, + -- insertItem, + -- insertItemWithItemRow, -- * Trait - insertTrait, - insertTraitWithTraitRow, + -- insertTrait, + -- insertTraitWithTraitRow, ) where @@ -44,74 +43,6 @@ insertCategory -> "enabledSections" :! Set ItemSection -> ExceptT DatabaseError Transaction () insertCategory - catId - (arg #title -> title) - (arg #group -> group_) - (arg #created -> created) - (arg #status -> status) - (arg #enabledSections -> enabledSections) - = - do - let statement :: Statement CategoryRow () - statement = - [execute| - INSERT INTO categories - ( uid - , title - , created - , group_ - , status - , notes - , enabled_sections - , items_order - , deleted - ) - VALUES ($1,$2,$3,$4,$5,$6,$7,$8,$9) - |] - lift $ HT.statement - CategoryRow - { categoryRowUid = catId - , categoryRowTitle = title - , categoryRowCreated = created - , categoryRowGroup = group_ - , categoryRowStatus = status - , categoryRowNotes = "" - , categoryRowEnabledSections = enabledSections - , categoryRowItemsOrder = [] - , categoryRowDeleted = False - } - statement - --- | Create category passing 'CategoryRow'. -insertCategoryWithCategoryRow :: CategoryRow -> ExceptT DatabaseError Transaction () -insertCategoryWithCategoryRow categoryRow = do - let statement :: Statement CategoryRow () - statement = - [execute| - INSERT INTO categories - ( uid - , title - , created - , group_ - , status - , notes - , enabled_sections - , items_order - , deleted - ) - VALUES ($1,$2,$3,$4,$5,$6,$7,$8,$9) - |] - lift $ HT.statement categoryRow statement - -insertCategory2 - :: Uid Category -- ^ New category's id - -> "title" :! Text - -> "group" :! Text - -> "created" :! UTCTime - -> "status" :! CategoryStatus - -> "enabledSections" :! Set ItemSection - -> ExceptT DatabaseError Transaction () -insertCategory2 catId (arg #title -> title) (arg #group -> group_) @@ -131,98 +62,169 @@ insertCategory2 , categoryItemsDeleted = [] , categoryEnabledSections = enabledSections } - insertCategoryWithCategory category + insertCategoryWithCategory (#archived False) category --- | Create category passing 'Category'. -insertCategoryWithCategory :: Category -> ExceptT DatabaseError Transaction () -insertCategoryWithCategory category = do - let statement :: Statement (Uid Category, Category) () +-- | Create category passing 'Category' and archived parameter. +insertCategoryWithCategory + :: "archived" :! Bool + -> Category + -> ExceptT DatabaseError Transaction () +insertCategoryWithCategory (arg #archived -> archived) category = do + let statement :: Statement (Uid Category, Category, Bool) () statement = [execute| INSERT INTO categories ( uid , data + , archived ) - VALUES ($1,$2) + VALUES ($1,$2,$3) |] - lift $ HT.statement (categoryUid category, category) statement + lift $ HT.statement (categoryUid category, category, archived) statement + +-- insertCategory +-- :: Uid Category -- ^ New category's id +-- -> "title" :! Text +-- -> "group" :! Text +-- -> "created" :! UTCTime +-- -> "status" :! CategoryStatus +-- -> "enabledSections" :! Set ItemSection +-- -> ExceptT DatabaseError Transaction () +-- insertCategory +-- catId +-- (arg #title -> title) +-- (arg #group -> group_) +-- (arg #created -> created) +-- (arg #status -> status) +-- (arg #enabledSections -> enabledSections) +-- = +-- do +-- let statement :: Statement CategoryRow () +-- statement = +-- [execute| +-- INSERT INTO categories +-- ( uid +-- , title +-- , created +-- , group_ +-- , status +-- , notes +-- , enabled_sections +-- , items_order +-- , deleted +-- ) +-- VALUES ($1,$2,$3,$4,$5,$6,$7,$8,$9) +-- |] +-- lift $ HT.statement +-- CategoryRow +-- { categoryRowUid = catId +-- , categoryRowTitle = title +-- , categoryRowCreated = created +-- , categoryRowGroup = group_ +-- , categoryRowStatus = status +-- , categoryRowNotes = "" +-- , categoryRowEnabledSections = enabledSections +-- , categoryRowItemsOrder = [] +-- , categoryRowDeleted = False +-- } +-- statement +-- | Create category passing 'CategoryRow'. +-- insertCategoryWithCategoryRow :: CategoryRow -> ExceptT DatabaseError Transaction () +-- insertCategoryWithCategoryRow categoryRow = do +-- let statement :: Statement CategoryRow () +-- statement = +-- [execute| +-- INSERT INTO categories +-- ( uid +-- , title +-- , created +-- , group_ +-- , status +-- , notes +-- , enabled_sections +-- , items_order +-- , deleted +-- ) +-- VALUES ($1,$2,$3,$4,$5,$6,$7,$8,$9) +-- |] +-- lift $ HT.statement categoryRow statement ---------------------------------------------------------------------------- -- Item ---------------------------------------------------------------------------- -- | Create an item record. The item will also be added to its category. -insertItem - :: Uid Category -- ^ Category id - -> Uid Item -- ^ New item's id - -> "name" :! Text -- ^ Name - -> "created" :! UTCTime -- ^ Creation time - -> ExceptT DatabaseError Transaction () -insertItem catId itemId (arg #name -> name) (arg #created -> created) = do - let statement :: Statement ItemRow () - statement = - [execute| - INSERT INTO items - ( uid - , name - , created - , link - , hackage - , summary - , ecosystem - , notes - , deleted - , category_uid - , pros_order - , cons_order - ) - VALUES ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12) - |] - lift $ HT.statement - ItemRow - { itemRowUid = itemId - , itemRowName = name - , itemRowCreated = created - , itemRowLink = Nothing - , itemRowHackage = Nothing - , itemRowSummary = "" - , itemRowEcosystem = "" - , itemRowNotes = "" - , itemRowDeleted = False - , itemRowCategoryUid = catId - , itemRowProsOrder = [] - , itemRowConsOrder = [] - } - statement - updateCategoryRow catId $ - _categoryRowItemsOrder %~ (++ [itemId]) +-- insertItem +-- :: Uid Category -- ^ Category id +-- -> Uid Item -- ^ New item's id +-- -> "name" :! Text -- ^ Name +-- -> "created" :! UTCTime -- ^ Creation time +-- -> ExceptT DatabaseError Transaction () +-- insertItem catId itemId (arg #name -> name) (arg #created -> created) = do +-- let statement :: Statement ItemRow () +-- statement = +-- [execute| +-- INSERT INTO items +-- ( uid +-- , name +-- , created +-- , link +-- , hackage +-- , summary +-- , ecosystem +-- , notes +-- , deleted +-- , category_uid +-- , pros_order +-- , cons_order +-- ) +-- VALUES ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12) +-- |] +-- lift $ HT.statement +-- ItemRow +-- { itemRowUid = itemId +-- , itemRowName = name +-- , itemRowCreated = created +-- , itemRowLink = Nothing +-- , itemRowHackage = Nothing +-- , itemRowSummary = "" +-- , itemRowEcosystem = "" +-- , itemRowNotes = "" +-- , itemRowDeleted = False +-- , itemRowCategoryUid = catId +-- , itemRowProsOrder = [] +-- , itemRowConsOrder = [] +-- } +-- statement +-- updateCategoryRow catId $ +-- _categoryRowItemsOrder %~ (++ [itemId]) -- | Create item passing 'ItemRow'. -insertItemWithItemRow :: ItemRow -> ExceptT DatabaseError Transaction () -insertItemWithItemRow itemRow@ItemRow{..} = do - let statement :: Statement ItemRow () - statement = - [execute| - INSERT INTO items - ( uid - , name - , created - , link - , hackage - , summary - , ecosystem - , notes - , deleted - , category_uid - , pros_order - , cons_order - ) - VALUES ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12) - |] - lift $ HT.statement itemRow statement - unless itemRowDeleted $ updateCategoryRow itemRowCategoryUid $ - _categoryRowItemsOrder %~ (++ [itemRowUid]) +-- insertItemWithItemRow :: ItemRow -> ExceptT DatabaseError Transaction () +-- insertItemWithItemRow itemRow@ItemRow{..} = do +-- let statement :: Statement ItemRow () +-- statement = +-- [execute| +-- INSERT INTO items +-- ( uid +-- , name +-- , created +-- , link +-- , hackage +-- , summary +-- , ecosystem +-- , notes +-- , deleted +-- , category_uid +-- , pros_order +-- , cons_order +-- ) +-- VALUES ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12) +-- |] +-- lift $ HT.statement itemRow statement +-- unless itemRowDeleted $ updateCategoryRow itemRowCategoryUid $ +-- _categoryRowItemsOrder %~ (++ [itemRowUid]) ---------------------------------------------------------------------------- -- Trait @@ -230,50 +232,50 @@ insertItemWithItemRow itemRow@ItemRow{..} = do -- | Create a trait record. The trait will also be added to its item in the -- pros or cons section. -insertTrait - :: Uid Item -- ^ Item id - -> Uid Trait -- ^ New trait's id - -> TraitType -- ^ Pro or Con - -> "content" :! Text -- ^ Trait content - -> ExceptT DatabaseError Transaction () -insertTrait itemId traitId traitType (arg #content -> content) = do - let statement :: Statement TraitRow () - statement = - [execute| - INSERT INTO traits (uid, content, deleted, type_, item_uid) - VALUES ($1,$2,$3,($4 :: trait_type),$5) - |] - lift $ HT.statement - TraitRow - { traitRowUid = traitId - , traitRowContent = content - , traitRowDeleted = False - , traitRowType = traitType - , traitRowItemUid = itemId - } - statement - case traitType of - TraitTypePro -> - updateItemRow itemId $ - _itemRowProsOrder %~ (++ [traitId]) - TraitTypeCon -> - updateItemRow itemId $ - _itemRowConsOrder %~ (++ [traitId]) +-- insertTrait +-- :: Uid Item -- ^ Item id +-- -> Uid Trait -- ^ New trait's id +-- -> TraitType -- ^ Pro or Con +-- -> "content" :! Text -- ^ Trait content +-- -> ExceptT DatabaseError Transaction () +-- insertTrait itemId traitId traitType (arg #content -> content) = do +-- let statement :: Statement TraitRow () +-- statement = +-- [execute| +-- INSERT INTO traits (uid, content, deleted, type_, item_uid) +-- VALUES ($1,$2,$3,($4 :: trait_type),$5) +-- |] +-- lift $ HT.statement +-- TraitRow +-- { traitRowUid = traitId +-- , traitRowContent = content +-- , traitRowDeleted = False +-- , traitRowType = traitType +-- , traitRowItemUid = itemId +-- } +-- statement +-- case traitType of +-- TraitTypePro -> +-- updateItemRow itemId $ +-- _itemRowProsOrder %~ (++ [traitId]) +-- TraitTypeCon -> +-- updateItemRow itemId $ +-- _itemRowConsOrder %~ (++ [traitId]) -- | Create trait record passing 'TraitRow'. -insertTraitWithTraitRow :: TraitRow -> ExceptT DatabaseError Transaction () -insertTraitWithTraitRow traitRow@TraitRow{..} = do - let statement :: Statement TraitRow () - statement = - [execute| - INSERT INTO traits (uid, content, deleted, type_, item_uid) - VALUES ($1,$2,$3,($4 :: trait_type),$5) - |] - lift $ HT.statement traitRow statement - unless traitRowDeleted $ case traitRowType of - TraitTypePro -> - updateItemRow traitRowItemUid $ - _itemRowProsOrder %~ (++ [traitRowUid]) - TraitTypeCon -> - updateItemRow traitRowItemUid $ - _itemRowConsOrder %~ (++ [traitRowUid]) +-- insertTraitWithTraitRow :: TraitRow -> ExceptT DatabaseError Transaction () +-- insertTraitWithTraitRow traitRow@TraitRow{..} = do +-- let statement :: Statement TraitRow () +-- statement = +-- [execute| +-- INSERT INTO traits (uid, content, deleted, type_, item_uid) +-- VALUES ($1,$2,$3,($4 :: trait_type),$5) +-- |] +-- lift $ HT.statement traitRow statement +-- unless traitRowDeleted $ case traitRowType of +-- TraitTypePro -> +-- updateItemRow traitRowItemUid $ +-- _itemRowProsOrder %~ (++ [traitRowUid]) +-- TraitTypeCon -> +-- updateItemRow traitRowItemUid $ +-- _itemRowConsOrder %~ (++ [traitRowUid]) diff --git a/back/src/Guide/Database/Queries/Select.hs b/back/src/Guide/Database/Queries/Select.hs index 63dc055e..0d03515d 100644 --- a/back/src/Guide/Database/Queries/Select.hs +++ b/back/src/Guide/Database/Queries/Select.hs @@ -5,29 +5,31 @@ module Guide.Database.Queries.Select ( -- * Category - selectCategoryRow, selectCategory, - selectCategoryRowMaybe, selectCategoryMaybe, - selectCategoryRows, - selectCategoryRowByItemMaybe, selectCategoryIds, - selectCategoryIdByItem, - selectCategoryIdByItemMaybe, + selectCategories, + isCategoryArchived, + -- selectCategoryRow, + -- selectCategoryRowMaybe, + -- selectCategoryRows, + -- selectCategoryRowByItemMaybe, + -- selectCategoryIdByItem, + -- selectCategoryIdByItemMaybe, -- * Item - selectItemRow, - selectItemRowMaybe, - selectItemRowsByCategory, - selectDeletedItemRowsByCategory, - selectItemIdByTrait, - selectItemIdByTraitMaybe, + -- selectItemRow, + -- selectItemRowMaybe, + -- selectItemRowsByCategory, + -- selectDeletedItemRowsByCategory, + -- selectItemIdByTrait, + -- selectItemIdByTraitMaybe, -- * Trait - selectTraitRowMaybe, - selectTraitRow, - selectTraitRowsByItem, - selectDeletedTraitRowsByItem, + -- selectTraitRowMaybe, + -- selectTraitRow, + -- selectTraitRowsByItem, + -- selectDeletedTraitRowsByItem, ) where @@ -35,7 +37,7 @@ import Imports import Hasql.Statement (Statement (..)) import Hasql.Transaction (Transaction) -import Data.Profunctor (lmap, rmap, dimap) +import Data.Profunctor (rmap, dimap) import qualified Hasql.Transaction as HT @@ -48,6 +50,7 @@ import Guide.Uid -- Categories ---------------------------------------------------------------------------- +-- | Fetch a 'Category' selectCategoryMaybe :: Uid Category -> ExceptT DatabaseError Transaction (Maybe Category) selectCategoryMaybe catId = do let statement :: Statement (Uid Category) (Maybe Category) @@ -59,97 +62,136 @@ selectCategoryMaybe catId = do |] lift $ HT.statement catId statement +-- | Fetch a 'Category' or fail. selectCategory :: Uid Category -> ExceptT DatabaseError Transaction Category selectCategory catId = do - mCatRow <- selectCategoryMaybe catId - case mCatRow of - Nothing -> throwError $ CategoryNotFound catId - Just catRow -> pure catRow + mCategory <- selectCategoryMaybe catId + case mCategory of + Nothing -> throwError $ CategoryNotFound catId + Just category -> pure category --- | Get a 'CategoryRow'. -selectCategoryRowMaybe :: Uid Category -> ExceptT DatabaseError Transaction (Maybe CategoryRow) -selectCategoryRowMaybe catId = do - let statement :: Statement (Uid Category) (Maybe CategoryRow) - statement = lmap SingleParam $ +-- | Check if category is archived +isCategoryArchived :: Uid Category -> ExceptT DatabaseError Transaction Bool +isCategoryArchived catId = do + let statement :: Statement (Uid Category) (Maybe Bool) + statement = dimap SingleParam (fmap fromSingleColumn) $ [queryRowMaybe| - SELECT - uid - , title - , created - , group_ - , status - , notes - , enabled_sections - , items_order - , deleted + SELECT archived FROM categories WHERE uid = $1 |] - lift $ HT.statement catId statement + mArchived <- lift $ HT.statement catId statement + case mArchived of + Nothing -> throwError $ CategoryNotFound catId + Just archived -> pure archived + +-- | Fetch a list of available or archived categories' IDs. +-- +-- Run command twice with different Bool to fetch all categories' IDs. +selectCategoryIds :: "archived" :! Bool -> ExceptT DatabaseError Transaction [Uid Category] +selectCategoryIds (arg #archived -> archived) = do + let statement :: Statement Bool [Uid Category] + statement = + dimap SingleParam (map fromSingleColumn) $ + [queryRows| + SELECT uid + FROM categories + WHERE archived = $1 + |] + lift $ HT.statement archived statement + +-- | Fetch a list of available or archived categories. +-- +-- Run command twice with different Bool to fetch all categories. +selectCategories :: "archived" :! Bool -> ExceptT DatabaseError Transaction [Category] +selectCategories (arg #archived -> archived) = do + catIds <- selectCategoryIds (#archived archived) + traverse selectCategory catIds + +-- | Get a 'CategoryRow'. +-- selectCategoryRowMaybe :: Uid Category -> ExceptT DatabaseError Transaction (Maybe CategoryRow) +-- selectCategoryRowMaybe catId = do +-- let statement :: Statement (Uid Category) (Maybe CategoryRow) +-- statement = lmap SingleParam $ +-- [queryRowMaybe| +-- SELECT +-- uid +-- , title +-- , created +-- , group_ +-- , status +-- , notes +-- , enabled_sections +-- , items_order +-- , deleted +-- FROM categories +-- WHERE uid = $1 +-- |] +-- lift $ HT.statement catId statement -- | Get a 'CategoryRow'. -- -- Fails with 'CategoryNotFound' when the category does not exist. -selectCategoryRow :: Uid Category -> ExceptT DatabaseError Transaction CategoryRow -selectCategoryRow catId = do - mCatRow <- selectCategoryRowMaybe catId - case mCatRow of - Nothing -> throwError $ CategoryNotFound catId - Just catRow -> pure catRow +-- selectCategoryRow :: Uid Category -> ExceptT DatabaseError Transaction CategoryRow +-- selectCategoryRow catId = do +-- mCatRow <- selectCategoryRowMaybe catId +-- case mCatRow of +-- Nothing -> throwError $ CategoryNotFound catId +-- Just catRow -> pure catRow -- | Get the ID of the category that an item belongs to. -selectCategoryIdByItemMaybe - :: Uid Item -> ExceptT DatabaseError Transaction (Maybe (Uid Category)) -selectCategoryIdByItemMaybe itemId = do - let statement :: Statement (Uid Item) (Maybe (Uid Category)) - statement = dimap SingleParam (fmap fromSingleColumn) $ - [queryRowMaybe| - SELECT category_uid - FROM items - WHERE uid = $1 - |] - lift $ HT.statement itemId statement +-- selectCategoryIdByItemMaybe +-- :: Uid Item -> ExceptT DatabaseError Transaction (Maybe (Uid Category)) +-- selectCategoryIdByItemMaybe itemId = do +-- let statement :: Statement (Uid Item) (Maybe (Uid Category)) +-- statement = dimap SingleParam (fmap fromSingleColumn) $ +-- [queryRowMaybe| +-- SELECT category_uid +-- FROM items +-- WHERE uid = $1 +-- |] +-- lift $ HT.statement itemId statement -- | Get an ID of the category that an item belongs to. -- -- Throw error if item not found. -selectCategoryIdByItem :: Uid Item -> ExceptT DatabaseError Transaction (Uid Category) -selectCategoryIdByItem itemId = do - mCatId <- selectCategoryIdByItemMaybe itemId - case mCatId of - Nothing -> throwError $ ItemNotFound itemId - Just catId -> pure catId +-- selectCategoryIdByItem :: Uid Item -> ExceptT DatabaseError Transaction (Uid Category) +-- selectCategoryIdByItem itemId = do +-- mCatId <- selectCategoryIdByItemMaybe itemId +-- case mCatId of +-- Nothing -> throwError $ ItemNotFound itemId +-- Just catId -> pure catId -- | Get the 'CategoryRow' that an item belongs to. -- -- Returns 'Nothing' if either the item or the category are not found. -selectCategoryRowByItemMaybe - :: Uid Item -> ExceptT DatabaseError Transaction (Maybe CategoryRow) -selectCategoryRowByItemMaybe itemId = do - catId <- selectCategoryIdByItemMaybe itemId - join @Maybe <$> traverse selectCategoryRowMaybe catId +-- selectCategoryRowByItemMaybe +-- :: Uid Item -> ExceptT DatabaseError Transaction (Maybe CategoryRow) +-- selectCategoryRowByItemMaybe itemId = do +-- catId <- selectCategoryIdByItemMaybe itemId +-- join @Maybe <$> traverse selectCategoryRowMaybe catId -- | Get a list of available categories' IDs. -- -- Includes categories marked as deleted. See -- -- for an explanation of why we store deleted objects at all. -selectCategoryIds :: ExceptT DatabaseError Transaction [Uid Category] -selectCategoryIds = do - let statement :: Statement () [Uid Category] - statement = - rmap (map fromSingleColumn) $ - [queryRows| - SELECT uid - FROM categories - |] - lift $ HT.statement () statement +-- selectCategoryIds :: ExceptT DatabaseError Transaction [Uid Category] +-- selectCategoryIds = do +-- let statement :: Statement () [Uid Category] +-- statement = +-- rmap (map fromSingleColumn) $ +-- [queryRows| +-- SELECT uid +-- FROM categories +-- |] +-- lift $ HT.statement () statement -- | Get all category rows. -selectCategoryRows :: ExceptT DatabaseError Transaction [CategoryRow] -selectCategoryRows = do - catIds <- selectCategoryIds - traverse selectCategoryRow catIds +-- selectCategoryRows :: ExceptT DatabaseError Transaction [CategoryRow] +-- selectCategoryRows = do +-- catIds <- selectCategoryIds +-- traverse selectCategoryRow catIds ---------------------------------------------------------------------------- -- Items @@ -159,28 +201,28 @@ selectCategoryRows = do -- -- Items marked as deleted will still be returned if they physically exist -- in the database. -selectItemRowMaybe :: Uid Item -> ExceptT DatabaseError Transaction (Maybe ItemRow) -selectItemRowMaybe itemId = do - let statement :: Statement (Uid Item) (Maybe ItemRow) - statement = lmap SingleParam $ - [queryRowMaybe| - SELECT - uid - , name - , created - , link - , hackage - , summary - , ecosystem - , notes - , deleted - , category_uid - , pros_order - , cons_order - FROM items - WHERE uid = $1 - |] - lift $ HT.statement itemId statement +-- selectItemRowMaybe :: Uid Item -> ExceptT DatabaseError Transaction (Maybe ItemRow) +-- selectItemRowMaybe itemId = do +-- let statement :: Statement (Uid Item) (Maybe ItemRow) +-- statement = lmap SingleParam $ +-- [queryRowMaybe| +-- SELECT +-- uid +-- , name +-- , created +-- , link +-- , hackage +-- , summary +-- , ecosystem +-- , notes +-- , deleted +-- , category_uid +-- , pros_order +-- , cons_order +-- FROM items +-- WHERE uid = $1 +-- |] +-- lift $ HT.statement itemId statement -- | Get an 'ItemRow'. -- @@ -188,70 +230,70 @@ selectItemRowMaybe itemId = do -- in the database. -- -- Fails with 'ItemNotFound' when the item does not exist. -selectItemRow :: Uid Item -> ExceptT DatabaseError Transaction ItemRow -selectItemRow itemId = do - mItemRow <- selectItemRowMaybe itemId - case mItemRow of - Nothing -> throwError $ ItemNotFound itemId - Just itemRow -> pure itemRow +-- selectItemRow :: Uid Item -> ExceptT DatabaseError Transaction ItemRow +-- selectItemRow itemId = do +-- mItemRow <- selectItemRowMaybe itemId +-- case mItemRow of +-- Nothing -> throwError $ ItemNotFound itemId +-- Just itemRow -> pure itemRow -- | Get deleted ItemRows belonging to a category. -- -- Returns item rows without order. -selectDeletedItemRowsByCategory :: Uid Category -> ExceptT DatabaseError Transaction [ItemRow] -selectDeletedItemRowsByCategory catId = do - let statement :: Statement (Uid Category) [ItemRow] - statement = - lmap SingleParam $ - [queryRows| - SELECT - uid - , name - , created - , link - , hackage - , summary - , ecosystem - , notes - , deleted - , category_uid - , pros_order - , cons_order - FROM items - WHERE category_uid = $1 - AND deleted = true - |] - lift $ HT.statement catId statement +-- selectDeletedItemRowsByCategory :: Uid Category -> ExceptT DatabaseError Transaction [ItemRow] +-- selectDeletedItemRowsByCategory catId = do +-- let statement :: Statement (Uid Category) [ItemRow] +-- statement = +-- lmap SingleParam $ +-- [queryRows| +-- SELECT +-- uid +-- , name +-- , created +-- , link +-- , hackage +-- , summary +-- , ecosystem +-- , notes +-- , deleted +-- , category_uid +-- , pros_order +-- , cons_order +-- FROM items +-- WHERE category_uid = $1 +-- AND deleted = true +-- |] +-- lift $ HT.statement catId statement -- | Get available ItemRows belonging to a category. -- -- Returns item rows sorted by order. -selectItemRowsByCategory :: Uid Category -> ExceptT DatabaseError Transaction [ItemRow] -selectItemRowsByCategory catId = do - itemUids <- categoryRowItemsOrder <$> selectCategoryRow catId - traverse selectItemRow itemUids +-- selectItemRowsByCategory :: Uid Category -> ExceptT DatabaseError Transaction [ItemRow] +-- selectItemRowsByCategory catId = do +-- itemUids <- categoryRowItemsOrder <$> selectCategoryRow catId +-- traverse selectItemRow itemUids -- | Get item id by trait. -selectItemIdByTraitMaybe :: Uid Trait -> ExceptT DatabaseError Transaction (Maybe (Uid Item)) -selectItemIdByTraitMaybe traitId = do - let statement :: Statement (Uid Trait) (Maybe (Uid Item)) - statement = dimap SingleParam (fmap fromSingleColumn) $ - [queryRowMaybe| - SELECT item_uid - FROM traits - WHERE uid = $1 - |] - lift $ HT.statement traitId statement +-- selectItemIdByTraitMaybe :: Uid Trait -> ExceptT DatabaseError Transaction (Maybe (Uid Item)) +-- selectItemIdByTraitMaybe traitId = do +-- let statement :: Statement (Uid Trait) (Maybe (Uid Item)) +-- statement = dimap SingleParam (fmap fromSingleColumn) $ +-- [queryRowMaybe| +-- SELECT item_uid +-- FROM traits +-- WHERE uid = $1 +-- |] +-- lift $ HT.statement traitId statement -- | Get item id by trait. -- -- Can throw 'TraitNotFound'. -selectItemIdByTrait :: Uid Trait -> ExceptT DatabaseError Transaction (Uid Item) -selectItemIdByTrait traitId = do - mItemId <- selectItemIdByTraitMaybe traitId - case mItemId of - Nothing -> throwError $ TraitNotFound traitId - Just itemId -> pure itemId +-- selectItemIdByTrait :: Uid Trait -> ExceptT DatabaseError Transaction (Uid Item) +-- selectItemIdByTrait traitId = do +-- mItemId <- selectItemIdByTraitMaybe traitId +-- case mItemId of +-- Nothing -> throwError $ TraitNotFound traitId +-- Just itemId -> pure itemId ---------------------------------------------------------------------------- -- Traits @@ -261,16 +303,16 @@ selectItemIdByTrait traitId = do -- -- Traits marked as deleted will still be returned if they physically exist -- in the database. -selectTraitRowMaybe :: Uid Trait -> ExceptT DatabaseError Transaction (Maybe TraitRow) -selectTraitRowMaybe traitId = do - let statement :: Statement (Uid Trait) (Maybe TraitRow) - statement = lmap SingleParam $ - [queryRowMaybe| - SELECT uid, content, deleted, type_, item_uid - FROM traits - WHERE uid = $1 - |] - lift $ HT.statement traitId statement +-- selectTraitRowMaybe :: Uid Trait -> ExceptT DatabaseError Transaction (Maybe TraitRow) +-- selectTraitRowMaybe traitId = do +-- let statement :: Statement (Uid Trait) (Maybe TraitRow) +-- statement = lmap SingleParam $ +-- [queryRowMaybe| +-- SELECT uid, content, deleted, type_, item_uid +-- FROM traits +-- WHERE uid = $1 +-- |] +-- lift $ HT.statement traitId statement -- | Get a 'TraitRow'. -- @@ -278,40 +320,40 @@ selectTraitRowMaybe traitId = do -- in the database. -- -- Fails with 'TraitNotFound' when the trait does not exist. -selectTraitRow :: Uid Trait -> ExceptT DatabaseError Transaction TraitRow -selectTraitRow traitId = do - mTraitRow <- selectTraitRowMaybe traitId - case mTraitRow of - Nothing -> throwError $ TraitNotFound traitId - Just traitRow -> pure traitRow +-- selectTraitRow :: Uid Trait -> ExceptT DatabaseError Transaction TraitRow +-- selectTraitRow traitId = do +-- mTraitRow <- selectTraitRowMaybe traitId +-- case mTraitRow of +-- Nothing -> throwError $ TraitNotFound traitId +-- Just traitRow -> pure traitRow -- | Get deleted traits belonging to an item. -- -- | To fetch pro and con traits use 'getDeletedTraitRowsByItem' twice. -selectDeletedTraitRowsByItem - :: Uid Item - -> TraitType - -> ExceptT DatabaseError Transaction [TraitRow] -selectDeletedTraitRowsByItem itemId traitType = do - let statement :: Statement (Uid Item, TraitType) [TraitRow] - statement = - [queryRows| - SELECT uid, content, deleted, type_, item_uid - FROM traits - WHERE item_uid = $1 - AND deleted = true - AND type_ = ($2 :: trait_type) - |] - lift $ HT.statement (itemId, traitType) statement +-- selectDeletedTraitRowsByItem +-- :: Uid Item +-- -> TraitType +-- -> ExceptT DatabaseError Transaction [TraitRow] +-- selectDeletedTraitRowsByItem itemId traitType = do +-- let statement :: Statement (Uid Item, TraitType) [TraitRow] +-- statement = +-- [queryRows| +-- SELECT uid, content, deleted, type_, item_uid +-- FROM traits +-- WHERE item_uid = $1 +-- AND deleted = true +-- AND type_ = ($2 :: trait_type) +-- |] +-- lift $ HT.statement (itemId, traitType) statement -- | Get available traits (they ordered) belonging to an item. -selectTraitRowsByItem - :: Uid Item - -> TraitType - -> ExceptT DatabaseError Transaction [TraitRow] -selectTraitRowsByItem itemId traitType = do - itemRow <- selectItemRow itemId - let traitsOrder = case traitType of - TraitTypePro -> itemRowProsOrder itemRow - TraitTypeCon -> itemRowConsOrder itemRow - traverse selectTraitRow traitsOrder +-- selectTraitRowsByItem +-- :: Uid Item +-- -> TraitType +-- -> ExceptT DatabaseError Transaction [TraitRow] +-- selectTraitRowsByItem itemId traitType = do +-- itemRow <- selectItemRow itemId +-- let traitsOrder = case traitType of +-- TraitTypePro -> itemRowProsOrder itemRow +-- TraitTypeCon -> itemRowConsOrder itemRow +-- traverse selectTraitRow traitsOrder diff --git a/back/src/Guide/Database/Queries/Update.hs b/back/src/Guide/Database/Queries/Update.hs index ba3f1dd2..533dc4e9 100644 --- a/back/src/Guide/Database/Queries/Update.hs +++ b/back/src/Guide/Database/Queries/Update.hs @@ -1,12 +1,12 @@ module Guide.Database.Queries.Update ( -- * Category - updateCategoryRow, updateCategory, + -- updateCategoryRow, -- * Item - updateItemRow, + -- updateItemRow, -- * Trait - updateTraitRow, + -- updateTraitRow, ) where @@ -29,6 +29,8 @@ import Guide.Utils (fieldsPrefixed) -- Categories ---------------------------------------------------------------------------- +-- | Fetch category by uid, apply a function and write it back. +-- | Be aware changing 'Uid' or 'UTCTime' fields. updateCategory :: Uid Category -> (Category -> Category) @@ -44,6 +46,21 @@ updateCategory catId update = do WHERE uid = $1|] lift $ HT.statement (catId, new_category) statement +-- | Update category archived field when it is different then passed parameter. +updateCategoryArchive + :: Uid Category + -> "archived" :! Bool + -> ExceptT DatabaseError Transaction () +updateCategoryArchive catId (arg #archived -> archived) = do + isArchived <- isCategoryArchived catId + when (isArchived /= archived) $ do + let statement :: Statement (Uid Category, Bool) () + statement = [execute| + UPDATE categories + SET archived = $2 + WHERE uid = $1|] + lift $ HT.statement (catId, archived) statement + -- | Fetch a row corresponding to a category, apply a function and write it -- back. You can break database invariants with this function, so be -- careful. @@ -52,73 +69,73 @@ updateCategory catId update = do -- -- Fields 'categoryRowUid' and 'categoryRowCreated' can not be modified. An -- attempt to modify them would result in 'CategoryRowUpdateNotAllowed'. -updateCategoryRow - :: Uid Category - -> (CategoryRow -> CategoryRow) - -> ExceptT DatabaseError Transaction () -updateCategoryRow catId f = do - -- Fetch the old row - row <- selectCategoryRow catId +-- updateCategoryRow +-- :: Uid Category +-- -> (CategoryRow -> CategoryRow) +-- -> ExceptT DatabaseError Transaction () +-- updateCategoryRow catId f = do +-- -- Fetch the old row +-- row <- selectCategoryRow catId -- Expose all fields of the old and the new row, and make sure that if we -- forget to use one of them, the compiler will warn us. - let $(fieldsPrefixed "old_" 'CategoryRow) = row - $(fieldsPrefixed "new_" 'CategoryRow) = f row - - -- Updating uid is not allowed - when (old_categoryRowUid /= new_categoryRowUid) $ - throwError CategoryRowUpdateNotAllowed - { deCategoryId = catId - , deFieldName = "categoryRowUid" } - - -- Updating creation time is not allowed - when (old_categoryRowCreated /= new_categoryRowCreated) $ - throwError CategoryRowUpdateNotAllowed - { deCategoryId = catId - , deFieldName = "categoryRowCreated" } - - -- Update title - when (old_categoryRowTitle /= new_categoryRowTitle) $ do - let statement :: Statement (Uid Category, Text) () - statement = [execute|UPDATE categories SET title = $2 WHERE uid = $1|] - lift $ HT.statement (catId, new_categoryRowTitle) statement - - -- Update group - when (old_categoryRowGroup /= new_categoryRowGroup) $ do - let statement :: Statement (Uid Category, Text) () - statement = [execute|UPDATE categories SET group_ = $2 WHERE uid = $1|] - lift $ HT.statement (catId, new_categoryRowGroup) statement - - -- Update status - when (old_categoryRowStatus /= new_categoryRowStatus) $ do - let statement :: Statement (Uid Category, CategoryStatus) () - statement = [execute|UPDATE categories SET status = $2 WHERE uid = $1|] - lift $ HT.statement (catId, new_categoryRowStatus) statement - - -- Update notes - when (old_categoryRowNotes /= new_categoryRowNotes) $ do - let statement :: Statement (Uid Category, Text) () - statement = [execute|UPDATE categories SET notes = $2 WHERE uid = $1|] - lift $ HT.statement (catId, new_categoryRowNotes) statement - - -- Update enabled sections - when (old_categoryRowEnabledSections /= new_categoryRowEnabledSections) $ do - let statement :: Statement (Uid Category, Set ItemSection) () - statement = - [execute|UPDATE categories SET enabled_sections = $2 WHERE uid = $1|] - lift $ HT.statement (catId, new_categoryRowEnabledSections) statement - - -- Update item order - when (old_categoryRowItemsOrder /= new_categoryRowItemsOrder) $ do - let statement :: Statement (Uid Category, [Uid Item]) () - statement = [execute|UPDATE categories SET items_order = $2 WHERE uid = $1|] - lift $ HT.statement (catId, nub new_categoryRowItemsOrder) statement - - -- Update deleted - when (old_categoryRowDeleted /= new_categoryRowDeleted) $ do - let statement :: Statement (Uid Category, Bool) () - statement = [execute|UPDATE categories SET deleted = $2 WHERE uid = $1|] - lift $ HT.statement (catId, new_categoryRowDeleted) statement + -- let $(fieldsPrefixed "old_" 'CategoryRow) = row + -- $(fieldsPrefixed "new_" 'CategoryRow) = f row + + -- -- Updating uid is not allowed + -- when (old_categoryRowUid /= new_categoryRowUid) $ + -- throwError CategoryRowUpdateNotAllowed + -- { deCategoryId = catId + -- , deFieldName = "categoryRowUid" } + + -- -- Updating creation time is not allowed + -- when (old_categoryRowCreated /= new_categoryRowCreated) $ + -- throwError CategoryRowUpdateNotAllowed + -- { deCategoryId = catId + -- , deFieldName = "categoryRowCreated" } + + -- -- Update title + -- when (old_categoryRowTitle /= new_categoryRowTitle) $ do + -- let statement :: Statement (Uid Category, Text) () + -- statement = [execute|UPDATE categories SET title = $2 WHERE uid = $1|] + -- lift $ HT.statement (catId, new_categoryRowTitle) statement + + -- -- Update group + -- when (old_categoryRowGroup /= new_categoryRowGroup) $ do + -- let statement :: Statement (Uid Category, Text) () + -- statement = [execute|UPDATE categories SET group_ = $2 WHERE uid = $1|] + -- lift $ HT.statement (catId, new_categoryRowGroup) statement + + -- -- Update status + -- when (old_categoryRowStatus /= new_categoryRowStatus) $ do + -- let statement :: Statement (Uid Category, CategoryStatus) () + -- statement = [execute|UPDATE categories SET status = $2 WHERE uid = $1|] + -- lift $ HT.statement (catId, new_categoryRowStatus) statement + + -- -- Update notes + -- when (old_categoryRowNotes /= new_categoryRowNotes) $ do + -- let statement :: Statement (Uid Category, Text) () + -- statement = [execute|UPDATE categories SET notes = $2 WHERE uid = $1|] + -- lift $ HT.statement (catId, new_categoryRowNotes) statement + + -- -- Update enabled sections + -- when (old_categoryRowEnabledSections /= new_categoryRowEnabledSections) $ do + -- let statement :: Statement (Uid Category, Set ItemSection) () + -- statement = + -- [execute|UPDATE categories SET enabled_sections = $2 WHERE uid = $1|] + -- lift $ HT.statement (catId, new_categoryRowEnabledSections) statement + + -- -- Update item order + -- when (old_categoryRowItemsOrder /= new_categoryRowItemsOrder) $ do + -- let statement :: Statement (Uid Category, [Uid Item]) () + -- statement = [execute|UPDATE categories SET items_order = $2 WHERE uid = $1|] + -- lift $ HT.statement (catId, nub new_categoryRowItemsOrder) statement + + -- -- Update deleted + -- when (old_categoryRowDeleted /= new_categoryRowDeleted) $ do + -- let statement :: Statement (Uid Category, Bool) () + -- statement = [execute|UPDATE categories SET deleted = $2 WHERE uid = $1|] + -- lift $ HT.statement (catId, new_categoryRowDeleted) statement ---------------------------------------------------------------------------- -- Items @@ -132,95 +149,95 @@ updateCategoryRow catId f = do -- -- Fields 'itemRowUid' and 'itemRowCreated' can not be modified. An attempt -- to modify them would result in 'ItemRowUpdateNotAllowed'. -updateItemRow - :: Uid Item - -> (ItemRow -> ItemRow) - -> ExceptT DatabaseError Transaction () -updateItemRow itemId f = do - -- Fetch the old row - row <- selectItemRow itemId - - -- Expose all fields of the old and the new row, and make sure that if we - -- forget to use one of them, the compiler will warn us. - let $(fieldsPrefixed "old_" 'ItemRow) = row - $(fieldsPrefixed "new_" 'ItemRow) = f row - - -- Updating uid is not allowed - when (old_itemRowUid /= new_itemRowUid) $ - throwError ItemRowUpdateNotAllowed - { deItemId = itemId - , deFieldName = "itemRowUid" } - - -- Updating creation time is not allowed - when (old_itemRowCreated /= new_itemRowCreated) $ - throwError ItemRowUpdateNotAllowed - { deItemId = itemId - , deFieldName = "itemRowCreated" } - - -- Update name - when (old_itemRowName /= new_itemRowName) $ do - let statement :: Statement (Uid Item, Text) () - statement = [execute|UPDATE items SET name = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, new_itemRowName) statement - - -- Update link - when (old_itemRowLink /= new_itemRowLink) $ do - let statement :: Statement (Uid Item, Maybe Text) () - statement = [execute|UPDATE items SET link = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, new_itemRowLink) statement - - -- Update hackage - when (old_itemRowHackage /= new_itemRowHackage) $ do - let statement :: Statement (Uid Item, Maybe Text) () - statement = [execute|UPDATE items SET hackage = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, new_itemRowHackage) statement - - -- Update summary - when (old_itemRowSummary /= new_itemRowSummary) $ do - let statement :: Statement (Uid Item, Text) () - statement = [execute|UPDATE items SET summary = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, new_itemRowSummary) statement - - -- Update ecosystem - when (old_itemRowEcosystem /= new_itemRowEcosystem) $ do - let statement :: Statement (Uid Item, Text) () - statement = [execute|UPDATE items SET ecosystem = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, new_itemRowEcosystem) statement - - -- Update notes - when (old_itemRowNotes /= new_itemRowNotes) $ do - let statement :: Statement (Uid Item, Text) () - statement = [execute|UPDATE items SET notes = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, new_itemRowNotes) statement - - -- Update deleted - when (old_itemRowDeleted /= new_itemRowDeleted) $ do - let statement :: Statement (Uid Item, Bool) () - statement = [execute|UPDATE items SET deleted = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, new_itemRowDeleted) statement - if new_itemRowDeleted - then updateCategoryRow new_itemRowCategoryUid $ - _categoryRowItemsOrder %~ delete itemId - else updateCategoryRow new_itemRowCategoryUid $ - _categoryRowItemsOrder %~ (++ [itemId]) - - -- Update categoryUid - when (old_itemRowCategoryUid /= new_itemRowCategoryUid) $ do - let statement :: Statement (Uid Item, Uid Category) () - statement = [execute|UPDATE items SET category_uid = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, new_itemRowCategoryUid) statement - - -- Update prosOrder - when (old_itemRowProsOrder /= new_itemRowProsOrder) $ do - let statement :: Statement (Uid Item, [Uid Trait]) () - statement = [execute|UPDATE items SET pros_order = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, nub new_itemRowProsOrder) statement - - -- Update consOrder - when (old_itemRowConsOrder /= new_itemRowConsOrder) $ do - let statement :: Statement (Uid Item, [Uid Trait]) () - statement = [execute|UPDATE items SET cons_order = $2 WHERE uid = $1|] - lift $ HT.statement (itemId, nub new_itemRowConsOrder) statement +-- updateItemRow +-- :: Uid Item +-- -> (ItemRow -> ItemRow) +-- -> ExceptT DatabaseError Transaction () +-- updateItemRow itemId f = do +-- -- Fetch the old row +-- row <- selectItemRow itemId + +-- -- Expose all fields of the old and the new row, and make sure that if we +-- -- forget to use one of them, the compiler will warn us. +-- let $(fieldsPrefixed "old_" 'ItemRow) = row +-- $(fieldsPrefixed "new_" 'ItemRow) = f row + +-- -- Updating uid is not allowed +-- when (old_itemRowUid /= new_itemRowUid) $ +-- throwError ItemRowUpdateNotAllowed +-- { deItemId = itemId +-- , deFieldName = "itemRowUid" } + +-- -- Updating creation time is not allowed +-- when (old_itemRowCreated /= new_itemRowCreated) $ +-- throwError ItemRowUpdateNotAllowed +-- { deItemId = itemId +-- , deFieldName = "itemRowCreated" } + +-- -- Update name +-- when (old_itemRowName /= new_itemRowName) $ do +-- let statement :: Statement (Uid Item, Text) () +-- statement = [execute|UPDATE items SET name = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, new_itemRowName) statement + +-- -- Update link +-- when (old_itemRowLink /= new_itemRowLink) $ do +-- let statement :: Statement (Uid Item, Maybe Text) () +-- statement = [execute|UPDATE items SET link = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, new_itemRowLink) statement + +-- -- Update hackage +-- when (old_itemRowHackage /= new_itemRowHackage) $ do +-- let statement :: Statement (Uid Item, Maybe Text) () +-- statement = [execute|UPDATE items SET hackage = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, new_itemRowHackage) statement + +-- -- Update summary +-- when (old_itemRowSummary /= new_itemRowSummary) $ do +-- let statement :: Statement (Uid Item, Text) () +-- statement = [execute|UPDATE items SET summary = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, new_itemRowSummary) statement + +-- -- Update ecosystem +-- when (old_itemRowEcosystem /= new_itemRowEcosystem) $ do +-- let statement :: Statement (Uid Item, Text) () +-- statement = [execute|UPDATE items SET ecosystem = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, new_itemRowEcosystem) statement + +-- -- Update notes +-- when (old_itemRowNotes /= new_itemRowNotes) $ do +-- let statement :: Statement (Uid Item, Text) () +-- statement = [execute|UPDATE items SET notes = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, new_itemRowNotes) statement + +-- -- Update deleted +-- when (old_itemRowDeleted /= new_itemRowDeleted) $ do +-- let statement :: Statement (Uid Item, Bool) () +-- statement = [execute|UPDATE items SET deleted = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, new_itemRowDeleted) statement +-- if new_itemRowDeleted +-- then updateCategoryRow new_itemRowCategoryUid $ +-- _categoryRowItemsOrder %~ delete itemId +-- else updateCategoryRow new_itemRowCategoryUid $ +-- _categoryRowItemsOrder %~ (++ [itemId]) + +-- -- Update categoryUid +-- when (old_itemRowCategoryUid /= new_itemRowCategoryUid) $ do +-- let statement :: Statement (Uid Item, Uid Category) () +-- statement = [execute|UPDATE items SET category_uid = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, new_itemRowCategoryUid) statement + +-- -- Update prosOrder +-- when (old_itemRowProsOrder /= new_itemRowProsOrder) $ do +-- let statement :: Statement (Uid Item, [Uid Trait]) () +-- statement = [execute|UPDATE items SET pros_order = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, nub new_itemRowProsOrder) statement + +-- -- Update consOrder +-- when (old_itemRowConsOrder /= new_itemRowConsOrder) $ do +-- let statement :: Statement (Uid Item, [Uid Trait]) () +-- statement = [execute|UPDATE items SET cons_order = $2 WHERE uid = $1|] +-- lift $ HT.statement (itemId, nub new_itemRowConsOrder) statement ---------------------------------------------------------------------------- -- Traits @@ -234,60 +251,60 @@ updateItemRow itemId f = do -- -- Field 'traitRowUid' can not be modified. An attempt to modify it would -- result in 'TraitRowUpdateNotAllowed'. -updateTraitRow - :: Uid Trait - -> (TraitRow -> TraitRow) - -> ExceptT DatabaseError Transaction () -updateTraitRow traitId f = do - -- Fetch the old row - row <- selectTraitRow traitId - - -- Expose all fields of the old and the new row, and make sure that if we - -- forget to use one of them, the compiler will warn us. - let $(fieldsPrefixed "old_" 'TraitRow) = row - $(fieldsPrefixed "new_" 'TraitRow) = f row - - -- Updating uid is not allowed - when (old_traitRowUid /= new_traitRowUid) $ - throwError TraitRowUpdateNotAllowed - { deTraitId = traitId - , deFieldName = "traitRowUid" } - - -- Update content - when (old_traitRowContent /= new_traitRowContent) $ do - let statement :: Statement (Uid Trait, Text) () - statement = [execute|UPDATE traits SET content = $2 WHERE uid = $1|] - lift $ HT.statement (traitId, new_traitRowContent) statement - - -- Update deleted - when (old_traitRowDeleted /= new_traitRowDeleted) $ do - let statement :: Statement (Uid Trait, Bool) () - statement = [execute|UPDATE traits SET deleted = $2 WHERE uid = $1|] - lift $ HT.statement (traitId, new_traitRowDeleted) statement - if new_traitRowDeleted - then case new_traitRowType of - TraitTypePro -> - updateItemRow new_traitRowItemUid $ - _itemRowProsOrder %~ delete traitId - TraitTypeCon -> - updateItemRow new_traitRowItemUid $ - _itemRowConsOrder %~ delete traitId - else case new_traitRowType of - TraitTypePro -> - updateItemRow new_traitRowItemUid $ - _itemRowProsOrder %~ (++ [traitId]) - TraitTypeCon -> - updateItemRow new_traitRowItemUid $ - _itemRowConsOrder %~ (++ [traitId]) - - -- Update type - when (old_traitRowType /= new_traitRowType) $ do - let statement :: Statement (Uid Trait, TraitType) () - statement = [execute|UPDATE traits SET type_ = ($2 :: trait_type) WHERE uid = $1|] - lift $ HT.statement (traitId, new_traitRowType) statement - - -- Update itemUid - when (old_traitRowItemUid /= new_traitRowItemUid) $ do - let statement :: Statement (Uid Trait, Uid Item) () - statement = [execute|UPDATE traits SET item_uid = $2 WHERE uid = $1|] - lift $ HT.statement (traitId, new_traitRowItemUid) statement +-- updateTraitRow +-- :: Uid Trait +-- -> (TraitRow -> TraitRow) +-- -> ExceptT DatabaseError Transaction () +-- updateTraitRow traitId f = do +-- -- Fetch the old row +-- row <- selectTraitRow traitId + +-- -- Expose all fields of the old and the new row, and make sure that if we +-- -- forget to use one of them, the compiler will warn us. +-- let $(fieldsPrefixed "old_" 'TraitRow) = row +-- $(fieldsPrefixed "new_" 'TraitRow) = f row + +-- -- Updating uid is not allowed +-- when (old_traitRowUid /= new_traitRowUid) $ +-- throwError TraitRowUpdateNotAllowed +-- { deTraitId = traitId +-- , deFieldName = "traitRowUid" } + +-- -- Update content +-- when (old_traitRowContent /= new_traitRowContent) $ do +-- let statement :: Statement (Uid Trait, Text) () +-- statement = [execute|UPDATE traits SET content = $2 WHERE uid = $1|] +-- lift $ HT.statement (traitId, new_traitRowContent) statement + +-- -- Update deleted +-- when (old_traitRowDeleted /= new_traitRowDeleted) $ do +-- let statement :: Statement (Uid Trait, Bool) () +-- statement = [execute|UPDATE traits SET deleted = $2 WHERE uid = $1|] +-- lift $ HT.statement (traitId, new_traitRowDeleted) statement +-- if new_traitRowDeleted +-- then case new_traitRowType of +-- TraitTypePro -> +-- updateItemRow new_traitRowItemUid $ +-- _itemRowProsOrder %~ delete traitId +-- TraitTypeCon -> +-- updateItemRow new_traitRowItemUid $ +-- _itemRowConsOrder %~ delete traitId +-- else case new_traitRowType of +-- TraitTypePro -> +-- updateItemRow new_traitRowItemUid $ +-- _itemRowProsOrder %~ (++ [traitId]) +-- TraitTypeCon -> +-- updateItemRow new_traitRowItemUid $ +-- _itemRowConsOrder %~ (++ [traitId]) + +-- -- Update type +-- when (old_traitRowType /= new_traitRowType) $ do +-- let statement :: Statement (Uid Trait, TraitType) () +-- statement = [execute|UPDATE traits SET type_ = ($2 :: trait_type) WHERE uid = $1|] +-- lift $ HT.statement (traitId, new_traitRowType) statement + +-- -- Update itemUid +-- when (old_traitRowItemUid /= new_traitRowItemUid) $ do +-- let statement :: Statement (Uid Trait, Uid Item) () +-- statement = [execute|UPDATE traits SET item_uid = $2 WHERE uid = $1|] +-- lift $ HT.statement (traitId, new_traitRowItemUid) statement diff --git a/back/src/Guide/Database/Schema.hs b/back/src/Guide/Database/Schema.hs index f39d61b9..6130d94a 100644 --- a/back/src/Guide/Database/Schema.hs +++ b/back/src/Guide/Database/Schema.hs @@ -115,7 +115,9 @@ v0_createTableCategories = HS.statement () $ [execute| CREATE TABLE categories ( uid text PRIMARY KEY, -- Unique category ID - data jsonb NOT NULL -- Single category with all items and raits belong to it + data jsonb NOT NULL, -- Single category with items and traits. + archived boolean -- Whether the category is archived. + NOT NULL ); |] diff --git a/back/src/Guide/Database/Types.hs b/back/src/Guide/Database/Types.hs index 79fd5014..b2077076 100644 --- a/back/src/Guide/Database/Types.hs +++ b/back/src/Guide/Database/Types.hs @@ -3,104 +3,104 @@ module Guide.Database.Types ( -- * Types DatabaseError(..) - , CategoryRow (..) - , ItemRow (..) - , TraitRow (..) + -- , CategoryRow (..) + -- , ItemRow (..) + -- , TraitRow (..) -- ** Lenses - , CategoryRowLenses (..) - , ItemRowLenses (..) - , TraitRowLenses (..) + -- , CategoryRowLenses (..) + -- , ItemRowLenses (..) + -- , TraitRowLenses (..) -- * Type convertions - , categoryRowToCategory - , categoryToRowCategory - , itemRowToItem - , itemToRowItem - , traitRowToTrait - , traitToTraitRow + -- , categoryRowToCategory + -- , categoryToRowCategory + -- , itemRowToItem + -- , itemToRowItem + -- , traitRowToTrait + -- , traitToTraitRow ) where import Imports -import Guide.Markdown (toMarkdownBlock, toMarkdownTree, toMarkdownInline, markdownBlockSource, markdownTreeSource, markdownInlineSource) +-- import Guide.Markdown (toMarkdownBlock, toMarkdownTree, toMarkdownInline, markdownBlockSource, markdownTreeSource, markdownInlineSource) import Guide.Types.Core import Guide.Uid -import Guide.Utils (makeClassWithLenses, fields) -import Guide.Database.Utils +-- import Guide.Utils (makeClassWithLenses, fields) +-- import Guide.Database.Utils -- | Custom datatype errors for database data DatabaseError - = ItemNotFound (Uid Item) - | CategoryNotFound (Uid Category) - | TraitNotFound (Uid Trait) - | CategoryRowUpdateNotAllowed - { deCategoryId :: Uid Category - , deFieldName :: Text } - | ItemRowUpdateNotAllowed - { deItemId :: Uid Item - , deFieldName :: Text } - | TraitRowUpdateNotAllowed - { deTraitId :: Uid Trait - , deFieldName :: Text } + = CategoryNotFound (Uid Category) + -- ItemNotFound (Uid Item) + -- | TraitNotFound (Uid Trait) + -- | CategoryRowUpdateNotAllowed + -- { deCategoryId :: Uid Category + -- , deFieldName :: Text } + -- | ItemRowUpdateNotAllowed + -- { deItemId :: Uid Item + -- , deFieldName :: Text } + -- | TraitRowUpdateNotAllowed + -- { deTraitId :: Uid Trait + -- , deFieldName :: Text } deriving Show -- | Category intermediary type. -data CategoryRow = CategoryRow - { categoryRowUid :: Uid Category - , categoryRowTitle :: Text - , categoryRowCreated :: UTCTime - , categoryRowGroup :: Text - , categoryRowStatus :: CategoryStatus - , categoryRowNotes :: Text - , categoryRowEnabledSections :: Set ItemSection - , categoryRowItemsOrder :: [Uid Item] - , categoryRowDeleted :: Bool - } deriving (Show, Generic) +-- data CategoryRow = CategoryRow +-- { categoryRowUid :: Uid Category +-- , categoryRowTitle :: Text +-- , categoryRowCreated :: UTCTime +-- , categoryRowGroup :: Text +-- , categoryRowStatus :: CategoryStatus +-- , categoryRowNotes :: Text +-- , categoryRowEnabledSections :: Set ItemSection +-- , categoryRowItemsOrder :: [Uid Item] +-- , categoryRowDeleted :: Bool +-- } deriving (Show, Generic) -- | Make CategoryRowLenses Class to use lenses with this type. -makeClassWithLenses ''CategoryRow +-- makeClassWithLenses ''CategoryRow -instance ToPostgresParams CategoryRow -instance FromPostgresRow CategoryRow +-- instance ToPostgresParams CategoryRow +-- instance FromPostgresRow CategoryRow -- | Item intermediary type. -data ItemRow = ItemRow - { itemRowUid :: Uid Item - , itemRowName :: Text - , itemRowCreated :: UTCTime - , itemRowLink :: Maybe Text - , itemRowHackage :: Maybe Text - , itemRowSummary :: Text - , itemRowEcosystem :: Text - , itemRowNotes :: Text - , itemRowDeleted :: Bool - , itemRowCategoryUid :: Uid Category - , itemRowProsOrder :: [Uid Trait] - , itemRowConsOrder :: [Uid Trait] - } deriving (Show, Generic) +-- data ItemRow = ItemRow +-- { itemRowUid :: Uid Item +-- , itemRowName :: Text +-- , itemRowCreated :: UTCTime +-- , itemRowLink :: Maybe Text +-- , itemRowHackage :: Maybe Text +-- , itemRowSummary :: Text +-- , itemRowEcosystem :: Text +-- , itemRowNotes :: Text +-- , itemRowDeleted :: Bool +-- , itemRowCategoryUid :: Uid Category +-- , itemRowProsOrder :: [Uid Trait] +-- , itemRowConsOrder :: [Uid Trait] +-- } deriving (Show, Generic) -- | Make ItemRowLenses Class to use lenses with this type. -makeClassWithLenses ''ItemRow +-- makeClassWithLenses ''ItemRow -instance ToPostgresParams ItemRow -instance FromPostgresRow ItemRow +-- instance ToPostgresParams ItemRow +-- instance FromPostgresRow ItemRow -- | Trait intermediary type. -data TraitRow = TraitRow - { traitRowUid :: Uid Trait - , traitRowContent :: Text - , traitRowDeleted :: Bool - , traitRowType :: TraitType - , traitRowItemUid :: Uid Item - } deriving (Show, Generic) +-- data TraitRow = TraitRow +-- { traitRowUid :: Uid Trait +-- , traitRowContent :: Text +-- , traitRowDeleted :: Bool +-- , traitRowType :: TraitType +-- , traitRowItemUid :: Uid Item +-- } deriving (Show, Generic) -- | Make TraitRowLenses Class to use lenses with this type. -makeClassWithLenses ''TraitRow +-- makeClassWithLenses ''TraitRow -instance ToPostgresParams TraitRow -instance FromPostgresRow TraitRow +-- instance ToPostgresParams TraitRow +-- instance FromPostgresRow TraitRow ---------------------------------------------------------------------------- -- Convertions between types @@ -111,139 +111,139 @@ instance FromPostgresRow TraitRow -- To fetch items, use @selectItemRowsByCategory@ from -- "Guide.Database.Queries.Select". To fetch deleted items, use -- @selectDeletedItemRowsByCategory@. -categoryRowToCategory - :: "items" :! [Item] - -> "itemsDeleted" :! [Item] - -> CategoryRow - -> Category -categoryRowToCategory - (arg #items -> items) - (arg #itemsDeleted -> itemsDeleted) - $(fields 'CategoryRow) - = - Category - { categoryUid = categoryRowUid - , categoryTitle = categoryRowTitle - , categoryCreated = categoryRowCreated - , categoryGroup = categoryRowGroup - , categoryStatus = categoryRowStatus - , categoryNotes = toMarkdownBlock categoryRowNotes - , categoryItems = items - , categoryItemsDeleted = itemsDeleted - , categoryEnabledSections = categoryRowEnabledSections - } - where - -- Ignored fields - _ = categoryRowDeleted - _ = categoryRowItemsOrder +-- categoryRowToCategory +-- :: "items" :! [Item] +-- -> "itemsDeleted" :! [Item] +-- -> CategoryRow +-- -> Category +-- categoryRowToCategory +-- (arg #items -> items) +-- (arg #itemsDeleted -> itemsDeleted) +-- $(fields 'CategoryRow) +-- = +-- Category +-- { categoryUid = categoryRowUid +-- , categoryTitle = categoryRowTitle +-- , categoryCreated = categoryRowCreated +-- , categoryGroup = categoryRowGroup +-- , categoryStatus = categoryRowStatus +-- , categoryNotes = toMarkdownBlock categoryRowNotes +-- , categoryItems = items +-- , categoryItemsDeleted = itemsDeleted +-- , categoryEnabledSections = categoryRowEnabledSections +-- } +-- where +-- -- Ignored fields +-- _ = categoryRowDeleted +-- _ = categoryRowItemsOrder -- | Convert Category to CategoryRow. -categoryToRowCategory - :: Category - -> "deleted" :! Bool - -> CategoryRow -categoryToRowCategory $(fields 'Category) (arg #deleted -> deleted) = - CategoryRow - { categoryRowUid = categoryUid - , categoryRowTitle = categoryTitle - , categoryRowCreated = categoryCreated - , categoryRowGroup = categoryGroup - , categoryRowStatus = categoryStatus - , categoryRowNotes = markdownBlockSource categoryNotes - , categoryRowEnabledSections = categoryEnabledSections - , categoryRowItemsOrder = map itemUid categoryItems - , categoryRowDeleted = deleted - } - where - -- Ignored fields - _ = categoryItemsDeleted +-- categoryToRowCategory +-- :: Category +-- -> "deleted" :! Bool +-- -> CategoryRow +-- categoryToRowCategory $(fields 'Category) (arg #deleted -> deleted) = +-- CategoryRow +-- { categoryRowUid = categoryUid +-- , categoryRowTitle = categoryTitle +-- , categoryRowCreated = categoryCreated +-- , categoryRowGroup = categoryGroup +-- , categoryRowStatus = categoryStatus +-- , categoryRowNotes = markdownBlockSource categoryNotes +-- , categoryRowEnabledSections = categoryEnabledSections +-- , categoryRowItemsOrder = map itemUid categoryItems +-- , categoryRowDeleted = deleted +-- } +-- where +-- -- Ignored fields +-- _ = categoryItemsDeleted -- | Convert ItemRow to Item. -- -- To fetch traits, use @getTraitRowsByItem@ from -- "Guide.Database.Queries.Select". To fetch deleted traits, use -- @getDeletedTraitRowsByItem@. -itemRowToItem - :: "proTraits" :! [Trait] - -> "proDeletedTraits" :! [Trait] - -> "conTraits" :! [Trait] - -> "conDeletedTraits" :! [Trait] - -> ItemRow - -> Item -itemRowToItem - (arg #proTraits -> proTraits) - (arg #proDeletedTraits -> proDeletedTraits) - (arg #conTraits -> conTraits) - (arg #conDeletedTraits -> conDeletedTraits) - $(fields 'ItemRow) - = - Item - { itemUid = itemRowUid - , itemName = itemRowName - , itemCreated = itemRowCreated - , itemHackage = itemRowHackage - , itemSummary = toMarkdownBlock itemRowSummary - , itemPros = proTraits - , itemProsDeleted = proDeletedTraits - , itemCons = conTraits - , itemConsDeleted = conDeletedTraits - , itemEcosystem = toMarkdownBlock itemRowEcosystem - , itemNotes = toMarkdownTree prefix itemRowNotes - , itemLink = itemRowLink - } - where - prefix = "item-notes-" <> uidToText itemRowUid <> "-" - -- Ignored fields - _ = (itemRowConsOrder, itemRowProsOrder) - _ = itemRowCategoryUid - _ = itemRowDeleted +-- itemRowToItem +-- :: "proTraits" :! [Trait] +-- -> "proDeletedTraits" :! [Trait] +-- -> "conTraits" :! [Trait] +-- -> "conDeletedTraits" :! [Trait] +-- -> ItemRow +-- -> Item +-- itemRowToItem +-- (arg #proTraits -> proTraits) +-- (arg #proDeletedTraits -> proDeletedTraits) +-- (arg #conTraits -> conTraits) +-- (arg #conDeletedTraits -> conDeletedTraits) +-- $(fields 'ItemRow) +-- = +-- Item +-- { itemUid = itemRowUid +-- , itemName = itemRowName +-- , itemCreated = itemRowCreated +-- , itemHackage = itemRowHackage +-- , itemSummary = toMarkdownBlock itemRowSummary +-- , itemPros = proTraits +-- , itemProsDeleted = proDeletedTraits +-- , itemCons = conTraits +-- , itemConsDeleted = conDeletedTraits +-- , itemEcosystem = toMarkdownBlock itemRowEcosystem +-- , itemNotes = toMarkdownTree prefix itemRowNotes +-- , itemLink = itemRowLink +-- } +-- where +-- prefix = "item-notes-" <> uidToText itemRowUid <> "-" +-- -- Ignored fields +-- _ = (itemRowConsOrder, itemRowProsOrder) +-- _ = itemRowCategoryUid +-- _ = itemRowDeleted -- | Convert Item to ItemRow. -itemToRowItem :: Uid Category -> "deleted" :! Bool -> Item -> ItemRow -itemToRowItem catId (arg #deleted -> deleted) $(fields 'Item) = - ItemRow - { itemRowUid = itemUid - , itemRowName = itemName - , itemRowCreated = itemCreated - , itemRowLink = itemLink - , itemRowHackage = itemHackage - , itemRowSummary = markdownBlockSource itemSummary - , itemRowEcosystem = markdownBlockSource itemEcosystem - , itemRowNotes = markdownTreeSource itemNotes - , itemRowDeleted = deleted - , itemRowCategoryUid = catId - , itemRowProsOrder = map traitUid itemPros - , itemRowConsOrder = map traitUid itemCons - } - where - -- Ignored fields - _ = (itemConsDeleted, itemProsDeleted) - --- | Convert TraitRow to Trait. -traitRowToTrait :: TraitRow -> Trait -traitRowToTrait $(fields 'TraitRow) = - Trait - { traitUid = traitRowUid - , traitContent = toMarkdownInline traitRowContent - } - where - -- Ignored fields - _ = traitRowItemUid - _ = traitRowType - _ = traitRowDeleted - --- | Convert Trait to TraitRow. -traitToTraitRow - :: Uid Item - -> "deleted" :! Bool - -> TraitType - -> Trait - -> TraitRow -traitToTraitRow itemId (arg #deleted -> deleted) traitType $(fields 'Trait) = - TraitRow - { traitRowUid = traitUid - , traitRowContent = markdownInlineSource traitContent - , traitRowDeleted = deleted - , traitRowType = traitType - , traitRowItemUid = itemId - } +-- itemToRowItem :: Uid Category -> "deleted" :! Bool -> Item -> ItemRow +-- itemToRowItem catId (arg #deleted -> deleted) $(fields 'Item) = +-- ItemRow +-- { itemRowUid = itemUid +-- , itemRowName = itemName +-- , itemRowCreated = itemCreated +-- , itemRowLink = itemLink +-- , itemRowHackage = itemHackage +-- , itemRowSummary = markdownBlockSource itemSummary +-- , itemRowEcosystem = markdownBlockSource itemEcosystem +-- , itemRowNotes = markdownTreeSource itemNotes +-- , itemRowDeleted = deleted +-- , itemRowCategoryUid = catId +-- , itemRowProsOrder = map traitUid itemPros +-- , itemRowConsOrder = map traitUid itemCons +-- } +-- where +-- -- Ignored fields +-- _ = (itemConsDeleted, itemProsDeleted) + +-- -- | Convert TraitRow to Trait. +-- traitRowToTrait :: TraitRow -> Trait +-- traitRowToTrait $(fields 'TraitRow) = +-- Trait +-- { traitUid = traitRowUid +-- , traitContent = toMarkdownInline traitRowContent +-- } +-- where +-- -- Ignored fields +-- _ = traitRowItemUid +-- _ = traitRowType +-- _ = traitRowDeleted + +-- -- | Convert Trait to TraitRow. +-- traitToTraitRow +-- :: Uid Item +-- -> "deleted" :! Bool +-- -> TraitType +-- -> Trait +-- -> TraitRow +-- traitToTraitRow itemId (arg #deleted -> deleted) traitType $(fields 'Trait) = +-- TraitRow +-- { traitRowUid = traitUid +-- , traitRowContent = markdownInlineSource traitContent +-- , traitRowDeleted = deleted +-- , traitRowType = traitType +-- , traitRowItemUid = itemId +-- } diff --git a/back/src/Guide/Uid.hs b/back/src/Guide/Uid.hs index 0a7a5806..e7704e76 100644 --- a/back/src/Guide/Uid.hs +++ b/back/src/Guide/Uid.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveAnyClass #-} -- | A type for unique identifiers. module Guide.Uid From c01f511014980252ad0a2396444ef24f92ca829d Mon Sep 17 00:00:00 2001 From: willbasky Date: Mon, 2 Sep 2019 00:30:34 +0500 Subject: [PATCH 04/13] Fix markdown instances. Remove unused instances --- back/src/Guide/Database/Import.hs | 7 ++ back/src/Guide/Database/Queries/Delete.hs | 2 - back/src/Guide/Database/Queries/Insert.hs | 1 - back/src/Guide/Database/Queries/Select.hs | 2 +- back/src/Guide/Database/Queries/Update.hs | 6 +- back/src/Guide/Markdown.hs | 33 ++------- back/src/Guide/Types/Core.hs | 85 +++++++++++------------ 7 files changed, 57 insertions(+), 79 deletions(-) diff --git a/back/src/Guide/Database/Import.hs b/back/src/Guide/Database/Import.hs index 7e97107e..9e237646 100644 --- a/back/src/Guide/Database/Import.hs +++ b/back/src/Guide/Database/Import.hs @@ -37,6 +37,13 @@ loadIntoPostgres config@Config{..} = withLogger config $ \logger -> do postgresLoader :: Logger -> GlobalState -> IO () postgresLoader logger globalState = do -- Postgres should be started and 'guide' base created. + -- Don't forget to drop and create schema + {- + DROP SCHEMA public CASCADE; + CREATE SCHEMA public; + GRANT ALL ON SCHEMA public TO postgres; + GRANT ALL ON SCHEMA public TO public; + -} setupDatabase -- Upload to Postgres conn <- connect diff --git a/back/src/Guide/Database/Queries/Delete.hs b/back/src/Guide/Database/Queries/Delete.hs index 1930add7..dc3c6741 100644 --- a/back/src/Guide/Database/Queries/Delete.hs +++ b/back/src/Guide/Database/Queries/Delete.hs @@ -15,8 +15,6 @@ import Data.Profunctor (lmap) import qualified Hasql.Transaction as HT -import Guide.Database.Queries.Select -import Guide.Database.Queries.Update import Guide.Database.Types import Guide.Database.Utils import Guide.Types.Core diff --git a/back/src/Guide/Database/Queries/Insert.hs b/back/src/Guide/Database/Queries/Insert.hs index c4c12b22..b481cfec 100644 --- a/back/src/Guide/Database/Queries/Insert.hs +++ b/back/src/Guide/Database/Queries/Insert.hs @@ -21,7 +21,6 @@ import Hasql.Transaction (Transaction) import qualified Hasql.Transaction as HT -import Guide.Database.Queries.Update import Guide.Database.Types import Guide.Database.Utils (execute) import Guide.Markdown (toMarkdownBlock) diff --git a/back/src/Guide/Database/Queries/Select.hs b/back/src/Guide/Database/Queries/Select.hs index 0d03515d..8a1aad03 100644 --- a/back/src/Guide/Database/Queries/Select.hs +++ b/back/src/Guide/Database/Queries/Select.hs @@ -37,7 +37,7 @@ import Imports import Hasql.Statement (Statement (..)) import Hasql.Transaction (Transaction) -import Data.Profunctor (rmap, dimap) +import Data.Profunctor (dimap) import qualified Hasql.Transaction as HT diff --git a/back/src/Guide/Database/Queries/Update.hs b/back/src/Guide/Database/Queries/Update.hs index 533dc4e9..c7a0aac1 100644 --- a/back/src/Guide/Database/Queries/Update.hs +++ b/back/src/Guide/Database/Queries/Update.hs @@ -2,6 +2,7 @@ module Guide.Database.Queries.Update ( -- * Category updateCategory, + updateCategoryArchived, -- updateCategoryRow, -- * Item -- updateItemRow, @@ -22,7 +23,6 @@ import Guide.Database.Types import Guide.Database.Utils import Guide.Types.Core import Guide.Uid -import Guide.Utils (fieldsPrefixed) ---------------------------------------------------------------------------- @@ -47,11 +47,11 @@ updateCategory catId update = do lift $ HT.statement (catId, new_category) statement -- | Update category archived field when it is different then passed parameter. -updateCategoryArchive +updateCategoryArchived :: Uid Category -> "archived" :! Bool -> ExceptT DatabaseError Transaction () -updateCategoryArchive catId (arg #archived -> archived) = do +updateCategoryArchived catId (arg #archived -> archived) = do isArchived <- isCategoryArchived catId when (isArchived /= archived) $ do let statement :: Statement (Uid Category, Bool) () diff --git a/back/src/Guide/Markdown.hs b/back/src/Guide/Markdown.hs index 36cbdf11..efb5f4cc 100644 --- a/back/src/Guide/Markdown.hs +++ b/back/src/Guide/Markdown.hs @@ -47,9 +47,6 @@ import ShortcutLinks.All (hackage) -- acid-state import Data.SafeCopy -import Data.Functor.Contravariant ((>$<)) - -import Guide.Database.Utils (FromPostgres (..), ToPostgres (..)) import Guide.Utils import qualified CMark as MD @@ -57,8 +54,6 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.Set as S import qualified Data.Text as T -import qualified Hasql.Decoders as HD -import qualified Hasql.Encoders as HE data MarkdownInline = MarkdownInline { @@ -90,10 +85,6 @@ deriving instance NFData (WithSource [MD.Node]) deriving instance (NFData b, NFData t) => NFData (Document t b) deriving instance (NFData b, NFData t) => NFData (Section t b) deriving instance NFData Heading --- instance NFData (Node a f) where --- rnf tree = foldl1 (seq . rnf) tree `seq` rnf (measure tree) - -- rnf = (`seq` ()) - -- rnf (Node info nodeType nodes) = Node (rnf info) (rnf nodeType) (map rnf nodes) -- | Table-of-contents heading data Heading = Heading @@ -339,7 +330,8 @@ instance Aeson.ToJSON MarkdownBlock where "html" Aeson..= utf8ToText (markdownBlockHtml md) ] instance Aeson.ToJSON MarkdownTree where toJSON md = Aeson.object [ - "text" Aeson..= markdownTreeSource md ] + "text" Aeson..= markdownTreeSource md, + "prefix" Aeson..= markdownTreeIdPrefix md ] instance Aeson.FromJSON MarkdownInline where parseJSON = Aeson.withObject "MarkdownInline" $ \o -> do @@ -352,7 +344,8 @@ instance Aeson.FromJSON MarkdownBlock where instance Aeson.FromJSON MarkdownTree where parseJSON = Aeson.withObject "MarkdownTree" $ \o -> do txt <- o Aeson..: "text" - pure $ toMarkdownTree "" txt + prefix <- o Aeson..:? "prefix" Aeson..!= T.empty + pure $ toMarkdownTree prefix txt instance ToHtml MarkdownInline where toHtmlRaw = toHtml @@ -396,21 +389,3 @@ instance SafeCopy MarkdownTree where safePut (markdownTreeSource md) getCopy = contain $ toMarkdownTree <$> safeGet <*> safeGet - -instance ToPostgres MarkdownInline where - toPostgres = markdownInlineSource >$< HE.text - -instance ToPostgres MarkdownBlock where - toPostgres = markdownBlockSource >$< HE.text - -instance ToPostgres MarkdownTree where - toPostgres = markdownTreeSource >$< HE.text - -instance FromPostgres MarkdownInline where - fromPostgres = toMarkdownInline <$> HD.text - -instance FromPostgres MarkdownBlock where - fromPostgres = toMarkdownBlock <$> HD.text - -instance FromPostgres MarkdownTree where - fromPostgres = toMarkdownTree "" <$> HD.text diff --git a/back/src/Guide/Types/Core.hs b/back/src/Guide/Types/Core.hs index 1d4c7249..032a3288 100644 --- a/back/src/Guide/Types/Core.hs +++ b/back/src/Guide/Types/Core.hs @@ -33,14 +33,13 @@ import Data.Functor.Contravariant ((>$<)) import Data.SafeCopy hiding (kind) import Data.SafeCopy.Migrate -import Guide.Database.Utils (ToPostgres (..), FromPostgres (..), ToPostgresParams (..), FromPostgresRow (..)) +import Guide.Database.Utils import Guide.Markdown import Guide.Types.Hue import Guide.Uid import Guide.Utils import qualified Data.Aeson as Aeson -import qualified Data.Text as T import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE @@ -73,23 +72,17 @@ changelog ''Trait (Current 4, Past 3) [] deriveSafeCopySorted 3 'base ''Trait_v3 instance Aeson.ToJSON Trait where - toJSON = Aeson.genericToJSON Aeson.defaultOptions { - Aeson.fieldLabelModifier = over _head toLower . drop (T.length "trait") } + toJSON $(fields 'Trait) = Aeson.object [ + "uid" Aeson..= traitUid, + "content" Aeson..= traitContent + ] instance Aeson.FromJSON Trait where parseJSON = Aeson.withObject "Trait" $ \o -> do traitUid <- o Aeson..: "uid" - content <- o Aeson..: "content" - traitContent <- toMarkdownInline <$> content Aeson..: "text" + traitContent <- o Aeson..: "content" pure Trait{..} -instance ToPostgres Trait where - toPostgres = toByteString . Aeson.encode >$< HE.jsonbBytes - -instance FromPostgres Trait where - fromPostgres = HD.jsonbBytes $ - either (Left . toText) (Right . id) . Aeson.eitherDecodeStrict - -- | ADT for trait type. Traits can be pros (positive traits) and cons -- (negative traits). data TraitType = TraitTypePro | TraitTypeCon @@ -229,36 +222,37 @@ changelog ''Item (Past 11, Past 10) [] deriveSafeCopySorted 10 'base ''Item_v10 instance Aeson.ToJSON Item where - toJSON = Aeson.genericToJSON Aeson.defaultOptions { - Aeson.fieldLabelModifier = over _head toLower . drop (T.length "item") } + toJSON $(fields 'Item) = Aeson.object [ + "uid" Aeson..= itemUid, + "name" Aeson..= itemName, + "created" Aeson..= itemCreated, + "hackage" Aeson..= itemHackage, + "summary" Aeson..= itemSummary, + "pros" Aeson..= itemPros, + "prosDeleted" Aeson..= itemProsDeleted, + "cons" Aeson..= itemCons, + "consDeleted" Aeson..= itemConsDeleted, + "ecosystem" Aeson..= itemEcosystem, + "notes" Aeson..= itemNotes, + "link" Aeson..= itemLink + ] instance Aeson.FromJSON Item where parseJSON = Aeson.withObject "Item" $ \o -> do - itemUid <- o Aeson..: "uid" - itemName <- o Aeson..: "name" - itemCreated <- o Aeson..: "created" + itemUid <- o Aeson..: "uid" + itemName <- o Aeson..: "name" + itemCreated <- o Aeson..: "created" itemHackage <- o Aeson..:? "hackage" - summary <- o Aeson..: "summary" - itemSummary <- toMarkdownBlock <$> summary Aeson..: "text" - itemPros <- o Aeson..: "pros" - itemProsDeleted <- o Aeson..: "prosDeleted" - itemCons <- o Aeson..: "cons" - itemConsDeleted <- o Aeson..: "consDeleted" - ecosystem <- o Aeson..: "ecosystem" - itemEcosystem <- toMarkdownBlock <$> ecosystem Aeson..: "text" - notes <- o Aeson..: "notes" - let prefix = "item-notes-" <> uidToText itemUid <> "-" - itemNotes <- toMarkdownTree prefix <$> notes Aeson..: "text" + itemSummary <- o Aeson..: "summary" + itemPros <- o Aeson..: "pros" + itemProsDeleted <- o Aeson..: "prosDeleted" + itemCons <- o Aeson..: "cons" + itemConsDeleted <- o Aeson..: "consDeleted" + itemEcosystem <- o Aeson..: "ecosystem" + itemNotes <- o Aeson..: "notes" itemLink <- o Aeson..:? "link" pure Item{..} -instance ToPostgres Item where - toPostgres = toByteString . Aeson.encode >$< HE.jsonbBytes - -instance FromPostgres Item where - fromPostgres = HD.jsonbBytes $ - either (Left . toText) (Right . id) . Aeson.eitherDecodeStrict - ---------------------------------------------------------------------------- -- Category ---------------------------------------------------------------------------- @@ -359,8 +353,17 @@ changelog ''Category (Past 9, Past 8) [] deriveSafeCopySorted 8 'base ''Category_v8 instance Aeson.ToJSON Category where - toJSON = Aeson.genericToJSON Aeson.defaultOptions { - Aeson.fieldLabelModifier = over _head toLower . drop (T.length "category") } + toJSON $(fields 'Category) = Aeson.object [ + "uid" Aeson..= categoryUid, + "title" Aeson..= categoryTitle, + "created" Aeson..= categoryCreated, + "group" Aeson..= categoryGroup, + "status" Aeson..= categoryStatus, + "notes" Aeson..= categoryNotes, + "items" Aeson..= categoryItems, + "itemsDeleted" Aeson..= categoryItemsDeleted, + "enabledSections" Aeson..= categoryEnabledSections + ] instance Aeson.FromJSON Category where parseJSON = Aeson.withObject "Category" $ \o -> do @@ -369,8 +372,7 @@ instance Aeson.FromJSON Category where categoryCreated <- o Aeson..: "created" categoryGroup <- o Aeson..: "group" categoryStatus <- o Aeson..: "status" - notes <- o Aeson..: "notes" - categoryNotes <- toMarkdownBlock <$> notes Aeson..: "text" + categoryNotes <- o Aeson..: "notes" categoryItems <- o Aeson..: "items" categoryItemsDeleted <- o Aeson..: "itemsDeleted" categoryEnabledSections <- o Aeson..: "enabledSections" @@ -383,9 +385,6 @@ instance FromPostgres Category where fromPostgres = HD.jsonbBytes $ either (Left . toText) (Right . id) . Aeson.eitherDecodeStrict -instance ToPostgresParams Category -instance FromPostgresRow Category - -- | Category identifier (used in URLs). E.g. for a category with title -- “Performance optimization” and UID “t3c9hwzo” the slug would be -- @performance-optimization-t3c9hwzo@. From 397a2b99446c5ef89a506ce63e22c053e562d674 Mon Sep 17 00:00:00 2001 From: willbasky Date: Mon, 2 Sep 2019 10:33:15 +0500 Subject: [PATCH 05/13] jsonbbytes to jsonb --- back/src/Guide/Types/Core.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/back/src/Guide/Types/Core.hs b/back/src/Guide/Types/Core.hs index 032a3288..9112d04e 100644 --- a/back/src/Guide/Types/Core.hs +++ b/back/src/Guide/Types/Core.hs @@ -379,11 +379,15 @@ instance Aeson.FromJSON Category where pure Category{..} instance ToPostgres Category where - toPostgres = toByteString . Aeson.encode >$< HE.jsonbBytes + toPostgres = Aeson.toJSON >$< HE.jsonb instance FromPostgres Category where - fromPostgres = HD.jsonbBytes $ - either (Left . toText) (Right . id) . Aeson.eitherDecodeStrict + fromPostgres = resultToEither . Aeson.fromJSON <$> HD.jsonb + +-- | Unwrap result to category or fail. +resultToEither :: Aeson.Result Category -> Category +resultToEither (Aeson.Success category) = category +resultToEither (Aeson.Error s) = error $ "fromJSON failed with error: " ++ s -- | Category identifier (used in URLs). E.g. for a category with title -- “Performance optimization” and UID “t3c9hwzo” the slug would be From a9fc3784f47ee86a7c071bab9eb15e6675c97d7a Mon Sep 17 00:00:00 2001 From: willbasky Date: Mon, 2 Sep 2019 15:04:35 +0500 Subject: [PATCH 06/13] Add comment --- back/src/Guide/Types/Core.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/back/src/Guide/Types/Core.hs b/back/src/Guide/Types/Core.hs index 9112d04e..5b7a0bdb 100644 --- a/back/src/Guide/Types/Core.hs +++ b/back/src/Guide/Types/Core.hs @@ -378,13 +378,16 @@ instance Aeson.FromJSON Category where categoryEnabledSections <- o Aeson..: "enabledSections" pure Category{..} +-- | jsonb encode data through JSON AST. +-- +-- | If you want more speed then use jsonbBytes, it encodes through raw JSON. instance ToPostgres Category where toPostgres = Aeson.toJSON >$< HE.jsonb instance FromPostgres Category where fromPostgres = resultToEither . Aeson.fromJSON <$> HD.jsonb --- | Unwrap result to category or fail. +-- | Unwarp result to category or fail. resultToEither :: Aeson.Result Category -> Category resultToEither (Aeson.Success category) = category resultToEither (Aeson.Error s) = error $ "fromJSON failed with error: " ++ s From 25a674a15859ae8b37d291efce6e435cb114f632 Mon Sep 17 00:00:00 2001 From: willbasky Date: Tue, 3 Sep 2019 01:27:19 +0500 Subject: [PATCH 07/13] Refactor on review --- README.md | 13 +++++++ back/benchmarks/Main.hs | 42 +++++++++++++++++++++-- back/package.yaml | 2 ++ back/src/Guide/Database/Import.hs | 6 ++-- back/src/Guide/Database/Queries/Update.hs | 10 +++--- back/src/Guide/Markdown.hs | 2 +- back/src/Guide/Types/Core.hs | 15 +++----- 7 files changed, 69 insertions(+), 21 deletions(-) diff --git a/README.md b/README.md index 37c0d1bb..8d13dbb6 100644 --- a/README.md +++ b/README.md @@ -5,3 +5,16 @@ The production version is running at [guide.aelve.com](https://guide.aelve.com). The new frontend is being developed at [staging.guide.aelve.com](https://staging.guide.aelve.com). Installation instructions and the explanation of config variables (in `config.json`) are here: [INSTALL.md](INSTALL.md). + +## Benchmarking + +Deploy postgres server and create `guide` database. + +Add next parameter to benchmarks and library section of `package.yaml`: + + ghc-options: + - -O + +Run benchmarks with command: + + stack bench diff --git a/back/benchmarks/Main.hs b/back/benchmarks/Main.hs index e4c92874..5ba20590 100644 --- a/back/benchmarks/Main.hs +++ b/back/benchmarks/Main.hs @@ -9,17 +9,26 @@ import Imports import Gauge import Hasql.Transaction.Sessions (Mode (..)) import Hasql.Connection (Connection) +import qualified Data.Set as Set import Guide.Database.Queries.Update import Guide.Database.Queries.Select +import Guide.Database.Queries.Insert +import Guide.Database.Queries.Delete import Guide.Types.Core import Guide.Database.Connection +import Guide.Markdown (toMarkdownBlock, toMarkdownTree) +-- | See readme for instruction. main :: IO () main = do conn <- connect + time <- getCurrentTime + runTransactionExceptT conn Write $ + insertCategoryWithCategory (#archived False) $ category time defaultMain [databaseBenchmark conn] + runTransactionExceptT conn Write $ deleteCategory "categoryUid1" databaseBenchmark :: Connection -> Benchmark databaseBenchmark conn = @@ -27,11 +36,40 @@ databaseBenchmark conn = update = _categoryTitle <>~ " +" in bgroup "Database" [ bench "select" $ nfIO $ - runTransactionExceptT conn Read $ selectCategory "category1111" + runTransactionExceptT conn Read $ selectCategory "categoryUid1" , bench "update" $ nfIO $ - runTransactionExceptT conn Write $ updateCategory "category1111" update + runTransactionExceptT conn Write $ updateCategory "categoryUid1" update ] +category :: UTCTime -> Category +category time = Category + { categoryUid = "categoryUid1" + , categoryTitle = "catTitle1" + , categoryCreated = time + , categoryGroup = "group1" + , categoryStatus = CategoryStub + , categoryNotes = toMarkdownBlock "notes" + , categoryItems = [item time] + , categoryItemsDeleted = [] + , categoryEnabledSections = Set.fromList [] + } + +item :: UTCTime -> Item +item time = Item + { itemUid = "itemUid1234" + , itemName = "title" + , itemCreated = time + , itemHackage = Just "hello" + , itemSummary = toMarkdownBlock "summary" + , itemPros = [] + , itemProsDeleted = [] + , itemCons = [] + , itemConsDeleted = [] + , itemEcosystem = toMarkdownBlock "eco" + , itemNotes = toMarkdownTree "" "notes" + , itemLink = Just "google.ru" + } + {- benchmarked Database/select time 843.9 μs (812.4 μs .. 879.6 μs) diff --git a/back/package.yaml b/back/package.yaml index 7b641cb4..7f0960e2 100644 --- a/back/package.yaml +++ b/back/package.yaml @@ -204,10 +204,12 @@ benchmarks: source-dirs: benchmarks dependencies: - base <5 + - containers - guide - gauge - hasql - hasql-transaction + - time ghc-options: - -O diff --git a/back/src/Guide/Database/Import.hs b/back/src/Guide/Database/Import.hs index 9e237646..585b9c4e 100644 --- a/back/src/Guide/Database/Import.hs +++ b/back/src/Guide/Database/Import.hs @@ -24,7 +24,7 @@ import Guide.Config import Guide.Logger --- | Load categories and archives categories from acid state to postgres +-- | Load categories and archived categories from acid state to postgres -- and check if they are equal. -- -- NOTE: It loads categories and categoriesDeleted fields of GlobalState only. @@ -51,7 +51,7 @@ postgresLoader logger globalState = do -- Download from Postgres catPostgres <- runTransactionExceptT conn Read $ selectCategories (#archived False) - catarchivedPostgres <- runTransactionExceptT conn Read $ + catArchivedPostgres <- runTransactionExceptT conn Read $ selectCategories (#archived True) -- Check identity of available categories let checkedCat = @@ -59,7 +59,7 @@ postgresLoader logger globalState = do sortOn categoryUid (categories globalState) -- Check identity of archived categories let checkedCatDeleted = - sortOn categoryUid catarchivedPostgres == + sortOn categoryUid catArchivedPostgres == sortOn categoryUid (categoriesDeleted globalState) let checked = checkedCat && checkedCatDeleted diff --git a/back/src/Guide/Database/Queries/Update.hs b/back/src/Guide/Database/Queries/Update.hs index c7a0aac1..4e356d26 100644 --- a/back/src/Guide/Database/Queries/Update.hs +++ b/back/src/Guide/Database/Queries/Update.hs @@ -46,20 +46,20 @@ updateCategory catId update = do WHERE uid = $1|] lift $ HT.statement (catId, new_category) statement --- | Update category archived field when it is different then passed parameter. +-- | Update category archived field when it is different updateCategoryArchived :: Uid Category -> "archived" :! Bool -> ExceptT DatabaseError Transaction () -updateCategoryArchived catId (arg #archived -> archived) = do - isArchived <- isCategoryArchived catId - when (isArchived /= archived) $ do +updateCategoryArchived catId (arg #archived -> new_archived) = do + old_archived <- isCategoryArchived catId + when (old_archived /= new_archived) $ do let statement :: Statement (Uid Category, Bool) () statement = [execute| UPDATE categories SET archived = $2 WHERE uid = $1|] - lift $ HT.statement (catId, archived) statement + lift $ HT.statement (catId, new_archived) statement -- | Fetch a row corresponding to a category, apply a function and write it -- back. You can break database invariants with this function, so be diff --git a/back/src/Guide/Markdown.hs b/back/src/Guide/Markdown.hs index efb5f4cc..91269539 100644 --- a/back/src/Guide/Markdown.hs +++ b/back/src/Guide/Markdown.hs @@ -344,7 +344,7 @@ instance Aeson.FromJSON MarkdownBlock where instance Aeson.FromJSON MarkdownTree where parseJSON = Aeson.withObject "MarkdownTree" $ \o -> do txt <- o Aeson..: "text" - prefix <- o Aeson..:? "prefix" Aeson..!= T.empty + prefix <- o Aeson..:? "prefix" Aeson..!= "" pure $ toMarkdownTree prefix txt instance ToHtml MarkdownInline where diff --git a/back/src/Guide/Types/Core.hs b/back/src/Guide/Types/Core.hs index 5b7a0bdb..e7dd1735 100644 --- a/back/src/Guide/Types/Core.hs +++ b/back/src/Guide/Types/Core.hs @@ -378,19 +378,14 @@ instance Aeson.FromJSON Category where categoryEnabledSections <- o Aeson..: "enabledSections" pure Category{..} --- | jsonb encode data through JSON AST. --- --- | If you want more speed then use jsonbBytes, it encodes through raw JSON. +-- | 'jsonbBytes' is used to report an error as Left +-- without using 'error' function. instance ToPostgres Category where - toPostgres = Aeson.toJSON >$< HE.jsonb + toPostgres = toByteString . Aeson.encode >$< HE.jsonbBytes instance FromPostgres Category where - fromPostgres = resultToEither . Aeson.fromJSON <$> HD.jsonb - --- | Unwarp result to category or fail. -resultToEither :: Aeson.Result Category -> Category -resultToEither (Aeson.Success category) = category -resultToEither (Aeson.Error s) = error $ "fromJSON failed with error: " ++ s + fromPostgres = HD.jsonbBytes $ + either (Left . toText) (Right . id) . Aeson.eitherDecodeStrict -- | Category identifier (used in URLs). E.g. for a category with title -- “Performance optimization” and UID “t3c9hwzo” the slug would be From 8cb6b51bd4df56d2ed17429e6c501c2b6cd186b8 Mon Sep 17 00:00:00 2001 From: willbasky Date: Wed, 4 Sep 2019 22:46:00 +0500 Subject: [PATCH 08/13] Remove commented code to compile haddock --- back/src/Guide/Database/Types.hs | 230 ------------------------------- 1 file changed, 230 deletions(-) diff --git a/back/src/Guide/Database/Types.hs b/back/src/Guide/Database/Types.hs index b2077076..8696cb97 100644 --- a/back/src/Guide/Database/Types.hs +++ b/back/src/Guide/Database/Types.hs @@ -1,249 +1,19 @@ -- | Types for postgres database module Guide.Database.Types ( - -- * Types DatabaseError(..) - -- , CategoryRow (..) - -- , ItemRow (..) - -- , TraitRow (..) - -- ** Lenses - -- , CategoryRowLenses (..) - -- , ItemRowLenses (..) - -- , TraitRowLenses (..) - - -- * Type convertions - -- , categoryRowToCategory - -- , categoryToRowCategory - -- , itemRowToItem - -- , itemToRowItem - -- , traitRowToTrait - -- , traitToTraitRow ) where import Imports --- import Guide.Markdown (toMarkdownBlock, toMarkdownTree, toMarkdownInline, markdownBlockSource, markdownTreeSource, markdownInlineSource) import Guide.Types.Core import Guide.Uid --- import Guide.Utils (makeClassWithLenses, fields) --- import Guide.Database.Utils -- | Custom datatype errors for database data DatabaseError = CategoryNotFound (Uid Category) - -- ItemNotFound (Uid Item) - -- | TraitNotFound (Uid Trait) - -- | CategoryRowUpdateNotAllowed - -- { deCategoryId :: Uid Category - -- , deFieldName :: Text } - -- | ItemRowUpdateNotAllowed - -- { deItemId :: Uid Item - -- , deFieldName :: Text } - -- | TraitRowUpdateNotAllowed - -- { deTraitId :: Uid Trait - -- , deFieldName :: Text } deriving Show --- | Category intermediary type. --- data CategoryRow = CategoryRow --- { categoryRowUid :: Uid Category --- , categoryRowTitle :: Text --- , categoryRowCreated :: UTCTime --- , categoryRowGroup :: Text --- , categoryRowStatus :: CategoryStatus --- , categoryRowNotes :: Text --- , categoryRowEnabledSections :: Set ItemSection --- , categoryRowItemsOrder :: [Uid Item] --- , categoryRowDeleted :: Bool --- } deriving (Show, Generic) - --- | Make CategoryRowLenses Class to use lenses with this type. --- makeClassWithLenses ''CategoryRow - --- instance ToPostgresParams CategoryRow --- instance FromPostgresRow CategoryRow - --- | Item intermediary type. --- data ItemRow = ItemRow --- { itemRowUid :: Uid Item --- , itemRowName :: Text --- , itemRowCreated :: UTCTime --- , itemRowLink :: Maybe Text --- , itemRowHackage :: Maybe Text --- , itemRowSummary :: Text --- , itemRowEcosystem :: Text --- , itemRowNotes :: Text --- , itemRowDeleted :: Bool --- , itemRowCategoryUid :: Uid Category --- , itemRowProsOrder :: [Uid Trait] --- , itemRowConsOrder :: [Uid Trait] --- } deriving (Show, Generic) - --- | Make ItemRowLenses Class to use lenses with this type. --- makeClassWithLenses ''ItemRow - --- instance ToPostgresParams ItemRow --- instance FromPostgresRow ItemRow - --- | Trait intermediary type. --- data TraitRow = TraitRow --- { traitRowUid :: Uid Trait --- , traitRowContent :: Text --- , traitRowDeleted :: Bool --- , traitRowType :: TraitType --- , traitRowItemUid :: Uid Item --- } deriving (Show, Generic) - --- | Make TraitRowLenses Class to use lenses with this type. --- makeClassWithLenses ''TraitRow - --- instance ToPostgresParams TraitRow --- instance FromPostgresRow TraitRow - ----------------------------------------------------------------------------- --- Convertions between types ----------------------------------------------------------------------------- - --- | Convert CategoryRow to Category. --- --- To fetch items, use @selectItemRowsByCategory@ from --- "Guide.Database.Queries.Select". To fetch deleted items, use --- @selectDeletedItemRowsByCategory@. --- categoryRowToCategory --- :: "items" :! [Item] --- -> "itemsDeleted" :! [Item] --- -> CategoryRow --- -> Category --- categoryRowToCategory --- (arg #items -> items) --- (arg #itemsDeleted -> itemsDeleted) --- $(fields 'CategoryRow) --- = --- Category --- { categoryUid = categoryRowUid --- , categoryTitle = categoryRowTitle --- , categoryCreated = categoryRowCreated --- , categoryGroup = categoryRowGroup --- , categoryStatus = categoryRowStatus --- , categoryNotes = toMarkdownBlock categoryRowNotes --- , categoryItems = items --- , categoryItemsDeleted = itemsDeleted --- , categoryEnabledSections = categoryRowEnabledSections --- } --- where --- -- Ignored fields --- _ = categoryRowDeleted --- _ = categoryRowItemsOrder - --- | Convert Category to CategoryRow. --- categoryToRowCategory --- :: Category --- -> "deleted" :! Bool --- -> CategoryRow --- categoryToRowCategory $(fields 'Category) (arg #deleted -> deleted) = --- CategoryRow --- { categoryRowUid = categoryUid --- , categoryRowTitle = categoryTitle --- , categoryRowCreated = categoryCreated --- , categoryRowGroup = categoryGroup --- , categoryRowStatus = categoryStatus --- , categoryRowNotes = markdownBlockSource categoryNotes --- , categoryRowEnabledSections = categoryEnabledSections --- , categoryRowItemsOrder = map itemUid categoryItems --- , categoryRowDeleted = deleted --- } --- where --- -- Ignored fields --- _ = categoryItemsDeleted - --- | Convert ItemRow to Item. --- --- To fetch traits, use @getTraitRowsByItem@ from --- "Guide.Database.Queries.Select". To fetch deleted traits, use --- @getDeletedTraitRowsByItem@. --- itemRowToItem --- :: "proTraits" :! [Trait] --- -> "proDeletedTraits" :! [Trait] --- -> "conTraits" :! [Trait] --- -> "conDeletedTraits" :! [Trait] --- -> ItemRow --- -> Item --- itemRowToItem --- (arg #proTraits -> proTraits) --- (arg #proDeletedTraits -> proDeletedTraits) --- (arg #conTraits -> conTraits) --- (arg #conDeletedTraits -> conDeletedTraits) --- $(fields 'ItemRow) --- = --- Item --- { itemUid = itemRowUid --- , itemName = itemRowName --- , itemCreated = itemRowCreated --- , itemHackage = itemRowHackage --- , itemSummary = toMarkdownBlock itemRowSummary --- , itemPros = proTraits --- , itemProsDeleted = proDeletedTraits --- , itemCons = conTraits --- , itemConsDeleted = conDeletedTraits --- , itemEcosystem = toMarkdownBlock itemRowEcosystem --- , itemNotes = toMarkdownTree prefix itemRowNotes --- , itemLink = itemRowLink --- } --- where --- prefix = "item-notes-" <> uidToText itemRowUid <> "-" --- -- Ignored fields --- _ = (itemRowConsOrder, itemRowProsOrder) --- _ = itemRowCategoryUid --- _ = itemRowDeleted - --- | Convert Item to ItemRow. --- itemToRowItem :: Uid Category -> "deleted" :! Bool -> Item -> ItemRow --- itemToRowItem catId (arg #deleted -> deleted) $(fields 'Item) = --- ItemRow --- { itemRowUid = itemUid --- , itemRowName = itemName --- , itemRowCreated = itemCreated --- , itemRowLink = itemLink --- , itemRowHackage = itemHackage --- , itemRowSummary = markdownBlockSource itemSummary --- , itemRowEcosystem = markdownBlockSource itemEcosystem --- , itemRowNotes = markdownTreeSource itemNotes --- , itemRowDeleted = deleted --- , itemRowCategoryUid = catId --- , itemRowProsOrder = map traitUid itemPros --- , itemRowConsOrder = map traitUid itemCons --- } --- where --- -- Ignored fields --- _ = (itemConsDeleted, itemProsDeleted) - --- -- | Convert TraitRow to Trait. --- traitRowToTrait :: TraitRow -> Trait --- traitRowToTrait $(fields 'TraitRow) = --- Trait --- { traitUid = traitRowUid --- , traitContent = toMarkdownInline traitRowContent --- } --- where --- -- Ignored fields --- _ = traitRowItemUid --- _ = traitRowType --- _ = traitRowDeleted --- -- | Convert Trait to TraitRow. --- traitToTraitRow --- :: Uid Item --- -> "deleted" :! Bool --- -> TraitType --- -> Trait --- -> TraitRow --- traitToTraitRow itemId (arg #deleted -> deleted) traitType $(fields 'Trait) = --- TraitRow --- { traitRowUid = traitUid --- , traitRowContent = markdownInlineSource traitContent --- , traitRowDeleted = deleted --- , traitRowType = traitType --- , traitRowItemUid = itemId --- } From 77f839f14e951cfcef6f010cfec14daf5c96df07 Mon Sep 17 00:00:00 2001 From: willbasky Date: Wed, 4 Sep 2019 23:33:22 +0500 Subject: [PATCH 09/13] Bump up chromo-driver --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 76aa6194..89ae9c54 100644 --- a/.travis.yml +++ b/.travis.yml @@ -106,7 +106,7 @@ jobs: # travis_retry works around https://github.com/commercialhaskell/stack/issues/4888 - travis_retry stack setup # Install chromedriver - - wget https://chromedriver.storage.googleapis.com/76.0.3809.68/chromedriver_linux64.zip + - wget https://chromedriver.storage.googleapis.com/76.0.3809.126/chromedriver_linux64.zip - unzip chromedriver_linux64.zip - chmod +x chromedriver - sudo mv -f chromedriver /usr/local/share/chromedriver From 007283be6d10728d67a07e4b3373dec86d207959 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Tue, 10 Sep 2019 16:48:00 +0300 Subject: [PATCH 10/13] Better benchmark instructions --- README.md | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 8d13dbb6..a2ac9607 100644 --- a/README.md +++ b/README.md @@ -8,13 +8,16 @@ Installation instructions and the explanation of config variables (in `config.js ## Benchmarking -Deploy postgres server and create `guide` database. +Start Postgres and create the `guide` database. -Add next parameter to benchmarks and library section of `package.yaml`: +If you've been building with `stack build --fast`, do a cleanup: - ghc-options: - - -O +``` +stack clean +``` -Run benchmarks with command: +Then build and run benchmarks: - stack bench +``` +stack bench +``` From 0ee809ad085c84fc41b3788714cb46743fd42452 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 23 Sep 2019 19:01:06 +0300 Subject: [PATCH 11/13] Use a different database name for benchmarks --- README.md | 13 ++++++++----- back/benchmarks/Main.hs | 6 +++++- back/src/Guide/Database/Connection.hs | 19 +++++++------------ back/src/Guide/Database/Import.hs | 4 ++-- back/src/Guide/Database/Schema.hs | 12 ++++++------ 5 files changed, 28 insertions(+), 26 deletions(-) diff --git a/README.md b/README.md index a2ac9607..fb9e8723 100644 --- a/README.md +++ b/README.md @@ -8,16 +8,19 @@ Installation instructions and the explanation of config variables (in `config.js ## Benchmarking -Start Postgres and create the `guide` database. - -If you've been building with `stack build --fast`, do a cleanup: +Start Postgres and create an empty database called `guide-bench`. An example +with Docker: ``` -stack clean +docker run --name guide-db -e POSTGRES_PASSWORD=3 -e POSTGRES_DB=guide-bench -p 5432:5432 -d postgres ``` -Then build and run benchmarks: +Build and run benchmarks: ``` stack bench ``` + +If you have been building with `--fast` previously, or using `make`, Stack +will detect that Guide has to be recompiled with `-O` and do it +automatically. diff --git a/back/benchmarks/Main.hs b/back/benchmarks/Main.hs index 5ba20590..e9926bd6 100644 --- a/back/benchmarks/Main.hs +++ b/back/benchmarks/Main.hs @@ -11,6 +11,7 @@ import Hasql.Transaction.Sessions (Mode (..)) import Hasql.Connection (Connection) import qualified Data.Set as Set +import Guide.Database.Schema (setupDatabase) import Guide.Database.Queries.Update import Guide.Database.Queries.Select import Guide.Database.Queries.Insert @@ -23,7 +24,10 @@ import Guide.Markdown (toMarkdownBlock, toMarkdownTree) -- | See readme for instruction. main :: IO () main = do - conn <- connect + putStrLn "Connecting to database guide-bench" + conn <- connect (#database "guide-bench") + putStrLn "Initializing database" + setupDatabase conn time <- getCurrentTime runTransactionExceptT conn Write $ insertCategoryWithCategory (#archived False) $ category time diff --git a/back/src/Guide/Database/Connection.hs b/back/src/Guide/Database/Connection.hs index 72164fff..f0415a27 100644 --- a/back/src/Guide/Database/Connection.hs +++ b/back/src/Guide/Database/Connection.hs @@ -8,7 +8,7 @@ module Guide.Database.Connection ) where import Imports -import Hasql.Connection (Connection, Settings) +import Hasql.Connection (Connection) import Hasql.Session (Session) import Hasql.Transaction (Transaction) import Hasql.Transaction.Sessions (Mode, IsolationLevel(..)) @@ -23,17 +23,16 @@ import Guide.Database.Types (DatabaseError) -- | Create a database connection (the destination is hard-coded for now). -- -- Throws an 'error' if the connection could not be established. -connect :: IO Connection -connect = do - HC.acquire connectionSettings >>= \case +connect + :: "database" :! ByteString + -> IO Connection +connect (arg #database -> dbName) = do + let settings = HC.settings "localhost" 5432 dbUser dbPass dbName + HC.acquire settings >>= \case Left Nothing -> error "connect: unknown exception" Left (Just x) -> error ("connect: " ++ utf8ToString x) Right conn -> pure conn --- | Connection settings -connectionSettings :: Settings -connectionSettings = HC.settings "localhost" 5432 dbUser dbPass dbName - -- | Database user dbUser :: ByteString dbUser = "postgres" @@ -42,10 +41,6 @@ dbUser = "postgres" dbPass :: ByteString dbPass = "3" --- | Database name -dbName :: ByteString -dbName = "guide" - ---------------------------------------------------------------------------- -- Utilities ---------------------------------------------------------------------------- diff --git a/back/src/Guide/Database/Import.hs b/back/src/Guide/Database/Import.hs index 585b9c4e..91af528c 100644 --- a/back/src/Guide/Database/Import.hs +++ b/back/src/Guide/Database/Import.hs @@ -44,9 +44,9 @@ postgresLoader logger globalState = do GRANT ALL ON SCHEMA public TO postgres; GRANT ALL ON SCHEMA public TO public; -} - setupDatabase + conn <- connect (#database "guide") + setupDatabase conn -- Upload to Postgres - conn <- connect runTransactionExceptT conn Write $ insertCategories globalState -- Download from Postgres catPostgres <- runTransactionExceptT conn Read $ diff --git a/back/src/Guide/Database/Schema.hs b/back/src/Guide/Database/Schema.hs index 6130d94a..921a32c2 100644 --- a/back/src/Guide/Database/Schema.hs +++ b/back/src/Guide/Database/Schema.hs @@ -8,13 +8,14 @@ where import Imports import Hasql.Session (Session) +import Hasql.Connection (Connection) import Hasql.Statement (Statement (..)) import Data.Profunctor (lmap) import qualified Hasql.Session as HS import Guide.Database.Utils -import Guide.Database.Connection (connect, runSession) +import Guide.Database.Connection (runSession) -- | List of all migrations. @@ -32,12 +33,11 @@ migrations = -- not create a database if it does not exist yet. You should create the -- database manually by doing @CREATE DATABASE guide;@ or run Postgres with -- @POSTGRES_DB=guide@ when running when running the app for the first time. -setupDatabase :: IO () -setupDatabase = do - conn <- connect +setupDatabase :: Connection -> IO () +setupDatabase conn = do mbSchemaVersion <- runSession conn getSchemaVersion case mbSchemaVersion of - Nothing -> formatLn "No schema found. Creating tables and running all migrations." + Nothing -> formatLn "No schema found." Just v -> formatLn "Schema version is {}." v let schemaVersion = fromMaybe (-1) mbSchemaVersion let neededMigrations = @@ -47,7 +47,7 @@ setupDatabase = do if null neededMigrations then putStrLn "Schema is up to date." else do - putStrLn "Schema is not up to date, running migrations." + putStrLn "Running migrations:" for_ neededMigrations $ \(migrationVersion, migration) -> do format "Migration {}: " migrationVersion runSession conn (migration >> setSchemaVersion migrationVersion) From d7295d53f844e24c71da7c0bfc0d654d5441c9b7 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 23 Sep 2019 19:02:03 +0300 Subject: [PATCH 12/13] Remove ghc-options --- back/package.yaml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/back/package.yaml b/back/package.yaml index 7f0960e2..1bd63f7c 100644 --- a/back/package.yaml +++ b/back/package.yaml @@ -205,11 +205,9 @@ benchmarks: dependencies: - base <5 - containers - - guide - gauge + - guide - hasql - hasql-transaction + - random - time - - ghc-options: - - -O From c051d27a4183c8143dc65f55ff04da67c9cc3511 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 23 Sep 2019 19:02:22 +0300 Subject: [PATCH 13/13] Add a TODO --- back/src/Guide/Markdown.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/back/src/Guide/Markdown.hs b/back/src/Guide/Markdown.hs index 91269539..c4c412f1 100644 --- a/back/src/Guide/Markdown.hs +++ b/back/src/Guide/Markdown.hs @@ -323,10 +323,12 @@ deriving instance Show Heading instance Aeson.ToJSON MarkdownInline where toJSON md = Aeson.object [ "text" Aeson..= markdownInlineSource md, + -- TODO: remove "html" when the old frontend is removed "html" Aeson..= utf8ToText (markdownInlineHtml md) ] instance Aeson.ToJSON MarkdownBlock where toJSON md = Aeson.object [ "text" Aeson..= markdownBlockSource md, + -- TODO: remove "html" when the old frontend is removed "html" Aeson..= utf8ToText (markdownBlockHtml md) ] instance Aeson.ToJSON MarkdownTree where toJSON md = Aeson.object [