{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module WaiAppStatic.Listing
    ( defaultListing
    ) where

import qualified Text.Blaze.Html5.Attributes as A
import qualified Text.Blaze.Html5            as H
import           Text.Blaze                  ((!))
import qualified Data.Text as T
import Data.Time
import Data.Time.Clock.POSIX
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 :: Listing
defaultListing Pieces
pieces (Folder [Either FolderName File]
contents) = do
    let isTop :: Bool
isTop = forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pieces
pieces Bool -> Bool -> Bool
|| forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just Pieces
pieces forall a. Eq a => a -> a -> Bool
== [Text -> Maybe FolderName
toPiece Text
""]
    let fps'' :: [Either FolderName File]
        fps'' :: [Either FolderName File]
fps'' = (if Bool
isTop then forall a. a -> a
id else (forall a b. a -> Either a b
Left (Text -> FolderName
unsafeToPiece Text
"") forall a. a -> [a] -> [a]
:)) [Either FolderName File]
contents -- FIXME emptyParentFolder feels like a bit of a hack
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Html -> Builder
HU.renderHtmlBuilder
           forall a b. (a -> b) -> a -> b
$ Html -> Html
H.html forall a b. (a -> b) -> a -> b
$ do
             Html -> Html
H.head forall a b. (a -> b) -> a -> b
$ do
                 let title :: Text
title = Text -> [Text] -> Text
T.intercalate Text
"/" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FolderName -> Text
fromPiece Pieces
pieces
                 let title' :: Text
title' = if Text -> Bool
T.null Text
title then Text
"root folder" else Text
title
                 Html -> Html
H.title forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml Text
title'
                 Html -> Html
H.style forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
"table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
                                              , String
"table, th, td { border: 1px solid #353948; }"
                                              , String
"td.size { text-align: right; font-size: 0.7em; width: 50px }"
                                              , String
"td.date { text-align: right; font-size: 0.7em; width: 130px }"
                                              , String
"td { padding-right: 1em; padding-left: 1em; }"
                                              , String
"th.first { background-color: white; width: 24px }"
                                              , String
"td.first { padding-right: 0; padding-left: 0; text-align: center }"
                                              , String
"tr { background-color: white; }"
                                              , String
"tr.alt { background-color: #A3B5BA}"
                                              , String
"th { background-color: #3C4569; color: white; font-size: 1.125em; }"
                                              , String
"h1 { width: 760px; margin: 1em auto; font-size: 1em; font-family: sans-serif }"
                                              , String
"img { width: 20px }"
                                              , String
"a { text-decoration: none }"
                                              ]
             Html -> Html
H.body forall a b. (a -> b) -> a -> b
$ do
                 let hasTrailingSlash :: Bool
hasTrailingSlash =
                        case forall a b. (a -> b) -> [a] -> [b]
map FolderName -> Text
fromPiece forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse Pieces
pieces of
                            Text
"":[Text]
_ -> Bool
True
                            [Text]
_ -> Bool
False
                 Html -> Html
H.h1 forall a b. (a -> b) -> a -> b
$ Bool -> Pieces -> Html
showFolder' Bool
hasTrailingSlash forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. FolderName -> Text
fromPiece) Pieces
pieces
                 [Text] -> String -> String -> [Either FolderName File] -> Html
renderDirectoryContentsTable (forall a b. (a -> b) -> [a] -> [b]
map FolderName -> Text
fromPiece Pieces
pieces) String
haskellSrc String
folderSrc [Either FolderName File]
fps''
  where
    image :: Text -> String
image Text
x = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Pieces -> Text
relativeDirFromPieces Pieces
pieces, Text
".hidden/", Text
x, Text
".png"]
    folderSrc :: String
folderSrc = Text -> String
image Text
"folder"
    haskellSrc :: String
haskellSrc = Text -> String
image Text
"haskell"
    showName :: a -> a
showName a
"" = a
"root"
    showName a
x = a
x

    -- Add a link to the root of the tree
    showFolder' :: Bool -> Pieces -> H.Html
    showFolder' :: Bool -> Pieces -> Html
