Skip to content

Commit fc80be6

Browse files
ChrisPennerChrisPenner
committed
Pipeline all the things
1 parent bb807ae commit fc80be6

File tree

5 files changed

+114
-75
lines changed

5 files changed

+114
-75
lines changed

‎src/Share/Postgres.hs

Lines changed: 50 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,8 @@ module Share.Postgres
2525
Only (..),
2626
QueryA (..),
2727
QueryM (..),
28+
unrecoverableError,
29+
throwErr,
2830
decodeField,
2931
(:.) (..),
3032

@@ -120,7 +122,7 @@ instance MonadError e (Transaction e) where
120122
Right a -> pure (Right a)
121123

122124
-- | Applicative pipelining transaction
123-
newtype Pipeline e a = Pipeline {unPipeline :: Hasql.Pipeline.Pipeline (Either (TransactionError e) a)}
125+
newtype Pipeline e a = Pipeline {_unPipeline :: Hasql.Pipeline.Pipeline (Either (TransactionError e) a)}
124126
deriving (Functor, Applicative) via (Compose Hasql.Pipeline.Pipeline (Either (TransactionError e)))
125127

126128
pFor :: (Traversable f) => f a -> (a -> Pipeline e b) -> Transaction e (f b)
@@ -320,9 +322,9 @@ class (Applicative m) => QueryA m e | m -> e where
320322
statement :: q -> Hasql.Statement q r -> m r
321323

322324
-- | Fail the transaction and whole request with an unrecoverable server error.
323-
unrecoverableError :: (HasCallStack, ToServerError x, Loggable x, Show x) => x -> m a
325+
unrecoverableErrorA :: (HasCallStack, ToServerError x, Loggable x, Show x) => m (Either x a) -> m a
324326

325-
throwErr :: (ToServerError e, Loggable e, Show e) => e -> m a
327+
throwErrA :: (ToServerError e, Loggable e, Show e) => m (Either e a) -> m a
326328

327329
pipelined :: Pipeline e a -> m a
328330

@@ -335,11 +337,14 @@ instance QueryA (Transaction e) e where
335337
statement q s = do
336338
transactionStatement q s
337339

338-
throwErr = throwError
340+
throwErrA m = m >>= either throwError pure
339341

340-
pipelined p = Transaction (Hasql.pipeline (unPipeline p))
342+
pipelined (Pipeline p) = Transaction (Hasql.pipeline p)
341343

342-
unrecoverableError e = Transaction (pure (Left (Unrecoverable (someServerError e))))
344+
unrecoverableErrorA me =
345+
me >>= \case
346+
Right a -> pure a
347+
Left e -> Transaction (pure (Left (Unrecoverable (someServerError e))))
343348

344349
instance QueryM (Transaction e) e where
345350
transactionUnsafeIO io = Transaction (Right <$> liftIO io)
@@ -348,49 +353,78 @@ instance QueryA (Session e) e where
348353
statement q s = do
349354
lift $ Session.statement q s
350355

351-
throwErr = throwError . Err
356+
throwErrA m = m >>= either (throwError . Err) pure
352357

353-
pipelined p = do
354-
ExceptT $ Hasql.pipeline (unPipeline p)
358+
pipelined (Pipeline p) = do
359+
ExceptT $ Hasql.pipeline p
355360

356-
unrecoverableError e = throwError (Unrecoverable (someServerError e))
361+
unrecoverableErrorA me =
362+
me >>= \case
363+
Right a -> pure a
364+
Left e -> throwError (Unrecoverable (someServerError e))
357365

358366
instance QueryM (Session e) e where
359367
transactionUnsafeIO io = lift $ liftIO io
360368

361369
instance QueryA (Pipeline e) e where
362370
statement q s = Pipeline (Right <$> Hasql.Pipeline.statement q s)
363371

364-
throwErr = Pipeline . pure . Left . Err
372+
throwErrA (Pipeline me) =
373+
-- Flatten error into pipeline
374+
Pipeline $
375+
me <&> \case
376+
Left e -> Left e
377+
Right (Left e) -> Left (Err e)
378+
Right (Right a) -> Right a
365379

366380
pipelined p = p
367381

