{-# 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 = Pieces -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pieces
pieces Bool -> Bool -> Bool
|| (FolderName -> Maybe FolderName) -> Pieces -> [Maybe FolderName]
forall a b. (a -> b) -> [a] -> [b]
map FolderName -> Maybe FolderName
forall a. a -> Maybe a
Just Pieces
pieces [Maybe FolderName] -> [Maybe FolderName] -> Bool
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 [Either FolderName File] -> [Either FolderName File]
forall a. a -> a
id else (FolderName -> Either FolderName File
forall a b. a -> Either a b
Left (Text -> FolderName
unsafeToPiece Text
"") Either FolderName File
-> [Either FolderName File] -> [Either FolderName File]
forall a. a -> [a] -> [a]
:)) [Either FolderName File]
contents -- FIXME emptyParentFolder feels like a bit of a hack
    Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$ Html -> Builder
HU.renderHtmlBuilder
           (Html -> Builder) -> Html -> Builder
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.html (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
             Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
                 let title :: Text
title = Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FolderName -> Text) -> Pieces -> [Text]
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 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.toHtml Text
title'
                 Html -> Html
H.style (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (String -> Html) -> String -> Html
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 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
                 let hasTrailingSlash :: Bool
hasTrailingSlash =
                        case (FolderName -> Text) -> Pieces -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FolderName -> Text
fromPiece (Pieces -> [Text]) -> Pieces -> [Text]
forall a b. (a -> b) -> a -> b
$ Pieces -> Pieces
forall a. [a] -> [a]
reverse (Pieces -> Pieces) -> Pieces -> Pieces
forall a b. (a -> b) -> a -> b
$ Pieces
pieces of
                            Text
"":[Text]
_ -> Bool
True
                            [Text]
_ -> Bool
False
                 Html -> Html
H.h1 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Bool -> Pieces -> Html
showFolder' Bool
hasTrailingSlash (Pieces -> Html) -> Pieces -> Html
forall a b. (a -> b) -> a -> b
$ (FolderName -> Bool) -> Pieces -> Pieces
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FolderName -> Bool) -> FolderName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (FolderName -> Text) -> FolderName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FolderName -> Text
fromPiece) Pieces
pieces
                 [Text] -> String -> String -> [Either FolderName File] -> Html
renderDirectoryContentsTable ((FolderName -> Text) -> Pieces -> [Text]
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 (Text -> String) -> Text -> String
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 :: p -> p
showName p
"" = p
"root"
    showName p
x = p
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" FolderName -> Pieces -> Pieces
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] = Text -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall p. (Eq p, IsString p) => p -> p
showName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FolderName -> Text
fromPiece FolderName
x
    showFolder Bool
hasTrailingSlash (FolderName
x:Pieces
xs) = do
        let len :: Int
len = Pieces -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Pieces
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- (if Bool
hasTrailingSlash then Int
0 else Int
1)
            href :: String
href
                | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String
"."
                | Bool
otherwise = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
len String
"../" :: String
        Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
href) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall p. (Eq p, IsString p) => p -> p
showName (Text -> Text) -> Text -> Text
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 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do Html -> Html
H.thead (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do Html -> Html
H.th (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! (AttributeValue -> Attribute
A.class_ AttributeValue
"first") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
H.img Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! (AttributeValue -> Attribute
A.src (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
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 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ((Either FolderName File, Bool) -> Html)
-> [(Either FolderName File, Bool)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Either FolderName File, Bool) -> Html
mkRow ([Either FolderName File]
-> [Bool] -> [(Either FolderName File, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Either FolderName File -> Either FolderName File -> Ordering)
-> [Either FolderName File] -> [Either FolderName File]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Either FolderName File -> Either FolderName File -> Ordering
sortMD [Either FolderName File]
fps) ([Bool] -> [(Either FolderName File, Bool)])
-> [Bool] -> [(Either FolderName File, Bool)]
forall a b. (a -> b) -> a -> b
$ [Bool] -> [Bool]
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) = FolderName -> FolderName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare FolderName
a FolderName
b
      sortMD (Right File
a) (Right File
b) = FolderName -> FolderName -> Ordering
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 (Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"alt") else Html -> Html
forall a. a -> a
id) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
          Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
                   Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"first"
                        (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ case Either FolderName File
md of
                            Left{} -> Html
H.img Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.src (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue String
folderSrc)
                                            Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.alt AttributeValue
"Folder"
                            Right{} -> () -> Html
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   let name :: FolderName
name =
                           case (FolderName -> FolderName)
-> (File -> FolderName) -> Either FolderName File -> FolderName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FolderName -> FolderName
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 isFile :: Bool
isFile = (FolderName -> Bool)
-> (File -> Bool) -> Either FolderName File -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> FolderName -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> File -> Bool
forall a b. a -> b -> a
const Bool
True) Either FolderName File
md
                       href :: Text
href = Text -> Text
addCurrentDir (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FolderName -> Text
fromPiece FolderName
name
                       addCurrentDir :: Text -> Text
addCurrentDir Text
x =
                           case [Text] -> [Text]
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 (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
href) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ FolderName -> Text
fromPiece FolderName
name)
                   Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"date" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$
                       case Either FolderName File
md of
                           Right File { fileGetModified :: File -> Maybe EpochTime
fileGetModified = Just EpochTime
t } ->
                                   TimeLocale -> String -> EpochTime -> String
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 (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"size" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$
                       case Either FolderName File
md of
                           Right File { fileGetSize :: File -> Integer
fileGetSize = Integer
s } -> Integer -> String
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 =  TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
a String
b (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime (a -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
c :: POSIXTime)
      prettyShow :: a -> String
prettyShow a
x
        | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1024 = a -> String
forall a. (Show a, Integral a) => a -> String
prettyShowK (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
1024
        | Bool
otherwise = String -> a -> String
forall a. Show a => String -> a -> String
addCommas String
"B" a
x
      prettyShowK :: a -> String
prettyShowK a
x
        | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1024 = a -> String
forall a. (Show a, Integral a) => a -> String
prettyShowM (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
1024
        | Bool
otherwise = String -> a -> String
forall a. Show a => String -> a -> String
addCommas String
"KB" a
x
      prettyShowM :: a -> String
prettyShowM a
x
        | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1024 = a -> String
forall a. Show a => a -> String
prettyShowG (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
1024
        | Bool
otherwise = String -> a -> String
forall a. Show a => String -> a -> String
addCommas String
"MB" a
x
      prettyShowG :: a -> String
prettyShowG a
x = String -> a -> String
forall a. Show a => String -> a -> String
addCommas String
"GB" a
x
      addCommas :: String -> a -> String
addCommas String
s = (String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s)) (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
addCommas' (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
      addCommas' :: String -> String
addCommas' (Char
a:Char
b:Char
c:Char
d:String
e) = Char
a Char -> String -> String
forall a. a -> [a] -> [a]
: Char
b Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
',' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
addCommas' (Char
d Char -> String -> String
forall a. a -> [a] -> [a]
: String
e)
      addCommas' String
x = String
x