showFolder' Bool
hasTrailingSlash Pieces
pieces' = Bool -> Pieces -> Html
showFolder Bool
hasTrailingSlash (Text -> FolderName
unsafeToPiece Text
"root" forall a. a -> [a] -> [a]
: Pieces
pieces')

    showFolder :: Bool -> Pieces -> H.Html
    showFolder :: Bool -> Pieces -> Html
showFolder Bool
_ [] = Html
"/" -- won't happen
    showFolder Bool
_ [FolderName
x] = forall a. ToMarkup a => a -> Html
H.toHtml forall a b. (a -> b) -> a -> b
$ forall {a}. (Eq a, IsString a) => a -> a
showName forall a b. (a -> b) -> a -> b
$ FolderName -> Text
fromPiece FolderName
x
    showFolder Bool
hasTrailingSlash (FolderName
x:Pieces
xs) = do
        let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length Pieces
xs forall a. Num a => a -> a -> a
- (if Bool
hasTrailingSlash then Int
0 else Int
1)
            href :: String
href
                | Int
len forall a. Eq a => a -> a -> Bool
== Int
0 = String
"."
                | Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
len String
"../" :: String
        Html -> Html
H.a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (forall a. ToValue a => a -> AttributeValue
H.toValue String
href) forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml forall a b. (a -> b) -> a -> b
$ forall {a}. (Eq a, IsString a) => a -> a
showName forall a b. (a -> b) -> a -> b
$ FolderName -> Text
fromPiece FolderName
x
        Html
" / " :: H.Html
        Bool -> Pieces -> Html
showFolder Bool
hasTrailingSlash Pieces
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 :: [Text] -> String -> String -> [Either FolderName File] -> Html
renderDirectoryContentsTable [Text]
pathInfo' String
haskellSrc String
folderSrc [Either FolderName File]
fps =
           Html -> Html
H.table forall a b. (a -> b) -> a -> b
$ do Html -> Html
H.thead forall a b. (a -> b) -> a -> b
$ do Html -> Html
H.th forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"first" forall a b. (a -> b) -> a -> b
$ Html
H.img forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.src (forall a. ToValue a => a -> AttributeValue
H.toValue String
haskellSrc)
                                     Html -> Html
H.th Html
"Name"
                                     Html -> Html
H.th Html
"Modified"
                                     Html -> Html
H.th Html
"Size"
                        Html -> Html
H.tbody forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Either FolderName File, Bool) -> Html
mkRow (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Either FolderName File -> Either FolderName File -> Ordering
sortMD [Either FolderName File]
fps) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
cycle [Bool
False, Bool
True])
    where
      sortMD :: Either FolderName File -> Either FolderName File -> Ordering
      sortMD :: Either FolderName File -> Either FolderName File -> Ordering
sortMD Left{} Right{} = Ordering
LT
      sortMD Right{} Left{} = Ordering
GT
      sortMD (Left FolderName
a) (Left FolderName
b) = forall a. Ord a => a -> a -> Ordering
compare FolderName
a FolderName
b
      sortMD (Right File
a) (Right File
b) = forall a. Ord a => a -> a -> Ordering
compare (File -> FolderName
fileName File
a) (File -> FolderName
fileName File
b)

      mkRow :: (Either FolderName File, Bool) -> H.Html
      mkRow :: (Either FolderName File, Bool) -> Html
