From 0da58adc2ea2764a4e99b13bd4b1de3b480d2932 Mon Sep 17 00:00:00 2001 From: Ashley Stacey Date: Mon, 29 Jul 2019 14:14:42 +1000 Subject: [PATCH] [#500] Trails: Copy-paste code from OrgRegistry to implement database structures. --- .../src/Mirza/Trails/Database/Migrate.hs | 42 ++++++ .../src/Mirza/Trails/Database/Schema.hs | 35 +++++ .../src/Mirza/Trails/Database/Schema/V0001.hs | 135 ++++++++++++++++++ projects/trails/src/Mirza/Trails/Main.hs | 36 ++--- projects/trails/src/Mirza/Trails/Types.hs | 72 +++++++--- projects/trails/trails.cabal | 12 +- 6 files changed, 297 insertions(+), 35 deletions(-) create mode 100644 projects/trails/src/Mirza/Trails/Database/Migrate.hs create mode 100644 projects/trails/src/Mirza/Trails/Database/Schema.hs create mode 100644 projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs diff --git a/projects/trails/src/Mirza/Trails/Database/Migrate.hs b/projects/trails/src/Mirza/Trails/Database/Migrate.hs new file mode 100644 index 00000000..f0aa14f5 --- /dev/null +++ b/projects/trails/src/Mirza/Trails/Database/Migrate.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Mirza.Trails.Database.Migrate ( migrations + , runMigrationSimple + , dropTablesSimple + ) where + + +import Mirza.Trails.Database.Schema.V0001 + +import Mirza.Common.Database + +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.Types + +import Data.Text.Encoding + + +migrations :: [Migration] +migrations = [ m_0001 ] + +m_0001 :: Migration +m_0001 conn = do + _ <- execute_ conn $ Query $ encodeUtf8 $ "CREATE TABLE " <> entriesTName + <> "(" + <> entriesTFieldSignature <> " TEXT PRIMARY KEY, " + <> entriesTFieldTimestamp <> " TIMESTAMP NOT NULL, " + <> entriesTFieldGS1CompanyPrefix <> " TEXT NOT NULL, " + <> entriesTFieldEventId <> " UUID NOT NULL, " + <> "last_update TIMESTAMP " + <> ");" + createTrigger conn $ Query $ encodeUtf8 entriesTName + + _ <- execute_ conn $ Query $ encodeUtf8 $ "CREATE TABLE " <> parentsTName + <> "(" + <> parentsTFieldSignature <> " TEXT NOT NULL REFERENCES " <> entriesTName <> "(" <> entriesTFieldSignature <> ") ON DELETE CASCADE, " + <> parentsTFieldParentSignature <> " TEXT NOT NULL REFERENCES " <> entriesTName <> "(" <> entriesTFieldSignature <> "), " + <> "last_update TIMESTAMP, " + <> "PRIMARY KEY(" <> parentsTFieldSignature <> ", " <> parentsTFieldParentSignature <>")" + <> ");" + createTrigger conn $ Query $ encodeUtf8 parentsTName diff --git a/projects/trails/src/Mirza/Trails/Database/Schema.hs b/projects/trails/src/Mirza/Trails/Database/Schema.hs new file mode 100644 index 00000000..e93d1c21 --- /dev/null +++ b/projects/trails/src/Mirza/Trails/Database/Schema.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Mirza.Trails.Database.Schema + ( module Current + , migration + , trailsDB + , checkedTrailsDB + , primaryKey + ) where + + +import Mirza.Trails.Database.Schema.V0001 as Current hiding + (migration) + +import qualified Mirza.Trails.Database.Schema.V0001 as V0001 (migration) +-- import qualified Mirza.Trails.Database.Schema.V0002 as V0002 (migration) + +import Database.Beam (DatabaseSettings) +import Database.Beam.Migrate.Types hiding (migrateScript) +import Database.Beam.Postgres (Postgres) +import Database.Beam.Schema.Tables (primaryKey) + +--import Control.Arrow ( (>>>) ) + + +migration :: MigrationSteps Postgres () (CheckedDatabaseSettings Postgres Current.TrailsDB) +migration = migrationStep "Initial commit" V0001.migration +-- >>> migrationStep "TBA" V0002.migration + +trailsDB :: DatabaseSettings Postgres Current.TrailsDB +trailsDB = unCheckDatabase checkedTrailsDB + +checkedTrailsDB :: CheckedDatabaseSettings Postgres Current.TrailsDB +checkedTrailsDB = evaluateDatabase migration diff --git a/projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs b/projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs new file mode 100644 index 00000000..da505ae9 --- /dev/null +++ b/projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module contains all the table definitions +-- Convention: Table types and constructors are suffixed with T (for Table). +module Mirza.Trails.Database.Schema.V0001 where + + +import Mirza.Trails.Types + +import Mirza.Common.Beam (defaultFkConstraint, + lastUpdateField) +import Mirza.Common.GS1BeamOrphans + +import Data.GS1.EPC (GS1CompanyPrefix) + +import Database.Beam as B +import Database.Beam.Migrate.SQL as BSQL +import Database.Beam.Migrate.Types +import Database.Beam.Postgres (Postgres) +import Database.Beam.Postgres.Migrate (uuid) + +import Control.Lens + +import Data.Text +import Data.Time (LocalTime) +import Data.UUID (UUID) + +import GHC.Generics (Generic) + + +-- Convention: Table types and constructors are suffixed with T (for Table). + +-- Database +data TrailsDB f = TrailsDB + { _entries :: f (TableEntity EntriesT) + , _parents :: f (TableEntity ParentsT) + } + deriving Generic +instance Database anybackend TrailsDB + + +-- Migration: Intialisation -> V1. +migration :: () -> Migration Postgres (CheckedDatabaseSettings Postgres TrailsDB) +migration () = do + entriesT <- createTable entriesTName $ + EntriesT (field entriesTFieldSignature signatureType notNull) + (field entriesTFieldTimestamp timestamp notNull) + (field entriesTFieldGS1CompanyPrefix gs1CompanyPrefixFieldType notNull) + (field entriesTFieldEventId uuid notNull) + lastUpdateField + + parentsT <- createTable parentsTName $ + ParentsT (EntriesPrimaryKey $ field parentsTFieldSignature signatureType notNull (defaultFkConstraint entriesTName [entriesTFieldSignature])) + (field parentsTFieldParentSignature signatureType notNull) + + pure $ TrailsDB entriesT parentsT + +-- Table names +entriesTName :: Text +entriesTName = "entries" +entriesTFieldSignature :: Text +entriesTFieldSignature = "entries_signature" +entriesTFieldTimestamp :: Text +entriesTFieldTimestamp = "entries_timestanp" +entriesTFieldGS1CompanyPrefix :: Text +entriesTFieldGS1CompanyPrefix = "entries_gs1_company_prefix" +entriesTFieldEventId :: Text +entriesTFieldEventId = "entries_event_id" + +parentsTName :: Text +parentsTName = "parents" +parentsTFieldSignature :: Text +parentsTFieldSignature = "parents_" <> entriesTFieldSignature +parentsTFieldParentSignature :: Text +parentsTFieldParentSignature = "parents_parent_signature" + + +-------------------------------------------------------------------------------- +-- Entries table +-------------------------------------------------------------------------------- + +type Entries = EntriesT Identity +deriving instance Show Entries + +data EntriesT f = EntriesT + { entries_signature :: C f SignaturePlaceholder + , entries_timestamp :: C f LocalTime + , entries_gs1company_prefix :: C f GS1CompanyPrefix + , entries_event_id :: C f UUID + , entries_last_update :: C f (Maybe LocalTime) + } deriving Generic + +type EntriesPrimaryKey = PrimaryKey EntriesT Identity +deriving instance Show (PrimaryKey EntriesT Identity) + +instance Beamable EntriesT +instance Beamable (PrimaryKey EntriesT) + +instance Table EntriesT where + data PrimaryKey EntriesT f = EntriesPrimaryKey (C f SignaturePlaceholder) + deriving Generic + primaryKey = EntriesPrimaryKey . entries_signature +deriving instance Eq (PrimaryKey EntriesT Identity) + + +-------------------------------------------------------------------------------- +-- Parent table +-------------------------------------------------------------------------------- + +type Parents = ParentsT Identity +deriving instance Show Parents + +data ParentsT f = ParentsT + { parents_entry_signature :: PrimaryKey EntriesT f + , parents_parent_signature :: C f SignaturePlaceholder + } deriving Generic + +type ParentsPrimaryKey = PrimaryKey ParentsT Identity +deriving instance Show (PrimaryKey ParentsT Identity) + +instance Beamable ParentsT +instance Beamable (PrimaryKey ParentsT) + +instance Table ParentsT where + data PrimaryKey ParentsT f = ParentMapping (PrimaryKey EntriesT f) (C f SignaturePlaceholder) + deriving Generic + primaryKey = ParentMapping <$> parents_entry_signature <*> parents_parent_signature +deriving instance Eq (PrimaryKey ParentsT Identity) diff --git a/projects/trails/src/Mirza/Trails/Main.hs b/projects/trails/src/Mirza/Trails/Main.hs index 4e5b1af1..e80676ec 100644 --- a/projects/trails/src/Mirza/Trails/Main.hs +++ b/projects/trails/src/Mirza/Trails/Main.hs @@ -7,31 +7,35 @@ module Mirza.Trails.Main where import Mirza.Trails.API +import Mirza.Trails.Database.Migrate import Mirza.Trails.Service import Mirza.Trails.Types import Mirza.Common.Types +import Katip as K + import Servant import Servant.Swagger.UI -import qualified Data.Pool as Pool import Database.PostgreSQL.Simple -import Network.Wai (Middleware) -import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.Wai.Middleware.Cors as CorsMiddleware +import Network.Wai (Middleware) +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Middleware.Cors as CorsMiddleware + +import Control.Exception (finally) +import System.IO (FilePath, IOMode (AppendMode), + hPutStr, openFile, stderr, + stdout) -import Data.ByteString (ByteString) -import Data.Semigroup ((<>)) -import Data.Text (pack) -import Options.Applicative hiding (action) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) +import qualified Data.Pool as Pool +import Data.Semigroup ((<>)) +import Data.Text (pack) +import Options.Applicative hiding (action) -import Control.Exception (finally) -import Data.Maybe (fromMaybe) -import Katip as K -import System.IO (FilePath, IOMode (AppendMode), - hPutStr, openFile, stderr, stdout) -------------------------------------------------------------------------------- @@ -156,9 +160,9 @@ server context = runMigration :: ServerOptionsTrails -> IO () runMigration opts = do - _ctx <- initTrailsContext opts - --res <- runMigrationWithConfirmation @ORContextMinimal @SqlError ctx interactiveMigrationConfirm - --print res + ctx <- initTrailsContext opts + res <- runMigrationSimple @TrailsContext @SqlError ctx migrations + print res pure () -------------------------------------------------------------------------------- diff --git a/projects/trails/src/Mirza/Trails/Types.hs b/projects/trails/src/Mirza/Trails/Types.hs index f189618b..835ffb20 100644 --- a/projects/trails/src/Mirza/Trails/Types.hs +++ b/projects/trails/src/Mirza/Trails/Types.hs @@ -1,35 +1,50 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} module Mirza.Trails.Types where +import Mirza.Common.Beam import Mirza.Common.Time import Mirza.Common.Types -import Data.GS1.EPC (GS1CompanyPrefix) -import Data.GS1.EventId (EventId) +import Data.GS1.EPC (GS1CompanyPrefix) +import Data.GS1.EventId (EventId) -import Database.PostgreSQL.Simple (Connection, SqlError) +import qualified Database.Beam as B +import qualified Database.Beam.Backend.SQL as BSQL +import Database.Beam.Postgres (Postgres) +import qualified Database.Beam.Postgres as BPostgres +import Database.Beam.Postgres.Syntax (pgTextType, + pgUnboundedArrayType) +import Database.PostgreSQL.Simple (Connection, SqlError) +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField (ToField, toField) -import Katip as K +import Katip as K -import Data.Aeson (FromJSON (..), ToJSON (..), object, - withObject, (.:), (.=)) +import Data.Swagger (ToParamSchema, ToSchema) -import Data.Swagger (ToParamSchema, ToSchema) +import Servant (FromHttpApiData (..), + ToHttpApiData (..)) -import Servant (FromHttpApiData (..), - ToHttpApiData (..)) +import Data.Aeson (FromJSON (..), + ToJSON (..), object, + withObject, (.:), (.=)) -import Control.Lens hiding ((.=)) +import Control.Lens hiding ((.=)) -import Data.Pool as Pool +import Data.Pool as Pool import Data.Text -import Data.Time (UTCTime) -import GHC.Generics (Generic) +import Data.Time (UTCTime) + +import GHC.Generics (Generic) -- ***************************************************************************** @@ -123,6 +138,7 @@ instance ModelTimestamp EntryTime where fromDbTimestamp = onLocalTime EntryTime + newtype SignaturePlaceholder = SignaturePlaceholder {getSignature :: Text} deriving (Show, Eq, Generic, Read, Ord) instance FromJSON SignaturePlaceholder where @@ -137,6 +153,30 @@ instance ToHttpApiData SignaturePlaceholder where toUrlPiece (SignaturePlaceholder sig) = toUrlPiece sig +instance BSQL.HasSqlValueSyntax be String => + BSQL.HasSqlValueSyntax be SignaturePlaceholder where + sqlValueSyntax (SignaturePlaceholder sig) = BSQL.sqlValueSyntax $ unpack sig + +instance BSQL.BeamSqlBackend be => B.HasSqlEqualityCheck be SignaturePlaceholder +instance BSQL.BeamSqlBackend be => B.HasSqlQuantifiedEqualityCheck be SignaturePlaceholder + +instance BSQL.FromBackendRow BPostgres.Postgres SignaturePlaceholder where + fromBackendRow = SignaturePlaceholder <$> BSQL.fromBackendRow + +instance FromField SignaturePlaceholder where + fromField mbs conv = SignaturePlaceholder <$> fromField mbs conv + +instance ToField SignaturePlaceholder where + toField (SignaturePlaceholder sig) = toField (unpack sig) + +signatureType :: B.DataType Postgres SignaturePlaceholder +signatureType = textType + +signaturesType :: B.DataType Postgres [SignaturePlaceholder] +signaturesType = B.DataType (pgUnboundedArrayType pgTextType) + + + -- ***************************************************************************** -- Error Types -- ***************************************************************************** diff --git a/projects/trails/trails.cabal b/projects/trails/trails.cabal index 79def7c1..980229ea 100644 --- a/projects/trails/trails.cabal +++ b/projects/trails/trails.cabal @@ -28,6 +28,9 @@ library exposed-modules: Mirza.Trails.API Mirza.Trails.Client.Servant + Mirza.Trails.Database.Migrate + Mirza.Trails.Database.Schema + Mirza.Trails.Database.Schema.V0001 Mirza.Trails.Handlers.Health Mirza.Trails.Handlers.Trails Mirza.Trails.Main @@ -40,10 +43,11 @@ library , mirza-common-haskell , mirza-test-utils-haskell , GS1Combinators - , servant - , servant-client , aeson , attoparsec + , beam-core + , beam-migrate + , beam-postgres , bytestring , insert-ordered-containers , katip @@ -53,14 +57,16 @@ library , optparse-applicative , postgresql-simple , resource-pool + , servant + , servant-client , servant-server , servant-swagger , servant-swagger-ui , swagger2 , text , time - , wai , uuid + , wai , wai-cors , warp default-language: Haskell2010