Merge pull request #632 from IntersectMBO/wenkokke/mkSnapshotName

fix: replace mkSnapshotName that returns Maybe with toSnapshotName that errors

Author: jorisdral

bench/macro/lsm-tree-bench-wp8.hs

@@ -411,8 +411,7 @@ doSetup' gopts opts = do
 
     hasBlockIO <- FsIO.ioHasBlockIO hasFS FS.defaultIOCtxParams
 
-    name <- maybe (fail "invalid snapshot name") return $
-        LSM.mkSnapshotName "bench"
+    let name = LSM.toSnapshotName "bench"
 
     LSM.withSession (mkTracer gopts) hasFS hasBlockIO (FS.mkFsPath []) $ \session -> do
         tbl <- LSM.new @IO @K @V @B session (mkTableConfigSetup gopts opts benchTableConfig)
@@ -574,8 +573,7 @@ doRun gopts opts = do
 
     hasBlockIO <- FsIO.ioHasBlockIO hasFS FS.defaultIOCtxParams
 
-    name <- maybe (fail "invalid snapshot name") return $
-        LSM.mkSnapshotName "bench"
+    let name = LSM.toSnapshotName "bench"
 
     LSM.withSession (mkTracer gopts) hasFS hasBlockIO (FS.mkFsPath []) $ \session ->
       withLatencyHandle $ \h -> do

src/Database/LSMTree.hs

