[#500] Trails: Add check to make sure that the timestamps accepted by…

… the service are in the past.

projects/mirza-test-utils-haskell/test/Mirza/Common/Tests/Utils.hs

@@ -16,6 +16,7 @@ module Mirza.Common.Tests.Utils
   , databaseNameToConnectionString
   , makeDatabase
   , dropTables
+  , secondsToMicroseconds
   )
   where
 
@@ -178,3 +179,8 @@ dropTables db conn = do
   --       investigating.
   void $ forM_ tables $ \tableName -> do
     execute_ conn $ fromString $ T.unpack $ "DROP TABLE IF EXISTS " <> tableName <> ";"
+
+
+-- | Converts from number of seconds to the number of microseconds.
+secondsToMicroseconds :: (Num a) => a -> a
+secondsToMicroseconds = (* 1000000)

projects/or_scs/test/Mirza/OrgRegistry/Tests/Keys.hs

@@ -22,6 +22,7 @@ import           Mirza.OrgRegistry.Handlers.Users
 import qualified Mirza.OrgRegistry.Tests.Dummies   as Dummies
 import           Mirza.OrgRegistry.Types           as ORT
 
+import           Mirza.Common.Tests.Utils
 import           Mirza.OrgRegistry.Tests.Utils
 
 import           Data.GS1.EPC                      (GS1CompanyPrefix (..))

projects/or_scs/test/Mirza/OrgRegistry/Tests/Utils.hs

@@ -13,6 +13,3 @@ goodRsaPublicKey = readJWK "./test/Mirza/Common/TestData/testKeys/goodJWKs/4096b
 goodRsaPrivateKey :: IO (Maybe JWK)
 goodRsaPrivateKey = readJWK "./test/Mirza/Common/TestData/testKeys/goodJWKs/4096bit_rsa.json"
 
--- | Converts from number of seconds to the number of microseconds.
-secondsToMicroseconds :: (Num a) => a -> a
-secondsToMicroseconds = (* 1000000)

projects/trails/src/Mirza/Trails/Handlers/Trails.hs

@@ -27,6 +27,7 @@ import           Control.Monad.Identity
 
 import           Data.Maybe
 import           Data.List                                (nub)
+import           Data.Time.Clock
 
 
 
@@ -142,6 +143,9 @@ buildTrailEntry entries previous = TrailEntry 1
 addEntryQuery :: (AsTrailsServiceError err)
               => [TrailEntry] -> DB context err ()
 addEntryQuery entriesRaw = do
+  timestampsPast <- liftIO $ allTimestampsPassed entriesRaw
+  throwing_If _FutureTimestampTSE timestampsPast
+
   let ignoreNotFound = handleError (\err -> if is _SignatureNotFoundTSE err then pure Nothing else throwError err)
   existingEntries <- fmap catMaybes $ traverse (ignoreNotFound . (fmap Just <$> getEntryBySignature)) (trailEntrySignature <$> entriesRaw)
   -- Note: We only need to check if the signature exists (and not that the full event contents match) since the signature guarantees that they events are the same.
@@ -205,3 +209,9 @@ trailEntryToEntriesT trailEntry = EntriesT (trailEntrySignature trailEntry)
 
 trailEntryToPreviousT :: TrailEntry -> [PreviousT Identity]
 trailEntryToPreviousT trailEntry = (PreviousT (EntriesPrimaryKey $ trailEntrySignature trailEntry)) <$> (trailEntryPreviousSignatures trailEntry)
+
+
+allTimestampsPassed :: [TrailEntry] -> IO Bool
+allTimestampsPassed trail = do
+  now <- getCurrentTime
+  pure $ or $ ((> now) . getEntryTime . trailEntryTimestamp) <$> trail

projects/trails/src/Mirza/Trails/Service.hs

@@ -109,6 +109,7 @@ trailsErrorToHttpError 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."
     (InvalidEntryVersionTSE)        -> httpError err400 "Only version 1 trail entries are currently supported by this service."
+    (FutureTimestampTSE)            -> httpError err400 "Only trails with timestamps that have passed may be added to this service."
     (DuplicatePreviousEntriesTSE)   -> httpError err400 "Duplicating a signature in the previous signatures of an event is not allowed."
     (PreviousEntryNotFoundTSE)      -> httpError err400 "It is not possible to add entries with previous signatures that are not present in the current trail or already stored by the service."
     (UnmatchedUniqueViolationTSE _) -> unexpectedError trailsError

projects/trails/src/Mirza/Trails/Types.hs

@@ -196,6 +196,7 @@ data TrailsServiceError
   | SignatureNotFoundTSE
   | EventIdNotFoundTSE
   | InvalidEntryVersionTSE
