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

src/Nuthatch/Paths.hs

@@ -0,0 +1,60 @@
+module Nuthatch.Paths
+  ( validateRelativePath
+  , buildObjectKey
+  , listCacheAncestorPrefixes
+  , encodeUserId
+  , basename
+  ) where
+
+import           Crypto.Hash (Digest, SHA256, hash)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as B16
+import           Data.Char (isControl)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import           Nuthatch.Types
+
+validateRelativePath :: Text -> Either Text RelativePath
+validateRelativePath raw = do
+  let path = T.dropWhile (== '/') raw
+  if T.null path
+    then Left "path must not be empty"
+    else do
+      let segments = T.splitOn "/" path
+      mapM_ validateSegment segments
+      pure (RelativePath path)
+  where
+    validateSegment seg
+      | T.null seg = Left "empty path segment"
+      | seg == "." || seg == ".." = Left "path segment may not be . or .."
+      | T.any (== '\\') seg = Left "backslash is not allowed"
+      | T.any isControl seg = Left "control characters are not allowed"
+      | otherwise = Right ()
+
+buildObjectKey :: Root -> UserId -> RelativePath -> ObjectKey
+buildObjectKey root uid (RelativePath path) =
+  ObjectKey $ case root of
+    Personal -> "users/" <> unUserId uid <> "/" <> path
+    Shared   -> "shared/" <> path
+
+listCacheAncestorPrefixes :: RelativePath -> [Text]
+listCacheAncestorPrefixes (RelativePath path) =
+  let segs = filter (not . T.null) (T.splitOn "/" path)
+  in case segs of
+       [] -> [""]
+       _  -> "" : init (scanl1 (\a b -> a <> "/" <> b) segs)
+
+encodeUserId :: Text -> Text -> UserId
+encodeUserId iss sub =
+  let material = TE.encodeUtf8 (iss <> "\0" <> sub)
+      digest = hash material :: Digest SHA256
+      hex = B16.encode (BS.pack (BA.unpack digest))
+  in UserId (TE.decodeUtf8 hex)
+
+basename :: RelativePath -> Text
+basename (RelativePath path) =
+  case reverse (T.splitOn "/" path) of
+    (x : _) -> x
+    []      -> path