From 36a92f9bf73a142ccfebaeb1d31e79581e275263 Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Thu, 25 Jul 2019 17:17:29 +0500 Subject: [PATCH] Add get functions for categories, traits and items (#339) --- .gitignore | 2 + back/guide.cabal | 12 +- back/src/Guide/Api/Methods.hs | 4 +- back/src/Guide/Api/Types.hs | 24 +- back/src/Guide/Database.hs | 9 + back/src/Guide/Database/Connection.hs | 91 +++++++ back/src/Guide/Database/Convert.hs | 149 ++++++++++++ back/src/Guide/Database/Get.hs | 281 ++++++++++++++++++++++ back/src/Guide/{Db => Database}/Schema.hs | 69 ++---- back/src/Guide/Database/Types.hs | 17 ++ back/src/Guide/Db.hs | 7 - back/src/Guide/Main.hs | 9 +- back/src/Guide/Types/Core.hs | 5 + back/src/Guide/Views/Page.hs | 8 +- back/src/Guide/Views/Utils.hs | 1 - stack.yaml | 1 + 16 files changed, 609 insertions(+), 80 deletions(-) create mode 100644 back/src/Guide/Database.hs create mode 100644 back/src/Guide/Database/Connection.hs create mode 100644 back/src/Guide/Database/Convert.hs create mode 100644 back/src/Guide/Database/Get.hs rename back/src/Guide/{Db => Database}/Schema.hs (76%) create mode 100644 back/src/Guide/Database/Types.hs delete mode 100644 back/src/Guide/Db.hs diff --git a/.gitignore b/.gitignore index 61b8dab..27bdb76 100644 --- a/.gitignore +++ b/.gitignore @@ -22,6 +22,8 @@ cabal.config *.swp *.swo *# +*.lock + # IDE/support .idea/ diff --git a/back/guide.cabal b/back/guide.cabal index 8c92012..1f0e34a 100644 --- a/back/guide.cabal +++ b/back/guide.cabal @@ -56,8 +56,12 @@ library Guide.Api.Error Guide.Api.Utils Guide.Api.Guider - Guide.Db - Guide.Db.Schema + Guide.Database + Guide.Database.Connection + Guide.Database.Convert + Guide.Database.Get + Guide.Database.Schema + Guide.Database.Types Guide.Logger Guide.Logger.Types Guide.Logger.Functions @@ -108,6 +112,7 @@ library , cmark-highlight == 0.2.* , cmark-sections == 0.3.* , containers >= 0.5 + , contravariant-extras , data-default >= 0.5 , deepseq >= 1.2.0.0 , df1 @@ -129,6 +134,7 @@ library , hashable , haskell-src-meta , hasql + , hasql-transaction , http-api-data , http-client , http-client-tls @@ -143,11 +149,13 @@ library , microlens-platform >= 0.3.2 , mmorph == 1.* , mtl >= 2.1.1 + , named , neat-interpolation == 0.3.* , network , network-uri , patches-vector , random >= 1.1 + , raw-strings-qq , reroute , safe , safecopy diff --git a/back/src/Guide/Api/Methods.hs b/back/src/Guide/Api/Methods.hs index 7ef00c8..9772043 100644 --- a/back/src/Guide/Api/Methods.hs +++ b/back/src/Guide/Api/Methods.hs @@ -199,8 +199,8 @@ createTrait itemId CCreateTrait{..} = throwError err400{errReasonPhrase = "'content' can not be empty"} traitId <- randomShortUid addEdit . fst =<< case cctType of - Con -> dbUpdate (AddCon itemId traitId cctContent) - Pro -> dbUpdate (AddPro itemId traitId cctContent) + CCon -> dbUpdate (AddCon itemId traitId cctContent) + CPro -> dbUpdate (AddPro itemId traitId cctContent) pure traitId -- | Update the text of a trait (pro/con). diff --git a/back/src/Guide/Api/Types.hs b/back/src/Guide/Api/Types.hs index 460522a..39d51e0 100644 --- a/back/src/Guide/Api/Types.hs +++ b/back/src/Guide/Api/Types.hs @@ -308,17 +308,27 @@ type Api = RequestDetails :> ToServant Site AsApi -------------------------------------------------------------------------- -- | Trait type (Pro/Con) and instances. -data CTraitType = Pro | Con +data CTraitType = CPro | CCon deriving (Show, Generic) instance ToSchema CTraitType where declareNamedSchema = genericDeclareNamedSchema schemaOptions + { constructorTagModifier = \case + "CPro" -> "Pro" + "CCon" -> "Con" + other -> error ("CTraitType schema: unknown value " <> show other) + } instance A.ToJSON CTraitType where - toJSON = A.genericToJSON jsonOptions + toJSON = \case + CPro -> "Pro" + CCon -> "Con" instance A.FromJSON CTraitType where - parseJSON = A.genericParseJSON jsonOptions + parseJSON = A.withText "CTraitType" $ \case + "Pro" -> pure CPro + "Con" -> pure CCon + other -> fail ("unknown trait type " <> show other) ---------------------------------------------------------------------------- -- CDirection @@ -333,7 +343,7 @@ instance ToSchema CDirection where { constructorTagModifier = \case "DirectionUp" -> "up" "DirectionDown" -> "down" - other -> error ("Direction schema: unknown tag " <> show other) + other -> error ("CDirection schema: unknown value " <> show other) } instance A.ToJSON CDirection where @@ -342,10 +352,10 @@ instance A.ToJSON CDirection where DirectionDown -> "down" instance A.FromJSON CDirection where - parseJSON = \case - "up" -> pure DirectionUp + parseJSON = A.withText "CDirection" $ \case + "up" -> pure DirectionUp "down" -> pure DirectionDown - tag -> fail ("unknown direction " ++ show tag) + other -> fail ("unknown direction " <> show other) ---------------------------------------------------------------------------- -- CCreateItem diff --git a/back/src/Guide/Database.hs b/back/src/Guide/Database.hs new file mode 100644 index 0000000..f9e8e09 --- /dev/null +++ b/back/src/Guide/Database.hs @@ -0,0 +1,9 @@ +module Guide.Database +( + module Guide.Database.Schema, + module Guide.Database.Get +) +where + +import Guide.Database.Schema +import Guide.Database.Get diff --git a/back/src/Guide/Database/Connection.hs b/back/src/Guide/Database/Connection.hs new file mode 100644 index 0000000..e40790e --- /dev/null +++ b/back/src/Guide/Database/Connection.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + + +-- | Connect to the Guide database. +module Guide.Database.Connection + ( connect + , runSessionExceptT + , runSession + , runTransactionExceptT + , runTransaction + ) where + +import Imports +import Hasql.Connection (Connection, Settings) +import Hasql.Session (Session) +import Hasql.Transaction (Transaction) +import Hasql.Transaction.Sessions (Mode, IsolationLevel(..)) + +import qualified Hasql.Connection as HC +import qualified Hasql.Session as HS +import qualified Hasql.Transaction.Sessions as HT + +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 + Left Nothing -> error "connect: unknown exception" + Left (Just x) -> error ("connect: " ++ toString x) + Right conn -> pure conn + +-- | Connection settings +connectionSettings :: Settings +connectionSettings = HC.settings "localhost" 5432 dbUser dbPass dbName + +-- | Database user +dbUser :: ByteString +dbUser = "postgres" + +-- | Database password +dbPass :: ByteString +dbPass = "3" + +-- | Database name +dbName :: ByteString +dbName = "guide" + +---------------------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------------------- + +-- | Run an @ExceptT Session@ against the given database connection, +-- throwing an 'error' in case of failure. +runSessionExceptT :: Connection -> ExceptT DatabaseError Session a -> IO a +runSessionExceptT connection session = + unwrapRight =<< unwrapRight =<< HS.run (runExceptT session) connection + +-- | Run a @Session@ against the given database connection, throwing an +-- 'error' in case of failure. +runSession :: Connection -> Session a -> IO a +runSession connection session = + unwrapRight =<< HS.run session connection + +-- | Run an @ExceptT Transaction@ against the given database connection, +-- throwing an 'error' in case of failure. +-- +-- The transaction is ran with the strongest ('Serializable') isolation +-- level. Use 'HT.transaction' if you need a different isolation level. +runTransactionExceptT + :: Connection -> Mode -> ExceptT DatabaseError Transaction a -> IO a +runTransactionExceptT connection mode transaction = + unwrapRight =<< unwrapRight =<< + HS.run (HT.transaction Serializable mode (runExceptT transaction)) connection + +-- | Run a @Transaction@ against the given database connection, throwing an +-- 'error' in case of failure. +-- +-- The transaction is ran with the strongest ('Serializable') isolation +-- level. Use 'HT.transaction' if you need a different isolation level. +runTransaction :: Connection -> Mode -> Transaction a -> IO a +runTransaction connection mode transaction = + unwrapRight =<< + HS.run (HT.transaction Serializable mode transaction) connection + +-- | Unwrap 'Either', failing in case of 'Left'. +unwrapRight :: Show e => Either e a -> IO a +unwrapRight = either (error . show) pure diff --git a/back/src/Guide/Database/Convert.hs b/back/src/Guide/Database/Convert.hs new file mode 100644 index 0000000..b0d883b --- /dev/null +++ b/back/src/Guide/Database/Convert.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} + + +-- | Encoders and decoders for types used in the database schema. +module Guide.Database.Convert + ( + -- * 'Bool' + boolParam + , boolParamNullable + + -- * 'Text' + , textParam + , textParamNullable + , textColumn + , textColumnNullable + + -- * 'Uid' + , uidParam + , uidColumn + + -- * 'UTCTime' + , timestamptzColumn + + -- * 'TraitType' + , traitTypeParam + + -- * 'CategoryStatus' + , categoryStatusColumn + + -- * @Set 'ItemSection'@ + , itemSectionSetColumn + ) where + + +import Imports + +import Data.Functor.Contravariant (contramap) +import qualified Data.Set as Set + +import qualified Hasql.Decoders as HD +import qualified Hasql.Encoders as HE + +import Guide.Types.Core (CategoryStatus (..), ItemSection (..), TraitType (..)) +import Guide.Utils (Uid (..)) + + +---------------------------------------------------------------------------- +-- Bool +---------------------------------------------------------------------------- + +-- | Pass a 'Bool' to a query. +boolParam :: HE.Params Bool +boolParam = HE.param (HE.nonNullable HE.bool) + +-- | Pass a nullable 'Bool' to a query. +boolParamNullable :: HE.Params (Maybe Bool) +boolParamNullable = HE.param (HE.nullable HE.bool) + +---------------------------------------------------------------------------- +-- Text +---------------------------------------------------------------------------- + +-- | Pass a 'Text' to a query. +textParam :: HE.Params Text +textParam = HE.param (HE.nonNullable HE.text) + +-- | Pass a nullable 'Text' to a query. +textParamNullable :: HE.Params (Maybe Text) +textParamNullable = HE.param (HE.nullable HE.text) + +-- | Get a 'Text' from a query. +textColumn :: HD.Row Text +textColumn = HD.column (HD.nonNullable HD.text) + +-- | Get a nullable 'Text' from a query. +textColumnNullable :: HD.Row (Maybe Text) +textColumnNullable = HD.column (HD.nullable HD.text) + +---------------------------------------------------------------------------- +-- Uid +---------------------------------------------------------------------------- + +-- | Pass a 'Uid' to a query. +uidParam :: HE.Params (Uid a) +uidParam = contramap uidToText textParam + +-- | Get a 'Uid' from a query. +uidColumn :: HD.Row (Uid a) +uidColumn = Uid <$> textColumn + +---------------------------------------------------------------------------- +-- UTCTime +---------------------------------------------------------------------------- + +-- | Get a 'UTCTime' from a query. +timestamptzColumn :: HD.Row UTCTime +timestamptzColumn = HD.column (HD.nonNullable HD.timestamptz) + +---------------------------------------------------------------------------- +-- TraitType +---------------------------------------------------------------------------- + +-- | Encode a 'TraitType'. +traitTypeEncoder :: HE.Value TraitType +traitTypeEncoder = HE.enum $ \case + Pro -> "pro" + Con -> "con" + +-- | Pass a 'TraitType' to a query. +traitTypeParam :: HE.Params TraitType +traitTypeParam = HE.param (HE.nonNullable traitTypeEncoder) + +---------------------------------------------------------------------------- +-- CategoryStatus +---------------------------------------------------------------------------- + +-- | Decode a 'CategoryStatus'. +categoryStatusDecoder :: HD.Value CategoryStatus +categoryStatusDecoder = HD.enum $ \case + "stub" -> Just CategoryStub + "wip" -> Just CategoryWIP + "finished" -> Just CategoryFinished + _ -> Nothing + +-- | Get a 'CategoryStatus' from a query. +categoryStatusColumn :: HD.Row CategoryStatus +categoryStatusColumn = HD.column (HD.nonNullable categoryStatusDecoder) + +---------------------------------------------------------------------------- +-- Set ItemSection +---------------------------------------------------------------------------- + +-- | Decode an 'ItemSection'. +itemSectionDecoder :: HD.Value ItemSection +itemSectionDecoder = HD.enum $ \case + "pros_cons" -> Just ItemProsConsSection + "ecosystem" -> Just ItemEcosystemSection + "notes" -> Just ItemNotesSection + _ -> Nothing + +-- | Get a @Set ItemSection@ from a query. +itemSectionSetColumn :: HD.Row (Set ItemSection) +itemSectionSetColumn = + fmap Set.fromList + $ HD.column + $ HD.nonNullable + $ HD.listArray + $ HD.nonNullable + $ itemSectionDecoder diff --git a/back/src/Guide/Database/Get.hs b/back/src/Guide/Database/Get.hs new file mode 100644 index 0000000..3c34cf5 --- /dev/null +++ b/back/src/Guide/Database/Get.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + + +-- | Read-only database queries. +module Guide.Database.Get + ( + -- * Trait + getTraitMaybe + , getTraitsByItem + -- * Item + , getItem + , getItemMaybe + , getItemsByCategory + -- * Category + , getCategory + , getCategoryMaybe + , getCategories + , getCategoryByItemMaybe + + ) where + +import Imports + +import Contravariant.Extras.Contrazip (contrazip2, contrazip3) +import Hasql.Statement (Statement (..)) +import Hasql.Transaction (Transaction) +import Hasql.Transaction.Sessions (Mode(Read)) +import Named +import Text.RawString.QQ (r) + +import qualified Data.Map as Map +import qualified Hasql.Decoders as HD +import qualified Hasql.Encoders as HE +import qualified Hasql.Transaction as HT + +import Guide.Database.Connection (connect, runTransactionExceptT) +import Guide.Database.Convert +import Guide.Database.Types +import Guide.Markdown (toMarkdownBlock, toMarkdownInline, toMarkdownTree) +import Guide.Types.Core (Category (..), Item (..), Trait (..), TraitType (..)) +import Guide.Utils (Uid (..)) + + +-- | Just to test queries +getTest :: IO () +getTest = do + conn <- connect + mTrait <- runTransactionExceptT conn Read (getTraitMaybe "qwertassdf34") + print mTrait + traits <- runTransactionExceptT conn Read $ + getTraitsByItem "items1234567" (#deleted False) (#traitType Pro) + print traits + mItem <- runTransactionExceptT conn Read (getItemMaybe "items1234567") + print mItem + item <- runTransactionExceptT conn Read (getItem "items1234567") + print item + -- wrong uid + -- itemErr <- runTransactionExceptT conn Read (getItemByItemId "wrong1234567") + -- print itemErr + items <- runTransactionExceptT conn Read $ + getItemsByCategory "categories11" (#deleted False) + print items + catM <- runTransactionExceptT conn Read (getCategoryMaybe "categories11") + print catM + cat <- runTransactionExceptT conn Read (getCategory "categories11") + print cat + mCatId <- runTransactionExceptT conn Read (getCategoryIdByItemMaybe "items1234567") + print mCatId + catIds <- runTransactionExceptT conn Read getCategoryIds + print catIds + cats <- runTransactionExceptT conn Read getCategories + print cats + +---------------------------------------------------------------------------- +-- Traits +---------------------------------------------------------------------------- + +-- | Get a 'Trait'. +-- +-- Traits marked as deleted will still be returned if they physically exist +-- in the database. +getTraitMaybe :: Uid Trait -> ExceptT DatabaseError Transaction (Maybe Trait) +getTraitMaybe traitId = do + let sql = [r| + SELECT uid, content + FROM traits + WHERE uid = $1 + |] + encoder = uidParam + decoder = HD.rowMaybe $ do + _traitUid <- uidColumn + _traitContent <- toMarkdownInline <$> textColumn + pure $ Trait{..} + lift $ HT.statement traitId (Statement sql encoder decoder False) + +-- | Get traits belonging to an item. +-- +-- The @#deleted@ flag specifies whether to return only "normal" or only +-- deleted traits. To get both, call 'getTraitsByItem' twice. +getTraitsByItem + :: Uid Item + -> "deleted" :! Bool + -> "traitType" :! TraitType + -> ExceptT DatabaseError Transaction [Trait] +getTraitsByItem itemId (arg #deleted -> deleted) (arg #traitType -> traitType) = do + let sql = [r| + SELECT uid, content + FROM traits + WHERE item_uid = $1 + AND deleted = $2 + AND type_ = ($3 :: trait_type) + |] + encoder = contrazip3 uidParam boolParam traitTypeParam + decoder = HD.rowList $ do + _traitUid <- uidColumn + _traitContent <- toMarkdownInline <$> textColumn + pure $ Trait{..} + lift $ HT.statement (itemId,deleted,traitType) (Statement sql encoder decoder False) + +---------------------------------------------------------------------------- +-- Items +---------------------------------------------------------------------------- + +-- | Get an 'Item'. +-- +-- Items marked as deleted will still be returned if they physically exist +-- in the database. +getItemMaybe :: Uid Item -> ExceptT DatabaseError Transaction (Maybe Item) +getItemMaybe itemId = do + _itemPros <- getTraitsByItem itemId (#deleted False) (#traitType Pro) + _itemProsDeleted <- getTraitsByItem itemId (#deleted True) (#traitType Pro) + _itemCons <- getTraitsByItem itemId (#deleted False) (#traitType Con) + _itemConsDeleted <- getTraitsByItem itemId (#deleted True) (#traitType Con) + let prefix = "item-notes-" <> uidToText itemId <> "-" + let sql = [r| + SELECT uid, name, created, group_, link, hackage, summary, ecosystem, notes + FROM items + WHERE uid = $1 + |] + encoder = uidParam + decoder = HD.rowMaybe $ do + _itemUid <- uidColumn + _itemName <- textColumn + _itemCreated <- timestamptzColumn + _itemGroup_ <- textColumnNullable + _itemLink <- textColumnNullable + _itemHackage <- textColumnNullable + _itemSummary <- toMarkdownBlock <$> textColumn + _itemEcosystem <- toMarkdownBlock <$> textColumn + _itemNotes <- toMarkdownTree prefix <$> textColumn + pure $ Item{..} + lift $ HT.statement itemId (Statement sql encoder decoder False) + +-- | Get an 'Item'. +-- +-- Items marked as deleted will still be returned if they physically exist +-- in the database. +-- +-- Fails with 'ItemNotFound' when the item does not exist. +getItem :: Uid Item -> ExceptT DatabaseError Transaction Item +getItem itemId = do + mItem <- getItemMaybe itemId + case mItem of + Nothing -> throwError $ ItemNotFound itemId + Just item -> pure item + +-- | Get items belonging to a category. +-- +-- The @#deleted@ flag specifies whether to return only "normal" or only +-- deleted items. To get both, call 'getItemsByCategory' twice. +getItemsByCategory + :: Uid Category + -> "deleted" :! Bool + -> ExceptT DatabaseError Transaction [Item] +getItemsByCategory catId (arg #deleted -> deleted) = do + let sql = [r| + SELECT uid + FROM items + WHERE category_uid = $1 + AND deleted = $2 + |] + encoder = contrazip2 uidParam boolParam + decoder = HD.rowList $ uidColumn + itemUids <- lift $ HT.statement (catId,deleted) (Statement sql encoder decoder False) + traverse getItem itemUids + +---------------------------------------------------------------------------- +-- Categories +---------------------------------------------------------------------------- + +-- | Get a 'Category'. +-- +-- Categories marked as deleted will still be returned if they physically +-- exist in the database. +getCategoryMaybe :: Uid Category -> ExceptT DatabaseError Transaction (Maybe Category) +getCategoryMaybe catId = do + _categoryItems <- getItemsByCategory catId (#deleted False) + _categoryItemsDeleted <- getItemsByCategory catId (#deleted True) + let sql = [r| + SELECT uid, title, created, group_, status_, notes, enabled_sections + FROM categories + WHERE uid = $1 + |] + encoder = uidParam + decoder = HD.rowMaybe $ do + _categoryUid <- uidColumn + _categoryTitle <- textColumn + _categoryCreated <- timestamptzColumn + _categoryGroup_ <- textColumn + _categoryStatus <- categoryStatusColumn + _categoryNotes <- toMarkdownBlock <$> textColumn + _categoryEnabledSections <- itemSectionSetColumn + let _categoryGroups = Map.empty -- TODO fix + pure $ Category{..} + lift $ HT.statement catId (Statement sql encoder decoder False) + +-- | Get a 'Category'. +-- +-- Categories marked as deleted will still be returned if they physically +-- exist in the database. +-- +-- Fails with 'CategoryNotFound' when the category does not exist. +getCategory :: Uid Category -> ExceptT DatabaseError Transaction Category +getCategory catId = do + mCat <- getCategoryMaybe catId + case mCat of + Nothing -> throwError $ CategoryNotFound catId + Just cat -> pure cat + -- TODO: consider not returning deleted categories? Otherwise somebody + -- deletes a category but the page is still there. + +-- | Get the ID of the category that an item belongs to. +getCategoryIdByItemMaybe + :: Uid Item -> ExceptT DatabaseError Transaction (Maybe (Uid Category)) +getCategoryIdByItemMaybe itemId = do + let sql = [r| + SELECT category_uid + FROM items + WHERE uid = $1 + |] + encoder = uidParam + decoder = HD.rowMaybe $ uidColumn + lift $ HT.statement itemId (Statement sql encoder decoder False) + +-- | Get the category that an item belongs to. +-- +-- Returns 'Nothing' if either the item or the category are not found. +getCategoryByItemMaybe + :: Uid Item -> ExceptT DatabaseError Transaction (Maybe Category) +getCategoryByItemMaybe itemId = do + catId <- getCategoryIdByItemMaybe itemId + join @Maybe <$> traverse getCategoryMaybe catId + +-- | Get a list of available categories' IDs. +-- +-- Includes categories marked as deleted. +-- +-- TODO explain why we store deleted categories at all. +getCategoryIds :: ExceptT DatabaseError Transaction [Uid Category] +getCategoryIds = do + let sql = [r| + SELECT uid + FROM categories + |] + encoder = HE.noParams + decoder = HD.rowList $ uidColumn + lift $ HT.statement () (Statement sql encoder decoder False) + +-- | Get all categories. +-- +-- Includes categories marked as deleted. +getCategories :: ExceptT DatabaseError Transaction [Category] +getCategories = do + catIds <- getCategoryIds + traverse getCategory catIds diff --git a/back/src/Guide/Db/Schema.hs b/back/src/Guide/Database/Schema.hs similarity index 76% rename from back/src/Guide/Db/Schema.hs rename to back/src/Guide/Database/Schema.hs index 4a5620a..ba102cb 100644 --- a/back/src/Guide/Db/Schema.hs +++ b/back/src/Guide/Database/Schema.hs @@ -2,7 +2,8 @@ {-# LANGUAGE QuasiQuotes #-} -module Guide.Db.Schema +-- | Schemas to create table for guide database +module Guide.Database.Schema ( setupDatabase, ) @@ -11,15 +12,15 @@ where import Imports import Hasql.Session (Session) -import NeatInterpolation -import Hasql.Connection (Connection, Settings) +import Text.RawString.QQ import Hasql.Statement (Statement (..)) import qualified Hasql.Session as HS -import qualified Hasql.Connection as HC import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD +import Guide.Database.Connection (connect, runSession) + -- | List of all migrations. migrations :: [(Int32, Session ())] @@ -41,7 +42,7 @@ migrations = setupDatabase :: IO () setupDatabase = do conn <- connect - mbSchemaVersion <- run' getSchemaVersion conn + mbSchemaVersion <- runSession conn getSchemaVersion case mbSchemaVersion of Nothing -> formatLn "No schema found. Creating tables and running all migrations." Just v -> formatLn "Schema version is {}." v @@ -49,43 +50,9 @@ setupDatabase = do for_ migrations $ \(migrationVersion, migration) -> when (migrationVersion > schemaVersion) $ do format "Migration {}: " migrationVersion - run' (migration >> setSchemaVersion migrationVersion) conn + runSession conn (migration >> setSchemaVersion migrationVersion) formatLn "done." --- | 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 - Left Nothing -> error "connect: unknown exception" - Left (Just x) -> error ("connect: " ++ toString x) - Right conn -> pure conn - --- | Connection settings -connectionSettings :: Settings -connectionSettings = HC.settings "localhost" 5432 dbUser dbPass dbName - --- | Database user -dbUser :: ByteString -dbUser = "postgres" - --- | Database password -dbPass :: ByteString -dbPass = "3" - --- | Database name -dbName :: ByteString -dbName = "guide" - ----------------------------------------------------------------------------- --- Utilities ----------------------------------------------------------------------------- - --- | Like 'HS.run', but errors out in case of failure. -run' :: Session a -> Connection -> IO a -run' s c = either (error . show) pure =<< HS.run s c - ---------------------------------------------------------------------------- -- Schema version table ---------------------------------------------------------------------------- @@ -96,7 +63,7 @@ run' s c = either (error . show) pure =<< HS.run s c -- If the @schema_version@ table doesn't exist, creates it. getSchemaVersion :: Session (Maybe Int32) getSchemaVersion = do - HS.sql $ toByteString [text| + HS.sql [r| CREATE TABLE IF NOT EXISTS schema_version ( name text PRIMARY KEY, version integer @@ -136,17 +103,17 @@ v0 = do -- | Create an enum type for trait type ("pro" or "con"). v0_createTypeProCon :: Session () -v0_createTypeProCon = HS.sql $ toByteString [text| +v0_createTypeProCon = HS.sql [r| CREATE TYPE trait_type AS ENUM ('pro', 'con'); |] -- | Create table @traits@, corresponding to 'Guide.Types.Core.Trait'. v0_createTableTraits :: Session () -v0_createTableTraits = HS.sql $ toByteString [text| +v0_createTableTraits = HS.sql [r| 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 + deleted boolean -- Whether the trait is deleted DEFAULT false NOT NULL, type_ trait_type NOT NULL, -- Trait type (pro or con) @@ -158,11 +125,11 @@ v0_createTableTraits = HS.sql $ toByteString [text| -- | Create table @items@, corresponding to 'Guide.Types.Core.Item'. v0_createTableItems :: Session () -v0_createTableItems = HS.sql $ toByteString [text| +v0_createTableItems = HS.sql [r| CREATE TABLE items ( uid text PRIMARY KEY, -- Unique item ID name text NOT NULL, -- Item title - created timestamp NOT NULL, -- When the item was created + created timestamptz NOT NULL, -- When the item was created group_ text, -- Optional group link text, -- Optional URL hackage text, -- Package name on Hackage @@ -180,11 +147,11 @@ v0_createTableItems = HS.sql $ toByteString [text| -- | Create table @categories@, corresponding to 'Guide.Types.Core.Category'. v0_createTableCategories :: Session () -v0_createTableCategories = HS.sql $ toByteString [text| +v0_createTableCategories = HS.sql [r| CREATE TABLE categories ( uid text PRIMARY KEY, -- Unique category ID title text NOT NULL, -- Category title - created timestamp NOT NULL, -- When the category was created + 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 @@ -196,7 +163,7 @@ v0_createTableCategories = HS.sql $ toByteString [text| -- | Create table @users@, storing user data. v0_createTableUsers :: Session () -v0_createTableUsers = HS.sql $ toByteString [text| +v0_createTableUsers = HS.sql [r| CREATE TABLE users ( uid text PRIMARY KEY, -- Unique user ID name text NOT NULL, -- User name @@ -211,11 +178,11 @@ v0_createTableUsers = HS.sql $ toByteString [text| -- | Create table @pending_edits@, storing users' edits and metadata about -- them (who made the edit, when, etc). v0_createTablePendingEdits :: Session () -v0_createTablePendingEdits = HS.sql $ toByteString [text| +v0_createTablePendingEdits = HS.sql [r| CREATE TABLE pending_edits ( uid bigserial PRIMARY KEY, -- Unique id edit json NOT NULL, -- Edit in JSON format ip inet, -- IP address of edit maker - time_ timestamp NOT NULL -- When the edit was created + time_ timestamptz NOT NULL -- When the edit was created ); |] diff --git a/back/src/Guide/Database/Types.hs b/back/src/Guide/Database/Types.hs new file mode 100644 index 0000000..387aeb5 --- /dev/null +++ b/back/src/Guide/Database/Types.hs @@ -0,0 +1,17 @@ +-- | Types for postgres database +module Guide.Database.Types + ( + DatabaseError(..) + ) where + +import Imports + +import Guide.Types.Core (Category (..), Item (..)) +import Guide.Utils (Uid (..)) + + +-- | Custom datatype errors for database +data DatabaseError + = ItemNotFound (Uid Item) + | CategoryNotFound (Uid Category) + deriving Show diff --git a/back/src/Guide/Db.hs b/back/src/Guide/Db.hs deleted file mode 100644 index b43e29a..0000000 --- a/back/src/Guide/Db.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Guide.Db -( - module Guide.Db.Schema -) -where - -import Guide.Db.Schema diff --git a/back/src/Guide/Main.hs b/back/src/Guide/Main.hs index 4ba1e08..ad9caf6 100644 --- a/back/src/Guide/Main.hs +++ b/back/src/Guide/Main.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -28,8 +27,6 @@ import Control.Concurrent.Async import Safe (headDef) -- Monads and monad transformers import Control.Monad.Morph --- Text -import NeatInterpolation (text) -- Web import Lucid hiding (for_) import Network.Wai.Middleware.Static (addBase, staticPolicy) @@ -261,9 +258,9 @@ guideApp waiMetrics = do Spock.get "/js.js" $ do setHeader "Content-Type" "application/javascript; charset=utf-8" (csrfTokenName, csrfTokenValue) <- getCsrfHeader - let jqueryCsrfProtection = [text| - guidejs.csrfProtection.enable("$csrfTokenName", "$csrfTokenValue"); - |] + let jqueryCsrfProtection = + format "guidejs.csrfProtection.enable(\"{}\", \"{}\");" + csrfTokenName csrfTokenValue js <- getJS Spock.bytes $ toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection) -- CSS diff --git a/back/src/Guide/Types/Core.hs b/back/src/Guide/Types/Core.hs index dd0af15..11210a8 100644 --- a/back/src/Guide/Types/Core.hs +++ b/back/src/Guide/Types/Core.hs @@ -19,6 +19,7 @@ module Guide.Types.Core ( Trait(..), + TraitType (..), ItemKind(..), hackageName, ItemSection(..), @@ -102,6 +103,10 @@ instance A.ToJSON Trait where toJSON = A.genericToJSON A.defaultOptions { A.fieldLabelModifier = over _head toLower . drop (T.length "_trait") } +-- | ADT for traitType +data TraitType = Pro | Con + deriving Eq + ---------------------------------------------------------------------------- -- Item ---------------------------------------------------------------------------- diff --git a/back/src/Guide/Views/Page.hs b/back/src/Guide/Views/Page.hs index 6761f4c..e585d70 100644 --- a/back/src/Guide/Views/Page.hs +++ b/back/src/Guide/Views/Page.hs @@ -30,7 +30,7 @@ where import Imports import Lucid hiding (for_) -import NeatInterpolation +import Text.RawString.QQ (r) import Guide.Config import Guide.JS (JS (..)) @@ -131,7 +131,7 @@ headTagDef page = do unless (T.null googleToken) $ meta_ [name_ "google-site-verification", content_ googleToken] -- Report all Javascript errors with alerts - script_ [text| + script_ [r| window.onerror = function (msg, url, lineNo, columnNo, error) { alert("Error in "+url+" at "+lineNo+":"+columnNo+": "+msg+ "\n\n"+ @@ -145,10 +145,10 @@ headTagDef page = do onPageLoad (JS "autosize($('textarea'));") -- CSS that makes 'shown' and 'noScriptShown' work; -- see Note [show-hide] - noscript_ $ style_ [text| + noscript_ $ style_ [r| .section:not(.noscript-shown) {display:none;} |] - script_ [text| + script_ [r| var sheet = document.createElement('style'); sheet.innerHTML = '.section:not(.shown) {display:none;}'; // “head” instead of “body” because body isn't loaded yet diff --git a/back/src/Guide/Views/Utils.hs b/back/src/Guide/Views/Utils.hs index bae0444..a0e1607 100644 --- a/back/src/Guide/Views/Utils.hs +++ b/back/src/Guide/Views/Utils.hs @@ -64,7 +64,6 @@ import Web.Spock.Config import Data.List.Split -- digestive-functors import Text.Digestive (View) --- import NeatInterpolation -- Web import Lucid hiding (for_) import Lucid.Base (makeAttribute) diff --git a/stack.yaml b/stack.yaml index 3d19727..ebc9fde 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,6 +21,7 @@ extra-deps: - lzma-clib-5.2.2 - regex-1.0.1.5 - hasql-1.4 +- hasql-transaction-0.7.2 # Old versions from LTS 12+ (can and should be upgraded) - megaparsec-6.5.0