{-# LANGUAGE OverloadedStrings #-}
module Pantry.Internal
( parseTree
, renderTree
, Tree (..)
, TreeEntry (..)
, FileType(..)
, mkSafeFilePath
, pcHpackExecutable
, normalizeParents
, makeTarRelative
, getGlobalHintsFile
, hpackVersion
, Storage
, initStorage
, withStorage_
) where
import Control.Exception (assert)
import Pantry.Types
import Pantry.SQLite (initStorage)
import Pantry.HPack (hpackVersion)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
normalizeParents
:: FilePath
-> Either String FilePath
normalizeParents :: FilePath -> Either FilePath FilePath
normalizeParents "" = FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left "empty file path"
normalizeParents ('/':_) = FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left "absolute path"
normalizeParents ('.':'.':'/':_) = FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left "absolute path"
normalizeParents fp :: FilePath
fp = do
let t0 :: Text
t0 = FilePath -> Text
T.pack FilePath
fp
t :: Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t0 (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix "/" Text
t0
case Text -> Maybe (Text, Char)
T.unsnoc Text
t of
Just (_, '/') -> FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left "multiple trailing slashes"
_ -> () -> Either FilePath ()
forall a b. b -> Either a b
Right ()
let c1 :: [Text]
c1 = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/') Text
t
case [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
c1 of
".":_ -> FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left "last component is a single dot"
_ -> () -> Either FilePath ()
forall a b. b -> Either a b
Right ()
let c2 :: [Text]
c2 = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: Text
x -> Bool -> Bool
not (Text -> Bool
T.null Text
x Bool -> Bool -> Bool
|| Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ".")) [Text]
c1
let loop :: [a] -> [a]
loop [] = []
loop (_:"..":rest :: [a]
rest) = [a] -> [a]
loop [a]
rest
loop (x :: a
x:xs :: [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
loop [a]
xs
case [Text] -> [Text]
forall a. (Eq a, IsString a) => [a] -> [a]
loop [Text]
c2 of
[] -> FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left "no non-empty components"
c' :: [Text]
c' -> FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right (FilePath -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate "/" [Text]
c'
makeTarRelative
:: FilePath
-> FilePath
-> Either String FilePath
makeTarRelative :: FilePath -> FilePath -> Either FilePath FilePath
makeTarRelative _ ('/':_) = FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left "absolute path found"
makeTarRelative base :: FilePath
base rel :: FilePath
rel =
case FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
base of
[] -> FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left "cannot have empty base"
'/':_ -> FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left "base cannot be a directory"
_:rest :: FilePath
rest -> FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right (FilePath -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$
case (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '/') FilePath
rest of
'/':rest' :: FilePath
rest' -> FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
rest' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ '/' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
rel
rest' :: FilePath
rest' -> Bool -> FilePath -> FilePath
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
rest') FilePath
rel