{-# 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 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 isFile = either (const False) (const True) md
                       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