+  | FutureTimestampTSE
   | DuplicatePreviousEntriesTSE
   | PreviousEntryNotFoundTSE
   | UnmatchedUniqueViolationTSE SqlError

projects/trails/test/Mirza/Trails/Tests/Client.hs

@@ -13,6 +13,7 @@ import           Mirza.Common.Tests.ServantUtils
 
 import           Mirza.Common.Tests.Utils        (checkFailureMessage,
                                                   checkFailureStatus,
+                                                  secondsToMicroseconds,
                                                   within1Second)
 
 import           Mirza.Common.Types
@@ -34,6 +35,7 @@ import           Crypto.Hash
 
 import           System.Random
 
+import           Control.Concurrent              (threadDelay)
 import           Control.Exception               (bracket)
 import           Control.Monad
 import           Data.Aeson
@@ -296,6 +298,27 @@ clientSpec = do
           zeroVersionEntryResult `shouldSatisfy` isLeft
           zeroVersionEntryResult `shouldSatisfy` (checkFailureStatus NS.badRequest400)
           zeroVersionEntryResult `shouldSatisfy` (checkFailureMessage "Only version 1 trail entries are currently supported by this service.")
+          zeroVersionEntryGetResult <- http $ getTrailByEventId (trailEntryEventId zeroVersionEntry)
+          zeroVersionEntryGetResult `shouldSatisfy` isLeft
+
+          step "That adding an entry with a future timestamp fails"
+          let futureDelay = 1
+          futureTime <- (addUTCTime (fromInteger futureDelay)) <$> getCurrentTime
+          let setFutureTimestamp entry = resign $ entry{trailEntryTimestamp = EntryTime futureTime}
+          futureTimestampEntry <- setFutureTimestamp <$> buildEntry
+          verifyValidTrailTestIntegrityCheck [futureTimestampEntry]
+          futureTimestampEntryResult <- http $ addTrail [futureTimestampEntry]
+          futureTimestampEntryResult `shouldSatisfy` isLeft
+          futureTimestampEntryResult `shouldSatisfy` (checkFailureStatus NS.badRequest400)
+          futureTimestampEntryResult `shouldSatisfy` (checkFailureMessage "Only trails with timestamps that have passed may be added to this service.")
+          futureTimestampEntryGetResult <- http $ getTrailByEventId (trailEntryEventId futureTimestampEntry)
+          futureTimestampEntryGetResult `shouldSatisfy` isLeft
+          -- Integrity Check: That after the timestamp deplay has elapsed that the entry can be entered.
+          threadDelay $ fromIntegral $ secondsToMicroseconds futureDelay
+          futureTimestampEntryElapsedResult <- http $ addTrail [futureTimestampEntry]
+          futureTimestampEntryElapsedResult `shouldBe` Right NoContent
+          futureTimestampEntryElapsedGetResult <- http $ getTrailByEventId (trailEntryEventId futureTimestampEntry)
+          futureTimestampEntryElapsedGetResult `shouldMatchTrail` [futureTimestampEntry]
 
           step "That adding a trail with a failing entry causes the rest of the trail not to be added"
           invalidMiddleEntryTrail <- addNextEntryIO $ fmap (applyHead setVersionZero) $ addNextEntryIO $  buildSingleEntryTrail
@@ -330,6 +353,8 @@ clientSpec = do
           duplicatePreviousSignaturesTrailResult `shouldSatisfy` isLeft
           duplicatePreviousSignaturesTrailResult `shouldSatisfy` (checkFailureStatus NS.badRequest400)
           duplicatePreviousSignaturesTrailResult `shouldSatisfy` (checkFailureMessage "Duplicating a signature in the previous signatures of an event is not allowed.")
+          duplicatePreviousSignaturesTrailGetResult <- http $ getTrailByEventId (trailEntryEventId $ head duplicatePreviousSignaturesTrail)
+          duplicatePreviousSignaturesTrailGetResult `shouldSatisfy` isLeft
 
           step "That adding an entry with the previous signature not in the trail, but already stored by the service succeeds"
           multiPhaseAddFirst  <- buildEntry
@@ -351,9 +376,10 @@ clientSpec = do
           noPreviousAddResult `shouldSatisfy` isLeft
           noPreviousAddResult `shouldSatisfy` (checkFailureStatus NS.badRequest400)
           noPreviousAddResult `shouldSatisfy` (checkFailureMessage "It is not possible to add entries with previous signatures that are not present in the current trail or already stored by the service.")
+          noPreviousAddGetResult <- http $ getTrailByEventId (trailEntryEventId noPreviousEntry)
+          noPreviousAddGetResult `shouldSatisfy` isLeft
 
           -- TODO: Test that invalid signature fails.
-          -- TODO: Test that timestamp in the future is invalid.
 
 
   let healthTests = testCaseSteps "Provides health status" $ \step ->