module System.FilePath.Rules
( Rules
, posix
, windows
, toBytes
, fromBytes
, toText
, fromText
, valid
, splitSearchPath
) where
import Prelude hiding (FilePath, null)
import qualified Prelude as P
import qualified Control.Exception as Exc
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.Char (toUpper, chr)
import Data.List (intersperse)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Text.Encoding.Error (UnicodeException)
import System.IO.Unsafe (unsafePerformIO)
import System.FilePath hiding (root, filename)
import System.FilePath.Internal
toBytes :: Rules -> FilePath -> B.ByteString
toBytes r = B.concat . toByteChunks r
toText :: Rules -> FilePath -> Either T.Text T.Text
toText r path = encoded where
bytes = toBytes r path
encoded = case maybeDecodeUtf8 bytes of
Just text -> Right text
Nothing -> Left (T.pack (B8.unpack bytes))
fromText :: Rules -> T.Text -> FilePath
fromText r text = fromBytes r (TE.encodeUtf8 text)
rootBytes :: Maybe Root -> B.ByteString
rootBytes r = B8.pack $ flip (maybe "") r $ \r' -> case r' of
RootPosix -> "/"
RootWindowsVolume c -> c : ":\\"
RootWindowsCurrentVolume -> "\\"
byteDirectories :: FilePath -> [B.ByteString]
byteDirectories path = pathDirectories path ++ [filenameBytes path]
upperBytes :: B.ByteString -> B.ByteString
upperBytes bytes = (`B.map` bytes) $ \b -> if b >= 0x41 && b <= 0x5A
then b + 0x20
else b
maybeDecodeUtf8 :: B.ByteString -> Maybe T.Text
maybeDecodeUtf8 = excToMaybe . TE.decodeUtf8 where
excToMaybe :: a -> Maybe a
excToMaybe x = unsafePerformIO $ Exc.catch
(fmap Just (Exc.evaluate x))
unicodeError
unicodeError :: UnicodeException -> IO (Maybe a)
unicodeError _ = return Nothing
posix :: Rules
posix = Rules
{ rulesName = "POSIX"
, toByteChunks = posixToByteChunks
, fromBytes = posixFromBytes
, valid = posixValid
, splitSearchPath = posixSplitSearch
}
posixToByteChunks :: FilePath -> [B.ByteString]
posixToByteChunks p = root : chunks where
root = rootBytes $ pathRoot p
chunks = intersperse (B8.pack "/") $ byteDirectories p
posixFromBytes :: B.ByteString -> FilePath
posixFromBytes bytes = if B.null bytes then empty else path where
path = FilePath root directories basename exts
split = B.split 0x2F bytes
(root, pastRoot) = if B.null (head split)
then (Just RootPosix, tail split)
else (Nothing, split)
(directories, filename)
| P.null pastRoot = ([], B.empty)
| otherwise = case last pastRoot of
fn | fn == B8.pack "." -> (goodDirs pastRoot, B.empty)
fn | fn == B8.pack ".." -> (goodDirs pastRoot, B.empty)
fn -> (goodDirs (init pastRoot), fn)
goodDirs = filter (not . B.null)
(basename, exts) = if B.null filename
then (Nothing, [])
else case B.split 0x2E filename of
[] -> (Nothing, [])
(name':exts') -> (Just name', exts')
posixValid :: FilePath -> Bool
posixValid p = validRoot && validDirectories where
validDirectories = flip all (byteDirectories p)
$ not . B.any (\b -> b == 0 || b == 0x2F)
validRoot = case pathRoot p of
Nothing -> True
Just RootPosix -> True
_ -> False
posixSplitSearch :: B.ByteString -> [FilePath]
posixSplitSearch = map (posixFromBytes . normSearch) . B.split 0x3A where
normSearch bytes = if B.null bytes then B8.pack "." else bytes
windows :: Rules
windows = Rules
{ rulesName = "Windows"
, toByteChunks = winToByteChunks
, fromBytes = winFromBytes
, valid = winValid
, splitSearchPath = map winFromBytes . filter (not . B.null) . B.split 0x3B
}
winToByteChunks :: FilePath -> [B.ByteString]
winToByteChunks p = root : chunks where
root = rootBytes $ pathRoot p
chunks = intersperse (B8.pack "\\") $ byteDirectories p
winFromBytes :: B.ByteString -> FilePath
winFromBytes bytes = if B.null bytes then empty else path where
path = FilePath root directories basename exts
split = B.splitWith (\b -> b == 0x2F || b == 0x5C) bytes
(root, pastRoot) = let
head' = head split
tail' = tail split
in if B.null head'
then (Just RootWindowsCurrentVolume, tail')
else if B.elem 0x3A head'
then (Just (parseDrive head'), tail')
else (Nothing, split)
parseDrive bytes' = RootWindowsVolume c where
c = (toUpper . chr . fromIntegral . B.head) bytes'
(directories, filename)
| P.null pastRoot = ([], B.empty)
| otherwise = case last pastRoot of
fn | fn == B8.pack "." -> (goodDirs pastRoot, B.empty)
fn | fn == B8.pack ".." -> (goodDirs pastRoot, B.empty)
fn -> (goodDirs (init pastRoot), fn)
goodDirs = filter (not . B.null)
(basename, exts) = if B.null filename
then (Nothing, [])
else case B.split 0x2E filename of
[] -> (Nothing, [])
(name':exts') -> (Just name', exts')
winValid :: FilePath -> Bool
winValid p = validRoot && noReserved && validCharacters where
reservedChars = [0..0x1F] ++ [0x2F, 0x5C, 0x3F, 0x2A, 0x3A, 0x7C, 0x22, 0x3C, 0x3E]
reservedNames = map B8.pack
[ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4"
, "COM5", "COM6", "COM7", "COM8", "COM9", "CON"
, "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6"
, "LPT7", "LPT8", "LPT9", "NUL", "PRN"
]
validRoot = case pathRoot p of
Nothing -> True
Just RootWindowsCurrentVolume -> True
Just (RootWindowsVolume v) -> elem (toUpper v) ['A'..'Z']
_ -> False
noExt = p { pathExtensions = [] }
noReserved = flip all (byteDirectories noExt)
$ \c -> notElem (upperBytes c) reservedNames
validCharacters = flip all (byteDirectories p)
$ not . B.any (`elem` reservedChars)