    {-# 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 a. [a] -> 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 a. a -> IO a
    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 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 :: 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" 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 {a}. (Eq a, IsString a) => a -> a
    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 a. [a] -> 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 {a}. (Eq a, IsString a) => a -> a
    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 (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. HasCallStack => [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 a. a -> MarkupM a
    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 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