Skip to content

Commit

Permalink
[#500] Trails: Change terminology from parent/child to previous/follo…
Browse files Browse the repository at this point in the history 
…wing to give a more intuative trail entry time ordering expectation.

I still don't love this nomenclature because really "previous" means "previous entry" but that would be to verbose and so it doesn't fit, but previously it was getting confusing which direction was parent and child.
  • Loading branch information
@a-stacey
a-stacey committed Jul 31, 2019
1 parent 94dd746 commit 8afee94
Show file tree
Hide file tree
Showing 3 changed files with 64 additions and 64 deletions.
10 changes: 5 additions & 5 deletions projects/trails/src/Mirza/Trails/Database/Migrate.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
58 changes: 29 additions & 29 deletions projects/trails/src/Mirza/Trails/Database/Schema/V0001.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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"


--------------------------------------------------------------------------------
Expand Down Expand Up @@ -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)
60 changes: 30 additions & 30 deletions projects/trails/src/Mirza/Trails/Handlers/Trails.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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)


Expand All @@ -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 ()


Expand All @@ -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)

0 comments on commit 8afee94

Please sign in to comment.