368-
unrecoverableError e = Pipeline $ pure (Left (Unrecoverable (someServerError e)))
382+
unrecoverableErrorA (Pipeline me) =
383+
Pipeline
384+
( me <&> \case
385+
Right (Left e) -> Left . Unrecoverable . someServerError $ e
386+
Right (Right a) -> Right a
387+
Left e -> Left e
388+
)
389+
390+
-- Pipeline $ pure (Left (Unrecoverable (someServerError e)))
369391

370392
instance (QueryM m e) => QueryA (ReaderT r m) e where
371393
statement q s = lift $ statement q s
372394

373-
throwErr = lift . throwErr
395+
throwErrA m = mapReaderT throwErrA m
374396

375397
pipelined p = lift $ pipelined p
376398

377-
unrecoverableError e = lift $ unrecoverableError e
399+
unrecoverableErrorA me = mapReaderT unrecoverableErrorA me
378400

379401
instance (QueryM m e) => QueryM (ReaderT r m) e where
380402
transactionUnsafeIO io = lift $ transactionUnsafeIO io
381403

382404
instance (QueryM m e) => QueryA (MaybeT m) e where
383405
statement q s = lift $ statement q s
384406

385-
throwErr = lift . throwErr
407+
throwErrA m =
408+
m >>= \case
409+
Left e -> lift $ throwErr e
410+
Right a -> pure a
386411

387412
pipelined p = lift $ pipelined p
388413

389-
unrecoverableError e = lift $ unrecoverableError e
414+
unrecoverableErrorA m =
415+
m >>= \case
416+
Left e -> lift $ unrecoverableError e
417+
Right a -> pure a
390418

391419
instance (QueryM m e) => QueryM (MaybeT m) e where
392420
transactionUnsafeIO io = lift $ transactionUnsafeIO io
393421

422+
unrecoverableError :: (QueryA m e) => (ToServerError x, Loggable x, Show x) => x -> m a
423+
unrecoverableError e = unrecoverableErrorA (pure $ Left e)
424+
425+
throwErr :: (QueryA m e, ToServerError e, Loggable e, Show e) => e -> m a
426+
throwErr e = throwErrA (pure $ Left e)
427+
394428
prepareStatements :: Bool
395429
prepareStatements = True
396430

‎src/Share/Postgres/Causal/Queries.hs

Lines changed: 15 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -59,7 +59,7 @@ import Unison.NameSegment.Internal as NameSegment
5959
import Unison.Reference qualified as Reference
6060
import Unison.Util.Map qualified as Map
6161

62-
expectCausalNamespace :: (HasCallStack, QueryM m e) => CausalId -> m (CausalNamespace m)
62+
expectCausalNamespace :: (QueryM m e) => CausalId -> m (CausalNamespace m)
6363
expectCausalNamespace causalId =
6464
loadCausalNamespace causalId
6565
`whenNothingM` unrecoverableError (MissingExpectedEntity $ "Expected causal branch for hash:" <> tShow causalId)
@@ -101,26 +101,27 @@ expectPgCausalNamespace causalId =
101101

