[#500] Trails: Copy-paste code from OrgRegistry to implement database…

… structures.

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

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

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)

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

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