diff --git a/projects/trails/src/Mirza/Trails/Database/Migrate.hs b/projects/trails/src/Mirza/Trails/Database/Migrate.hs index f0aa14f5..d84dbce9 100644 --- a/projects/trails/src/Mirza/Trails/Database/Migrate.hs +++ b/projects/trails/src/Mirza/Trails/Database/Migrate.hs @@ -32,11 +32,11 @@ m_0001 conn = do <> ");" createTrigger conn $ Query $ encodeUtf8 entriesTName - _ <- execute_ conn $ Query $ encodeUtf8 $ "CREATE TABLE " <> parentsTName + _ <- execute_ conn $ Query $ encodeUtf8 $ "CREATE TABLE " <> previousTName <> "(" - <> parentsTFieldSignature <> " TEXT NOT NULL REFERENCES " <> entriesTName <> "(" <> entriesTFieldSignature <> ") ON DELETE CASCADE, " - <> parentsTFieldParentSignature <> " TEXT NOT NULL REFERENCES " <> entriesTName <> "(" <> entriesTFieldSignature <> "), " + <> previousTFieldSignature <> " TEXT NOT NULL REFERENCES " <> entriesTName <> "(" <> entriesTFieldSignature <> ") ON DELETE CASCADE, " + <> previousTFieldPreviousSignature <> " TEXT NOT NULL REFERENCES " <> entriesTName <> "(" <> entriesTFieldSignature <> "), " <> "last_update TIMESTAMP, " - <> "PRIMARY KEY(" <> parentsTFieldSignature <> ", " <> parentsTFieldParentSignature <>")" + <> "PRIMARY KEY(" <> previousTFieldSignature <> ", " <> previousTFieldPreviousSignature <>")" <> ");" - createTrigger conn $ Query $ encodeUtf8 parentsTName + createTrigger conn $ Query $ encodeUtf8 previousTName diff --git a/projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs b/projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs index fc02991f..884a1ccc 100644 --- a/projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs +++ b/projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs @@ -37,8 +37,8 @@ import GHC.Generics (Generic) -- Database data TrailsDB f = TrailsDB - { _entries :: f (TableEntity EntriesT) - , _parents :: f (TableEntity ParentsT) + { _entries :: f (TableEntity EntriesT) + , _previous :: f (TableEntity PreviousT) } deriving Generic instance Database anybackend TrailsDB @@ -54,30 +54,30 @@ migration () = do (field entriesTFieldEventId uuid notNull) lastUpdateField - parentsT <- createTable parentsTName $ - ParentsT (EntriesPrimaryKey $ field parentsTFieldSignature signatureType notNull (defaultFkConstraint entriesTName [entriesTFieldSignature])) - (field parentsTFieldParentSignature signatureType notNull) + previousT <- createTable previousTName $ + PreviousT (EntriesPrimaryKey $ field previousTFieldSignature signatureType notNull (defaultFkConstraint entriesTName [entriesTFieldSignature])) + (field previousTFieldPreviousSignature signatureType notNull) - pure $ TrailsDB entriesT parentsT + pure $ TrailsDB entriesT previousT -- Table names entriesTName :: Text entriesTName = "entries" entriesTFieldSignature :: Text -entriesTFieldSignature = "entries_signature" +entriesTFieldSignature = entriesTName <> "_signature" entriesTFieldTimestamp :: Text -entriesTFieldTimestamp = "entries_timestanp" +entriesTFieldTimestamp = entriesTName <> "_timestanp" entriesTFieldGS1CompanyPrefix :: Text -entriesTFieldGS1CompanyPrefix = "entries_gs1_company_prefix" +entriesTFieldGS1CompanyPrefix = entriesTName <> "_gs1_company_prefix" entriesTFieldEventId :: Text -entriesTFieldEventId = "entries_event_id" +entriesTFieldEventId = entriesTName <> "_event_id" -parentsTName :: Text -parentsTName = "parents" -parentsTFieldSignature :: Text -parentsTFieldSignature = "parents_" <> entriesTFieldSignature -parentsTFieldParentSignature :: Text -parentsTFieldParentSignature = "parents_parent_signature" +previousTName :: Text +previousTName = "previous" +previousTFieldSignature :: Text +previousTFieldSignature = previousTName <> "_" <> entriesTFieldSignature +previousTFieldPreviousSignature :: Text +previousTFieldPreviousSignature = previousTName <> "previous_signature" -------------------------------------------------------------------------------- @@ -116,22 +116,22 @@ entriesPrimaryKeyToSignature (EntriesPrimaryKey sig) = sig -- Parent table -------------------------------------------------------------------------------- -type Parents = ParentsT Identity -deriving instance Show Parents +type Previous = PreviousT Identity +deriving instance Show Previous -data ParentsT f = ParentsT - { parents_entry_signature :: PrimaryKey EntriesT f - , parents_parent_signature :: C f SignaturePlaceholder +data PreviousT f = PreviousT + { previous_entry_signature :: PrimaryKey EntriesT f + , previous_previous_signature :: C f SignaturePlaceholder -- Note: The naming convention is table and then field name so it looks weird but its the previous table and its the previous_signature field. } deriving Generic -type ParentsPrimaryKey = PrimaryKey ParentsT Identity -deriving instance Show (PrimaryKey ParentsT Identity) +type PreviousPrimaryKey = PrimaryKey PreviousT Identity +deriving instance Show (PrimaryKey PreviousT Identity) -instance Beamable ParentsT -instance Beamable (PrimaryKey ParentsT) +instance Beamable PreviousT +instance Beamable (PrimaryKey PreviousT) -instance Table ParentsT where - data PrimaryKey ParentsT f = ParentMapping (PrimaryKey EntriesT f) (C f SignaturePlaceholder) +instance Table PreviousT where + data PrimaryKey PreviousT f = ParentMapping (PrimaryKey EntriesT f) (C f SignaturePlaceholder) deriving Generic - primaryKey = ParentMapping <$> parents_entry_signature <*> parents_parent_signature -deriving instance Eq (PrimaryKey ParentsT Identity) + primaryKey = ParentMapping <$> previous_entry_signature <*> previous_previous_signature +deriving instance Eq (PrimaryKey PreviousT Identity) diff --git a/projects/trails/src/Mirza/Trails/Handlers/Trails.hs b/projects/trails/src/Mirza/Trails/Handlers/Trails.hs index 1b72d64f..aa816e11 100644 --- a/projects/trails/src/Mirza/Trails/Handlers/Trails.hs +++ b/projects/trails/src/Mirza/Trails/Handlers/Trails.hs @@ -50,33 +50,33 @@ getTrailBySignature sig = do getTrailBySignatureQuery :: (AsTrailsServiceError err) => SignaturePlaceholder -> DB context err [TrailEntryResponse] getTrailBySignatureQuery searchSignature = do - parentEntries <- getParentsBySignatureQuery searchSignature - childEntries <- getChildrenQuery searchSignature - pure $ childEntries <> parentEntries + previousEntries <- getPreviousEntriesBySignatureQuery searchSignature + followingEntries <- getPreviousEntriesQuery searchSignature + pure $ followingEntries <> previousEntries -getChildrenQuery :: (AsTrailsServiceError err) +getPreviousEntriesQuery :: (AsTrailsServiceError err) => SignaturePlaceholder -> DB context err [TrailEntryResponse] -getChildrenQuery searchSignature = do - childSignatures <- pg $ runSelectReturningList $ select $ do - parents <- all_ (_parents trailsDB) - guard_ (parents_parent_signature parents ==. val_ searchSignature) - pure $ (parents_entry_signature parents) +getPreviousEntriesQuery searchSignature = do + followingSignatures <- pg $ runSelectReturningList $ select $ do + previous <- all_ (_previous trailsDB) + guard_ (previous_previous_signature previous ==. val_ searchSignature) + pure $ (previous_entry_signature previous) - entries <- traverse getEntryBySignature (entriesPrimaryKeyToSignature <$> childSignatures) + entries <- traverse getEntryBySignature (entriesPrimaryKeyToSignature <$> followingSignatures) - childEntries <- concat <$> traverse getChildrenQuery (trailEntryResponseSignature <$> entries) + followingEntries <- concat <$> traverse getPreviousEntriesQuery (trailEntryResponseSignature <$> entries) - pure $ childEntries <> entries + pure $ followingEntries <> entries -getParentsBySignatureQuery :: (AsTrailsServiceError err) +getPreviousEntriesBySignatureQuery :: (AsTrailsServiceError err) => SignaturePlaceholder -> DB context err [TrailEntryResponse] -getParentsBySignatureQuery searchSignature = do +getPreviousEntriesBySignatureQuery searchSignature = do entry <- getEntryBySignature searchSignature - let parents = trailEntryResponseParentSignatures entry - parentEntries <- concat <$> traverse getParentsBySignatureQuery parents - pure $ entry : parentEntries + let previous = trailEntryResponseParentSignatures entry + previousEntries <- concat <$> traverse getPreviousEntriesBySignatureQuery previous + pure $ entry : previousEntries getEntryBySignature :: (AsTrailsServiceError err) @@ -89,19 +89,19 @@ getEntryBySignature searchSignature = do case maybeEntry of Nothing -> throwing_ _SignatureNotFoundTSE Just entry -> do - parents <- pg $ runSelectReturningList $ select $ do - parents <- all_ (_parents trailsDB) - guard_ (parents_entry_signature parents ==. val_ (EntriesPrimaryKey searchSignature)) - pure parents - pure $ buildTrailEntryResponse entry parents + previous <- pg $ runSelectReturningList $ select $ do + previous <- all_ (_previous trailsDB) + guard_ (previous_entry_signature previous ==. val_ (EntriesPrimaryKey searchSignature)) + pure previous + pure $ buildTrailEntryResponse entry previous -buildTrailEntryResponse :: Entries -> [Parents] -> TrailEntryResponse -buildTrailEntryResponse entries parents = TrailEntryResponse 1 +buildTrailEntryResponse :: Entries -> [Previous] -> TrailEntryResponse +buildTrailEntryResponse entries previous = TrailEntryResponse 1 (onLocalTime EntryTime $ entries_timestamp entries) (entries_gs1company_prefix entries) (EventId $ entries_event_id entries) - (parents_parent_signature <$> parents) + (previous_previous_signature <$> previous) (entries_signature entries) @@ -117,11 +117,11 @@ addEntryQuery :: (AsTrailsServiceError err) => [TrailEntryResponse] -> DB context err () addEntryQuery entries_raw = do let entries = trailEntryResponseToEntriesT <$> entries_raw - let parents = concat $ trailEntryResponseToParentsT <$> entries_raw + let previous = concat $ trailEntryResponseToParentsT <$> entries_raw _ <- pg $ runInsertReturningList $ insert (_entries trailsDB) $ insertValues entries - _ <- pg $ runInsertReturningList $ insert (_parents trailsDB) - $ insertValues parents + _ <- pg $ runInsertReturningList $ insert (_previous trailsDB) + $ insertValues previous pure () @@ -133,5 +133,5 @@ trailEntryResponseToEntriesT trailEntry = EntriesT (trailEntryResponseSignature Nothing -trailEntryResponseToParentsT :: TrailEntryResponse -> [ParentsT Identity] -trailEntryResponseToParentsT trailEntry = (ParentsT (EntriesPrimaryKey $ trailEntryResponseSignature trailEntry)) <$> (trailEntryResponseParentSignatures trailEntry) +trailEntryResponseToParentsT :: TrailEntryResponse -> [PreviousT Identity] +trailEntryResponseToParentsT trailEntry = (PreviousT (EntriesPrimaryKey $ trailEntryResponseSignature trailEntry)) <$> (trailEntryResponseParentSignatures trailEntry)