@@ -10,6 +10,7 @@
 module Database.LSMTree (
     -- * Exceptions
     Common.LSMTreeError (..)
+  , Common.InvalidSnapshotNameError (..)
 
     -- * Tracing
   , Common.LSMTreeTrace (..)
@@ -67,7 +68,8 @@ module Database.LSMTree (
 
     -- * Durability (snapshots)
   , SnapshotName
-  , Common.mkSnapshotName
+  , Common.isValidSnapshotName
+  , Common.toSnapshotName
   , Common.SnapshotLabel (..)
   , createSnapshot
   , openSnapshot

src/Database/LSMTree/Common.hs

@@ -3,6 +3,7 @@ module Database.LSMTree.Common (
     IOLike
     -- * Exceptions
   , Internal.LSMTreeError (..)
+  , Internal.InvalidSnapshotNameError (..)
     -- * Tracing
   , Internal.LSMTreeTrace (..)
   , Internal.TableTrace (..)
@@ -23,7 +24,8 @@ module Database.LSMTree.Common (
   , listSnapshots
     -- ** Snapshot names
   , Internal.SnapshotName
-  , Internal.mkSnapshotName
+  , Internal.toSnapshotName
+  , Internal.isValidSnapshotName
     -- * Blob references
   , BlobRef (..)
     -- * Table configuration

src/Database/LSMTree/Internal.hs

@@ -1394,15 +1394,14 @@ listSnapshots sesh = do
       snaps <- mapM (checkSnapshot hfs root) $ Set.toList contents
       pure $ catMaybes snaps
   where
-    checkSnapshot hfs root s =
-      case Paths.mkSnapshotName s of
-        Nothing   -> pure Nothing
-        Just snap -> do
-          -- check that it is a directory
-          b <- FS.doesDirectoryExist hfs
-                (Paths.getNamedSnapshotDir $ Paths.namedSnapshotDir root snap)
-          if b then pure $ Just snap
-               else pure $ Nothing
+    checkSnapshot hfs root s = do
+      -- TODO: rethrow 'ErrSnapshotNameInvalid' as 'ErrSnapshotDirCorrupted'
+      let snap = Paths.toSnapshotName s
+      -- check that it is a directory
+      b <- FS.doesDirectoryExist hfs
+            (Paths.getNamedSnapshotDir $ Paths.namedSnapshotDir root snap)
+      if b then pure $ Just snap
+            else pure $ Nothing
 
 {-------------------------------------------------------------------------------
   Multiple writable tables

src/Database/LSMTree/Internal/Paths.hs

@@ -16,7 +16,9 @@ module Database.LSMTree.Internal.Paths (
   , tableBlobPath
     -- * Snapshot name
   , SnapshotName
-  , mkSnapshotName
+  , isValidSnapshotName
+  , InvalidSnapshotNameError (..)
+  , toSnapshotName
     -- * Run paths
   , RunFsPaths (..)
   , pathsForRunFiles
@@ -52,10 +54,10 @@ module Database.LSMTree.Internal.Paths (
 
 import           Control.Applicative (Applicative (..))
 import           Control.DeepSeq (NFData (..))
+import           Control.Exception.Base (Exception, throw)
 import qualified Data.ByteString.Char8 as BS
 import           Data.Foldable (toList)
 import qualified Data.Map as Map
-import           Data.Maybe (fromMaybe)
 import           Data.String (IsString (..))
 import           Data.Traversable (for)
 import qualified Database.LSMTree.Internal.CRC32C as CRC
@@ -92,7 +94,7 @@ snapshotsDir (SessionRoot dir) = dir </> mkFsPath ["snapshots"]
 newtype NamedSnapshotDir = NamedSnapshotDir { getNamedSnapshotDir :: FsPath }
 
 namedSnapshotDir :: SessionRoot -> SnapshotName -> NamedSnapshotDir
-namedSnapshotDir root (MkSnapshotName name) =
+namedSnapshotDir root (SnapshotName name) =
     NamedSnapshotDir (snapshotsDir root </> mkFsPath [name])
 
 newtype SnapshotMetaDataFile = SnapshotMetaDataFile FsPath
@@ -111,47 +113,90 @@ snapshotMetaDataChecksumFile (NamedSnapshotDir dir) =
   Snapshot name
 -------------------------------------------------------------------------------}
 
-newtype SnapshotName = MkSnapshotName FilePath
+newtype SnapshotName = SnapshotName FilePath
   deriving stock (Eq, Ord)
 
 instance Show SnapshotName where
-  showsPrec d (MkSnapshotName p) = showsPrec d p
+  showsPrec d (SnapshotName p) = showsPrec d p
 
--- | This instance uses 'mkSnapshotName', so all the restrictions on snap shot names apply here too. An invalid snapshot name will lead to an error.
+-- | The given string must satsify 'isValidSnapshotName'.
+--   Otherwise, 'fromString' throws an 'InvalidSnapshotNameError'.
 instance IsString SnapshotName where
-  fromString s = fromMaybe bad (mkSnapshotName s)
-    where
-      bad = error ("SnapshotName.fromString: invalid name " ++ show s)
+  fromString :: String -> SnapshotName
+  fromString = toSnapshotName
 
--- | Create snapshot name.
+data InvalidSnapshotNameError
+  = ErrSnapshotNameInvalid !String
+  deriving stock (Show)
+  deriving anyclass (Exception)
+
+-- | Check if a 'String' would be a valid snapshot name.
+--
+-- Snapshot names consist of lowercase characters, digits, dashes @-@,
+-- and underscores @_@, and must be between 1 and 64 characters long.
+-- >>> isValidSnapshotName "main"
+-- True
 --
--- The name may consist of lowercase characters, digits, dashes @-@ and underscores @_@.
--- It must be non-empty and less than 65 characters long.
--- It may not be a special filepath name.
+-- >>> isValidSnapshotName "temporary-123-test_"
+-- True
 --
--- >>> mkSnapshotName "main"
--- Just "main"
+-- >>> isValidSnapshotName "UPPER"
+-- False
+-- >>> isValidSnapshotName "dir/dot.exe"
+-- False
+-- >>> isValidSnapshotName ".."
+-- False
+-- >>> isValidSnapshotName "\\"
+-- False
+-- >>> isValidSnapshotName ""
+-- False
+-- >>> isValidSnapshotName (replicate 100 'a')
+-- False
 --
--- >>> mkSnapshotName "temporary-123-test_"
--- Just "temporary-123-test_"
+-- Snapshot names must be valid directory on both POSIX and Windows.
+-- This rules out the following reserved file and directory names on Windows:
 --
--- >>> map mkSnapshotName ["UPPER", "dir/dot.exe", "..", "\\", "com1", "", replicate 100 'a']
--- [Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing]
+-- >>> isValidSnapshotName "con"
+-- False
+-- >>> isValidSnapshotName "prn"
+-- False
+-- >>> isValidSnapshotName "aux"
+-- False
+-- >>> isValidSnapshotName "nul"
+-- False
+-- >>> isValidSnapshotName "com1" -- "com2", "com3", etc.
+-- False
+-- >>> isValidSnapshotName "lpt1" -- "lpt2", "lpt3", etc.
+-- False
 --
-mkSnapshotName :: String -> Maybe SnapshotName
-mkSnapshotName s
-  | all isValid s
-  , len > 0
-  , len < 65
-  , System.FilePath.Posix.isValid s
-  , System.FilePath.Windows.isValid s
-  = Just (MkSnapshotName s)
-
-  | otherwise
-  = Nothing
+-- See, e.g., [the VBA docs for the "Bad file name or number" error](https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/bad-file-name-or-number-error-52).
+isValidSnapshotName :: String -> Bool
+isValidSnapshotName str =
+    and [ all isValidChar str
+        , strLength >= 1
+        , strLength <= 64
+        , System.FilePath.Posix.isValid str
+        , System.FilePath.Windows.isValid str
+        ]
   where
-    len = length s
-    isValid c = ('a' <= c && c <= 'z') || ('0' <= c && c <= '9' ) || c `elem` "-_"
+    strLength :: Int
+    strLength = length str
+    isValidChar :: Char -> Bool
+    isValidChar c = ('a' <= c && c <= 'z') || ('0' <= c && c <= '9' ) || c `elem` "-_"
+
+-- | Create snapshot name.
+--
+-- The given string must satsify 'isValidSnapshotName'.
+--
+-- Throws the following exceptions:
+--
+-- ['InvalidSnapshotNameError']:
+--   If the given string is not a valid snapshot name.
+--
+toSnapshotName :: String -> SnapshotName
+toSnapshotName str
+  | isValidSnapshotName str = SnapshotName str
+  | otherwise = throw (ErrSnapshotNameInvalid str)
 
 {-------------------------------------------------------------------------------
   Table paths

src/Database/LSMTree/Monoidal.hs

@@ -25,6 +25,7 @@
 module Database.LSMTree.Monoidal (
     -- * Exceptions
     Common.LSMTreeError (..)
+  , Common.InvalidSnapshotNameError (..)
 
     -- * Tracing
   , Common.LSMTreeTrace (..)
@@ -84,7 +85,8 @@ module Database.LSMTree.Monoidal (
 
     -- * Durability (snapshots)
   , SnapshotName
-  , Common.mkSnapshotName
+  , Common.toSnapshotName
+  , Common.isValidSnapshotName
   , Common.SnapshotLabel (..)
   , createSnapshot
   , openSnapshot

src/Database/LSMTree/Normal.hs

@@ -24,6 +24,7 @@
 module Database.LSMTree.Normal (
     -- * Exceptions
     Common.LSMTreeError (..)
+  , Common.InvalidSnapshotNameError (..)
 
     -- * Tracing
   , Common.LSMTreeTrace (..)
@@ -85,7 +86,8 @@ module Database.LSMTree.Normal (
 
     -- * Durability (snapshots)
   , SnapshotName
-  , Common.mkSnapshotName
+  , Common.toSnapshotName
+  , Common.isValidSnapshotName
   , Common.SnapshotLabel (..)
   , createSnapshot
   , openSnapshot

test/Test/Database/LSMTree/Class.hs

@@ -13,14 +13,13 @@ import           Data.Foldable (toList)
 import           Data.Functor.Compose (Compose (..))
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NE
-import           Data.Maybe (fromMaybe)
 import qualified Data.Proxy as Proxy
 import qualified Data.Vector as V
 import qualified Data.Vector.Algorithms.Merge as VA
 import           Data.Word (Word64)
 import qualified Database.LSMTree as R
 import           Database.LSMTree.Class
-import           Database.LSMTree.Common (mkSnapshotName)
+import           Database.LSMTree.Common (toSnapshotName)
 import           Database.LSMTree.Extras.Generators ()
 import qualified Database.LSMTree.Model.IO as ModelIO
 import qualified System.FS.API as FS
@@ -682,7 +681,7 @@ prop_snapshotNoChanges h ups ups' testKeys = ioProperty $ do
 
       res <- lookupsWithBlobs tbl1 ses $ V.fromList testKeys
 
-      let name = fromMaybe (error "invalid name") $ mkSnapshotName "foo"
+      let name = toSnapshotName "foo"
 
       createSnapshot label name tbl1
       updates tbl1 (V.fromList ups')
@@ -701,7 +700,7 @@ prop_snapshotNoChanges2 :: forall h.
     -> [(Key, Update Value Blob)] -> [Key] -> Property
 prop_snapshotNoChanges2 h ups ups' testKeys = ioProperty $ do
     withSessionAndTableNew h ups $ \sess tbl0 -> do
-      let name = fromMaybe (error "invalid name") $ mkSnapshotName "foo"
+      let name = toSnapshotName "foo"
       createSnapshot label name tbl0
 
       withTableFromSnapshot @h sess label name $ \tbl1 ->

test/Test/Database/LSMTree/Internal/Snapshot/FS.hs

@@ -8,7 +8,6 @@ import           Control.Monad.Class.MonadThrow
 import           Control.Monad.IOSim (runSimOrThrow)
 import           Control.Tracer
 import           Data.Bifunctor (Bifunctor (..))
-import           Data.Maybe (fromJust)
 import qualified Data.Vector as V
 import           Data.Word
 import           Database.LSMTree.Extras (showPowersOf10)
@@ -216,7 +215,7 @@ prop_flipSnapshotBit (Positive (Small bufferSize)) es pickFileBit =
     resolve (SerialisedValue x) (SerialisedValue y) =
         SerialisedValue (x <> y)
 
-    snapName = fromJust $ mkSnapshotName "snap"
+    snapName = toSnapshotName "snap"
     snapLabel = SnapshotLabel "label"
 
     createSnap t =

test/Test/Database/LSMTree/StateMachine.hs

@@ -78,7 +78,7 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (catMaybes, fromJust, fromMaybe, isJust)
+import           Data.Maybe (catMaybes, fromMaybe, isJust)
 import           Data.Monoid (First (..))
 import           Data.Primitive.MutVar
 import           Data.Set (Set)
@@ -1866,7 +1866,7 @@ arbitraryActionWithVars _ label ctx (ModelState st _stats) =
             then Left  snapshotname -- used
             else Right snapshotname -- unused
         | name <- ["snap1", "snap2", "snap3" ]
-        , let snapshotname = fromJust (R.mkSnapshotName name)
+        , let snapshotname = R.toSnapshotName name
         ]
 
     genActionsSession :: [(Int, Gen (Any (LockstepAction (ModelState h))))]