From ad1d8272929568e33da37c6da18942fd57590659 Mon Sep 17 00:00:00 2001 From: Ashley Stacey Date: Mon, 29 Jul 2019 15:37:42 +1000 Subject: [PATCH] [#500] Trails: Copy-paste code from OrgRegistry to add Trails endpoints. --- projects/trails/src/Mirza/Trails/API.hs | 2 +- .../src/Mirza/Trails/Handlers/Trails.hs | 126 +++++++++++++----- projects/trails/src/Mirza/Trails/Service.hs | 6 +- projects/trails/src/Mirza/Trails/Types.hs | 4 +- 4 files changed, 102 insertions(+), 36 deletions(-) diff --git a/projects/trails/src/Mirza/Trails/API.hs b/projects/trails/src/Mirza/Trails/API.hs index d53bb2c9..05c11964 100644 --- a/projects/trails/src/Mirza/Trails/API.hs +++ b/projects/trails/src/Mirza/Trails/API.hs @@ -36,4 +36,4 @@ type PublicAPI = :<|> "version" :> Get '[JSON] String :<|> "trail" :> Capture "eventId" EventId :> Get '[JSON] [TrailEntryResponse] :<|> "trail" :> Capture "signature" SignaturePlaceholder :> Get '[JSON] [TrailEntryResponse] - :<|> "trail" :> ReqBody '[JSON] [TrailEntryResponse] :> Post '[JSON] NoContent + :<|> "trail" :> ReqBody '[JSON] [TrailEntryResponse] :> Post '[JSON] NoContent diff --git a/projects/trails/src/Mirza/Trails/Handlers/Trails.hs b/projects/trails/src/Mirza/Trails/Handlers/Trails.hs index aa495f61..b5e7092a 100644 --- a/projects/trails/src/Mirza/Trails/Handlers/Trails.hs +++ b/projects/trails/src/Mirza/Trails/Handlers/Trails.hs @@ -1,45 +1,107 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} + module Mirza.Trails.Handlers.Trails where + import Mirza.Trails.Types +import Mirza.Trails.Database.Schema import Mirza.Common.Types +import Mirza.Common.Time -import Data.GS1.EPC (GS1CompanyPrefix (..)) -import Data.GS1.EventId (EventId (..)) +import Data.GS1.EventId (EventId (..)) -import Data.Time.Clock -import Data.UUID.V4 +import Database.Beam.Backend.SQL.BeamExtensions +import Database.Beam.Query hiding (time) import Servant +import Control.Monad.Identity + + +getTrailByEventId :: ( Member context '[HasEnvType, HasConnPool, HasKatipContext, HasKatipLogEnv] + , Member err '[AsTrailsServiceError, AsSqlError]) + => EventId -> AppM context err [TrailEntryResponse] +getTrailByEventId eventId = do + runDb $ (getTrailByEventIdQuery eventId) + + +getTrailByEventIdQuery :: (AsTrailsServiceError err) + => EventId -> DB context err [TrailEntryResponse] +getTrailByEventIdQuery eventId = do + entryList <- pg $ runSelectReturningList $ select $ do + entry <- all_ (_entries trailsDB) + guard_ (entries_event_id entry ==. val_ (unEventId eventId)) + pure entry + case entryList of + [] -> throwing_ _EventIdNotFoundTSE + entry -> concat <$> traverse getTrailBySignatureQuery (entries_signature <$> entry) + + +getTrailBySignature :: ( Member context '[HasEnvType, HasConnPool, HasKatipContext, HasKatipLogEnv] + , Member err '[AsTrailsServiceError, AsSqlError]) + => SignaturePlaceholder -> AppM context err [TrailEntryResponse] +getTrailBySignature sig = do + runDb $ (getTrailBySignatureQuery sig) + + +getTrailBySignatureQuery :: (AsTrailsServiceError err) + => SignaturePlaceholder -> DB context err [TrailEntryResponse] +getTrailBySignatureQuery searchSignature = do + maybeEntry <- pg $ runSelectReturningOne $ select $ do + entry <- all_ (_entries trailsDB) + guard_ (entries_signature entry ==. val_ searchSignature) + pure entry + 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 + let thisEntry = buildTrailEntryResponse entry parents + parentEntries <- concat <$> traverse getTrailBySignatureQuery (parents_parent_signature <$> parents) + pure $ thisEntry : parentEntries + + +buildTrailEntryResponse :: Entries -> [Parents] -> TrailEntryResponse +buildTrailEntryResponse entries parents = TrailEntryResponse 1 + (onLocalTime EntryTime $ entries_timestamp entries) + (entries_gs1company_prefix entries) + (EventId $ entries_event_id entries) + (parents_parent_signature <$> parents) + (entries_signature entries) + + +addTrail :: ( Member context '[HasEnvType, HasConnPool, HasKatipContext, HasKatipLogEnv] + , Member err '[AsTrailsServiceError, AsSqlError]) + => [TrailEntryResponse] -> AppM context err NoContent +addTrail trail = do + _ <- runDb $ (addEntryQuery trail) + pure NoContent + + +addEntryQuery :: (AsTrailsServiceError err) + => [TrailEntryResponse] -> DB context err () +addEntryQuery entries_raw = do + let entries = trailEntryResponseToEntriesT <$> entries_raw + let parents = concat $ trailEntryResponseToParentsT <$> entries_raw + _ <- pg $ runInsertReturningList $ insert (_entries trailsDB) + $ insertValues entries + _ <- pg $ runInsertReturningList $ insert (_parents trailsDB) + $ insertValues parents + pure () + + +trailEntryResponseToEntriesT :: TrailEntryResponse -> EntriesT Identity +trailEntryResponseToEntriesT trailEntry = EntriesT (trailEntryResponseSignature trailEntry) + (toDbTimestamp $ getEntryTime $ trailEntryResponseTimestamp trailEntry) + (trailEntryResponseGS1CompanyPrefix trailEntry) + (unEventId $ trailEntryResponseEventID trailEntry) + Nothing + -getTrailByEventId :: EventId -> AppM context err [TrailEntryResponse] -getTrailByEventId (EventId uuid) = do - time <- liftIO getCurrentTime - --uuid1 <- liftIO nextRandom - pure $ [ TrailEntryResponse 1 - (EntryTime time) - (GS1CompanyPrefix "0000001") - (EventId uuid) - [] - (SignaturePlaceholder "TODO") - ] - - -getTrailBySignature :: SignaturePlaceholder -> AppM context err [TrailEntryResponse] -getTrailBySignature (SignaturePlaceholder sig) = do - time <- liftIO getCurrentTime - uuid <- liftIO nextRandom - pure $ [ TrailEntryResponse 1 - (EntryTime time) - (GS1CompanyPrefix "0000002") - (EventId uuid) - [] - (SignaturePlaceholder sig) - ] - - -addTrail :: [TrailEntryResponse] -> AppM context err NoContent -addTrail _ = pure NoContent +trailEntryResponseToParentsT :: TrailEntryResponse -> [ParentsT Identity] +trailEntryResponseToParentsT trailEntry = (ParentsT (EntriesPrimaryKey $ trailEntryResponseSignature trailEntry)) <$> (trailEntryResponseParentSignatures trailEntry) diff --git a/projects/trails/src/Mirza/Trails/Service.hs b/projects/trails/src/Mirza/Trails/Service.hs index 3bad1a96..9da070c2 100644 --- a/projects/trails/src/Mirza/Trails/Service.hs +++ b/projects/trails/src/Mirza/Trails/Service.hs @@ -105,8 +105,10 @@ trailsErrorToHttpError :: TrailsServiceError -> KatipContextT Handler a trailsErrorToHttpError trailsError = let httpError = throwHttpError trailsError in case trailsError of - (DBErrorTE _) -> unexpectedError trailsError - (UnmatchedUniqueViolationTE _) -> unexpectedError trailsError + (DBErrorTE _) -> unexpectedError trailsError + (SignatureNotFoundTSE) -> httpError err404 "A trail with a matching signature was not found." + (EventIdNotFoundTSE) -> httpError err404 "A trail with the matching EventId was not found." + (UnmatchedUniqueViolationTSE _) -> unexpectedError trailsError -- | A generic internal server error has occured. We include no more information in the result returned to the user to -- limit further potential for exploitation, under the expectation that we log the errors to somewhere that is reviewed diff --git a/projects/trails/src/Mirza/Trails/Types.hs b/projects/trails/src/Mirza/Trails/Types.hs index 3ee6daf9..890df9ca 100644 --- a/projects/trails/src/Mirza/Trails/Types.hs +++ b/projects/trails/src/Mirza/Trails/Types.hs @@ -183,7 +183,9 @@ signaturesType = B.DataType (pgUnboundedArrayType pgTextType) data TrailsServiceError = DBErrorTE SqlError - | UnmatchedUniqueViolationTE SqlError + | SignatureNotFoundTSE + | EventIdNotFoundTSE + | UnmatchedUniqueViolationTSE SqlError deriving (Show) $(makeClassyPrisms ''TrailsServiceError)