102102
loadCausalNamespace :: forall m e. (QueryM m e) => CausalId -> m (Maybe (CausalNamespace m))
103103
loadCausalNamespace causalId = runMaybeT $ do
104-
causalHash <- HashQ.expectCausalHashesByIdsOf id causalId
105104
branchHashId <- HashQ.expectNamespaceIdsByCausalIdsOf id causalId
106-
namespaceHash <- HashQ.expectNamespaceHashesByNamespaceHashIdsOf id branchHashId
107-
let namespace = expectNamespace branchHashId
108-
ancestors <- lift $ ancestorsByCausalId causalId
109-
pure $
110-
Causal
111-
{ causalHash = causalHash,
112-
valueHash = namespaceHash,
113-
parents = ancestors,
114-
value = namespace
115-
}
105+
pipelined $ do
106+
causalHash <- HashQ.expectCausalHashesByIdsOf id causalId
107+
namespaceHash <- HashQ.expectNamespaceHashesByNamespaceHashIdsOf id branchHashId
108+
let namespace = expectNamespace branchHashId
109+
ancestors <- ancestorsByCausalId causalId
110+
pure $
111+
Causal
112+
{ causalHash = causalHash,
113+
valueHash = namespaceHash,
114+
parents = ancestors,
115+
value = namespace
116+
}
116117
where
117-
ancestorsByCausalId :: CausalId -> m ((Map CausalHash (m (CausalNamespace m))))
118+
ancestorsByCausalId :: CausalId -> Pipeline e ((Map CausalHash (m (CausalNamespace m))))
118119
ancestorsByCausalId causalId = do
119120
getAncestors
120121
<&> fmap (\(ancestorId, ancestorHash) -> (ancestorHash, expectCausalNamespace ancestorId))
121122
<&> Map.fromList
122123
where
123-
getAncestors :: m [(CausalId, CausalHash)]
124+
getAncestors :: Pipeline e [(CausalId, CausalHash)]
124125
getAncestors = do
125126
queryListRows
126127
[sql| SELECT ancestor_id, ancestor.hash

‎src/Share/Postgres/Definitions/Queries.hs

Lines changed: 10 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -221,10 +221,11 @@ expectShareTermComponent componentHashId = do
221221
)
222222
`whenNothingM` do
223223
lift . unrecoverableError $ InternalServerError "expected-term-component" (ExpectedTermComponentNotFound (That componentHashId))
224-
second (Hash32.fromHash . unComponentHash) . Share.TermComponent . toList <$> for componentElements \(termId, LocalTermBytes bytes) -> do
225-
textLookup <- lift $ termLocalTextReferences termId
226-
defnLookup <- lift $ termLocalComponentReferences termId
224+
results <- pipelined $ for componentElements \(termId, LocalTermBytes bytes) -> do
225+
textLookup <- termLocalTextReferences termId
226+
defnLookup <- termLocalComponentReferences termId
227227
pure (Share.LocalIds {texts = textLookup, hashes = defnLookup}, bytes)
228+
pure (second (Hash32.fromHash . unComponentHash) . Share.TermComponent . toList $ results)
228229
where
229230
checkElements :: [(TermId, Maybe LocalTermBytes)] -> Maybe (NonEmpty (TermId, LocalTermBytes))
230231
checkElements rows =
@@ -251,10 +252,11 @@ expectShareTypeComponent componentHashId = do
251252
)
252253
`whenNothingM` do
253254
lift . unrecoverableError $ InternalServerError "expected-type-component" (ExpectedTypeComponentNotFound (That componentHashId))
254-
second (Hash32.fromHash . unComponentHash) . Share.DeclComponent . toList <$> for componentElements \(typeId, LocalTypeBytes bytes) -> do
255-
textLookup <- lift $ typeLocalTextReferences typeId
256-
defnLookup <- lift $ typeLocalComponentReferences typeId
255+
results <- pipelined $ for componentElements \(typeId, LocalTypeBytes bytes) -> do
256+
textLookup <- typeLocalTextReferences typeId
257+
defnLookup <- typeLocalComponentReferences typeId
257258
pure (Share.LocalIds {texts = Vector.toList textLookup, hashes = Vector.toList defnLookup}, bytes)
259+
pure (second (Hash32.fromHash . unComponentHash) . Share.DeclComponent . toList $ results)
258260
where
259261
checkElements :: [(TypeId, Maybe LocalTypeBytes)] -> Maybe (NonEmpty (TypeId, LocalTypeBytes))
260262
checkElements rows =
@@ -407,7 +409,7 @@ loadDecl codebaseUser (Reference.Id compHash (pgComponentIndex -> compIndex)) =
407409
localIds = LocalIds.LocalIds {textLookup, defnLookup}
408410
pure $ s2cDecl localIds decl
409411

410-
typeLocalTextReferences :: TypeId -> Transaction e (Vector Text)
412+
typeLocalTextReferences :: (QueryA m e) => TypeId -> m (Vector Text)
411413
typeLocalTextReferences typeId =
412414
Vector.fromList
413415
<$> queryListCol
@@ -419,7 +421,7 @@ typeLocalTextReferences typeId =
419421
ORDER BY local_index ASC
420422
|]
421423

422-
typeLocalComponentReferences :: TypeId -> Transaction e (Vector ComponentHash)
424+
typeLocalComponentReferences :: (QueryA m e) => TypeId -> m (Vector ComponentHash)
423425
typeLocalComponentReferences typeId =
424426
Vector.fromList
425427
<$> queryListCol

