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