diff --git a/README.md b/README.md index 67cf265..80d88f1 100644 --- a/README.md +++ b/README.md @@ -6,16 +6,6 @@ A type-safe abstraction for platform-independent file system paths. -# Example - -```purescript -fullPath = rootDir dir "baz" file "foo.png" -``` - -See the [tests file](/test/Main.purs) for various example usages more. - -# Getting Started - ## Installation ```bash @@ -23,7 +13,7 @@ bower install purescript-pathy ``` ```purescript -import Data.Path.Pathy +import Pathy ``` ## Introduction @@ -34,9 +24,8 @@ Many path libraries provide a single abstraction to deal with file system paths. * The distinction between relative and absolute paths. * The distinction between paths denoting file resources and paths denoting directories. - * The distinction between paths that are secure (sandboxed to some location in the file system) and those that are insecure. -*Pathy* also uses a single abstraction for file system paths, called `Path`, but uses *phantom types* to keep track of the above distinctions. +Pathy also uses a single abstraction for file system paths, called `Path`, but uses *phantom types* to keep track of the above distinctions. This approach lets you write code that performs type-safe composition of relative, absolute, file, and directory paths, and makes sure you never use paths in an unsafe fashion. Bogus and insecure operations simply aren't allowed by the type system! @@ -46,48 +35,50 @@ Many paths come from user-input or configuration data. Pathy can parse such stri Building path liberals is easy. You will typically build path literals from the following components: - * `rootDir` — The root directory of an absolute path. - * `currentDir` — The current directory (AKA the "working directory"), useful for building relative paths. - * `file` — A file (in the current directory). - * `dir` — A directory (in the current directory). - * `()` — Adds a relative path to the end of a (relative or absolute) path. - * `(<.>)` — Sets the extension of a file path. - * `(<..>)` — Ascends one level in a directory, then descends into the specified relative path. + * `rootDir` – The root directory of an absolute path. + * `currentDir` – The current directory (AKA the "working directory"), useful for building relative paths. + * `file` – A file (in the current directory). + * `dir` – A directory (in the current directory). + * `()` – Adds a relative path to the end of a (relative or absolute) path. + * `(<.>)` – Sets the extension of a file path. + * `(<..>)` – Ascends one level in a directory, then descends into the specified relative path. + +All path segments (`file` / `dir`) names are required to be non-empty. This is enforced by `Name` being constructed from a `NonEmptyString`. At compile time, we can have provably non-empty strings by using `Symbol`s and a bit of type class trickery: -For example: +``` purescript +dirFoo :: Name Dir +dirFoo = dir (SProxy :: SProxy "foo") +``` + +Here we're using a symbol proxy (`SProxy`) and then typing it to explicitly carry the name that we want to use for our path at runtime. There is also a `dir'` and `file'` variation on the function that accepts normal `Name` values, so if you are not constructing a path at compile-time, you'd be using these instead. + +Some example compile-time path constructions: ```purescript -let - path1 = rootDir dir "foo" dir "bar" file "baz.boo" - path2 = currentDir dir "foo" -in do - trace $ show $ printPath path1 - trace $ show $ printPath path2 +path1 = rootDir dir (SProxy :: SProxy "foo") dir (SProxy :: SProxy "bar") file (SProxy :: SProxy "baz.boo") +path2 = currentDir dir (SProxy :: SProxy "foo") ``` -Pathy doesn't let you create combinators that don't make sense, such as: +Thanks to the phantom type parameters, Pathy doesn't let you create path combinations that don't make sense. The following examples will be rejected at compile time: ```purescript -rootDir rootDir +rootDir rootDir currentDir rootDir -file "foo" file "bar" -file "foo" dir "bar" +file (SProxy :: SProxy "foo") file (SProxy :: SProxy "bar") +file (SProxy :: SProxy "foo") dir (SProxy :: SProxy "bar") ``` -All these combinations will be disallowed at compile time! - ### The Path Type -The `Path a b s` type has three type parameters: +The `Path a b` type has two type parameters: - * `a` — This may be `Abs` or `Rel`, indicating whether the path is absolute or relative. - * `b` — This may be `Dir` or `File`, indicating whether the path is a file or directory. - * `s` — This may be `Sandboxed` or `Unsandboxed`, indicating whether the path has been sandboxed yet or not. + * `a` – This may be `Abs` or `Rel`, indicating whether the path is absolute or relative. + * `b` – This may be `Dir` or `File`, indicating whether the path is a file or directory. You should try to make the `Path` functions that you write as generic as possible. If you have a function that only cares if a path refers to a file, then you can write it like this: ```purescript -myFunction :: forall a s. Path a File s -> ... +myFunction :: forall a. Path a File -> ... myFunction p = ... ``` @@ -97,38 +88,34 @@ By universally quantifying over the type parameters you don't care about, you en To parse a string into a `Path`, you can use the `parsePath` function, which expects you to handle four cases: - * `Path Rel File Unsandboxed` - * `Path Abs File Unsandboxed` - * `Path Rel Dir Unsandboxed` - * `Path Abs Dir Unsandboxed` + * `Path Rel File` + * `Path Abs File` + * `Path Rel Dir` + * `Path Abs Dir` If you need a specific case, you can use helper functions such as `parseRelFile`, which return a `Maybe`. -### Print Paths to Strings - -You can print any path as a `String` by calling the `printPath` function. - -For security reasons, you can only perform this operation if you have *sandboxed* the path. Sandboxing a path ensures that users cannot escape a sandbox directory that you specify; it's the right thing to do! +The `parsePath` function also expects a `Parser` argument so that different path formats can be parsed into the common `Path` type. ### Sandboxing -Pathy makes it easy to create relative paths, even paths that ascend into parent directories of relative paths. - -With this power comes danger: if you parse a user string, the user may be able to escape any arbitrary directory. +Pathy makes it easy to create relative paths, even paths that ascend into parent directories of relative paths. With this power comes danger: if you parse a user string, the user may be able to escape any arbitrary directory. Pathy solves this security problem by *disallowing* conversion from a `Path` to a `String` until the `Path` has been *sandboxed*. To sandbox a path, you just call `sandbox` and provide the sandbox directory, as well as the path to sandbox: ```purescript -sandbox (rootDir dir "foo") (rootDir dir "foo" dir "bar") +sandbox + (rootDir dir (SProxy :: SProxy "foo")) -- sandbox root + (rootDir dir (SProxy :: SProxy "foo") dir (SProxy :: SProxy "bar")) -- path to sandbox ``` -This returns a `Maybe`, which is either equal to `Nothing` if the tainted path escapes the sandbox, or `Just p`, where `p` is the tainted path, relative to the sandbox path. +This returns a `Maybe`, which is `Nothing` if the tainted path escapes the sandbox. -After you have sandboxed a foreign path, you may call `printPath` on it. There's no need to remember this rule because it's enforced at compile-time by phantom types! +After you have sandboxed a foreign path, you may call `printPath` on it, which will print the path absolutely. -All the path literals you build by hand are automatically sandboxed, unless you call `parentDir'` on them. +There is also the option to `unsafePrintPath`. This is labelled as being unsafe as it may be depending on how it is used - for example, if a path was sandboxed against some path other than the current working directory, but then used when launching a command in the current working directory, it may still refer to a location that it should not have access to. ### Renaming, Transforming, Etc. diff --git a/bower.json b/bower.json index ac9ee13..80ee726 100644 --- a/bower.json +++ b/bower.json @@ -22,12 +22,12 @@ "purescript-lists": "^4.0.0", "purescript-partial": "^1.2.0", "purescript-profunctor": "^3.0.0", - "purescript-strings": "^3.0.0", + "purescript-strings": "^3.5.0", "purescript-transformers": "^3.0.0", - "purescript-unsafe-coerce": "^3.0.0" + "purescript-unsafe-coerce": "^3.0.0", + "purescript-typelevel-prelude": "^2.6.0" }, "devDependencies": { - "purescript-quickcheck": "^4.0.0", - "purescript-quickcheck-laws": "^3.0.0" + "purescript-quickcheck": "^4.0.0" } } diff --git a/src/Data/Path/Pathy.purs b/src/Data/Path/Pathy.purs deleted file mode 100644 index af4c12b..0000000 --- a/src/Data/Path/Pathy.purs +++ /dev/null @@ -1,560 +0,0 @@ -module Data.Path.Pathy - ( Abs - , AbsDir - , AbsFile - , AbsPath - , Dir - , DirName(..) - , Escaper(..) - , File - , FileName(..) - , Path - , AnyPath - , Rel - , RelDir - , RelFile - , RelPath - , Sandboxed - , Unsandboxed - , appendPath - , () - , setExtension - , (<.>) - , parentAppend - , (<..>) - , runDirName - , runFileName - , canonicalize - , changeExtension - , currentDir - , depth - , dir - , dir' - , dirName - , dropExtension - , extension - , file - , file' - , fileName - , pathName - , identicalPath - , isAbsolute - , isRelative - , maybeAbs - , maybeDir - , maybeFile - , maybeRel - , parentDir - , parentDir' - , peel - , posixEscaper - , parsePath - , parseAbsDir - , parseAbsFile - , parseRelDir - , parseRelFile - , printPath - , printPath' - , refine - , relativeTo - , renameDir - , renameFile - , rootDir - , runEscaper - , sandbox - , unsandbox - , unsafePrintPath - , unsafePrintPath' - ) - where - -import Prelude - -import Data.Array ((!!), filter, length, zipWith, range) -import Data.Bifunctor (bimap) -import Data.Either (Either(..), either) -import Data.Foldable (foldl) -import Data.Maybe (Maybe(..), maybe) -import Data.String as S -import Data.Tuple (Tuple(..), fst, snd) - -import Unsafe.Coerce (unsafeCoerce) - --- | The (phantom) type of relative paths. -foreign import data Rel :: Type - --- | The (phantom) type of absolute paths. -foreign import data Abs :: Type - --- | The (phantom) type of files. -foreign import data File :: Type - --- | The (phantom) type of directories. -foreign import data Dir :: Type - --- | The (phantom) type of unsandboxed paths. -foreign import data Unsandboxed :: Type - --- | The (phantom) type of sandboxed paths. -foreign import data Sandboxed :: Type - --- | A newtype around a file name. -newtype FileName = FileName String - --- | Unwraps the `FileName` newtype. -runFileName :: FileName -> String -runFileName (FileName name) = name - --- | A newtype around a directory name. -newtype DirName = DirName String - --- | Unwraps the `DirName` newtype. -runDirName :: DirName -> String -runDirName (DirName name) = name - --- | A type that describes a Path. All flavors of paths are described by this --- | type, whether they are absolute or relative paths, whether they --- | refer to files or directories, whether they are sandboxed or not. --- | --- | * The type parameter `a` describes whether the path is `Rel` or `Abs`. --- | * The type parameter `b` describes whether the path is `File` or `Dir`. --- | * The type parameter `s` describes whether the path is `Sandboxed` or `Unsandboxed`. --- | --- | To ensure type safety, there is no way for users to create a value of --- | this type directly. Instead, helpers should be used, such as `rootDir`, --- | `currentDir`, `file`, `dir`, `()`, and `parsePath`. --- | --- | This ADT allows invalid paths (e.g. paths inside files), but there is no --- | possible way for such paths to be constructed by user-land code. The only --- | "invalid path" that may be constructed is using the `parentDir'` function, e.g. --- | `parentDir' rootDir`, or by parsing an equivalent string such as `/../`, --- | but such paths are marked as unsandboxed, and may not be rendered to strings --- | until they are first sandboxed to some directory. -data Path a b s - = Current - | Root - | ParentIn (Path a b s) - | DirIn (Path a b s) DirName - | FileIn (Path a b s) FileName - --- | A type describing a file whose location is given relative to some other, --- | unspecified directory (referred to as the "current directory"). -type RelFile s = Path Rel File s - --- | A type describing a file whose location is absolutely specified. -type AbsFile s = Path Abs File s - --- | A type describing a directory whose location is given relative to some --- | other, unspecified directory (referred to as the "current directory"). -type RelDir s = Path Rel Dir s - --- | A type describing a directory whose location is absolutely specified. -type AbsDir s = Path Abs Dir s - --- | A type describing a file or directory path. -type AnyPath b s = Either (Path b Dir s) (Path b File s) - --- | A type describing a relative file or directory path. -type RelPath s = AnyPath Rel s - --- | A type describing an absolute file or directory path. -type AbsPath s = AnyPath Abs s - --- | Escapers encode segments or characters which have reserved meaning. -newtype Escaper = Escaper (String -> String) - --- | Given an escaper and a segment to encode, returns the encoded segment. -runEscaper :: Escaper -> String -> String -runEscaper (Escaper f) = f - --- | An escaper that does nothing except remove slashes (the bare minimum of --- | what must be done). -nonEscaper :: Escaper -nonEscaper = Escaper \s -> S.joinWith "" $ filter (_ /= "/") (S.split (S.Pattern "") s) - --- | An escaper that removes all slashes, converts ".." into "$dot$dot", and --- | converts "." into "$dot". -posixEscaper :: Escaper -posixEscaper = Escaper $ - runEscaper nonEscaper >>> - case _ of - ".." -> "$dot$dot" - "." -> "$dot" - s -> s - --- | Creates a path which points to a relative file of the specified name. -file :: forall s. String -> Path Rel File s -file f = file' (FileName f) - --- | Creates a path which points to a relative file of the specified name. -file' :: forall s. FileName -> Path Rel File s -file' f = FileIn Current f - --- | Retrieves the name of a file path. -fileName :: forall a s. Path a File s -> FileName -fileName (FileIn _ f) = f -fileName _ = FileName "" - --- | Retrieves the extension of a file name. -extension :: FileName -> String -extension (FileName f) = case S.lastIndexOf (S.Pattern ".") f of - Just x -> S.drop (x + 1) f - Nothing -> "" - --- | Drops the extension on a file name. -dropExtension :: FileName -> FileName -dropExtension (FileName n) = case S.lastIndexOf (S.Pattern ".") n of - Just x -> FileName $ S.take x n - Nothing -> FileName n - --- | Changes the extension on a file name. -changeExtension :: (String -> String) -> FileName -> FileName -changeExtension f nm = - update (f $ extension nm) (dropExtension nm) - where - update "" n = n - update ext (FileName n) = FileName $ n <> "." <> ext - --- | Creates a path which points to a relative directory of the specified name. -dir :: forall s. String -> Path Rel Dir s -dir d = dir' (DirName d) - --- | Creates a path which points to a relative directory of the specified name. -dir' :: forall s. DirName -> Path Rel Dir s -dir' d = DirIn Current d - --- | Retrieves the name of a directory path. Not all paths have such a name, --- | for example, the root or current directory. -dirName :: forall a s. Path a Dir s -> Maybe DirName -dirName p = case canonicalize p of - DirIn _ d -> Just d - _ -> Nothing - -pathName :: forall b s. AnyPath b s -> Either (Maybe DirName) FileName -pathName = bimap dirName fileName - --- | Given a directory path, appends either a file or directory to the path. -appendPath :: forall a b s. Path a Dir s -> Path Rel b s -> Path a b s -appendPath Current Current = Current -appendPath Root Current = Root -appendPath (ParentIn p1) Current = ParentIn (p1 Current) -appendPath (FileIn p1 f1) Current = FileIn (p1 Current) f1 -appendPath (DirIn p1 d1) Current = DirIn (p1 Current) d1 -appendPath p1 (ParentIn p2) = ParentIn (p1 p2) -appendPath p1 (FileIn p2 f2) = FileIn (p1 p2) f2 -appendPath p1 (DirIn p2 d2) = DirIn (p1 p2) d2 --- following cases don't make sense but cannot exist -appendPath Current Root = Current -appendPath Root Root = Root -appendPath (ParentIn p1) Root = ParentIn (p1 Current) -appendPath (FileIn p1 f1) Root = FileIn (p1 Current) f1 -appendPath (DirIn p1 d1) Root = DirIn (p1 Current) d1 - -infixl 6 appendPath as - --- | Sets the extension of the file to the specified extension. --- | --- | ```purescript --- | file "image" <.> "png" --- | ``` -setExtension :: forall a s. Path a File s -> String -> Path a File s -setExtension p ext = renameFile (changeExtension $ const ext) p - -infixl 6 setExtension as <.> - --- | Ascends into the parent of the specified directory, then descends into --- | the specified path. The result is always unsandboxed because it may escape --- | its previous sandbox. -parentAppend - :: forall a b s s' - . Path a Dir s - -> Path Rel b s' - -> Path a b Unsandboxed -parentAppend d p = parentDir' d unsandbox p - -infixl 6 parentAppend as <..> - --- | Determines if this path is absolutely located. -isAbsolute :: forall a b s. Path a b s -> Boolean -isAbsolute Current = false -isAbsolute Root = true -isAbsolute (ParentIn p) = isAbsolute p -isAbsolute (FileIn p _) = isAbsolute p -isAbsolute (DirIn p _) = isAbsolute p - --- | Determines if this path is relatively located. -isRelative :: forall a b s. Path a b s -> Boolean -isRelative = not <<< isAbsolute - --- | Peels off the last directory and the terminal file or directory name --- | from the path. Returns `Nothing` if there is no such pair (for example, --- | if the last path segment is root directory, current directory, or parent --- | directory). -peel - :: forall a b s - . Path a b s - -> Maybe (Tuple (Path a Dir s) (Either DirName FileName)) -peel Current = Nothing -peel Root = Nothing -peel p@(ParentIn _) = case canonicalize' p of - Tuple true p' -> peel p' - _ -> Nothing -peel (DirIn p d) = Just $ Tuple (unsafeCoerceType p) (Left d) -peel (FileIn p f) = Just $ Tuple (unsafeCoerceType p) (Right f) - --- | Determines if the path refers to a directory. -maybeDir :: forall a b s. Path a b s -> Maybe (Path a Dir s) -maybeDir Current = Just Current -maybeDir Root = Just Root -maybeDir (ParentIn p) = Just $ ParentIn (unsafeCoerceType p) -maybeDir (FileIn _ _) = Nothing -maybeDir (DirIn p d) = Just $ DirIn (unsafeCoerceType p) d - --- | Determines if the path refers to a file. -maybeFile :: forall a b s. Path a b s -> Maybe (Path a File s) -maybeFile Current = Nothing -maybeFile Root = Nothing -maybeFile (ParentIn _) = Nothing -maybeFile (FileIn p f) = () <$> maybeDir p <*> Just (file' f) -maybeFile (DirIn _ _) = Nothing - --- | Determines if the path is relatively specified. -maybeRel :: forall a b s. Path a b s -> Maybe (Path Rel b s) -maybeRel Current = Just Current -maybeRel Root = Nothing -maybeRel (ParentIn p) = ParentIn <$> maybeRel p -maybeRel (FileIn p f) = flip FileIn f <$> maybeRel p -maybeRel (DirIn p d) = flip DirIn d <$> maybeRel p - --- | Determines if the path is absolutely specified. -maybeAbs :: forall a b s. Path a b s -> Maybe (Path Rel b s) -maybeAbs Current = Nothing -maybeAbs Root = Just Root -maybeAbs (ParentIn p) = ParentIn <$> maybeAbs p -maybeAbs (FileIn p f) = flip FileIn f <$> maybeAbs p -maybeAbs (DirIn p d) = flip DirIn d <$> maybeAbs p - --- | Returns the depth of the path. This may be negative in some cases, e.g. --- | `./../../../` has depth `-3`. -depth :: forall a b s. Path a b s -> Int -depth Current = 0 -depth Root = 0 -depth (ParentIn p) = depth p - 1 -depth (FileIn p _) = depth p + 1 -depth (DirIn p _) = depth p + 1 - --- | Attempts to extract out the parent directory of the specified path. If the --- | function would have to use a relative path in the return value, the function will --- | instead return `Nothing`. -parentDir :: forall a b s. Path a b s -> Maybe (Path a Dir s) -parentDir p = fst <$> peel p - --- | Unsandboxes any path (whether sandboxed or not). -unsandbox :: forall a b s. Path a b s -> Path a b Unsandboxed -unsandbox Current = Current -unsandbox Root = Root -unsandbox (ParentIn p) = ParentIn (unsandbox p) -unsandbox (DirIn p d) = DirIn (unsandbox p) d -unsandbox (FileIn p f) = FileIn (unsandbox p) f - --- | Creates a path that points to the parent directory of the specified path. --- | This function always unsandboxes the path. -parentDir' :: forall a b s. Path a b s -> Path a Dir Unsandboxed -parentDir' = ParentIn <<< unsafeCoerceType <<< unsandbox - -unsafeCoerceType :: forall a b b' s. Path a b s -> Path a b' s -unsafeCoerceType = unsafeCoerce - - -- | The "current directory", which can be used to define relatively-located resources. -currentDir :: forall s. Path Rel Dir s -currentDir = Current - --- | The root directory, which can be used to define absolutely-located resources. -rootDir :: forall s. Path Abs Dir s -rootDir = Root - --- | Renames a file path. -renameFile :: forall a s. (FileName -> FileName) -> Path a File s -> Path a File s -renameFile f (FileIn p f0) = FileIn p (f f0) -renameFile _ p = p - --- | Renames a directory path. Note: This is a simple rename of the terminal --- | directory name, not a "move". -renameDir :: forall a s. (DirName -> DirName) -> Path a Dir s -> Path a Dir s -renameDir f (DirIn p d) = DirIn p (f d) -renameDir _ p = p - --- | Canonicalizes a path, by reducing things in the form `/x/../` to just `/x/`. -canonicalize :: forall a b s. Path a b s -> Path a b s -canonicalize = snd <<< canonicalize' - --- | Canonicalizes a path and returns information on whether or not it actually changed. -canonicalize' :: forall a b s. Path a b s -> Tuple Boolean (Path a b s) -canonicalize' Current = Tuple false Current -canonicalize' Root = Tuple false Root -canonicalize' (ParentIn (FileIn p f)) = Tuple true (snd $ canonicalize' p) -canonicalize' (ParentIn (DirIn p f)) = Tuple true (snd $ canonicalize' p) -canonicalize' (ParentIn p) = case canonicalize' p of - Tuple changed p' -> - let p'' = ParentIn p' - in if changed then canonicalize' p'' else Tuple changed p'' -canonicalize' (FileIn p f) = flip FileIn f <$> canonicalize' p -canonicalize' (DirIn p d) = flip DirIn d <$> canonicalize' p - -unsafePrintPath' :: forall a b s. Escaper -> Path a b s -> String -unsafePrintPath' r = go - where - go Current = "./" - go Root = "/" - go (ParentIn p) = go p <> "../" - go (DirIn p@(FileIn _ _ ) (DirName d)) = go p <> "/" <> escape d <> "/" -- dir inside a file - go (DirIn p (DirName d)) = go p <> escape d <> "/" -- dir inside a dir - go (FileIn p@(FileIn _ _) (FileName f)) = go p <> "/" <> escape f -- file inside a file - go (FileIn p (FileName f)) = go p <> escape f - escape = runEscaper r - -unsafePrintPath :: forall a b s. Path a b s -> String -unsafePrintPath = unsafePrintPath' posixEscaper - --- | Prints a `Path` into its canonical `String` representation. For security --- | reasons, the path must be sandboxed before it can be rendered to a string. -printPath :: forall a b. Path a b Sandboxed -> String -printPath = unsafePrintPath - --- | Prints a `Path` into its canonical `String` representation, using the --- | specified escaper to escape special characters in path segments. For --- | security reasons, the path must be sandboxed before rendering to string. -printPath' :: forall a b. Escaper -> Path a b Sandboxed -> String -printPath' = unsafePrintPath' - --- | Determines if two paths have the exact same representation. Note that --- | two paths may represent the same path even if they have different --- | representations! -identicalPath :: forall a a' b b' s s'. Path a b s -> Path a' b' s' -> Boolean -identicalPath p1 p2 = show p1 == show p2 - --- | Makes one path relative to another reference path, if possible, otherwise --- | returns `Nothing`. The returned path inherits the sandbox settings of the --- | reference path. --- | --- | Note there are some cases this function cannot handle. -relativeTo :: forall a b s s'. Path a b s -> Path a Dir s' -> Maybe (Path Rel b s') -relativeTo p1 p2 = relativeTo' (canonicalize p1) (canonicalize p2) - where - relativeTo' :: forall b'. Path a b' s -> Path a Dir s' -> Maybe (Path Rel b' s') - relativeTo' Root Root = Just Current - relativeTo' Current Current = Just Current - relativeTo' cp1 cp2 - | identicalPath cp1 cp2 = Just Current - | otherwise = case peel cp1 of - Just (Tuple cp1' e) -> - flip () (either (DirIn Current) (FileIn Current) e) <$> relativeTo' cp1' cp2 - Nothing -> Nothing - --- | Attempts to sandbox a path relative to some directory. If successful, the sandboxed --- | directory will be returned relative to the sandbox directory (although this can easily --- | be converted into an absolute path using ``). --- | --- | This combinator can be used to ensure that paths which originate from user-code --- | cannot access data outside a given directory. -sandbox :: forall a b s. Path a Dir Sandboxed -> Path a b s -> Maybe (Path Rel b Sandboxed) -sandbox p1 p2 = p2 `relativeTo` p1 - --- | Refines path segments but does not change anything else. -refine :: forall a b s. (FileName -> FileName) -> (DirName -> DirName) -> Path a b s -> Path a b s -refine f d = go - where go (Current ) = Current - go (Root ) = Root - go (ParentIn p ) = ParentIn (go p) - go (DirIn p d0) = DirIn (go p) (d d0) - go (FileIn p f0) = FileIn (go p) (f f0) - --- | Parses a canonical `String` representation of a path into a `Path` value. --- | Note that in order to be unambiguous, trailing directories should be --- | marked with a trailing slash character (`'/'`). -parsePath - :: forall z - . (RelDir Unsandboxed -> z) - -> (AbsDir Unsandboxed -> z) - -> (RelFile Unsandboxed -> z) - -> (AbsFile Unsandboxed -> z) - -> String - -> z -parsePath rd ad rf af "" = rd Current -parsePath rd ad rf af p = - let - segs = S.split (S.Pattern "/") p - last = length segs - 1 - isAbs = S.take 1 p == "/" - isFile = maybe false (_ /= "") (segs !! last) - tuples = zipWith Tuple segs (range 0 last) - - folder :: forall a b s. Path a b s -> Tuple String Int -> Path a b s - folder base (Tuple seg idx) = - case seg of - "." -> base - "" -> base - ".." -> ParentIn base - _ | isFile && idx == last -> FileIn base (FileName seg) - | otherwise -> DirIn base (DirName seg) - in - case isAbs, isFile of - true, true -> af (foldl folder Root tuples) - true, false -> ad (foldl folder Root tuples) - false, true -> rf (foldl folder Current tuples) - false, false -> rd (foldl folder Current tuples) - --- | Attempts to parse a relative file from a string. -parseRelFile :: String -> Maybe (RelFile Unsandboxed) -parseRelFile = parsePath (const Nothing) (const Nothing) Just (const Nothing) - --- | Attempts to parse an absolute file from a string. -parseAbsFile :: String -> Maybe (AbsFile Unsandboxed) -parseAbsFile = parsePath (const Nothing) (const Nothing) (const Nothing) Just - --- | Attempts to parse a relative directory from a string. -parseRelDir :: String -> Maybe (RelDir Unsandboxed) -parseRelDir = parsePath Just (const Nothing) (const Nothing) (const Nothing) - --- | Attempts to parse an absolute directory from a string. -parseAbsDir :: String -> Maybe (AbsDir Unsandboxed) -parseAbsDir = parsePath (const Nothing) Just (const Nothing) (const Nothing) - -instance showPath :: Show (Path a b s) where - show Current = "currentDir" - show Root = "rootDir" - show (ParentIn p) = "(parentDir' " <> show p <> ")" - show (FileIn p (FileName f)) = "(" <> show p <> " file " <> show f <> ")" - show (DirIn p (DirName f)) = "(" <> show p <> " dir " <> show f <> ")" - -instance eqPath :: Eq (Path a b s) where - eq p1 p2 = canonicalize p1 `identicalPath` canonicalize p2 - -instance ordPath :: Ord (Path a b s) where - compare p1 p2 = go (canonicalize p1) (canonicalize p2) - where - go Current Current = EQ - go Current _ = LT - go _ Current = GT - go Root Root = EQ - go Root _ = LT - go _ Root = GT - go (ParentIn p1') (ParentIn p2') = compare p1' p2' - go (ParentIn _) _ = LT - go _ (ParentIn _) = GT - go (DirIn p1' d1) (DirIn p2' d2) = compare p1' p2' <> compare d1 d2 - go (DirIn _ _) _ = LT - go _ (DirIn _ _) = GT - go (FileIn p1' f1) (FileIn p2' f2) = compare p1' p2' <> compare f1 f2 - -instance showFileName :: Show FileName where - show (FileName name) = "(FileName " <> show name <> ")" - -derive instance eqFileName :: Eq FileName -derive instance ordFileName :: Ord FileName - -instance showDirName :: Show DirName where - show (DirName name) = "(DirName " <> show name <> ")" - -derive instance eqDirName :: Eq DirName -derive instance ordDirName :: Ord DirName diff --git a/src/Data/Path/Pathy/Gen.purs b/src/Data/Path/Pathy/Gen.purs deleted file mode 100644 index 98e7c57..0000000 --- a/src/Data/Path/Pathy/Gen.purs +++ /dev/null @@ -1,58 +0,0 @@ -module Data.Path.Pathy.Gen - ( genAbsDirPath - , genAbsFilePath - , genAbsAnyPath - , genRelDirPath - , genRelFilePath - , genRelAnyPath - )where - -import Prelude - -import Control.Monad.Gen (class MonadGen) -import Control.Monad.Gen as Gen -import Control.Monad.Rec.Class (class MonadRec) -import Data.Char.Gen as CG -import Data.Either (Either(..)) -import Data.Foldable (foldr) -import Data.List as L -import Data.NonEmpty ((:|)) -import Data.Path.Pathy (AbsPath, AbsFile, AbsDir, RelDir, RelFile, RelPath, Sandboxed, ()) -import Data.Path.Pathy as P -import Data.String.Gen as SG - -genName ∷ ∀ m. MonadGen m ⇒ MonadRec m ⇒ m String -genName = SG.genString $ Gen.oneOf $ CG.genDigitChar :| [CG.genAlpha] - - -genAbsDirPath :: forall m. MonadGen m => MonadRec m => m (AbsDir Sandboxed) -genAbsDirPath = Gen.sized \size → do - newSize ← Gen.chooseInt 0 size - Gen.resize (const newSize) do - parts ∷ L.List String ← Gen.unfoldable genName - pure $ foldr (flip P.appendPath <<< P.dir) P.rootDir parts - -genAbsFilePath :: forall m. MonadGen m => MonadRec m => m (AbsFile Sandboxed) -genAbsFilePath = do - dir ← genAbsDirPath - file ← genName - pure $ dir P.file file - -genAbsAnyPath :: forall m. MonadGen m => MonadRec m => m (AbsPath Sandboxed) -genAbsAnyPath = Gen.oneOf $ (Left <$> genAbsDirPath) :| [Right <$> genAbsFilePath] - -genRelDirPath :: forall m. MonadGen m => MonadRec m => m (RelDir Sandboxed) -genRelDirPath = Gen.sized \size → do - newSize ← Gen.chooseInt 0 size - Gen.resize (const newSize) do - parts ∷ L.List String ← Gen.unfoldable genName - pure $ foldr (flip P.appendPath <<< P.dir) P.currentDir parts - -genRelFilePath :: forall m. MonadGen m => MonadRec m => m (RelFile Sandboxed) -genRelFilePath = do - dir ← genRelDirPath - file ← genName - pure $ dir P.file file - -genRelAnyPath :: forall m. MonadGen m => MonadRec m => m (RelPath Sandboxed) -genRelAnyPath = Gen.oneOf $ (Left <$> genRelDirPath) :| [Right <$> genRelFilePath] diff --git a/src/Pathy.purs b/src/Pathy.purs new file mode 100644 index 0000000..b77393e --- /dev/null +++ b/src/Pathy.purs @@ -0,0 +1,15 @@ +module Pathy + ( module Pathy.Path + , module Pathy.Name + , module Pathy.Printer + , module Pathy.Parser + , module Pathy.Phantom + , module Pathy.Sandboxed + ) where + +import Pathy.Path (AbsDir, AbsFile, AbsPath, AnyPath, AnyDir, AnyFile, Path, RelDir, RelFile, RelPath, appendPath, currentDir, dir, dir', extendPath, file, file', in', fileName, foldPath, name, parentAppend, parentOf, peel, peelFile, refine, relativeTo, rename, renameTraverse, rootDir, setExtension, (<..>), (<.>), ()) +import Pathy.Name (Name(..), joinName, splitName, alterExtension, extension) +import Pathy.Printer (Escaper(..), Printer, debugPrintPath, posixPrinter, printPath, unsafePrintPath, windowsPrinter) +import Pathy.Parser (Parser(..), parseAbsDir, parseAbsFile, parsePath, parseRelDir, parseRelFile, posixParser) +import Pathy.Phantom (class IsDirOrFile, class IsRelOrAbs, Abs, Dir, File, Rel, foldRelOrAbs, onRelOrAbs, foldDirOrFile, onDirOrFile) +import Pathy.Sandboxed (SandboxedPath, sandbox, sandboxAny, sandboxRoot, unsandbox) diff --git a/src/Pathy/Gen.purs b/src/Pathy/Gen.purs new file mode 100644 index 0000000..5939c7b --- /dev/null +++ b/src/Pathy/Gen.purs @@ -0,0 +1,69 @@ +module Pathy.Gen + ( genAbsDirPath + , genAbsFilePath + , genAbsAnyPath + , genRelDirPath + , genRelFilePath + , genRelAnyPath + , genName + , genDirName + , genFileName + ) where + +import Prelude + +import Control.Monad.Gen (class MonadGen) +import Control.Monad.Gen as Gen +import Control.Monad.Rec.Class (class MonadRec) +import Data.Char.Gen as CG +import Data.Either (Either(..)) +import Data.Foldable (foldr) +import Data.List as L +import Data.NonEmpty ((:|)) +import Data.String.Gen as SG +import Data.String.NonEmpty (cons) +import Pathy (AbsDir, AbsFile, AbsPath, Dir, File, RelDir, RelFile, RelPath, ()) +import Pathy as P + +genName ∷ ∀ m a. MonadGen m ⇒ MonadRec m ⇒ m (P.Name a) +genName = map P.Name $ cons <$> genChar <*> SG.genString genChar + where + genChar = Gen.oneOf $ CG.genDigitChar :| [CG.genAlpha] + +genDirName :: ∀ m. MonadGen m ⇒ MonadRec m ⇒ m (P.Name Dir) +genDirName = genName + +genFileName :: ∀ m. MonadGen m ⇒ MonadRec m ⇒ m (P.Name File) +genFileName = genName + +genAbsDirPath :: forall m. MonadGen m => MonadRec m => m AbsDir +genAbsDirPath = Gen.sized \size → do + newSize ← Gen.chooseInt 0 size + Gen.resize (const newSize) do + parts ∷ L.List (P.Name Dir) ← Gen.unfoldable genName + pure $ foldr (flip P.appendPath <<< P.dir') P.rootDir parts + +genAbsFilePath :: forall m. MonadGen m => MonadRec m => m AbsFile +genAbsFilePath = do + dir ← genAbsDirPath + file ← genName + pure $ dir P.file' file + +genAbsAnyPath :: forall m. MonadGen m => MonadRec m => m AbsPath +genAbsAnyPath = Gen.oneOf $ (Left <$> genAbsDirPath) :| [Right <$> genAbsFilePath] + +genRelDirPath :: forall m. MonadGen m => MonadRec m => m RelDir +genRelDirPath = Gen.sized \size → do + newSize ← Gen.chooseInt 0 size + Gen.resize (const newSize) do + parts ∷ L.List (P.Name Dir) ← Gen.unfoldable genName + pure $ foldr (flip P.appendPath <<< P.dir') P.currentDir parts + +genRelFilePath :: forall m. MonadGen m => MonadRec m => m RelFile +genRelFilePath = do + dir ← genRelDirPath + file ← genName + pure $ dir P.file' file + +genRelAnyPath :: forall m. MonadGen m => MonadRec m => m RelPath +genRelAnyPath = Gen.oneOf $ (Left <$> genRelDirPath) :| [Right <$> genRelFilePath] diff --git a/src/Pathy/Name.purs b/src/Pathy/Name.purs new file mode 100644 index 0000000..c3043c0 --- /dev/null +++ b/src/Pathy/Name.purs @@ -0,0 +1,102 @@ +module Pathy.Name where + +import Prelude + +import Data.Maybe (Maybe(..), fromMaybe) +import Data.Newtype (class Newtype) +import Data.String as S +import Data.String.NonEmpty (NonEmptyString) +import Data.String.NonEmpty as NES +import Data.Symbol (class IsSymbol, SProxy(..)) +import Data.Symbol (reflectSymbol) as Symbol +import Pathy.Phantom (kind DirOrFile) +import Type.Data.Boolean (False) as Symbol +import Type.Data.Symbol (class Equals) as Symbol +import Unsafe.Coerce (unsafeCoerce) + +-- | A type used for both directory and file names, indexed by `DirOrFile`. +newtype Name (n :: DirOrFile) = Name NonEmptyString + +derive instance newtypeName :: Newtype (Name n) _ +derive newtype instance eqName :: Eq (Name a) +derive newtype instance ordName :: Ord (Name a) + +instance showName :: Show (Name a) where + show (Name name) = "(Name " <> show name <> ")" + +-- | Splits `Name` in name and extension part. +-- | +-- | ```purescript +-- | splitName (Name ".foo") == { name: ".foo", extension: Nothing } +-- | splitName (Name "foo.") == { name: "foo.", extension: Nothing } +-- | splitName (Name "foo") == { name: "foo", extension: Nothing } +-- | splitName (Name ".") == { name: ".", extension: Nothing } +-- | splitName (Name "foo.baz") == { name: "foo", extension: Just "baz" } +-- | ``` +-- | _Note, in real code all strings from this examples would be `NonEmptyString`._ +-- | +-- | Also for any `Name` this property holds: +-- | ```purescript +-- | joinName <<< splitName = id +-- | ```` +-- | see [`joinName`](#v:joinName). +splitName :: forall n. Name n -> { name :: NonEmptyString, ext :: Maybe NonEmptyString } +splitName (Name nameIn) = + fromMaybe { name: nameIn, ext: Nothing } do + idx <- NES.lastIndexOf (S.Pattern ".") nameIn + name <- NES.take idx nameIn + ext <- NES.drop (idx + 1) nameIn + pure $ { name, ext: Just ext } + +-- | Joins name and extension part into one `Name`. +-- | +-- | Also for any `Name` this property holds: +-- | ```purescript +-- | joinName <<< splitName = id +-- | ```` +-- | see [`splitName`](#v:splitName). +joinName :: forall n. { name :: NonEmptyString, ext :: Maybe NonEmptyString } -> Name n +joinName { name, ext } = Name $ case ext of + Nothing -> name + Just ext' -> name <> NES.singleton '.' <> ext' + +-- | Retrieves the extension of a name. also see [`splitName`](#v:splitName) +-- | +-- | ```purescript +-- | extension (Name ".foo") == Nothing +-- | extension (Name "foo.") == Nothing +-- | extension (Name ".") == Nothing +-- | extension (Name "foo.baz") == Just "baz" +-- | ```` +-- | _Note, in real code all strings from this examples would be `NonEmptyString`._ +extension :: forall n. Name n -> Maybe NonEmptyString +extension = splitName >>> _.ext + +-- | Alters an extension of a name. This allows extensions to be added, removed, +-- | or modified. see [`splitName`](#v:splitName) and [`joinName`](#v:joinName) +-- | for how a `Name` is split into name and extention part and joined back +-- | into a `Name`. +-- | +-- | Also for any `Name` this property holds: +-- | ```purescript +-- | alterExtension id = id +-- | ```` +alterExtension + :: forall n + . (Maybe NonEmptyString -> Maybe NonEmptyString) + -> Name n + -> Name n +alterExtension f n = + let spn = splitName n + in joinName spn{ext = f spn.ext} + +-- | A class for creating `Name` values from type-level strings. This allows us +-- | to guarantee that a name is not empty at compile-time. +class IsName sym where + reflectName :: forall d. SProxy sym -> Name d + +instance isNameNESymbol :: (IsSymbol s, Symbol.Equals s "" Symbol.False) => IsName s where + reflectName _ = asNonEmpty $ Symbol.reflectSymbol (SProxy :: SProxy s) + where + asNonEmpty :: forall d. String -> Name d + asNonEmpty = unsafeCoerce diff --git a/src/Pathy/Parser.purs b/src/Pathy/Parser.purs new file mode 100644 index 0000000..e7f4605 --- /dev/null +++ b/src/Pathy/Parser.purs @@ -0,0 +1,110 @@ +module Pathy.Parser + ( Parser(..) + , posixParser + , parsePath + , parseRelFile + , parseAbsFile + , parseRelDir + , parseAbsDir + ) where + +import Prelude + +import Data.Array (foldl) +import Data.Array as A +import Data.Either (Either(..), either) +import Data.List (List(..), (:)) +import Data.List as L +import Data.Maybe (Maybe(..)) +import Data.String as S +import Data.String.NonEmpty (NonEmptyString) +import Data.String.NonEmpty as NES +import Pathy.Name (Name(..)) +import Pathy.Path (AbsDir, AbsFile, Path, RelDir, RelFile, currentDir, extendPath, parentOf, rootDir) +import Pathy.Phantom (class IsRelOrAbs, Dir) + +newtype Parser = Parser + ( forall z + . (RelDir -> z) + -> (AbsDir -> z) + -> (RelFile -> z) + -> (AbsFile -> z) + -> z + -> String + -> z) + +-- | A parser for POSIX paths. +posixParser :: Parser +posixParser = Parser \relDir absDir relFile absFile z -> + case _ of + "" -> z + "/" -> absDir rootDir + p -> + let + isAbs = S.take 1 p == "/" + isFile = S.takeRight 1 p /= "/" + -- NOTE: if we have `/foo/././//bar/` we will parse that as if it was `/foo/bar/` + segs = asReversedList $ A.mapMaybe NES.fromString $ S.split (S.Pattern "/") p + in + case isAbs, isFile of + true, true -> buildPath z rootDir (either (const z) absFile) segs + true, false -> buildPath z rootDir (either absDir absDir) segs + false, true -> buildPath z currentDir (either (const z) relFile) segs + false, false -> buildPath z currentDir (either relDir relDir) segs + +-- optimised version of `Array.reverse >>> List.fromFoldable` +asReversedList :: forall a. Array a -> L.List a +asReversedList = + foldl (flip L.Cons) L.Nil + +buildPath + :: forall z a b + . IsRelOrAbs a + => z + -> Path a Dir + -> (Either (Path a Dir) (Path a b) -> z) + -> List NonEmptyString + -> z +buildPath z init k segs = + case segs of + Nil -> z + name : segs' + | NES.toString name == ".." -> k $ Left (parentOf (go segs')) + | NES.toString name == "." -> k $ Left (go segs') + | otherwise -> k $ Right (extendPath (go segs') (Name name)) + where + go :: List NonEmptyString -> Path a Dir + go = case _ of + Nil -> init + name : segs' + | NES.toString name == ".." -> parentOf (go segs') + | NES.toString name == "." -> go segs' + | otherwise -> extendPath (go segs') (Name name) + +parsePath + :: forall z + . Parser + -> (RelDir -> z) + -> (AbsDir -> z) + -> (RelFile -> z) + -> (AbsFile -> z) + -> z + -> String + -> z +parsePath (Parser p) = p + +-- | Attempts to parse a relative file. +parseRelFile :: Parser -> String -> Maybe RelFile +parseRelFile p = parsePath p (const Nothing) (const Nothing) Just (const Nothing) Nothing + +-- | Attempts to parse an absolute file. +parseAbsFile :: Parser -> String -> Maybe AbsFile +parseAbsFile p = parsePath p (const Nothing) (const Nothing) (const Nothing) Just Nothing + +-- | Attempts to parse a relative directory. +parseRelDir :: Parser -> String -> Maybe RelDir +parseRelDir p = parsePath p Just (const Nothing) (const Nothing) (const Nothing) Nothing + +-- | Attempts to parse an absolute directory. +parseAbsDir :: Parser -> String -> Maybe AbsDir +parseAbsDir p = parsePath p (const Nothing) Just (const Nothing) (const Nothing) Nothing diff --git a/src/Pathy/Path.purs b/src/Pathy/Path.purs new file mode 100644 index 0000000..0841ab8 --- /dev/null +++ b/src/Pathy/Path.purs @@ -0,0 +1,305 @@ +module Pathy.Path + ( Path + , AnyPath + , RelPath + , AbsPath + , RelDir + , AbsDir + , AnyDir + , RelFile + , AbsFile + , AnyFile + , rootDir + , currentDir + , dir + , dir' + , file + , file' + , in' + , parentOf + , extendPath + , appendPath, () + , parentAppend, (<..>) + , foldPath + , peel + , peelFile + , name + , fileName + , rename + , renameTraverse + , setExtension, (<.>) + , relativeTo + , refine + ) where + +import Prelude + +import Data.Either (Either) +import Data.Identity (Identity(..)) +import Data.Maybe (Maybe(..), maybe) +import Data.Newtype (un) +import Data.String.NonEmpty as NES +import Data.Symbol (SProxy) +import Data.Tuple (Tuple(..), fst, snd) +import Partial.Unsafe (unsafeCrashWith) +import Pathy.Name (class IsName, Name(..), alterExtension, reflectName) +import Pathy.Phantom (class IsDirOrFile, class IsRelOrAbs, Abs, Dir, File, Rel, foldDirOrFile, foldRelOrAbs, onDirOrFile, onRelOrAbs, kind DirOrFile, kind RelOrAbs) +import Unsafe.Coerce (unsafeCoerce) + +-- | A type that describes a Path. All flavors of paths are described by this +-- | type, whether they are absolute or relative paths and whether they +-- | refer to files or directories. +-- | +-- | * The type parameter `a` describes whether the path is `Rel` or `Abs`. +-- | * The type parameter `b` describes whether the path is `File` or `Dir`. +-- | +-- | To ensure type safety, there is no way for users to create a value of +-- | this type directly. Instead, helpers should be used, such as `rootDir`, +-- | `currentDir`, `file`, `dir`, `()`, and `parsePath`. +-- | +-- | This ADT allows invalid paths (e.g. paths inside files), but there is no +-- | possible way for such paths to be constructed by user-land code. +data Path (a :: RelOrAbs) (b :: DirOrFile) + = Init + | ParentOf (Path Rel Dir) + | In (Path a Dir) (Name b) + +derive instance eqPath :: Eq (Path a b) +derive instance ordPath :: Ord (Path a b) + +instance showPathRelDir :: (IsRelOrAbs a, IsDirOrFile b) => Show (Path a b) where + show p@Init = foldRelOrAbs (const "currentDir") (const "rootDir") p + show (ParentOf p) = "(parentOf " <> show p <> ")" + show (In p n) = "(" <> show p <> " " <> foldDirOrFile (("dir " <> _) <<< show) (("file " <> _) <<< show) n <> ")" + +-- | A type describing a file or directory path. +type AnyPath a = Either (Path a Dir) (Path a File) + +-- | A type describing a relative file or directory path. +type RelPath = AnyPath Rel + +-- | A type describing an absolute file or directory path. +type AbsPath = AnyPath Abs + +-- | A type describing a directory whose location is given relative to some +-- | other, unspecified directory (referred to as the "current directory"). +type RelDir = Path Rel Dir + +-- | A type describing a directory whose location is absolutely specified. +type AbsDir = Path Abs Dir + +-- | A type describing a absolute or relative directory path. +type AnyDir = Either AbsDir RelDir + +-- | A type describing a file whose location is given relative to some other, +-- | unspecified directory (referred to as the "current directory"). +type RelFile = Path Rel File + +-- | A type describing a file whose location is absolutely specified. +type AbsFile = Path Abs File + +-- | A type describing a absolute or relative file path. +type AnyFile = Either AbsFile RelFile + +-- | The root directory, which can be used to define absolutely-located resources. +rootDir :: Path Abs Dir +rootDir = Init + +-- | The "current directory", which can be used to define relatively-located +-- | resources. +currentDir :: Path Rel Dir +currentDir = Init + +-- | Creates a path which points to a relative file of the specified name. +-- | +-- | Instead of accepting a runtime value, this function accepts a type-level +-- | string via a proxy, to ensure the constructed name is not empty. +file :: forall s. IsName s => SProxy s -> Path Rel File +file = file' <<< reflectName + +-- | Creates a path which points to a relative file of the specified name. +file' :: Name File -> Path Rel File +file' = in' + +-- | Creates a path which points to a relative directory of the specified name. +-- | +-- | Instead of accepting a runtime value, this function accepts a type-level +-- | string via a proxy, to ensure the constructed name is not empty. +dir :: forall s. IsName s => SProxy s -> Path Rel Dir +dir = dir' <<< reflectName + +-- | Creates a path which points to a relative directory of the specified name. +dir' :: Name Dir -> Path Rel Dir +dir' = in' + +-- | Creates a path which points to a relative directory or file of the specified name. +-- | In most cases [`dir'`](#v:dir') or [`file'`](#v:file') should be used instead, +-- | but it's still there in case the segment type is going to be determined based +-- | on some type variable. +-- | +-- | ``` purescript +-- | p == maybe p (\(Tuple r n) -> r in' n) (peel p) +-- | ``` +in' :: forall a. Name a -> Path Rel a +in' = In currentDir + +-- | Creates a path that points to the parent directory of the specified path. +-- | +-- | Calling `parentOf` on `rootDir` will return `rootDir`. +parentOf :: forall a. IsRelOrAbs a => Path a Dir -> Path a Dir +parentOf = + onRelOrAbs + (\coe p -> maybe (ParentOf p) (coe <<< fst) (peel p)) + (\coe -> coe <<< maybe Init fst <<< peel) + +-- | Extends a path with a file or directory under the current path. +extendPath :: forall a b. Path a Dir -> Name b -> Path a b +extendPath p = In p + +-- | Given a directory path, appends a relative path to extend the original +-- | path. +appendPath :: forall a b. IsRelOrAbs a => Path a Dir -> Path Rel b -> Path a b +appendPath = case _, _ of + Init, Init -> Init + ParentOf p, Init -> ParentOf (p Init) + In p (Name d), Init -> In (p Init) (Name d) + p1, ParentOf p2 -> (unsafeCoerce :: Path a Dir -> Path a b) $ parentOf (p1 p2) + p1, In p2 n -> In (p1 p2) n + +infixl 6 appendPath as + +-- | Ascends into the parent of the specified directory, then descends into +-- | the specified path. +-- | +-- | ```purescript +-- | rootDir dir "foo" <..> dir "bar" = rootDir dir "bar" +-- | ``` +parentAppend :: forall a b. IsRelOrAbs a => Path a Dir -> Path Rel b -> Path a b +parentAppend d p = parentOf d p + +infixl 6 parentAppend as <..> + +-- | A fold over `Path`s. Since `Path` has private constructors, this allows for +-- | functions to be written over its constructors, similar to a total pattern +-- | match. +-- | +-- | - The first argument is the value to return for the `currentDir`/`rootDir` +-- | at the base of the path. +-- | - The second argument is a function for handling a step into the parent +-- | directory of the path it receives (eliminates `parentOf`). +-- | - The third argument is a function representing a file or directory within +-- | the directory of the path it receives (eliminates `extendPath`). +foldPath + :: forall a b r + . r + -> (Path Rel Dir -> r) + -> (Path a Dir -> Name b -> r) + -> Path a b + -> r +foldPath r f g = case _ of + Init -> r + ParentOf d -> f d + In d n -> g d n + +-- | Peels off the last directory and the terminal file or directory name +-- | from the path. Returns `Nothing` if the path is `rootDir` / `currentDir` or +-- | a relative path that is ascending (`../`) +peel :: forall a b. Path a b -> Maybe (Tuple (Path a Dir) (Name b)) +peel = foldPath Nothing (const Nothing) (\p n -> Just (Tuple p n)) + +-- | Peels off the last director and terminal file from a path. Unlike the +-- | general `peel` function this is guaranteed to return a result, as `File` +-- | paths are known to have a name. +peelFile :: forall a. Path a File -> Tuple (Path a Dir) (Name File) +peelFile = case _ of + Init -> unsafeCrashWith "`Init` in Pathy.peelFile (this should be impossible)" + ParentOf _ -> unsafeCrashWith "`ParentOf` in Pathy.peelFile (this should be impossible)" + In p n -> Tuple p n + +-- | Retrieves the name of the terminal segment in a path. Returns `Nothing` if +-- | the path is `rootDir` / `currentDir` or some `parentOf p`. +name :: forall a b. IsRelOrAbs a => IsDirOrFile b => Path a b -> Maybe (Name b) +name = foldPath Nothing (const Nothing) (const Just) + +-- | Retrieves the name of a file path. Unlike the general `name` function, +-- | this is guaranteed to return a result, as `File` paths are known to have a +-- | name. +fileName :: forall a. Path a File -> Name File +fileName = snd <<< peelFile + +-- | Attempts to rename the terminal segment of a path. If the path is +-- | `rootDir` / `currentDir` or a relative path that is ascending (`../`) this +-- | will have no effect. +rename :: forall a b. (Name b -> Name b) -> Path a b -> Path a b +rename f = un Identity <<< renameTraverse (pure <<< f) + +-- | Attempts to rename the terminal segment of a path using a function that +-- | returns the result in some `Applicative`. If the path is `rootDir` / +-- | `currentDir` or a relative path that is ascending (`../`) this will +-- | have no effect. +renameTraverse + :: forall f a b + . Applicative f + => (Name b -> f (Name b)) + -> Path a b + -> f (Path a b) +renameTraverse f = case _ of + In p n -> In p <$> f n + p -> pure p + +-- | Sets the extension on the terminal segment of a path. If the path is +-- | `rootDir` / `currentDir` or a relative path that is ascending (`../`) this +-- | will have no effect. +-- | +-- | ```purescript +-- | file "image" <.> "png" +-- | ``` +-- | See [`splitName`](Pathy.Name#v:splitName) and [`alterExtension`](Pathy.Name#v:alterExtension) +-- | fore more examples. +setExtension :: forall a b. Path a b -> String -> Path a b +setExtension p ext = rename (alterExtension (const (NES.fromString ext))) p + +infixl 6 setExtension as <.> + +-- | Makes a path relative to a reference path. This function is best +-- | explaned using this property: +-- | +-- | ```purescript +-- | a == r a `relativeTo` r +-- | ``` +relativeTo :: forall b. Path Abs b -> Path Abs Dir -> Path Rel b +relativeTo p = coeB <<< step Init (coeD p) + where + step :: Path Rel Dir -> Path Abs Dir -> Path Abs Dir -> Path Rel Dir + step acc = case _, _ of + p', rp' | p' == rp' -> acc + Init, In rp' _ -> step (ParentOf acc) Init rp' + In p' n, Init -> In (step acc p' Init) n + In p' n, rp' + | p' == rp' -> In acc n + | otherwise -> In (step acc p' rp') n + _, _ -> + unsafeCrashWith "`ParentOf` in Pathy.relativeTo (this should be impossible)" + -- Unfortunately we can't avoid some coercions in this function unless + -- we actually write two different verions of `relativeTo` for file/dir + -- paths. Since the actual data representation is same either way the + -- coercions are safe. + coeD :: forall a. Path a b -> Path a Dir + coeD = unsafeCoerce + coeB :: forall a. Path a Dir -> Path a b + coeB = unsafeCoerce + +-- | Refines path segments but does not change anything else. +refine + :: forall a b + . IsDirOrFile b + => (Name File -> Name File) + -> (Name Dir -> Name Dir) + -> Path a b + -> Path a b +refine f d = go + where + go :: forall a' b'. IsDirOrFile b' => Path a' b' -> Path a' b' + go Init = Init + go (ParentOf p) = ParentOf (go p) + go (In p n) = In (go p) (onDirOrFile (_ <<< d) (_ <<< f) n) diff --git a/src/Pathy/Phantom.purs b/src/Pathy/Phantom.purs new file mode 100644 index 0000000..a17fac2 --- /dev/null +++ b/src/Pathy/Phantom.purs @@ -0,0 +1,73 @@ +module Pathy.Phantom where + +import Prelude + +-- | The kind for the relative/absolute phantom type. +foreign import kind RelOrAbs + +-- | The phantom type of relative paths. +foreign import data Rel :: RelOrAbs + +-- | The phantom type of absolute paths. +foreign import data Abs :: RelOrAbs + +-- | A class that enables writing operations that abstract over `RelOrAbs`. +-- | +-- | The provided `onRelOrAbs` function folds over a value indexed by +-- | `RelOrAbs` to produce a new result, passing proof/coercion functions to +-- | allow the inner functions to unify their return types if remapping. +class IsRelOrAbs (a :: RelOrAbs) where + onRelOrAbs + :: forall f b r + . ((f Rel b -> f a b) -> f Rel b -> r) + -> ((f Abs b -> f a b) -> f Abs b -> r) + -> f a b + -> r + +instance relIsRelOrAbs :: IsRelOrAbs Rel where onRelOrAbs f _ = f id +instance absIsRelOrAbs :: IsRelOrAbs Abs where onRelOrAbs _ f = f id + +-- | Folds over a value that uses `RelOrAbs` to produce a new result. +foldRelOrAbs + :: forall f a b r + . IsRelOrAbs a + => (f Rel b -> r) + -> (f Abs b -> r) + -> f a b + -> r +foldRelOrAbs f g = onRelOrAbs (const f) (const g) + +-- | The kind for the directory/file phantom type. +foreign import kind DirOrFile + +-- | The phantom type of directories. +foreign import data Dir :: DirOrFile + +-- | The phantom type of files. +foreign import data File :: DirOrFile + +-- | A class that enables writing operations that abstract over `DirOrFile`. +-- | +-- | The provided `onDirOrFile` function folds over a value indexed by +-- | `DirOrFile` to produce a new result, passing proof/coercion functions to +-- | allow the inner functions to unify their return types if remapping. +class IsDirOrFile (b :: DirOrFile) where + onDirOrFile + :: forall f r + . ((f Dir -> f b) -> f Dir -> r) + -> ((f File -> f b) -> f File -> r) + -> f b + -> r + +instance isDirOrFileDir :: IsDirOrFile Dir where onDirOrFile f _ = f id +instance isDirOrFileFile :: IsDirOrFile File where onDirOrFile _ f = f id + +-- | Folds over a value that uses `DirOrFile` to produce a new result. +foldDirOrFile + :: forall f b r + . IsDirOrFile b + => (f Dir -> r) + -> (f File -> r) + -> f b + -> r +foldDirOrFile f g = onDirOrFile (const f) (const g) diff --git a/src/Pathy/Printer.purs b/src/Pathy/Printer.purs new file mode 100644 index 0000000..709a402 --- /dev/null +++ b/src/Pathy/Printer.purs @@ -0,0 +1,197 @@ +module Pathy.Printer + ( Printer + , posixPrinter + , windowsPrinter + , printPath + , unsafePrintPath + , debugPrintPath + , Escaper(..) + , slashEscaper + , dotEscaper + , posixEscaper + , windowsEscaper + ) where + +import Prelude + +import Data.Foldable (fold) +import Data.Maybe (Maybe(..), maybe) +import Data.Monoid (class Monoid) +import Data.Newtype (class Newtype, un, unwrap) +import Data.String as Str +import Data.String.NonEmpty (NonEmptyString) +import Data.String.NonEmpty as NES +import Partial.Unsafe (unsafePartial) +import Pathy.Name (Name) +import Pathy.Path (Path, foldPath, ()) +import Pathy.Phantom (class IsDirOrFile, class IsRelOrAbs, Dir, Rel, foldDirOrFile, foldRelOrAbs, kind DirOrFile, kind RelOrAbs) +import Pathy.Sandboxed (SandboxedPath, sandboxRoot, unsandbox) + +-- | A `Printer` defines options for printing paths. +-- | +-- | - `root` is a function used to construct the initial segment of paths. +-- | - `current` is a representation of the current directory. +-- | - `up` is a representation of going up to the parent directory. +-- | - `sep` is the string to separate path segments by. +-- | - `escaper` specified how to deal with printing reserved names and +-- | characters. +type Printer = + { root :: Maybe NonEmptyString -> String + , current :: NonEmptyString + , up :: NonEmptyString + , sep :: NonEmptyString + , escaper :: Escaper + } + +-- | A printer for POSIX paths. +posixPrinter :: Printer +posixPrinter = + { root: maybe "/" (\name -> "/" <> NES.toString (un Escaper posixEscaper name)) + , current: NES.singleton '.' + , up: NES.singleton '.' <> NES.singleton '.' + , sep: NES.singleton '/' + , escaper: posixEscaper + } + +-- | A printer for Windows paths. +windowsPrinter :: Printer +windowsPrinter = + { root: maybe "\\" (\drive -> NES.toString drive <> ":") + , current: NES.singleton '.' + , up: NES.singleton '.' <> NES.singleton '.' + , sep: NES.singleton '\\' + , escaper: windowsEscaper + } + +-- | Prints a `SandboxedPath` into its canonical `String` representation, using +-- | the specified printer. The printed path will always be absolute, as this +-- | is the only way to ensure the path is safely referring to the intended +-- | location. +printPath + :: forall a b + . IsRelOrAbs a + => IsDirOrFile b + => Printer + -> SandboxedPath a b + -> String +printPath r sp = + let + root = sandboxRoot sp + p = unsandbox sp + in + printPathRep + r + (foldRelOrAbs (root _) id p) + +-- | Prints a `SandboxedPath` into its canonical `String` representation, using +-- | the specified printer. This will print a relative path if `b ~ Rel`, which +-- | depending on how the resulting string is used, may be unsafe. +unsafePrintPath + :: forall a b + . IsRelOrAbs a + => IsDirOrFile b + => Printer + -> SandboxedPath a b + -> String +unsafePrintPath r sp = printPathRep r (unsandbox sp) + +-- | Prints a path exactly according to its representation. This should only be +-- | used for debug purposes. Using this function will raise a warning at +-- | compile time as a reminder! +debugPrintPath + :: forall a b + . Warn "debugPrintPath usage" + => IsRelOrAbs a + => IsDirOrFile b + => Printer + -> Path a b + -> String +debugPrintPath = printPathRep + +printPathRep + :: forall a b + . IsRelOrAbs a + => IsDirOrFile b + => Printer + -> Path a b + -> String +printPathRep printer inputPath = go inputPath + where + go :: forall a' b'. IsRelOrAbs a' => IsDirOrFile b' => Path a' b' -> String + go = foldPath caseCurrent caseParentOf caseIn + + isAbs :: Boolean + isAbs = foldRelOrAbs (const false) (const true) inputPath + + caseCurrent :: String + caseCurrent = if isAbs + then printer.root Nothing + else NES.toString $ printer.current <> printer.sep + + caseParentOf :: Path Rel Dir -> String + caseParentOf p = go p <> NES.toString (printer.up <> printer.sep) + + caseIn :: forall a' b'. IsRelOrAbs a' => IsDirOrFile b' => Path a' Dir -> Name b' -> String + caseIn p name = name # foldDirOrFile + (\dirName -> p # foldPath + (if isAbs + then printer.root (Just $ unwrap dirName) <> NES.toString printer.sep + else caseCurrent <> printSegment printer dirName <> NES.toString printer.sep) + (\p' -> caseParentOf p' <> printSegment printer dirName <> NES.toString printer.sep) + (\p' n' -> caseIn p' n' <> printSegment printer dirName <> NES.toString printer.sep)) + (\fileName -> go p <> printSegment printer fileName) + +-- | Prints a name as a `String` using the escaper from the specified printer. +printSegment :: forall name. Newtype name NonEmptyString => Printer -> name -> String +printSegment printer = NES.toString <<< un Escaper printer.escaper <<< unwrap + +-- | An `Escaper` encodes segments or characters which have reserved meaning +-- | within names in a path. +newtype Escaper = Escaper (NonEmptyString -> NonEmptyString) + +derive instance newtypeEscaper :: Newtype Escaper _ + +instance semigroupEscaper :: Semigroup Escaper where + append (Escaper e1) (Escaper e2) = Escaper (e1 <<< e2) + +instance monoidEscaper :: Monoid Escaper where + mempty = Escaper id + +-- | An escaper that replaces all `'/'` characters in a name with `'-'`s. +slashEscaper :: Escaper +slashEscaper = Escaper (NES.replaceAll slash dash) + where + slash = Str.Pattern "/" + dash = NES.NonEmptyReplacement (NES.singleton '-') + +-- | An escaper that replaces names `"."` and `".."` with `"$dot"` and +-- | `"$dot$dot"`. +dotEscaper :: Escaper +dotEscaper = Escaper \s -> case NES.toString s of + ".." -> unsafePartial NES.unsafeFromString "$dot$dot" + "." -> unsafePartial NES.unsafeFromString "$dot" + _ -> s + +-- | An escaper that removes all slashes, converts ".." into "$dot$dot", and +-- | converts "." into "$dot". +posixEscaper :: Escaper +posixEscaper = slashEscaper <> dotEscaper + +-- | An escaper that attempts to encode all reserved names and characters for +-- | windows-style paths. +windowsEscaper :: Escaper +windowsEscaper = badCharEscaper <> badNameEscaper <> dotEscaper + where + badCharEscaper = + fold $ map + (\c -> Escaper (NES.replaceAll (Str.Pattern (Str.singleton c)) dash)) + ['\\', '/', ':', '*', '?', '"', '<', '>', '|'] + badNameEscaper = + fold $ map + (\n -> Escaper (NES.replaceAll (Str.Pattern n) (NES.NonEmptyReplacement (NES.cons '$' n)))) + ["CON", "PRN", "AUX", "NUL", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"] + dash = NES.NonEmptyReplacement (NES.singleton '-') + +-- | Prints a name as a `String` using the specified escaper. +escape :: forall name. Newtype name NonEmptyString => Escaper -> name -> String +escape r = NES.toString <<< un Escaper r <<< unwrap diff --git a/src/Pathy/Sandboxed.purs b/src/Pathy/Sandboxed.purs new file mode 100644 index 0000000..81f0987 --- /dev/null +++ b/src/Pathy/Sandboxed.purs @@ -0,0 +1,55 @@ +module Pathy.Sandboxed + ( SandboxedPath + , sandbox + , sandboxAny + , sandboxRoot + , unsandbox + ) where + +import Prelude + +import Data.Maybe (Maybe(..)) +import Pathy.Path (Path, foldPath, relativeTo, rootDir, ()) +import Pathy.Phantom (class IsDirOrFile, class IsRelOrAbs, Abs, Dir, onRelOrAbs) + +-- | The type for paths that have been sandboxed. +data SandboxedPath a b = SandboxedPath (Path Abs Dir) (Path a b) + +derive instance eqSandboxedPath :: (IsRelOrAbs a, IsDirOrFile b) => Eq (SandboxedPath a b) +derive instance ordSandboxedPath :: (IsRelOrAbs a, IsDirOrFile b) => Ord (SandboxedPath a b) +instance showSandboxedPath :: (IsRelOrAbs a, IsDirOrFile b) => Show (SandboxedPath a b) where + show (SandboxedPath root path) = "(SandboxedPath " <> show root <> " " <> show path <> ")" + +-- | Attempts to sandbox a path relative to an absolute directory ("sandbox +-- | root"). If the `Path a b` escapes the sandbox root `Nothing` will be +-- | returned. +sandbox + :: forall a b + . IsRelOrAbs a + => Path Abs Dir + -> Path a b + -> Maybe (SandboxedPath a b) +sandbox root = map (SandboxedPath root) <<< onRelOrAbs (go (root _)) (go id) + where + go :: forall p. (p -> Path Abs b) -> (p -> Path a b) -> p -> Maybe (Path a b) + go f coe p = + if goesUp (f p `relativeTo` root) + then Nothing + else Just (coe p) + goesUp :: forall x y. Path x y -> Boolean + goesUp = foldPath false (const true) (\p _ -> goesUp p) + +-- | Sandboxes any path to `/`. +-- | +-- | This should only be used for situations where a path is already constrained +-- | within a system so that access to `/` is safe - for instance, in URIs. +sandboxAny :: forall a b. Path a b -> SandboxedPath a b +sandboxAny p = SandboxedPath rootDir p + +-- | Returns the location a `SandboxedPath` was sandboxed to. +sandboxRoot :: forall a b. SandboxedPath a b -> Path Abs Dir +sandboxRoot (SandboxedPath root _) = root + +-- | Extracts the original path from a `SandboxedPath`. +unsandbox :: forall a b. SandboxedPath a b -> Path a b +unsandbox (SandboxedPath _ p) = p diff --git a/test/Main.purs b/test/Main.purs index 8bdfa49..af363b2 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -1,147 +1,408 @@ module Test.Main where import Prelude + import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, info, infoShow) -import Data.Foldable (foldl) -import Data.Maybe (Maybe(..), fromJust) -import Data.Path.Pathy (Path, Abs, Rel, Dir, File, Unsandboxed, Sandboxed, dir, rootDir, parseAbsDir, parseRelDir, currentDir, file, parseAbsFile, parseRelFile, parentDir', depth, sandbox, dropExtension, renameFile, canonicalize, unsandbox, unsafePrintPath, (), (<..>), (<.>)) -import Data.Path.Pathy.Gen as PG +import Control.Monad.Eff.Console (CONSOLE, info) +import Control.Monad.Eff.Exception (EXCEPTION, throw) +import Data.Maybe (Maybe(..), maybe) +import Data.Newtype (un) +import Data.NonEmpty ((:|)) import Data.String as Str -import Partial.Unsafe (unsafePartial) +import Data.String.NonEmpty (NonEmptyString) +import Data.String.NonEmpty as NES +import Data.Symbol (SProxy(..)) +import Data.Tuple (Tuple(..)) +import Pathy (class IsDirOrFile, class IsRelOrAbs, Abs, Dir, Name(..), Path, Rel, alterExtension, currentDir, debugPrintPath, dir, extension, file, in', joinName, parentOf, parseAbsDir, parseAbsFile, parseRelDir, parseRelFile, peel, posixParser, posixPrinter, printPath, relativeTo, rename, rootDir, sandbox, sandboxAny, splitName, unsandbox, windowsPrinter, (<..>), (<.>), ()) +import Pathy.Gen as PG +import Pathy.Name (reflectName) +import Test.QuickCheck ((===)) import Test.QuickCheck as QC import Test.QuickCheck.Gen as Gen -import Test.QuickCheck.Laws.Data as Laws.Data -import Type.Proxy (Proxy(..)) +import Unsafe.Coerce (unsafeCoerce) -test :: forall a eff. Show a => Eq a => String -> a -> a -> Eff (console :: CONSOLE | eff) Unit +test :: forall a eff. Show a => Eq a => String -> a -> a -> Eff (console :: CONSOLE, exception :: EXCEPTION | eff) Unit test name actual expected= do - infoShow $ "Test: " <> name - if expected == actual then infoShow $ "Passed: " <> (show expected) else infoShow $ "Failed: Expected " <> (show expected) <> " but found " <> (show actual) - -test' :: forall a b s eff. String -> Path a b s -> String -> Eff (console :: CONSOLE | eff) Unit -test' n p s = test n (unsafePrintPath p) s + info $ "Test: " <> name + if expected == actual + then info $ "Passed: " <> (show expected) + else throw $ "Failed:\n Expected: " <> (show expected) <> "\n Actual: " <> (show actual) -newtype ArbPath = ArbPath (Path Abs File Sandboxed) +test' :: forall a b eff. IsRelOrAbs a => IsDirOrFile b => String -> Path a b -> String -> Eff (console :: CONSOLE, exception :: EXCEPTION | eff) Unit +test' n p s = test n (printTestPath p) s -derive newtype instance eqArbPath :: Eq ArbPath -derive newtype instance ordArbPath :: Ord ArbPath +pathPart ∷ Gen.Gen NonEmptyString +pathPart = asNonEmptyString <$> Gen.suchThat QC.arbitrary (not <<< Str.null) + where + asNonEmptyString :: String -> NonEmptyString + asNonEmptyString = unsafeCoerce -runArbPath ∷ ArbPath → (Path Abs File Sandboxed) -runArbPath (ArbPath p) = p +dirFoo :: Path Rel Dir +dirFoo = dir (SProxy :: SProxy "foo") -instance arbitraryArbPath ∷ QC.Arbitrary ArbPath where - arbitrary = do - numDirs ← Gen.chooseInt 1 10 - dirs ← map dir <$> Gen.vectorOf numDirs pathPart - filename ← file <$> pathPart - pure $ ArbPath $ rootDir foldl (flip ()) filename (dirs ∷ Array (Path Rel Dir Sandboxed)) +dirBar :: Path Rel Dir +dirBar = dir (SProxy :: SProxy "bar") -pathPart ∷ Gen.Gen String -pathPart = Gen.suchThat QC.arbitrary (not <<< Str.null) +dirBaz :: Path Rel Dir +dirBaz = dir (SProxy :: SProxy "baz") -parsePrintCheck :: forall a b. Path a b Sandboxed -> Maybe (Path a b Unsandboxed) -> QC.Result +parsePrintCheck :: forall a b. IsRelOrAbs a => IsDirOrFile b => Path a b -> Maybe (Path a b) -> QC.Result parsePrintCheck input parsed = - if parsed == Just (unsandbox input) + if parsed == Just input then QC.Success else QC.Failed $ "`parse (print path) != Just path` for path: `" <> show input <> "` which was re-parsed into `" <> show parsed <> "`" - <> "\n\tPrinted path: " <> show (unsafePrintPath input) - <> "\n\tPrinted path': `" <> show (map unsafePrintPath parsed) <> "`" + <> "\n\tPrinted path: " <> show (printTestPath input) + <> "\n\tPrinted path': `" <> show (map (printTestPath) parsed) <> "`" parsePrintAbsDirPath :: Gen.Gen QC.Result parsePrintAbsDirPath = PG.genAbsDirPath <#> \path -> - parsePrintCheck path (parseAbsDir $ unsafePrintPath path) + parsePrintCheck path (parseAbsDir posixParser $ printTestPath path) parsePrintAbsFilePath :: Gen.Gen QC.Result parsePrintAbsFilePath = PG.genAbsFilePath <#> \path -> - parsePrintCheck path (parseAbsFile $ unsafePrintPath path) + parsePrintCheck path (parseAbsFile posixParser $ printTestPath path) parsePrintRelDirPath :: Gen.Gen QC.Result parsePrintRelDirPath = PG.genRelDirPath <#> \path -> - parsePrintCheck path (parseRelDir $ unsafePrintPath path) + parsePrintCheck path (parseRelDir posixParser $ printTestPath path) parsePrintRelFilePath :: Gen.Gen QC.Result parsePrintRelFilePath = PG.genRelFilePath <#> \path -> - parsePrintCheck path (parseRelFile $ unsafePrintPath path) + parsePrintCheck path (parseRelFile posixParser $ printTestPath path) + +genAmbigiousName :: forall a. Gen.Gen (Name a) +genAmbigiousName = + let + genNES = PG.genName <#> un Name + in + map Name $ Gen.oneOf $ genNES :| + [ genNES <#> \a -> a <> (NES.singleton '.') + , genNES <#> \a -> (NES.singleton '.') <> a + , pure (NES.singleton '.') + , do + a <- genNES + b <- genNES + pure $ a <> (NES.singleton '.') <> b + ] + +checkAlterExtensionId :: Gen.Gen QC.Result +checkAlterExtensionId = do + n <- genAmbigiousName + pure $ alterExtension id n === id n + +checkJoinSplitNameId :: Gen.Gen QC.Result +checkJoinSplitNameId = do + n <- genAmbigiousName + pure $ joinName (splitName n) === id n + +checkPeelIn :: forall b. IsDirOrFile b => Gen.Gen (Path Abs b) -> Gen.Gen QC.Result +checkPeelIn gen = do + p <- gen + pure $ p === maybe p (\(Tuple r n) -> r in' n) (peel p) + +checkRelative :: forall b. IsDirOrFile b => Gen.Gen (Path Abs b) -> Gen.Gen QC.Result +checkRelative gen = do + p1 <- gen + p2 <- PG.genAbsDirPath + let rel = p1 `relativeTo` p2 + let p1' = p2 rel + pure + if p1 == p1' + then QC.Success + else + QC.Failed + $ "`relativeTo` property did not hold:" + <> "\n\tp1: " <> printTestPath p1 + <> "\n\tp2: " <> printTestPath p2 + <> "\n\trel: " <> printTestPath rel + <> "\n\tp1': " <> printTestPath p1' main :: QC.QC () Unit main = do - info "checking `parse <<< print` for `AbsDir``" *> QC.quickCheck parsePrintAbsDirPath - info "checking `parse <<< print` for `AbsFile``" *> QC.quickCheck parsePrintAbsFilePath - info "checking `parse <<< print` for `RelDir``" *> QC.quickCheck parsePrintRelDirPath - info "checking `parse <<< print` for `RelFile``" *> QC.quickCheck parsePrintRelFilePath - -- Should not compile: - -- test "() - file in dir" (printPath (file "image.png" dir "foo")) "./image.png/foo" + info "checking `parse <<< print` for `AbsDir`" *> QC.quickCheck parsePrintAbsDirPath + info "checking `parse <<< print` for `AbsFile`" *> QC.quickCheck parsePrintAbsFilePath + info "checking `parse <<< print` for `RelDir`" *> QC.quickCheck parsePrintRelDirPath + info "checking `parse <<< print` for `RelFile`" *> QC.quickCheck parsePrintRelFilePath + info "checking `relativeTo` for `AbsDir`" *> QC.quickCheck (checkRelative PG.genAbsDirPath) + info "checking `relativeTo` for `AbsFile`" *> QC.quickCheck (checkRelative PG.genAbsFilePath) + info "checking `p === maybe p (\\(Tuple r n) -> r in' n) (peel p)` for `AbsDir`" *> QC.quickCheck (checkPeelIn PG.genAbsDirPath) + info "checking `p === maybe p (\\(Tuple r n) -> r in' n) (peel p)` for `AbsFile`" *> QC.quickCheck (checkPeelIn PG.genAbsFilePath) + info "checking `joinName <<< splitName === id`" *> QC.quickCheck checkJoinSplitNameId + info "checking `alterExtension id === id`" *> QC.quickCheck checkAlterExtensionId -- Should not compile: - -- test "() - absolute dir in absolute dir" (printPath (rootDir rootDir)) "/" + -- test + -- "() - file in dir" + -- (printPath (file "image.png" dirFoo)) + -- "./image.png/foo" -- Should not compile: - -- test "() - absolute dir in relative dir" (printPath (currentDir rootDir)) "/" + -- test + -- "() - absolute dir in absolute dir" + -- (printPath (rootDir rootDir)) + -- "/" -- Should not compile: - -- test "printPath -- cannot print unsandboxed" (printPath (parentDir' currentDir)) "./../" - - test' "() - two directories" (dir "foo" dir "bar") "./foo/bar/" - - test' "() - file with two parents" (dir "foo" dir "bar" file "image.png") "./foo/bar/image.png" - - test' "(<.>) - file without extension" (file "image" <.> "png") "./image.png" - - test' "(<.>) - file with extension" (file "image.jpg" <.> "png") "./image.png" - - test' "printPath - ./../" (parentDir' currentDir) "./../" - - test' "() - ./../foo/" (parentDir' currentDir unsandbox (dir "foo")) "./../foo/" - - test' "parentDir' - ./../foo/../" ((parentDir' currentDir unsandbox (dir "foo")) (parentDir' currentDir)) "./../foo/../" - - test' "(<..>) - ./../" (currentDir <..> currentDir) "./../" - - test' "(<..>) - ./../foo/" (currentDir <..> dir "foo") "./../foo/" - - test' "(<..>) - ./../foo/../" ((currentDir <..> dir "foo") <..> currentDir) "./../foo/../" - - test' "canonicalize - 1 down, 1 up" (canonicalize $ parentDir' $ dir "foo") "./" - - test' "canonicalize - 2 down, 2 up" (canonicalize (parentDir' (parentDir' (dir "foo" dir "bar")))) "./" - - test' "renameFile - single level deep" (renameFile dropExtension (file "image.png")) "./image" - - test' "sandbox - sandbox absolute dir to one level higher" - (unsafePartial $ fromJust $ sandbox (rootDir dir "foo") (rootDir dir "foo" dir "bar")) "./bar/" - - test "depth - negative" (depth (parentDir' $ parentDir' $ parentDir' $ currentDir)) (-3) - - test "parseRelFile - image.png" (parseRelFile "image.png") (Just $ file "image.png") - - test "parseRelFile - ./image.png" (parseRelFile "./image.png") (Just $ file "image.png") - - test "parseRelFile - foo/image.png" (parseRelFile "foo/image.png") (Just $ dir "foo" file "image.png") - - test "parseRelFile - ../foo/image.png" (parseRelFile "../foo/image.png") (Just $ currentDir <..> dir "foo" file "image.png") - - test "parseAbsFile - /image.png" (parseAbsFile "/image.png") (Just $ rootDir file "image.png") - - test "parseAbsFile - /foo/image.png" (parseAbsFile "/foo/image.png") (Just $ rootDir dir "foo" file "image.png") - - test "parseRelDir - empty string" (parseRelDir "") (Just $ currentDir) - - test "parseRelDir - ./../" (parseRelDir "./../") (Just $ currentDir <..> currentDir) - - test "parseRelDir - foo/" (parseRelDir "foo/") (Just $ dir "foo") - - test "parseRelDir - foo/bar" (parseRelDir "foo/bar/") (Just $ dir "foo" dir "bar") - - test "parseRelDir - ./foo/bar" (parseRelDir "./foo/bar/") (Just $ dir "foo" dir "bar") - - test "parseAbsDir - /" (parseAbsDir "/") (Just $ rootDir) - - test "parseAbsDir - /foo/" (parseAbsDir "/foo/") (Just $ rootDir dir "foo") - - test "parseAbsDir - /foo/bar" (parseAbsDir "/foo/bar/") (Just $ rootDir dir "foo" dir "bar") - - info "Checking typeclass laws..." - Laws.Data.checkEq (Proxy :: Proxy ArbPath) - Laws.Data.checkOrd (Proxy :: Proxy ArbPath) + -- test + -- "() - absolute dir in relative dir" + -- (printPath (currentDir rootDir)) + -- "/" + + test' "() - two directories" + (dirFoo dirBar) + "./foo/bar/" + + test "windowsPrinter" + (printWindowsPath $ rootDir dir (SProxy :: SProxy "C") dirBar) + "C:\\bar\\" + + test' "() - file with two parents" + (dirFoo + dirBar + file (SProxy :: SProxy "image.png")) + "./foo/bar/image.png" + + test' "(<.>) - file without extension" + (file (SProxy :: SProxy "image") + <.> "png") + "./image.png" + + test' "(<.>) - file with extension" + (file (SProxy :: SProxy "image.jpg") + <.> "png") + "./image.png" + + test' "printPath - ./../" + (parentOf currentDir) + "./../" + + test """printPath windowsPrinter - C:\Users\Default\""" + (printPath windowsPrinter $ sandboxAny $ rootDir dir (SProxy :: SProxy "C") dir (SProxy :: SProxy "Users") dir (SProxy :: SProxy "Default")) + """C:\Users\Default\""" + + test """printPath posixPrinter - /C/Users/Default/""" + (printPath posixPrinter $ sandboxAny $ rootDir dir (SProxy :: SProxy "C") dir (SProxy :: SProxy "Users") dir (SProxy :: SProxy "Default")) + """/C/Users/Default/""" + + test """printPath windowsPrinter - \""" + (printPath windowsPrinter $ sandboxAny rootDir) + """\""" + + test """printPath posixPrinter - /""" + (printPath posixPrinter $ sandboxAny rootDir) + """/""" + + test' "() - ./../foo/" + (parentOf currentDir dirFoo) + "./../foo/" + + test' "parentOf - ./../foo/../" + ((parentOf currentDir dirFoo) (parentOf currentDir)) + "./../" + + test' "(<..>) - ./../" + (currentDir <..> currentDir) + "./../" + + test' "(<..>) - ./../foo/" + (currentDir <..> dirFoo) + "./../foo/" + + test' "(<..>) - ./../foo/../" + ((currentDir <..> dirFoo) <..> currentDir) + "./../" + + test' "./foo/../ = ./" + (parentOf dirFoo) + "./" + + test' "./foo/bar/../../ = ./" + ((parentOf (parentOf (dirFoo dirBar)))) + "./" + + test' "/../../ = /" + ((parentOf (parentOf rootDir))) + "/" + + test "/foo/../bar/ = /bar" + ((rootDir dirFoo <..> dirBar)) + (rootDir dirBar) + + test "/foo/bar/ ../bar/ = /foo/bar/" + ((rootDir dirFoo dirBar) (currentDir <..> dirBar)) + (rootDir dirFoo dirBar) + + test "/foo/bar/ ../../bar/ = /bar/" + ((rootDir dirFoo dirBar) (currentDir <..> currentDir <..> currentDir dirBar)) + (rootDir dirBar) + + test "relativeTo rootDir rootDir = currentDir" + (relativeTo rootDir rootDir) + (currentDir) + + test' "(rootDir dirFoo) `relativeTo` (rootDir dirFoo) = ./" + ((rootDir dirFoo) `relativeTo` (rootDir dirFoo)) + "./" + + test' "(rootDir dirFoo) `relativeTo` rootDir = currentDir dirFoo" + ((rootDir dirFoo) `relativeTo` rootDir) + "./foo/" + + test' "(rootDir dirFoo) `relativeTo` (rootDir dirBar) = currentDir <..> dirFoo" + ((rootDir dirFoo) `relativeTo` (rootDir dirBar)) + "./../foo/" + + test' "(rootDir dirBar) `relativeTo` (rootDir dirFoo) = ./../bar/" + ((rootDir dirBar) `relativeTo` (rootDir dirFoo)) + "./../bar/" + + test' "(rootDir dirBar) `relativeTo` (rootDir dirFoo dirFoo) = ./../../bar/" + ((rootDir dirBar) `relativeTo` (rootDir dirFoo dirFoo)) + "./../../bar/" + + test' "(rootDir dirBar) `relativeTo` (rootDir dirFoo dirFoo dirFoo) = ./../../../bar/" + ((rootDir dirBar) `relativeTo` (rootDir dirFoo dirFoo dirFoo)) + "./../../../bar/" + + test' "(rootDir dirBar dirBar) `relativeTo` (rootDir dirFoo) = ./../bar/bar/" + ((rootDir dirBar dirBar) `relativeTo` (rootDir dirFoo)) + "./../bar/bar/" + + test' "(rootDir dirBar dirBar) `relativeTo` (rootDir dirFoo dirFoo) = ./../../bar/bar/" + ((rootDir dirBar dirBar) `relativeTo` (rootDir dirFoo dirFoo)) + "./../../bar/bar/" + + test' "(rootDir dirBar dirFoo dirFoo) `relativeTo` (rootDir dirFoo dirFoo dirFoo) = ./../../../bar/foo/foo" + ((rootDir dirBar dirFoo dirFoo) `relativeTo` (rootDir dirFoo dirFoo dirFoo)) + "./../../../bar/foo/foo/" + + test' "(rootDir dirFoo dirBar dirBaz) `relativeTo` rootDir = ./foo/bar/baz/" + ((rootDir dirFoo dirBar dirBaz) `relativeTo` rootDir) + "./foo/bar/baz/" + + test' "(rootDir dirFoo dirBar dirBaz) `relativeTo` (rootDir dirFoo) = ./bar/baz/" + ((rootDir dirFoo dirBar dirBaz) `relativeTo` (rootDir dirFoo)) + "./bar/baz/" + + test' "(rootDir dirFoo dirBar dirBaz) `relativeTo` (rootDir dirBaz) = ./../foo/bar/baz/" + ((rootDir dirFoo dirBar dirBaz) `relativeTo` (rootDir dirBaz)) + "./../foo/bar/baz/" + + test' "(rootDir dirBar dirFoo) `relativeTo` (rootDir dirBar) = ./foo/" + ((rootDir dirBar dirFoo) `relativeTo` (rootDir dirBar)) + "./foo/" + + test "rename - single level deep" + (rename (alterExtension (const Nothing)) (file (SProxy :: SProxy "image.png"))) + (file $ SProxy :: SProxy "image") + + test """extension (Name ".foo") == Nothing""" + (extension (reflectName $ SProxy :: SProxy ".foo")) + (Nothing) + test """extension (Name "foo.") == Nothing""" + (extension (reflectName $ SProxy :: SProxy "foo.")) + (Nothing) + test """extension (Name "foo") == Nothing""" + (extension (reflectName $ SProxy :: SProxy "foo")) + (Nothing) + test """extension (Name ".") == Nothing""" + (extension (reflectName $ SProxy :: SProxy ".")) + (Nothing) + test """extension (Name "foo.baz") == (Just "baz")""" + (extension (reflectName $ SProxy :: SProxy "foo.baz")) + (NES.fromString "baz") + + test "sandbox - fail when relative path lies outside sandbox (above)" + (sandbox (rootDir dirBar) (parentOf currentDir)) + Nothing + + test "sandbox - fail when relative path lies outside sandbox (neigbouring)" + (sandbox (rootDir dirBar) (parentOf currentDir dirFoo)) + Nothing + + test "sandbox - fail when absolute path lies outside sandbox" + (sandbox (rootDir dirBar) (rootDir dirFoo dirBar)) + Nothing + + test "sandbox - succeed when relative path goes above sandbox but returns to it" + (unsandbox <$> sandbox (rootDir dirBar) (parentOf currentDir dirBar)) + (Just (parentOf currentDir dirBar)) + + test "sandbox - succeed when absolute path lies inside sandbox" + (unsandbox <$> sandbox (rootDir dirBar) (rootDir dirBar dirFoo)) + (Just (rootDir dirBar dirFoo)) + + test "sandbox - print relative path that goes above sandbox but returns to it" + (printPath posixPrinter <$> sandbox (rootDir dirBar) (parentOf currentDir dirBar)) + (Just "/bar/") + + test "sandbox - print absolute path that lies inside sandbox" + (printPath posixPrinter <$> sandbox (rootDir dirBar) (rootDir dirBar dirFoo)) + (Just "/bar/foo/") + + test "parseRelFile - image.png" + (parseRelFile posixParser "image.png") + (Just $ file $ SProxy :: SProxy "image.png") + + test "parseRelFile - ./image.png" + (parseRelFile posixParser "./image.png") + (Just $ file $ SProxy :: SProxy "image.png") + + test "parseRelFile - foo/image.png" + (parseRelFile posixParser "foo/image.png") + (Just $ dirFoo file (SProxy :: SProxy "image.png")) + + test "parseRelFile - ../foo/image.png" + (parseRelFile posixParser "../foo/image.png") + (Just $ currentDir <..> dirFoo file (SProxy :: SProxy "image.png")) + + test "parseAbsFile - /image.png" + (parseAbsFile posixParser "/image.png") + (Just $ rootDir file (SProxy :: SProxy "image.png")) + + test "parseAbsFile - /foo/image.png" + (parseAbsFile posixParser "/foo/image.png") + (Just $ rootDir dirFoo file (SProxy :: SProxy "image.png")) + + test "parseRelDir - empty string" + (parseRelDir posixParser "") + Nothing + + test "parseRelDir - ./../" + (parseRelDir posixParser "./../") + (Just $ currentDir <..> currentDir) + + test "parseRelDir - foo/" + (parseRelDir posixParser "foo/") + (Just dirFoo) + + test "parseRelDir - foo/bar" + (parseRelDir posixParser "foo/bar/") + (Just $ dirFoo dirBar) + + test "parseRelDir - ./foo/bar" + (parseRelDir posixParser "./foo/bar/") + (Just $ dirFoo dirBar) + + test "parseAbsDir - /" + (parseAbsDir posixParser "/") + (Just $ rootDir) + + test "parseAbsDir - /foo/" + (parseAbsDir posixParser "/foo/") + (Just $ rootDir dirFoo) + + test "parseAbsDir - /foo/bar" + (parseAbsDir posixParser "/foo/bar/") + (Just $ rootDir dirFoo dirBar) + + test "parseRelDir - /foo/././//bar/" + (parseAbsDir posixParser "/foo/././//bar/") + (Just $ rootDir dirFoo dirBar) + +printTestPath :: forall a b. IsRelOrAbs a => IsDirOrFile b => Path a b -> String +printTestPath p = debugPrintPath posixPrinter p + +printWindowsPath :: forall a b. IsRelOrAbs a => IsDirOrFile b => Path a b -> String +printWindowsPath p = debugPrintPath windowsPrinter p