{-# 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 "" = Left "empty file path"
normalizeParents ('/':_) = Left "absolute path"
normalizeParents ('.':'.':'/':_) = Left "absolute path"
normalizeParents fp = do
let t0 = T.pack fp
t = fromMaybe t0 $ T.stripSuffix "/" t0
case T.unsnoc t of
Just (_, '/') -> Left "multiple trailing slashes"
_ -> Right ()
let c1 = T.split (== '/') t
case reverse c1 of
".":_ -> Left "last component is a single dot"
_ -> Right ()
let c2 = filter (\x -> not (T.null x || x == ".")) c1
let loop [] = []
loop (_:"..":rest) = loop rest
loop (x:xs) = x : loop xs
case loop c2 of
[] -> Left "no non-empty components"
c' -> Right $ T.unpack $ T.intercalate "/" c'
makeTarRelative
:: FilePath
-> FilePath
-> Either String FilePath
makeTarRelative _ ('/':_) = Left "absolute path found"
makeTarRelative base rel =
case reverse base of
[] -> Left "cannot have empty base"
'/':_ -> Left "base cannot be a directory"
_:rest -> Right $
case dropWhile (/= '/') rest of
'/':rest' -> reverse rest' ++ '/' : rel
rest' -> assert (null rest') rel