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

.gitignore

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

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

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).

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

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

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

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

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

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
   );
   |]

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

back/src/Guide/Db.hs

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

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

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

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

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)

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