1
1
mirror of https://github.com/aelve/guide.git synced 2024-12-23 04:42:24 +03:00

Add get functions for categories, traits and items (#339)

This commit is contained in:
Vladislav Sabanov 2019-07-25 17:17:29 +05:00 committed by Artyom Kazak
parent 9f8f0a2262
commit 36a92f9bf7
16 changed files with 609 additions and 80 deletions

2
.gitignore vendored
View File

@ -22,6 +22,8 @@ cabal.config
*.swp *.swp
*.swo *.swo
*# *#
*.lock
# IDE/support # IDE/support
.idea/ .idea/

View File

@ -56,8 +56,12 @@ library
Guide.Api.Error Guide.Api.Error
Guide.Api.Utils Guide.Api.Utils
Guide.Api.Guider Guide.Api.Guider
Guide.Db Guide.Database
Guide.Db.Schema Guide.Database.Connection
Guide.Database.Convert
Guide.Database.Get
Guide.Database.Schema
Guide.Database.Types
Guide.Logger Guide.Logger
Guide.Logger.Types Guide.Logger.Types
Guide.Logger.Functions Guide.Logger.Functions
@ -108,6 +112,7 @@ library
, cmark-highlight == 0.2.* , cmark-highlight == 0.2.*
, cmark-sections == 0.3.* , cmark-sections == 0.3.*
, containers >= 0.5 , containers >= 0.5
, contravariant-extras
, data-default >= 0.5 , data-default >= 0.5
, deepseq >= 1.2.0.0 , deepseq >= 1.2.0.0
, df1 , df1
@ -129,6 +134,7 @@ library
, hashable , hashable
, haskell-src-meta , haskell-src-meta
, hasql , hasql
, hasql-transaction
, http-api-data , http-api-data
, http-client , http-client
, http-client-tls , http-client-tls
@ -143,11 +149,13 @@ library
, microlens-platform >= 0.3.2 , microlens-platform >= 0.3.2
, mmorph == 1.* , mmorph == 1.*
, mtl >= 2.1.1 , mtl >= 2.1.1
, named
, neat-interpolation == 0.3.* , neat-interpolation == 0.3.*
, network , network
, network-uri , network-uri
, patches-vector , patches-vector
, random >= 1.1 , random >= 1.1
, raw-strings-qq
, reroute , reroute
, safe , safe
, safecopy , safecopy

View File

@ -199,8 +199,8 @@ createTrait itemId CCreateTrait{..} =
throwError err400{errReasonPhrase = "'content' can not be empty"} throwError err400{errReasonPhrase = "'content' can not be empty"}
traitId <- randomShortUid traitId <- randomShortUid
addEdit . fst =<< case cctType of addEdit . fst =<< case cctType of
Con -> dbUpdate (AddCon itemId traitId cctContent) CCon -> dbUpdate (AddCon itemId traitId cctContent)
Pro -> dbUpdate (AddPro itemId traitId cctContent) CPro -> dbUpdate (AddPro itemId traitId cctContent)
pure traitId pure traitId
-- | Update the text of a trait (pro/con). -- | Update the text of a trait (pro/con).

View File

@ -308,17 +308,27 @@ type Api = RequestDetails :> ToServant Site AsApi
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- | Trait type (Pro/Con) and instances. -- | Trait type (Pro/Con) and instances.
data CTraitType = Pro | Con data CTraitType = CPro | CCon
deriving (Show, Generic) deriving (Show, Generic)
instance ToSchema CTraitType where instance ToSchema CTraitType where
declareNamedSchema = genericDeclareNamedSchema schemaOptions declareNamedSchema = genericDeclareNamedSchema schemaOptions
{ constructorTagModifier = \case
"CPro" -> "Pro"
"CCon" -> "Con"
other -> error ("CTraitType schema: unknown value " <> show other)
}
instance A.ToJSON CTraitType where instance A.ToJSON CTraitType where
toJSON = A.genericToJSON jsonOptions toJSON = \case
CPro -> "Pro"
CCon -> "Con"
instance A.FromJSON CTraitType where 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 -- CDirection
@ -333,7 +343,7 @@ instance ToSchema CDirection where
{ constructorTagModifier = \case { constructorTagModifier = \case
"DirectionUp" -> "up" "DirectionUp" -> "up"
"DirectionDown" -> "down" "DirectionDown" -> "down"
other -> error ("Direction schema: unknown tag " <> show other) other -> error ("CDirection schema: unknown value " <> show other)
} }
instance A.ToJSON CDirection where instance A.ToJSON CDirection where
@ -342,10 +352,10 @@ instance A.ToJSON CDirection where
DirectionDown -> "down" DirectionDown -> "down"
instance A.FromJSON CDirection where instance A.FromJSON CDirection where
parseJSON = \case parseJSON = A.withText "CDirection" $ \case
"up" -> pure DirectionUp "up" -> pure DirectionUp
"down" -> pure DirectionDown "down" -> pure DirectionDown
tag -> fail ("unknown direction " ++ show tag) other -> fail ("unknown direction " <> show other)
---------------------------------------------------------------------------- ----------------------------------------------------------------------------
-- CCreateItem -- CCreateItem

View File

@ -0,0 +1,9 @@
module Guide.Database
(
module Guide.Database.Schema,
module Guide.Database.Get
)
where
import Guide.Database.Schema
import Guide.Database.Get

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -2,7 +2,8 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Guide.Db.Schema -- | Schemas to create table for guide database
module Guide.Database.Schema
( (
setupDatabase, setupDatabase,
) )
@ -11,15 +12,15 @@ where
import Imports import Imports
import Hasql.Session (Session) import Hasql.Session (Session)
import NeatInterpolation import Text.RawString.QQ
import Hasql.Connection (Connection, Settings)
import Hasql.Statement (Statement (..)) import Hasql.Statement (Statement (..))
import qualified Hasql.Session as HS import qualified Hasql.Session as HS
import qualified Hasql.Connection as HC
import qualified Hasql.Encoders as HE import qualified Hasql.Encoders as HE
import qualified Hasql.Decoders as HD import qualified Hasql.Decoders as HD
import Guide.Database.Connection (connect, runSession)
-- | List of all migrations. -- | List of all migrations.
migrations :: [(Int32, Session ())] migrations :: [(Int32, Session ())]
@ -41,7 +42,7 @@ migrations =
setupDatabase :: IO () setupDatabase :: IO ()
setupDatabase = do setupDatabase = do
conn <- connect conn <- connect
mbSchemaVersion <- run' getSchemaVersion conn mbSchemaVersion <- runSession conn getSchemaVersion
case mbSchemaVersion of case mbSchemaVersion of
Nothing -> formatLn "No schema found. Creating tables and running all migrations." Nothing -> formatLn "No schema found. Creating tables and running all migrations."
Just v -> formatLn "Schema version is {}." v Just v -> formatLn "Schema version is {}." v
@ -49,43 +50,9 @@ setupDatabase = do
for_ migrations $ \(migrationVersion, migration) -> for_ migrations $ \(migrationVersion, migration) ->
when (migrationVersion > schemaVersion) $ do when (migrationVersion > schemaVersion) $ do
format "Migration {}: " migrationVersion format "Migration {}: " migrationVersion
run' (migration >> setSchemaVersion migrationVersion) conn runSession conn (migration >> setSchemaVersion migrationVersion)
formatLn "done." 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 -- 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. -- If the @schema_version@ table doesn't exist, creates it.
getSchemaVersion :: Session (Maybe Int32) getSchemaVersion :: Session (Maybe Int32)
getSchemaVersion = do getSchemaVersion = do
HS.sql $ toByteString [text| HS.sql [r|
CREATE TABLE IF NOT EXISTS schema_version ( CREATE TABLE IF NOT EXISTS schema_version (
name text PRIMARY KEY, name text PRIMARY KEY,
version integer version integer
@ -136,13 +103,13 @@ v0 = do
-- | Create an enum type for trait type ("pro" or "con"). -- | Create an enum type for trait type ("pro" or "con").
v0_createTypeProCon :: Session () v0_createTypeProCon :: Session ()
v0_createTypeProCon = HS.sql $ toByteString [text| v0_createTypeProCon = HS.sql [r|
CREATE TYPE trait_type AS ENUM ('pro', 'con'); CREATE TYPE trait_type AS ENUM ('pro', 'con');
|] |]
-- | Create table @traits@, corresponding to 'Guide.Types.Core.Trait'. -- | Create table @traits@, corresponding to 'Guide.Types.Core.Trait'.
v0_createTableTraits :: Session () v0_createTableTraits :: Session ()
v0_createTableTraits = HS.sql $ toByteString [text| v0_createTableTraits = HS.sql [r|
CREATE TABLE traits ( CREATE TABLE traits (
uid text PRIMARY KEY, -- Unique trait ID uid text PRIMARY KEY, -- Unique trait ID
content text NOT NULL, -- Trait content as Markdown content text NOT NULL, -- Trait content as Markdown
@ -158,11 +125,11 @@ v0_createTableTraits = HS.sql $ toByteString [text|
-- | Create table @items@, corresponding to 'Guide.Types.Core.Item'. -- | Create table @items@, corresponding to 'Guide.Types.Core.Item'.
v0_createTableItems :: Session () v0_createTableItems :: Session ()
v0_createTableItems = HS.sql $ toByteString [text| v0_createTableItems = HS.sql [r|
CREATE TABLE items ( CREATE TABLE items (
uid text PRIMARY KEY, -- Unique item ID uid text PRIMARY KEY, -- Unique item ID
name text NOT NULL, -- Item title 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 group_ text, -- Optional group
link text, -- Optional URL link text, -- Optional URL
hackage text, -- Package name on Hackage 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'. -- | Create table @categories@, corresponding to 'Guide.Types.Core.Category'.
v0_createTableCategories :: Session () v0_createTableCategories :: Session ()
v0_createTableCategories = HS.sql $ toByteString [text| v0_createTableCategories = HS.sql [r|
CREATE TABLE categories ( CREATE TABLE categories (
uid text PRIMARY KEY, -- Unique category ID uid text PRIMARY KEY, -- Unique category ID
title text NOT NULL, -- Category title 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" group_ text NOT NULL, -- "Grandcategory"
status_ text NOT NULL, -- Category status ("in progress", etc); the list of status_ text NOT NULL, -- Category status ("in progress", etc); the list of
-- possible statuses is defined by backend -- possible statuses is defined by backend
@ -196,7 +163,7 @@ v0_createTableCategories = HS.sql $ toByteString [text|
-- | Create table @users@, storing user data. -- | Create table @users@, storing user data.
v0_createTableUsers :: Session () v0_createTableUsers :: Session ()
v0_createTableUsers = HS.sql $ toByteString [text| v0_createTableUsers = HS.sql [r|
CREATE TABLE users ( CREATE TABLE users (
uid text PRIMARY KEY, -- Unique user ID uid text PRIMARY KEY, -- Unique user ID
name text NOT NULL, -- User name 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 -- | Create table @pending_edits@, storing users' edits and metadata about
-- them (who made the edit, when, etc). -- them (who made the edit, when, etc).
v0_createTablePendingEdits :: Session () v0_createTablePendingEdits :: Session ()
v0_createTablePendingEdits = HS.sql $ toByteString [text| v0_createTablePendingEdits = HS.sql [r|
CREATE TABLE pending_edits ( CREATE TABLE pending_edits (
uid bigserial PRIMARY KEY, -- Unique id uid bigserial PRIMARY KEY, -- Unique id
edit json NOT NULL, -- Edit in JSON format edit json NOT NULL, -- Edit in JSON format
ip inet, -- IP address of edit maker 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
); );
|] |]

View File

@ -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

View File

@ -1,7 +0,0 @@
module Guide.Db
(
module Guide.Db.Schema
)
where
import Guide.Db.Schema

View File

@ -1,7 +1,6 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -28,8 +27,6 @@ import Control.Concurrent.Async
import Safe (headDef) import Safe (headDef)
-- Monads and monad transformers -- Monads and monad transformers
import Control.Monad.Morph import Control.Monad.Morph
-- Text
import NeatInterpolation (text)
-- Web -- Web
import Lucid hiding (for_) import Lucid hiding (for_)
import Network.Wai.Middleware.Static (addBase, staticPolicy) import Network.Wai.Middleware.Static (addBase, staticPolicy)
@ -261,9 +258,9 @@ guideApp waiMetrics = do
Spock.get "/js.js" $ do Spock.get "/js.js" $ do
setHeader "Content-Type" "application/javascript; charset=utf-8" setHeader "Content-Type" "application/javascript; charset=utf-8"
(csrfTokenName, csrfTokenValue) <- getCsrfHeader (csrfTokenName, csrfTokenValue) <- getCsrfHeader
let jqueryCsrfProtection = [text| let jqueryCsrfProtection =
guidejs.csrfProtection.enable("$csrfTokenName", "$csrfTokenValue"); format "guidejs.csrfProtection.enable(\"{}\", \"{}\");"
|] csrfTokenName csrfTokenValue
js <- getJS js <- getJS
Spock.bytes $ toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection) Spock.bytes $ toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
-- CSS -- CSS

View File

@ -19,6 +19,7 @@
module Guide.Types.Core module Guide.Types.Core
( (
Trait(..), Trait(..),
TraitType (..),
ItemKind(..), ItemKind(..),
hackageName, hackageName,
ItemSection(..), ItemSection(..),
@ -102,6 +103,10 @@ instance A.ToJSON Trait where
toJSON = A.genericToJSON A.defaultOptions { toJSON = A.genericToJSON A.defaultOptions {
A.fieldLabelModifier = over _head toLower . drop (T.length "_trait") } A.fieldLabelModifier = over _head toLower . drop (T.length "_trait") }
-- | ADT for traitType
data TraitType = Pro | Con
deriving Eq
---------------------------------------------------------------------------- ----------------------------------------------------------------------------
-- Item -- Item
---------------------------------------------------------------------------- ----------------------------------------------------------------------------

View File

@ -30,7 +30,7 @@ where
import Imports import Imports
import Lucid hiding (for_) import Lucid hiding (for_)
import NeatInterpolation import Text.RawString.QQ (r)
import Guide.Config import Guide.Config
import Guide.JS (JS (..)) import Guide.JS (JS (..))
@ -131,7 +131,7 @@ headTagDef page = do
unless (T.null googleToken) $ unless (T.null googleToken) $
meta_ [name_ "google-site-verification", content_ googleToken] meta_ [name_ "google-site-verification", content_ googleToken]
-- Report all Javascript errors with alerts -- Report all Javascript errors with alerts
script_ [text| script_ [r|
window.onerror = function (msg, url, lineNo, columnNo, error) { window.onerror = function (msg, url, lineNo, columnNo, error) {
alert("Error in "+url+" at "+lineNo+":"+columnNo+": "+msg+ alert("Error in "+url+" at "+lineNo+":"+columnNo+": "+msg+
"\n\n"+ "\n\n"+
@ -145,10 +145,10 @@ headTagDef page = do
onPageLoad (JS "autosize($('textarea'));") onPageLoad (JS "autosize($('textarea'));")
-- CSS that makes 'shown' and 'noScriptShown' work; -- CSS that makes 'shown' and 'noScriptShown' work;
-- see Note [show-hide] -- see Note [show-hide]
noscript_ $ style_ [text| noscript_ $ style_ [r|
.section:not(.noscript-shown) {display:none;} .section:not(.noscript-shown) {display:none;}
|] |]
script_ [text| script_ [r|
var sheet = document.createElement('style'); var sheet = document.createElement('style');
sheet.innerHTML = '.section:not(.shown) {display:none;}'; sheet.innerHTML = '.section:not(.shown) {display:none;}';
// head instead of body because body isn't loaded yet // head instead of body because body isn't loaded yet

View File

@ -64,7 +64,6 @@ import Web.Spock.Config
import Data.List.Split import Data.List.Split
-- digestive-functors -- digestive-functors
import Text.Digestive (View) import Text.Digestive (View)
-- import NeatInterpolation
-- Web -- Web
import Lucid hiding (for_) import Lucid hiding (for_)
import Lucid.Base (makeAttribute) import Lucid.Base (makeAttribute)

View File

@ -21,6 +21,7 @@ extra-deps:
- lzma-clib-5.2.2 - lzma-clib-5.2.2
- regex-1.0.1.5 - regex-1.0.1.5
- hasql-1.4 - hasql-1.4
- hasql-transaction-0.7.2
# Old versions from LTS 12+ (can and should be upgraded) # Old versions from LTS 12+ (can and should be upgraded)
- megaparsec-6.5.0 - megaparsec-6.5.0