101 lines
3.2 KiB
Haskell
101 lines
3.2 KiB
Haskell
|
{-# 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")
|