git.iko.soy/typeable/wai
on master help sign in
Piece datatype
d18012bMichael Snoyman
Network/Wai/Application/Static.hs+47−36
compare with master
unifiedsplit
@@ -216,13 +216,19 @@ stripTrailingSlash "/" = ""
216stripTrailingSlash "" = ""
216stripTrailingSlash "" = ""
217stripTrailingSlash (x:xs) = x : stripTrailingSlash xs
217stripTrailingSlash (x:xs) = x : stripTrailingSlash xs
218
218
219+data Piece = Piece
220+ { pieceRaw :: FilePath
221+ , piecePretty :: T.Text
222+ }
223+ deriving (Eq, Ord)
219−type Pieces = [T.Text]
224+type Pieces = [Piece]
225+
220relativeDirFromPieces :: Pieces -> T.Text
226relativeDirFromPieces :: Pieces -> T.Text
221relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
227relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
222
228
223pathFromPieces :: FilePath -> Pieces -> FilePath
229pathFromPieces :: FilePath -> Pieces -> FilePath
224pathFromPieces prefix pieces =
230pathFromPieces prefix pieces =
225− concat $ prefix : map ((:) '/') (map unfixPathName $ map T.unpack pieces)
231+ concat $ prefix : map ((:) '/') (map pieceRaw pieces)
226
232
227checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
233checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
228 -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
234 -> [T.Text] -- ^ List of default index files. Cannot contain slashes.
@@ -230,20 +236,20 @@ checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function
230 -> CacheSettings
236 -> CacheSettings
231 -> W.Request
237 -> W.Request
232 -> IO CheckPieces
238 -> IO CheckPieces
233−checkPieces _ _ [".hidden", "folder.png"] _ _ =
239+checkPieces _ _ [Piece _ ".hidden", Piece _ "folder.png"] _ _ =
234 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
240 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]
235−checkPieces _ _ [".hidden", "haskell.png"] _ _ =
241+checkPieces _ _ [Piece _ ".hidden", Piece _ "haskell.png"] _ _ =
236 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
242 return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]
237checkPieces fileLookup indices pieces cache req
243checkPieces fileLookup indices pieces cache req
238− | any unsafe pieces = return Forbidden
244+ | any (unsafe . piecePretty) pieces = return Forbidden
239− | any T.null $ safeInit pieces =
245+ | any (T.null . piecePretty) $ safeInit pieces =
240− return $ Redirect $ filterButLast (not . T.null) pieces
246+ return $ Redirect $ filterButLast (not . T.null . piecePretty) pieces
241 | otherwise = do
247 | otherwise = do
242 let (isFile, isFolder) =
248 let (isFile, isFolder) =
243 case () of
249 case () of
244 ()
250 ()
245 | null pieces -> (True, True)
251 | null pieces -> (True, True)
246− | T.null (last pieces) -> (False, True)
252+ | T.null $ piecePretty (last pieces) -> (False, True)
247 | otherwise -> (True, False)
253 | otherwise -> (True, False)
248
254
249 let fp = undefined
255 let fp = undefined
@@ -275,14 +281,14 @@ checkPieces fileLookup indices pieces cache req
275 (FLFile{}, False) -> return $ Redirect $ init pieces
281 (FLFile{}, False) -> return $ Redirect $ init pieces
276 (FLFolder folder@(Folder contents), _) -> do
282 (FLFolder folder@(Folder contents), _) -> do
277 case checkIndices $ map feName $ filter feIsFile contents of
283 case checkIndices $ map feName $ filter feIsFile contents of
278− Just index -> return $ Redirect $ setLast pieces index
284+ Just index -> return $ Redirect $ setLast pieces $ Piece (T.unpack index) index
279 Nothing ->
285 Nothing ->
280 if isFolder
286 if isFolder
281 then return $ DirectoryResponse folder
287 then return $ DirectoryResponse folder
282− else return $ Redirect $ pieces ++ [""]
288+ else return $ Redirect $ pieces ++ [Piece "" ""]
283
289
284 setLast [] x = [x]
290 setLast [] x = [x]
285− setLast [""] x = [x]
291+ setLast [Piece "" ""] x = [x]
286 setLast (a:b) x = a : setLast b x
292 setLast (a:b) x = a : setLast b x
287
293
288 checkIndices :: [T.Text] -> Maybe T.Text
294 checkIndices :: [T.Text] -> Maybe T.Text
@@ -366,7 +372,7 @@ fileSystemLookup prefix pieces = do
366 return $ FLFile File
372 return $ FLFile File
367 { fileGetSize = fmap (fromIntegral . fileSize) $ getFileStatus fp
373 { fileGetSize = fmap (fromIntegral . fileSize) $ getFileStatus fp
368 , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
374 , fileToResponse = \s h -> W.ResponseFile s h fp Nothing
369− , fileName = last pieces
375+ , fileName = piecePretty $ last pieces
370 }
376 }
371 else do
377 else do
372 de <- doesDirectoryExist fp
378 de <- doesDirectoryExist fp
@@ -390,9 +396,11 @@ data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded
390
396
391embeddedLookup :: Embedded -> Pieces -> IO FileLookup -- FIXME broken for unicode path names
397embeddedLookup :: Embedded -> Pieces -> IO FileLookup -- FIXME broken for unicode path names
392embeddedLookup root pieces =
398embeddedLookup root pieces =
393− return $ elookup pieces root
399+ return $ elookup (map piecePretty pieces) root
394 where
400 where
401+ elookup :: [T.Text] -> Embedded -> FileLookup
395 elookup [] x = FLFolder $ Folder $ map toEntry $ Map.toList x
402 elookup [] x = FLFolder $ Folder $ map toEntry $ Map.toList x
403+ elookup [""] x = elookup [] x
396 elookup (p:ps) x =
404 elookup (p:ps) x =
397 case Map.lookup p x of
405 case Map.lookup p x of
398 Nothing -> FLDoesNotExist
406 Nothing -> FLDoesNotExist
@@ -412,12 +420,12 @@ toEntry (name, ee) = FolderEntry
412 , feGetMetaData = return $ Just $
420 , feGetMetaData = return $ Just $
413 case ee of
421 case ee of
414 EEFile bs -> FileMetaData
422 EEFile bs -> FileMetaData
415− { mdName = T.unpack name
423+ { mdName = name
416 , mdModified = 0 -- FIXME
424 , mdModified = 0 -- FIXME
417 , mdSize = fromIntegral $ S8.length bs
425 , mdSize = fromIntegral $ S8.length bs
418 }
426 }
419 EEFolder _ -> FolderMetaData
427 EEFolder _ -> FolderMetaData
420− { mdName = T.unpack name
428+ { mdName = name
421 }
429 }
422 }
430 }
423
431
@@ -426,20 +434,21 @@ toEmbedded fps =
426 go texts
434 go texts
427 where
435 where
428 texts = map (\(x, y) -> (filter (not . T.null) $ toPieces x, y)) fps
436 texts = map (\(x, y) -> (filter (not . T.null) $ toPieces x, y)) fps
437+ toPiece fp = T.pack $ fixPathName fp
429 toPieces "" = []
438 toPieces "" = []
430 toPieces x =
439 toPieces x =
431 let (y, z) = break (== '/') x
440 let (y, z) = break (== '/') x
432− in T.pack y : toPieces (drop 1 z)
441+ in toPiece y : toPieces (drop 1 z)
433− go :: [(Pieces, S8.ByteString)] -> Embedded
442+ go :: [([T.Text], S8.ByteString)] -> Embedded
434 go orig =
443 go orig =
435 Map.fromList $ map (second go') hoisted
444 Map.fromList $ map (second go') hoisted
436 where
445 where
437 next = map (\(x, y) -> (head x, (tail x, y))) orig
446 next = map (\(x, y) -> (head x, (tail x, y))) orig
438− grouped :: [[(T.Text, (Pieces, S8.ByteString))]]
447+ grouped :: [[(T.Text, ([T.Text], S8.ByteString))]]
439 grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
448 grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
440− hoisted :: [(T.Text, [(Pieces, S8.ByteString)])]
449+ hoisted :: [(T.Text, [([T.Text], S8.ByteString)])]
441 hoisted = map (fst . head &&& map snd) grouped
450 hoisted = map (fst . head &&& map snd) grouped
442− go' :: [(Pieces, S8.ByteString)] -> EmbeddedEntry
451+ go' :: [([T.Text], S8.ByteString)] -> EmbeddedEntry
443 go' [([], content)] = EEFile content
452 go' [([], content)] = EEFile content
444 go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x
453 go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x
445
454
@@ -451,9 +460,13 @@ bsToFile name bs = File
451 }
460 }
452
461
453staticApp :: StaticSettings -> W.Application
462staticApp :: StaticSettings -> W.Application
454−staticApp set req = do
463+staticApp set req =
455− let pieces = W.pathInfo req
464+ staticAppPieces set (map toPiece $ W.pathInfo req) req
456− staticAppPieces set pieces req
465+ where
466+ toPiece t = Piece
467+ { piecePretty = t
468+ , pieceRaw = unfixPathName $ T.unpack t
469+ }
457
470
458status304, statusNotModified :: H.Status
471status304, statusNotModified :: H.Status
459status304 = H.Status 304 "Not Modified"
472status304 = H.Status 304 "Not Modified"
@@ -501,13 +514,13 @@ staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do
501 -- TODO: set Content-Length
514 -- TODO: set Content-Length
502 ] lbs
515 ] lbs
503 Redirect pieces' -> do
516 Redirect pieces' -> do
504− let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments pieces')
517+ let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map piecePretty pieces')
505
518
506 let loc' =
519 let loc' =
507 -- relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
520 -- relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir
508 -- (ssMkRedirect ss) pieces' $ encodePathInfo pieces' []
521 -- (ssMkRedirect ss) pieces' $ encodePathInfo pieces' []
509 toByteString $
522 toByteString $
510− foldr mappend (H.encodePathSegments pieces') -- FIXME use Text
523+ foldr mappend (H.encodePathSegments $ map piecePretty pieces') -- FIXME is this correct?
511 $ map (const $ copyByteString "../") $ drop 1 pieces
524 $ map (const $ copyByteString "../") $ drop 1 pieces
512 return $ W.responseLBS H.status301
525 return $ W.responseLBS H.status301
513 [ ("Content-Type", "text/plain")
526 [ ("Content-Type", "text/plain")
@@ -561,12 +574,12 @@ unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack
561defaultListing :: Listing
574defaultListing :: Listing
562defaultListing pieces (Folder contents) = do
575defaultListing pieces (Folder contents) = do
563 fps' <- mapM feGetMetaData contents
576 fps' <- mapM feGetMetaData contents
564− let isTop = null pieces || pieces == [""]
577+ let isTop = null pieces || pieces == [Piece "" ""]
565 let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
578 let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'
566 return $ HU.renderHtml
579 return $ HU.renderHtml
567 $ H.html $ do
580 $ H.html $ do
568 H.head $ do
581 H.head $ do
569− let title = T.unpack $ T.intercalate "/" pieces
582+ let title = T.unpack $ T.intercalate "/" $ map piecePretty pieces
570 let title' = if null title then "root folder" else title
583 let title' = if null title then "root folder" else title
571 H.title $ H.string title'
584 H.title $ H.string title'
572 H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
585 H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
@@ -584,7 +597,7 @@ defaultListing pieces (Folder contents) = do
584 , "a { text-decoration: none }"
597 , "a { text-decoration: none }"
585 ]
598 ]
586 H.body $ do
599 H.body $ do
587− H.h1 $ showFolder $ map T.unpack $ filter (not . T.null) pieces
600+ H.h1 $ showFolder $ map (T.unpack . piecePretty) $ filter (not . T.null . piecePretty) pieces -- FIXME don't unpack
588 renderDirectoryContentsTable haskellSrc folderSrc $ catMaybes fps''
601 renderDirectoryContentsTable haskellSrc folderSrc $ catMaybes fps''
589 where
602 where
590 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
603 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]
@@ -631,7 +644,7 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
631 then return ()
644 then return ()
632 else H.img ! A.src (H.stringValue folderSrc)
645 else H.img ! A.src (H.stringValue folderSrc)
633 ! A.alt (H.stringValue "Folder")
646 ! A.alt (H.stringValue "Folder")
634− H.td (H.a ! A.href (H.stringValue $ mdName' md ++ if mdIsFile md then "" else "/") $ H.string $ mdName' md)
647+ H.td (H.a ! A.href (H.stringValue $ T.unpack (mdName md) ++ if mdIsFile md then "" else "/") $ H.string $ T.unpack (mdName md))
635 H.td ! A.class_ (H.stringValue "date") $ H.string $
648 H.td ! A.class_ (H.stringValue "date") $ H.string $
636 if mdIsFile md
649 if mdIsFile md
637 then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" $ mdModified md
650 then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" $ mdModified md
@@ -655,17 +668,14 @@ renderDirectoryContentsTable haskellSrc folderSrc fps =
655 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
668 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)
656 addCommas' x = x
669 addCommas' x = x
657
670
658−mdName' :: MetaData -> FilePath
659−mdName' = fixPathName . mdName
660−
661data MetaData =
671data MetaData =
662 FileMetaData
672 FileMetaData
663− { mdName :: FilePath
673+ { mdName :: T.Text
664 , mdModified :: EpochTime
674 , mdModified :: EpochTime
665 , mdSize :: FileOffset
675 , mdSize :: FileOffset
666 }
676 }
667 | FolderMetaData
677 | FolderMetaData
668− { mdName :: FilePath
678+ { mdName :: T.Text
669 }
679 }
670 deriving Show
680 deriving Show
671
681
@@ -681,12 +691,13 @@ getMetaData _ ('.':_) = return Nothing
681getMetaData localPath fp = do
691getMetaData localPath fp = do
682 let fp' = localPath ++ '/' : fp
692 let fp' = localPath ++ '/' : fp
683 fe <- doesFileExist fp'
693 fe <- doesFileExist fp'
694+ let fpPretty = T.pack $ fixPathName fp
684 if fe
695 if fe
685 then do
696 then do
686 fs <- getFileStatus fp'
697 fs <- getFileStatus fp'
687 let modTime = modificationTime fs
698 let modTime = modificationTime fs
688 let count = fileSize fs
699 let count = fileSize fs
689− return $ Just $ FileMetaData fp modTime count
700+ return $ Just $ FileMetaData fpPretty modTime count
690 else do
701 else do
691 de <- doesDirectoryExist fp'
702 de <- doesDirectoryExist fp'
692− return $ if de then Just (FolderMetaData fp) else Nothing
703+ return $ if de then Just (FolderMetaData fpPretty) else Nothing