diff options
Diffstat (limited to 'walint/Paths.hs')
-rw-r--r-- | walint/Paths.hs | 86 |
1 files changed, 86 insertions, 0 deletions
diff --git a/walint/Paths.hs b/walint/Paths.hs new file mode 100644 index 0000000..f4dc3ed --- /dev/null +++ b/walint/Paths.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Paths are horrible, so they have their own module now. +-- I just hope you are running this on some kind of Unix +module Paths where + +import Universum +import qualified Universum.Unsafe as Unsafe + +import qualified Data.Text as T +import System.FilePath (splitPath) +import System.FilePath.Posix ((</>)) +import Text.Regex.TDFA +import Util (PrettyPrint (prettyprint)) + + +-- | a normalised path: a number of "upwards" steps, and +-- a path without any . or .. in it. Also possibly a +-- fragment, mostly for map links. +data RelPath = Path Int Text (Maybe Text) + deriving (Show, Eq, Ord, NFData, Generic) + + + +data PathResult = OkRelPath RelPath + | AbsolutePath + | NotAPath + | UnderscoreMapLink + | AtMapLink + | PathVarsDisallowed + +-- | horrible regex parsing for filepaths that is hopefully kinda safe +parsePath :: Text -> PathResult +parsePath text = + if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed + | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment) + | "/_/" `T.isPrefixOf` text -> UnderscoreMapLink + | "/@/" `T.isPrefixOf` text -> AtMapLink + | "/" `T.isPrefixOf` text -> AbsolutePath + | otherwise -> NotAPath + where + (_, prefix, rest, _) = + text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text]) + -- how many steps upwards in the tree? + up = length . filter (".." ==) . T.splitOn "/" $ prefix + parts = T.splitOn "#" rest + -- `head` is unsafe, but splitOn will always produce lists with at least one element + path = Unsafe.head parts + fragment = case nonEmpty parts of + Nothing -> Nothing + Just p -> Just $ T.concat $ tail p + +instance PrettyPrint RelPath where + prettyprint (Path up rest frag) = ups <> rest <> fragment + where ups = T.concat $ replicate up "../" + fragment = maybe mempty ("#" <>) frag + +-- | Normalises a path. +-- +-- It takes a `prefix`, and will "truncate" the .. operator +-- at the end of the prefix, i.e. it will never return paths +-- that lie (naïvely) outside of the prefix. +normalise :: FilePath -> RelPath -> FilePath +normalise prefix (Path 0 path _) = prefix </> toString path +normalise prefix (Path i path _) = + concat (take (length dirs - i) dirs) </> toString path + where dirs = splitPath prefix + +normaliseWithFrag :: FilePath -> RelPath -> FilePath +normaliseWithFrag prefix (Path i path frag) = + normalise prefix (Path (i+1) path frag) <> toString (maybe mempty ("#" <>) frag) + +-- | does this path contain an old-style pattern for inter-repository +-- links as was used at rc3 in 2020? +isOldStyle :: RelPath -> Bool +isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text) + where path = case frag of + Just f -> text <> f + _ -> text + +getExtension :: RelPath -> Text +getExtension (Path _ text _) = maybe "" last (nonEmpty splitted) + where splitted = T.splitOn "." text |