1{-# LANGUAGE CPP #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE ViewPatterns #-} 4module WaiAppStatic.Listing 5 ( defaultListing 6 ) where 7 8import qualified Text.Blaze.Html5.Attributes as A 9import qualified Text.Blaze.Html5 as H 10import Text.Blaze ((!)) 11import qualified Data.Text as T 12import Data.Time 13import Data.Time.Clock.POSIX 14import WaiAppStatic.Types 15#if !MIN_VERSION_time(1,5,0) 16import System.Locale (defaultTimeLocale) 17#endif 18import Data.List (sortBy) 19import Util 20 21import qualified Text.Blaze.Html.Renderer.Utf8 as HU 22 23-- | Provides a default directory listing, suitable for most apps. 24-- 25-- Code below taken from Happstack: <https://github.com/Happstack/happstack-server/blob/87e6c01a65c687d06c61345430a112fc9a444a95/src/Happstack/Server/FileServe/BuildingBlocks.hs> 26defaultListing :: Listing 27defaultListing pieces (Folder contents) = do 28 let isTop = null pieces || map Just pieces == [toPiece ""] 29 let fps'' :: [Either FolderName File] 30 fps'' = (if isTop then id else (Left (unsafeToPiece "") :)) contents -- FIXME emptyParentFolder feels like a bit of a hack 31 return $ HU.renderHtmlBuilder 32 $ H.html $ do 33 H.head $ do 34 let title = T.intercalate "/" $ map fromPiece pieces 35 let title' = if T.null title then "root folder" else title 36 H.title $ H.toHtml title' 37 H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }" 38 , "table, th, td { border: 1px solid #353948; }" 39 , "td.size { text-align: right; font-size: 0.7em; width: 50px }" 40 , "td.date { text-align: right; font-size: 0.7em; width: 130px }" 41 , "td { padding-right: 1em; padding-left: 1em; }" 42 , "th.first { background-color: white; width: 24px }" 43 , "td.first { padding-right: 0; padding-left: 0; text-align: center }" 44 , "tr { background-color: white; }" 45 , "tr.alt { background-color: #A3B5BA}" 46 , "th { background-color: #3C4569; color: white; font-size: 1.125em; }" 47 , "h1 { width: 760px; margin: 1em auto; font-size: 1em; font-family: sans-serif }" 48 , "img { width: 20px }" 49 , "a { text-decoration: none }" 50 ] 51 H.body $ do 52 let hasTrailingSlash = 53 case map fromPiece $ reverse $ pieces of 54 "":_ -> True 55 _ -> False 56 H.h1 $ showFolder' hasTrailingSlash $ filter (not . T.null . fromPiece) pieces 57 renderDirectoryContentsTable (map fromPiece pieces) haskellSrc folderSrc fps'' 58 where 59 image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"] 60 folderSrc = image "folder" 61 haskellSrc = image "haskell" 62 showName "" = "root" 63 showName x = x 64 65 -- Add a link to the root of the tree 66 showFolder' :: Bool -> Pieces -> H.Html 67 showFolder' hasTrailingSlash pieces' = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces') 68 69 showFolder :: Bool -> Pieces -> H.Html 70 showFolder _ [] = "/" -- won't happen 71 showFolder _ [x] = H.toHtml $ showName $ fromPiece x 72 showFolder hasTrailingSlash (x:xs) = do 73 let len = length xs - (if hasTrailingSlash then 0 else 1) 74 href 75 | len == 0 = "." 76 | otherwise = concat $ replicate len "../" :: String 77 H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x 78 " / " :: H.Html 79 showFolder hasTrailingSlash xs 80 81-- | a function to generate an HTML table showing the contents of a directory on the disk 82-- 83-- This function generates most of the content of the 84-- 'renderDirectoryContents' page. If you want to style the page 85-- differently, or add google analytics code, etc, you can just create 86-- a new page template to wrap around this HTML. 87-- 88-- see also: 'getMetaData', 'renderDirectoryContents' 89renderDirectoryContentsTable :: [T.Text] -- ^ requested path info 90 -> String 91 -> String 92 -> [Either FolderName File] 93 -> H.Html 94renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps = 95 H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc) 96 H.th "Name" 97 H.th "Modified" 98 H.th "Size" 99 H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True]) 100 where 101 sortMD :: Either FolderName File -> Either FolderName File -> Ordering 102 sortMD Left{} Right{} = LT 103 sortMD Right{} Left{} = GT 104 sortMD (Left a) (Left b) = compare a b 105 sortMD (Right a) (Right b) = compare (fileName a) (fileName b) 106 107 mkRow :: (Either FolderName File, Bool) -> H.Html 108 mkRow (md, alt) = 109 (if alt then (! A.class_ "alt") else id) $ 110 H.tr $ do 111 H.td ! A.class_ "first" 112 $ case md of 113 Left{} -> H.img ! A.src (H.toValue folderSrc) 114 ! A.alt "Folder" 115 Right{} -> return () 116 let name = 117 case either id fileName md of 118 (fromPiece -> "") -> unsafeToPiece ".." 119 x -> x 120 let isFile = either (const False) (const True) md 121 href = addCurrentDir $ fromPiece name 122 addCurrentDir x = 123 case reverse pathInfo' of 124 "":_ -> x -- has a trailing slash 125 [] -> x -- at the root 126 currentDir:_ -> T.concat [currentDir, "/", x] 127 H.td (H.a ! A.href (H.toValue href) $ H.toHtml $ fromPiece name) 128 H.td ! A.class_ "date" $ H.toHtml $ 129 case md of 130 Right File { fileGetModified = Just t } -> 131 formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t 132 _ -> "" 133 H.td ! A.class_ "size" $ H.toHtml $ 134 case md of 135 Right File { fileGetSize = s } -> prettyShow s 136 Left{} -> "" 137 formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime) 138 prettyShow x 139 | x > 1024 = prettyShowK $ x `div` 1024 140 | otherwise = addCommas "B" x 141 prettyShowK x 142 | x > 1024 = prettyShowM $ x `div` 1024 143 | otherwise = addCommas "KB" x 144 prettyShowM x 145 | x > 1024 = prettyShowG $ x `div` 1024 146 | otherwise = addCommas "MB" x 147 prettyShowG x = addCommas "GB" x 148 addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show 149 addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e) 150 addCommas' x = x 151