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