mkRow (Either FolderName File
md, Bool
alt) =
          (if Bool
alt then (forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"alt") else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
          Html -> Html
H.tr forall a b. (a -> b) -> a -> b
$ do
                   Html -> Html
H.td forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"first"
                        forall a b. (a -> b) -> a -> b
$ case Either FolderName File
md of
                            Left{} -> Html
H.img forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.src (forall a. ToValue a => a -> AttributeValue
H.toValue String
folderSrc)
                                            forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.alt AttributeValue
"Folder"
                            Right{} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   let name :: FolderName
name =
                           case forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id File -> FolderName
fileName Either FolderName File
md of
                               (FolderName -> Text
fromPiece -> Text
"") -> Text -> FolderName
unsafeToPiece Text
".."
                               FolderName
x -> FolderName
x
                   let href :: Text
href = Text -> Text
addCurrentDir forall a b. (a -> b) -> a -> b
$ FolderName -> Text
fromPiece FolderName
name
                       addCurrentDir :: Text -> Text
addCurrentDir Text
x =
                           case forall a. [a] -> [a]
reverse [Text]
pathInfo' of
                               Text
"":[Text]
_ -> Text
x -- has a trailing slash
                               [] -> Text
x -- at the root
                               Text
currentDir:[Text]
_ -> [Text] -> Text
T.concat [Text
currentDir, Text
"/", Text
x]
                   Html -> Html
H.td (Html -> Html
H.a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (forall a. ToValue a => a -> AttributeValue
H.toValue Text
href) forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml forall a b. (a -> b) -> a -> b
$ FolderName -> Text
fromPiece FolderName
name)
                   Html -> Html
H.td forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"date" forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml forall a b. (a -> b) -> a -> b
$
                       case Either FolderName File
md of
                           Right File { fileGetModified :: File -> Maybe EpochTime
fileGetModified = Just EpochTime
t } ->
                                   forall {a}. Real a => TimeLocale -> String -> a -> String
formatCalendarTime TimeLocale
defaultTimeLocale String
"%d-%b-%Y %X" EpochTime
t
                           Either FolderName File
_ -> String
""
                   Html -> Html
H.td forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"size" forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml forall a b. (a -> b) -> a -> b
$
                       case Either FolderName File
md of
                           Right File { fileGetSize :: File -> Integer
fileGetSize = Integer
s } -> forall {a}. (Show a, Integral a) => a -> String
prettyShow Integer
s
                           Left{} -> String
""
      formatCalendarTime :: TimeLocale -> String -> a -> String
formatCalendarTime TimeLocale
a String
b a
c =  forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
a String
b forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime (forall a b. (Real a, Fractional b) => a -> b
realToFrac a
c :: POSIXTime)
      prettyShow :: a -> String
prettyShow a
x
        | a
x forall a. Ord a => a -> a -> Bool
> a
1024 = forall {a}. (Show a, Integral a) => a -> String
prettyShowK forall a b. (a -> b) -> a -> b
$ a
x forall a. Integral a => a -> a -> a
`div` a
1024
        | Bool
otherwise = forall {a}. Show a => String -> a -> String
addCommas String
"B" a
x
      prettyShowK :: a -> String
prettyShowK a
x
        | a
x forall a. Ord a => a -> a -> Bool
> a
1024 = forall {a}. (Show a, Integral a) => a -> String
prettyShowM forall a b. (a -> b) -> a -> b
$ a
x forall a. Integral a => a -> a -> a
`div` a
1024
        | Bool
otherwise = forall {a}. Show a => String -> a -> String
addCommas String
"KB" a
x
      prettyShowM :: a -> String
prettyShowM a
x
        | a
x forall a. Ord a => a -> a -> Bool
> a
1024 = forall {a}. Show a => a -> String
prettyShowG forall a b. (a -> b) -> a -> b
$ a
x forall a. Integral a => a -> a -> a
`div` a
1024
        | Bool
otherwise = forall {a}. Show a => String -> a -> String
addCommas String
"MB" a
x
      prettyShowG :: a -> String
prettyShowG a
x = forall {a}. Show a => String -> a -> String
addCommas String
"GB" a
x
      addCommas :: String -> a -> String
addCommas String
s = (forall a. [a] -> [a] -> [a]
++ (Char
' ' forall a. a -> [a] -> [a]
: String
s)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
addCommas' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => a -> String
show
      addCommas' :: String -> String
addCommas' (Char
a:Char
b:Char
c:Char
d:String
e) = Char
a forall a. a -> [a] -> [a]
: Char
b forall a. a -> [a] -> [a]
: Char
c forall a. a -> [a] -> [a]
: Char
',' forall a. a -> [a] -> [a]
: String -> String
addCommas' (Char
d forall a. a -> [a] -> [a]
: String
e)
      addCommas' String
x = String
x