← Back to branch summary

~ubuntu-branches/ubuntu/vivid/haskell-system-filepath/vivid

« back to all changes in this revision

Viewing changes to lib/Filesystem/Path/Rules.hs

  • Committer: Package Import Robot
  • Author(s): Joachim Breitner
  • Date: 2014-06-19 13:31:22 UTC
  • mfrom: (3.3.1 sid)
  • Revision ID: package-import@ubuntu.com-20140619133122-jrv4ydv9nupckr4g
Tags: 0.4.12-1
* Adjust watch file to new hackage layout
* New upstream release

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Filesystem/Path/Rules.hs
26
26
        -- * Rule‐specific path properties
27
27
        , valid
28
28
        , splitSearchPath
 
29
        , splitSearchPathString
29
30
        ) where
30
31
 
31
32
import           Prelude hiding (FilePath, null)
52
53
        { rulesName = T.pack "POSIX"
53
54
        , valid = posixValid
54
55
        , splitSearchPath = posixSplitSearch
 
56
        , splitSearchPathString = posixSplitSearch . B8.pack
55
57
        , toText = posixToText
56
58
        , fromText = posixFromText
57
59
        , encode = posixToBytes
69
71
posix_ghc702 :: Rules B.ByteString
70
72
posix_ghc702 = posix
71
73
        { rulesName = T.pack "POSIX (GHC 7.2)"
 
74
        , splitSearchPathString = posixSplitSearchString posixFromGhc702String
72
75
        , encodeString = posixToGhc702String
73
76
        , decodeString = posixFromGhc702String
74
77
        }
82
85
posix_ghc704 :: Rules B.ByteString
83
86
posix_ghc704 = posix
84
87
        { rulesName = T.pack "POSIX (GHC 7.4)"
 
88
        , splitSearchPathString = posixSplitSearchString posixFromGhc704String
85
89
        , encodeString = posixToGhc704String
86
90
        , decodeString = posixFromGhc704String
87
91
        }
184
188
posixSplitSearch = map (posixFromBytes . normSearch) . B.split 0x3A where
185
189
        normSearch bytes = if B.null bytes then B8.pack "." else bytes
186
190
 
 
191
posixSplitSearchString :: (String -> FilePath) -> String -> [FilePath]
 
192
posixSplitSearchString toPath = map (toPath . normSearch) . splitBy (== ':') where
 
193
        normSearch s = if P.null s then "." else s
 
194
 
187
195
-------------------------------------------------------------------------------
188
196
-- Darwin
189
197
-------------------------------------------------------------------------------
199
207
        { rulesName = T.pack "Darwin"
200
208
        , valid = posixValid
201
209
        , splitSearchPath = darwinSplitSearch
 
210
        , splitSearchPathString = darwinSplitSearch . TE.decodeUtf8 . B8.pack
202
211
        , toText = Right . darwinToText
203
212
        , fromText = posixFromText
204
213
        , encode = darwinToText
216
225
darwin_ghc702 :: Rules T.Text
217
226
darwin_ghc702 = darwin
218
227
        { rulesName = T.pack "Darwin (GHC 7.2)"
 
228
        , splitSearchPathString = darwinSplitSearch . T.pack
219
229
        , encodeString = T.unpack . darwinToText
220
230
        , decodeString = posixFromText . T.pack
221
231
        }
245
255
        { rulesName = T.pack "Windows"
246
256
        , valid = winValid
247
257
        , splitSearchPath = winSplit
 
258
        , splitSearchPathString = winSplit . T.pack
248
259
        , toText = Right . winToText
249
260
        , fromText = winFromText
250
261
        , encode = winToText
254
265
        }
255
266
 
256
267
winToText :: FilePath -> T.Text
257
 
winToText p = T.concat (root : chunks) where
 
268
winToText p = case pathRoot p of
 
269
        Just RootWindowsUnc{} -> uncToText p
 
270
        _ -> dosToText p
 
271
 
 
272
dosToText :: FilePath -> T.Text
 
273
dosToText p = T.concat (root : chunks) where
258
274
        root = rootText (pathRoot p)
259
275
        chunks = intersperse (T.pack "\\") (map unescape' (directoryChunks p))
260
276
 
 
277
uncToText :: FilePath -> T.Text
 
278
uncToText p = T.concat (root : chunks) where
 
279
        root = if all T.null chunks
 
280
                then rootText (pathRoot p)
 
281
                else rootText (pathRoot p) `T.append` T.pack "\\"
 
282
        chunks = intersperse (T.pack "\\") (filter (not . T.null) (map unescape' (directoryChunks p)))
 
283
 
261
284
winFromText :: T.Text -> FilePath
262
285
winFromText text = if T.null text then empty else path where
263
286
        path = FilePath root directories basename exts
264
287
        
 
288
        -- Windows has various types of absolute paths:
 
289
        --
 
290
        -- * C:\foo\bar -> DOS-style absolute path
 
291
        -- * \\?\C:\foo\bar -> extended-length absolute path
 
292
        -- * \\host\share\foo\bar -> UNC path
 
293
        -- * \\?\UNC\host\share\foo\bar -> extended-length UNC path
 
294
        --
 
295
        -- \foo\bar looks like an absolute path, but is actually a path
 
296
        -- relative to the current DOS drive.
 
297
        --
 
298
        -- http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx
 
299
        (root, pastRoot) = if T.isPrefixOf (T.pack "\\\\") text
 
300
                then case stripUncasedPrefix (T.pack "\\\\?\\UNC\\") text of
 
301
                        Just stripped -> parseUncRoot stripped True
 
302
                        Nothing -> case T.stripPrefix (T.pack "\\\\?\\") text of
 
303
                                Just stripped -> parseDosRoot stripped True
 
304
                                Nothing -> case T.stripPrefix (T.pack "\\\\") text of
 
305
                                        Just stripped -> parseUncRoot stripped False
 
306
                                        Nothing -> parseDosRoot text False
 
307
                else case T.stripPrefix (T.pack "\\??\\") text of
 
308
                        Just stripped -> parseDoubleQmark stripped
 
309
                        Nothing -> parseDosRoot text False
 
310
        
 
311
        (directories, filename)
 
312
                | P.null pastRoot = ([], Nothing)
 
313
                | otherwise = case last pastRoot of
 
314
                        fn | fn == T.pack "." -> (goodDirs pastRoot, Just "")
 
315
                        fn | fn == T.pack ".." -> (goodDirs pastRoot, Just "")
 
316
                        fn -> (goodDirs (init pastRoot), Just (escape fn))
 
317
        
 
318
        goodDirs :: [T.Text] -> [Chunk]
 
319
        goodDirs = map escape . filter (not . T.null)
 
320
        
 
321
        (basename, exts) = case filename of
 
322
                Just fn -> parseFilename fn
 
323
                Nothing -> (Nothing, [])
 
324
 
 
325
stripUncasedPrefix :: T.Text -> T.Text -> Maybe T.Text
 
326
stripUncasedPrefix prefix text = if T.toCaseFold prefix == T.toCaseFold (T.take (T.length prefix) text)
 
327
        then Just (T.drop (T.length prefix) text)
 
328
        else Nothing
 
329
 
 
330
parseDosRoot :: T.Text -> Bool -> (Maybe Root, [T.Text])
 
331
parseDosRoot text extended = parsed where
265
332
        split = textSplitBy (\c -> c == '/' || c == '\\') text
266
333
        
267
 
        (root, pastRoot) = let
268
 
                head' = head split
269
 
                tail' = tail split
270
 
                in if T.null head'
271
 
                        then (Just RootWindowsCurrentVolume, tail')
272
 
                        else if T.any (== ':') head'
273
 
                                then (Just (parseDrive head'), tail')
 
334
        head' = head split
 
335
        tail' = tail split
 
336
        parsed = if T.null head'
 
337
                then (Just RootWindowsCurrentVolume, tail')
 
338
                else if T.any (== ':') head'
 
339
                        then (Just (parseDrive head'), tail')
274
340
                                else (Nothing, split)
275
341
        
276
 
        parseDrive = RootWindowsVolume . toUpper . T.head
277
 
        
278
 
        (directories, filename)
279
 
                | P.null pastRoot = ([], "")
280
 
                | otherwise = case last pastRoot of
281
 
                        fn | fn == T.pack "." -> (goodDirs pastRoot, "")
282
 
                        fn | fn == T.pack ".." -> (goodDirs pastRoot, "")
283
 
                        fn -> (goodDirs (init pastRoot), escape fn)
284
 
        
285
 
        goodDirs :: [T.Text] -> [Chunk]
286
 
        goodDirs = map escape . filter (not . T.null)
287
 
        
288
 
        (basename, exts) = parseFilename filename
 
342
        parseDrive c = RootWindowsVolume (toUpper (T.head c)) extended
 
343
 
 
344
parseDoubleQmark :: T.Text -> (Maybe Root, [T.Text])
 
345
parseDoubleQmark text = (Just RootWindowsDoubleQMark, components) where
 
346
        components = textSplitBy (\c -> c == '/' || c == '\\') text
 
347
 
 
348
parseUncRoot :: T.Text -> Bool -> (Maybe Root, [T.Text])
 
349
parseUncRoot text extended = parsed where
 
350
        (host, pastHost) = T.break (== '\\') text
 
351
        (share, pastShare) = T.break (== '\\') (T.drop 1 pastHost)
 
352
        split = if T.null pastShare
 
353
                then []
 
354
                else textSplitBy (== '\\') pastShare
 
355
        parsed = (Just (RootWindowsUnc (T.unpack host) (T.unpack share) extended), split)
289
356
 
290
357
winValid :: FilePath -> Bool
291
 
winValid p = validRoot && noReserved && validCharacters where
 
358
winValid p = case pathRoot p of
 
359
        Nothing -> dosValid p
 
360
        Just RootWindowsCurrentVolume -> dosValid p
 
361
        Just (RootWindowsVolume v _) -> elem v ['A'..'Z'] && dosValid p
 
362
        Just (RootWindowsUnc host share _) -> uncValid p host share
 
363
        -- don't even try to validate \??\ paths
 
364
        Just RootWindowsDoubleQMark -> True
 
365
        Just RootPosix -> False
 
366
 
 
367
dosValid :: FilePath -> Bool
 
368
dosValid p = noReserved && validCharacters where
292
369
        reservedChars = map chr [0..0x1F] ++ "/\\?*:|\"<>"
293
370
        reservedNames =
294
371
                [ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4"
297
374
                , "LPT7", "LPT8", "LPT9", "NUL", "PRN"
298
375
                ]
299
376
        
300
 
        validRoot = case pathRoot p of
301
 
                Nothing -> True
302
 
                Just RootWindowsCurrentVolume -> True
303
 
                Just (RootWindowsVolume v) -> elem v ['A'..'Z']
304
 
                _ -> False
305
 
        
306
377
        noExt = p { pathExtensions = [] }
307
378
        noReserved = flip all (directoryChunks noExt)
308
379
                $ \fn -> notElem (map toUpper fn) reservedNames
310
381
        validCharacters = flip all (directoryChunks p)
311
382
                $ not . any (`elem` reservedChars)
312
383
 
 
384
uncValid :: FilePath -> String -> String -> Bool
 
385
uncValid _ "" _ = False
 
386
uncValid _ _ "" = False
 
387
uncValid p host share = ok host && ok share && all ok (dropWhileEnd P.null (directoryChunks p)) where
 
388
        ok ""  = False
 
389
        ok c = not (any invalidChar c)
 
390
        invalidChar c = c == '\x00' || c == '\\'
 
391
 
 
392
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
 
393
dropWhileEnd p = foldr (\x xs -> if p x && P.null xs then [] else x : xs) []
 
394
 
313
395
winSplit :: T.Text -> [FilePath]
314
396
winSplit = map winFromText . filter (not . T.null) . textSplitBy (== ';')