‎src/Share/Postgres/Hashes/Queries.hs

Lines changed: 24 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -139,7 +139,7 @@ expectPatchHashesOf trav = do
139139
then error "expectPatchHashesOf: Missing expected patch hash"
140140
else pure results
141141

142-
expectPatchIdsOf :: (HasCallStack) => Traversal s t PatchHash PatchId -> s -> CodebaseM e t
142+
expectPatchIdsOf :: Traversal s t PatchHash PatchId -> s -> CodebaseM e t
143143
expectPatchIdsOf trav = do
144144
unsafePartsOf trav %%~ \hashes -> do
145145
codebaseOwner <- asks Codebase.codebaseOwner
@@ -183,7 +183,7 @@ loadBranchHashId branchHash = do
183183
)
184184
|]
185185

186-
expectBranchHashId :: (HasCallStack) => BranchHash -> CodebaseM e BranchHashId
186+
expectBranchHashId :: BranchHash -> CodebaseM e BranchHashId
187187
expectBranchHashId branchHash = do
188188
loadBranchHashId branchHash >>= \case
189189
Just hashId -> pure hashId
@@ -235,12 +235,12 @@ addKnownCausalHashMismatch providedHash actualHash = do
235235
|]
236236

237237
-- | Generic helper which fetches both branch hashes and causal hashes
238-
expectCausalHashesOfG :: (HasCallStack, QueryM m e) => ((BranchHash, CausalHash) -> h) -> Traversal s t CausalId h -> s -> m t
238+
expectCausalHashesOfG :: (HasCallStack, QueryA m e) => ((BranchHash, CausalHash) -> h) -> Traversal s t CausalId h -> s -> m t
239239
expectCausalHashesOfG project trav = do
240240
unsafePartsOf trav %%~ \hashIds -> do
241241
let numberedHashIds = zip [0 :: Int32 ..] hashIds
242-
results :: [(BranchHash, CausalHash)] <-
243-
queryListRows
242+
unrecoverableErrorA $
243+
queryListRows @(BranchHash, CausalHash)
244244
[sql|
245245
WITH causal_ids(ord, id) AS (
246246
SELECT * FROM ^{toTable numberedHashIds}
@@ -251,17 +251,18 @@ expectCausalHashesOfG project trav = do
251251
JOIN branch_hashes bh ON causal.namespace_hash_id = bh.id
252252
ORDER BY causal_ids.ord ASC
253253
|]
254-
if length results /= length hashIds
255-
then error "expectCausalHashesOf: Missing expected causal hash"
256-
else pure (project <$> results)
254+
<&> \results ->
255+
if length results /= length hashIds
256+
then Left . MissingExpectedEntity $ "expectCausalHashesOfG: Expected to get the same number of results as causal ids."
257+
else pure (project <$> results)
257258

258259
expectCausalAndBranchHashesOf :: (HasCallStack, QueryM m e) => Traversal s t CausalId (BranchHash, CausalHash) -> s -> m t
259260
expectCausalAndBranchHashesOf = expectCausalHashesOfG id
260261

261-
expectCausalHashesByIdsOf :: (HasCallStack, QueryM m e) => Traversal s t CausalId CausalHash -> s -> m t
262+
expectCausalHashesByIdsOf :: (HasCallStack, QueryA m e) => Traversal s t CausalId CausalHash -> s -> m t
262263
expectCausalHashesByIdsOf = expectCausalHashesOfG snd
263264

264-
expectCausalIdsOf :: (HasCallStack) => Traversal s t CausalHash (BranchHashId, CausalId) -> s -> CodebaseM e t
265+
expectCausalIdsOf :: Traversal s t CausalHash (BranchHashId, CausalId) -> s -> CodebaseM e t
265266
expectCausalIdsOf trav = do
266267
unsafePartsOf trav %%~ \hashes -> do
267268
codebaseOwnerId <- asks Codebase.codebaseOwner
@@ -287,12 +288,12 @@ expectCausalIdsOf trav = do
287288
then unrecoverableError $ EntityMissing "missing-expected-causal" $ "Missing one of these causals: " <> Text.intercalate ", " (into @Text <$> hashes)
288289
else pure results
289290

290-
expectNamespaceIdsByCausalIdsOf :: (QueryM m e) => Traversal s t CausalId BranchHashId -> s -> m t
291+
expectNamespaceIdsByCausalIdsOf :: (QueryA m e) => Traversal s t CausalId BranchHashId -> s -> m t
291292
expectNamespaceIdsByCausalIdsOf trav s = do
292293
s
293294
& unsafePartsOf trav %%~ \causalIds -> do
294295
let causalIdsTable = ordered causalIds
295-
results <-
296+
unrecoverableErrorA $
296297
queryListCol @(BranchHashId)
297298
[sql| WITH causal_ids(ord, causal_id) AS (
298299
SELECT ord, causal_id FROM ^{toTable causalIdsTable} as t(ord, causal_id)
@@ -302,16 +303,17 @@ expectNamespaceIdsByCausalIdsOf trav s = do
302303
JOIN causals c ON cid.causal_id = c.id
303304
ORDER BY cid.ord
304305
|]
305-
if length results /= length causalIds
306-
then unrecoverableError . MissingExpectedEntity $ "expectNamespaceIdsByCausalIdsOf: Expected to get the same number of results as causal ids. " <> tShow causalIds
307-
else pure results
306+
<&> \results ->
307+
if length results /= length causalIds
308+
then Left . MissingExpectedEntity $ "expectNamespaceIdsByCausalIdsOf: Expected to get the same number of results as causal ids. " <> tShow causalIds
309+
else Right results
308310

309-
expectNamespaceHashesByNamespaceHashIdsOf :: (HasCallStack, QueryM m e) => Traversal s t BranchHashId BranchHash -> s -> m t
311+
expectNamespaceHashesByNamespaceHashIdsOf :: (QueryA m e) => Traversal s t BranchHashId BranchHash -> s -> m t
310312
expectNamespaceHashesByNamespaceHashIdsOf trav s = do
311313
s
312314
& unsafePartsOf trav %%~ \namespaceHashIds -> do
313315
let namespaceHashIdsTable = ordered namespaceHashIds
314-
results <-
316+
unrecoverableErrorA $
315317
queryListCol @(BranchHash)
316318
[sql| WITH namespace_hash_ids(ord, namespace_hash_id) AS (
317319
SELECT ord, namespace_hash_id FROM ^{toTable namespaceHashIdsTable} as t(ord, namespace_hash_id)
@@ -321,9 +323,10 @@ expectNamespaceHashesByNamespaceHashIdsOf trav s = do
321323
JOIN branch_hashes bh ON nhi.namespace_hash_id = bh.id
322324
ORDER BY nhi.ord
323325
|]
324-
if length results /= length namespaceHashIds
325-
then unrecoverableError . MissingExpectedEntity $ "expectNamespaceHashesByNamespaceHashIdsOf: Expected to get the same number of results as namespace hash ids. " <> tShow namespaceHashIds
326-
else pure results
326+
<&> \results ->
327+
if length results /= length namespaceHashIds
328+
then Left . MissingExpectedEntity $ "expectNamespaceHashesByNamespaceHashIdsOf: Expected to get the same number of results as namespace hash ids. " <> tShow namespaceHashIds
329+
else Right results
327330

328331
loadCausalIdByHash :: CausalHash -> Codebase.CodebaseM e (Maybe CausalId)
329332
loadCausalIdByHash causalHash = do
@@ -334,7 +337,7 @@ loadCausalIdByHash causalHash = do
334337
AND EXISTS (SELECT FROM causal_ownership o WHERE o.causal_id = causals.id AND o.user_id = #{codebaseOwner})
335338
|]
336339

337-
expectCausalIdByHash :: (HasCallStack) => CausalHash -> Codebase.CodebaseM e CausalId
340+
expectCausalIdByHash :: CausalHash -> Codebase.CodebaseM e CausalId
338341
expectCausalIdByHash causalHash = do
339342
loadCausalIdByHash causalHash
340343
`whenNothingM` unrecoverableError (MissingExpectedEntity $ "Expected causal id for hash: " <> tShow causalHash)

0 commit comments

Comments
 (0)