Add Haskell MVP BFF with mutation protocol and local compose stack.

test/Spec.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Main (main) where
+
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Nuthatch.Paths
+  ( buildObjectKey
+  , encodeUserId
+  , listCacheAncestorPrefixes
+  , validateRelativePath
+  )
+import           Nuthatch.Protocol
+  ( MutationRecord (..)
+  , ObjectObservation (..)
+  , desiredMatches
+  , priorMatches
+  )
+import           Nuthatch.Types
+
+main :: IO ()
+main = do
+  assertRight "simple path" (validateRelativePath "a/b.txt")
+  assertLeft "dotdot" (validateRelativePath "a/../b")
+  assertLeft "empty segment" (validateRelativePath "a//b")
+  assertLeft "slash only" (validateRelativePath "/")
+  let uid = encodeUserId "iss" "sub"
+  assertTrue "user id stable" (uid == encodeUserId "iss" "sub")
+  assertTrue "user id differs"
+    (encodeUserId "iss" "sub" /= encodeUserId "iss" "other")
+  let key = buildObjectKey Personal uid (RelativePath "docs/a.txt")
+  assertTrue "personal key prefix" $
+    T.isPrefixOf ("users/" <> unUserId uid <> "/") (unObjectKey key)
+  let shared = buildObjectKey Shared uid (RelativePath "docs/a.txt")
+  assertTrue "shared key" (unObjectKey shared == "shared/docs/a.txt")
+
+  assertTrue "list ancestors nested" $
+    listCacheAncestorPrefixes (RelativePath "docs/a/b.txt")
+      == ["", "docs", "docs/a"]
+  assertTrue "list ancestors root file" $
+    listCacheAncestorPrefixes (RelativePath "file.txt") == [""]
+
+  let putRec = samplePut
+  assertTrue "put desired present" $
+    desiredMatches putRec (ObjectPresent 10 (Just (ContentSha256 "abc")))
+  assertTrue "put not desired absent" $
+    not (desiredMatches putRec ObjectAbsent)
+  assertTrue "put unavailable not desired" $
+    not (desiredMatches putRec (ObjectUnavailable "timeout"))
+  assertTrue "put prior empty absent" $
+    priorMatches putRec ObjectAbsent
+  assertTrue "put unavailable not prior" $
+    not (priorMatches putRec (ObjectUnavailable "timeout"))
+  let delRec = sampleDelete
+  assertTrue "delete desired absent" $
+    desiredMatches delRec ObjectAbsent
+  assertTrue "delete not desired present" $
+    not (desiredMatches delRec (ObjectPresent 10 Nothing))
+
+  putStrLn "nuthatch-unit: ok"
+
+samplePut :: MutationRecord
+samplePut = MutationRecord
+  { mrUserId = UserId "u"
+  , mrKind = Put
+  , mrOperationId = OperationId "op"
+  , mrPoolId = PoolId "personal:u"
+  , mrObjectKey = ObjectKey "users/u/file.txt"
+  , mrRelativePath = RelativePath "file.txt"
+  , mrDeclaredSize = 10
+  , mrContentSha256 = Just (ContentSha256 "abc")
+  , mrPriorSize = 0
+  , mrPriorSha256 = Nothing
+  , mrGrowth = 10
+  , mrState = Applying
+  , mrExternal = ExtSettled
+  }
+
+sampleDelete :: MutationRecord
+sampleDelete = samplePut
+  { mrKind = Delete
+  , mrDeclaredSize = 0
+  , mrContentSha256 = Nothing
+  , mrPriorSize = 10
+  , mrPriorSha256 = Just (ContentSha256 "abc")
+  , mrGrowth = 0
+  }
+
+assertRight :: String -> Either Text a -> IO ()
+assertRight label = \case
+  Right _ -> pure ()
+  Left err -> fail (label <> ": " <> T.unpack err)
+
+assertLeft :: String -> Either Text a -> IO ()
+assertLeft label = \case
+  Left _  -> pure ()
+  Right _ -> fail (label <> ": expected failure")
+
+assertTrue :: String -> Bool -> IO ()
+assertTrue _ True  = pure ()
+assertTrue label False = fail (label <> ": expected True")