From e04f651c66493caa0838f327ff301c9a97fb2999 Mon Sep 17 00:00:00 2001 From: Ashley Stacey Date: Wed, 21 Aug 2019 16:49:36 +1000 Subject: [PATCH] [#500] Trails: Clean up file ordering and spacing. --- .../src/Mirza/Trails/Handlers/Trails.hs | 80 +++++++++---------- projects/trails/src/Mirza/Trails/Types.hs | 5 ++ 2 files changed, 44 insertions(+), 41 deletions(-) diff --git a/projects/trails/src/Mirza/Trails/Handlers/Trails.hs b/projects/trails/src/Mirza/Trails/Handlers/Trails.hs index be77781c..cc45b60a 100644 --- a/projects/trails/src/Mirza/Trails/Handlers/Trails.hs +++ b/projects/trails/src/Mirza/Trails/Handlers/Trails.hs @@ -29,6 +29,7 @@ import Data.Maybe import Data.List (nub) + getTrailByEventId :: ( Member context '[HasEnvType, HasConnPool, HasKatipContext, HasKatipLogEnv] , Member err '[AsTrailsServiceError, AsSqlError]) => EventId -> AppM context err [TrailEntry] @@ -36,6 +37,22 @@ getTrailByEventId eventId = do runDb $ (getTrailByEventIdQuery eventId) +getTrailBySignature :: ( Member context '[HasEnvType, HasConnPool, HasKatipContext, HasKatipLogEnv] + , Member err '[AsTrailsServiceError, AsSqlError]) + => SignaturePlaceholder -> AppM context err [TrailEntry] +getTrailBySignature sig = do + runDb $ (getTrailBySignatureQuery [] sig) + + +addTrail :: ( Member context '[HasEnvType, HasConnPool, HasKatipContext, HasKatipLogEnv] + , Member err '[AsTrailsServiceError, AsSqlError]) + => [TrailEntry] -> AppM context err NoContent +addTrail trail = do + _ <- runDb $ (addEntryQuery trail) + pure NoContent + + + getTrailByEventIdQuery :: (AsTrailsServiceError err) => EventId -> DB context err [TrailEntry] getTrailByEventIdQuery eventId = do @@ -48,13 +65,6 @@ getTrailByEventIdQuery eventId = do entry -> build getTrailBySignatureQuery [] (entries_signature <$> entry) -getTrailBySignature :: ( Member context '[HasEnvType, HasConnPool, HasKatipContext, HasKatipLogEnv] - , Member err '[AsTrailsServiceError, AsSqlError]) - => SignaturePlaceholder -> AppM context err [TrailEntry] -getTrailBySignature sig = do - runDb $ (getTrailBySignatureQuery [] sig) - - -- Algorithm is basically get a node (TrailEntry), get all of the previous and following entries, if we haven't seen -- them before then recurse (if we have seen them before ignore them). We need to do this in a statefull way so that we -- can handle loop cases (cases where the trail meets in a loop). I realised after I had a working implementation that a @@ -67,18 +77,6 @@ getTrailBySignatureQuery discovered searchSignature = do getNextEntriesBySignatureQuery previousEntries searchSignature -getNextEntriesBySignatureQuery :: (AsTrailsServiceError err) - => [TrailEntry] -> SignaturePlaceholder -> DB context err [TrailEntry] -getNextEntriesBySignatureQuery discovered searchSignature = do - followingSignatures <- pg $ runSelectReturningList $ select $ do - previous <- all_ (_previous trailsDB) - guard_ (previous_previous_signature previous ==. val_ searchSignature) - pure $ (previous_entry_signature previous) - - let newFollowingSignatures = filter (isNotPresentIn discovered) (entriesPrimaryKeyToSignature <$> followingSignatures) - build getTrailBySignatureQuery discovered newFollowingSignatures - - getThisAndPreviousEntriesBySignatureQuery :: (AsTrailsServiceError err) => [TrailEntry] -> SignaturePlaceholder -> DB context err [TrailEntry] getThisAndPreviousEntriesBySignatureQuery discovered searchSignature = do @@ -91,9 +89,17 @@ getThisAndPreviousEntriesBySignatureQuery discovered searchSignature = do pure discovered -getEntriesBySignature :: (AsTrailsServiceError err) - => SignaturePlaceholder -> DB context err [TrailEntry] -getEntriesBySignature searchSignature = pure <$> (getEntryBySignature searchSignature) +getNextEntriesBySignatureQuery :: (AsTrailsServiceError err) + => [TrailEntry] -> SignaturePlaceholder -> DB context err [TrailEntry] +getNextEntriesBySignatureQuery discovered searchSignature = do + followingSignatures <- pg $ runSelectReturningList $ select $ do + previous <- all_ (_previous trailsDB) + guard_ (previous_previous_signature previous ==. val_ searchSignature) + pure $ (previous_entry_signature previous) + + let newFollowingSignatures = filter (isNotPresentIn discovered) (entriesPrimaryKeyToSignature <$> followingSignatures) + build getTrailBySignatureQuery discovered newFollowingSignatures + getEntryBySignature :: (AsTrailsServiceError err) => SignaturePlaceholder -> DB context err TrailEntry @@ -112,6 +118,10 @@ getEntryBySignature searchSignature = do pure $ buildTrailEntry entry previous +isNotPresentIn :: [TrailEntry] -> SignaturePlaceholder -> Bool +isNotPresentIn discovered element = not $ elem element $ trailEntrySignature <$> discovered + + -- I'm sure that there is a nicer "implemenentation" of this function, something like foldl >>=, but I can't find it right now so this will do and can always refactor this later. build :: (Monad m) => ([a] -> b -> m [a]) -> [a] -> [b] -> m [a] build _ discovered [] = pure discovered @@ -120,10 +130,6 @@ build fn discovered (sig : rest) = do build fn thisEntry rest -isNotPresentIn :: [TrailEntry] -> SignaturePlaceholder -> Bool -isNotPresentIn discovered element = not $ elem element $ trailEntrySignature <$> discovered - - buildTrailEntry :: Entries -> [Previous] -> TrailEntry buildTrailEntry entries previous = TrailEntry 1 (onLocalTime EntryTime $ entries_timestamp entries) @@ -133,21 +139,6 @@ buildTrailEntry entries previous = TrailEntry 1 (entries_signature entries) -addTrail :: ( Member context '[HasEnvType, HasConnPool, HasKatipContext, HasKatipLogEnv] - , Member err '[AsTrailsServiceError, AsSqlError]) - => [TrailEntry] -> AppM context err NoContent -addTrail trail = do - _ <- runDb $ (addEntryQuery trail) - pure NoContent - - -throwing_If :: MonadError e m => Control.Lens.Type.AReview e () -> Bool -> m () -throwing_If x result = if result then - throwing_ x - else - pure () - - addEntryQuery :: (AsTrailsServiceError err) => [TrailEntry] -> DB context err () addEntryQuery entriesRaw = do @@ -181,6 +172,13 @@ addEntryQuery entriesRaw = do pure () +throwing_If :: MonadError e m => Control.Lens.Type.AReview e () -> Bool -> m () +throwing_If x result = if result then + throwing_ x + else + pure () + + validPrevious :: [TrailEntry] -> DB context err Bool validPrevious entries = do let searchPrevious sig = pg $ runSelectReturningOne $ select $ do diff --git a/projects/trails/src/Mirza/Trails/Types.hs b/projects/trails/src/Mirza/Trails/Types.hs index f8fc9a38..d24e2e37 100644 --- a/projects/trails/src/Mirza/Trails/Types.hs +++ b/projects/trails/src/Mirza/Trails/Types.hs @@ -93,10 +93,12 @@ data TrailEntry = TrailEntry } deriving (Show, Generic, Eq) instance ToSchema TrailEntry + instance Ord TrailEntry where compare :: TrailEntry -> TrailEntry -> Ordering compare a b = compare (trailEntrySignature a) (trailEntrySignature b) + instance ToJSON TrailEntry where toJSON (TrailEntry version timestamp org eventId previousSignatures eventSignature) = object [ trailEntryJSONFieldVersion .= version @@ -106,6 +108,8 @@ instance ToJSON TrailEntry where , trailEntryJSONFieldPreviousSignatures .= previousSignatures , trailEntryJSONFieldSignature .= eventSignature ] + + instance FromJSON TrailEntry where parseJSON = withObject "TrailEntry" $ \o -> TrailEntry <$> o .: trailEntryJSONFieldVersion @@ -115,6 +119,7 @@ instance FromJSON TrailEntry where <*> o .: trailEntryJSONFieldPreviousSignatures <*> o .: trailEntryJSONFieldSignature + trailEntryJSONFieldVersion :: Text trailEntryJSONFieldVersion = "version" trailEntryJSONFieldTimestamp :: Text