{- |
Copyright: 2009, Henning Thielemann

Deliver a HTML document containing the contents of a directory.
-}
module Network.MoHWS.Part.Listing (Configuration, desc, ) where

import qualified Network.MoHWS.Module as Module
import qualified Network.MoHWS.Module.Description as ModuleDesc
import qualified Network.MoHWS.Server.Request as ServerRequest
import qualified Network.MoHWS.Server.Context as ServerContext
import qualified Network.MoHWS.HTTP.Header as Header
import qualified Network.MoHWS.HTTP.Request  as Request
import qualified Network.MoHWS.HTTP.Response as Response
import qualified Network.MoHWS.Stream as Stream

import qualified Network.MoHWS.Configuration as Config
import qualified Network.MoHWS.Configuration.Accessor as ConfigA
import qualified Network.MoHWS.Configuration.Parser as ConfigParser
import qualified Data.Accessor.Basic as Accessor
import Data.Accessor.Basic ((.>))

import qualified Text.Html as Html
import           Text.Html((<<), (+++))
import qualified Network.URI as URI
import Control.Monad.IO.Class (liftIO, )
import Control.Monad (guard, )
import Data.List (sort, )
import Control.Monad.Trans.Maybe (MaybeT, )
import Network.MoHWS.Utility (hasTrailingSlash, statFile, )

import qualified System.Directory as Dir
import System.Posix (isDirectory, )



desc :: (Stream.C body) => ModuleDesc.T body Configuration
desc :: T body Configuration
desc =
   T Any Any
forall body ext. T body ext
ModuleDesc.empty {
      name :: String
ModuleDesc.name = String
"directorylisting",
      load :: T Configuration -> IO (T body)
ModuleDesc.load = T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body))
-> (T Configuration -> T body) -> T Configuration -> IO (T body)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T Configuration -> T body
forall body. C body => T Configuration -> T body
funs,
      configParser :: T () Configuration
ModuleDesc.configParser = T () Configuration
forall st. T st Configuration
parser,
      setDefltConfig :: Configuration -> Configuration
ModuleDesc.setDefltConfig = Configuration -> Configuration -> Configuration
forall a b. a -> b -> a
const Configuration
defltConfig
   }

data Configuration =
   Configuration {
      Configuration -> Bool
listing_ :: Bool
   }

defltConfig :: Configuration
defltConfig :: Configuration
defltConfig =
   Configuration :: Bool -> Configuration
Configuration {
      listing_ :: Bool
listing_ = Bool
True
   }

listing :: Accessor.T Configuration Bool
listing :: T Configuration Bool
listing =
   (Bool -> Configuration -> Configuration)
-> (Configuration -> Bool) -> T Configuration Bool
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet (\Bool
x Configuration
c -> Configuration
c{listing_ :: Bool
listing_ = Bool
x}) Configuration -> Bool
listing_

parser :: ConfigParser.T st Configuration
parser :: T st Configuration
parser =
   String -> T st Configuration -> T st Configuration
forall st ext. String -> T st ext -> T st ext
ConfigParser.field String
"directorylisting" T st Configuration
forall st. T st Configuration
p_listing

p_listing :: ConfigParser.T st Configuration
p_listing :: T st Configuration
p_listing =
   T (T Configuration) Bool
-> GenParser Char st Bool -> T st Configuration
forall r a st.
T r a -> GenParser Char st a -> GenParser Char st (r -> r)
ConfigParser.set (T (T Configuration) Configuration
forall ext. T (T ext) ext
ConfigA.extension T (T Configuration) Configuration
-> T Configuration Bool -> T (T Configuration) Bool
forall a b c. T a b -> T b c -> T a c
.> T Configuration Bool
listing) (GenParser Char st Bool -> T st Configuration)
-> GenParser Char st Bool -> T st Configuration
forall a b. (a -> b) -> a -> b
$ GenParser Char st Bool
forall st. GenParser Char st Bool
ConfigParser.bool

funs :: (Stream.C body) => ServerContext.T Configuration -> Module.T body
funs :: T Configuration -> T body
funs T Configuration
st =
   T body
forall body. T body
Module.empty {
      handleRequest :: T body -> MaybeT IO (T body)
Module.handleRequest = T Configuration -> T body -> MaybeT IO (T body)
forall body.
C body =>
T Configuration -> T body -> MaybeT IO (T body)
handleRequest T Configuration
st
   }

handleRequest :: (Stream.C body) =>
   ServerContext.T Configuration -> ServerRequest.T body -> MaybeT IO (Response.T body)
handleRequest :: T Configuration -> T body -> MaybeT IO (T body)
handleRequest T Configuration
st T body
req =
   let conf :: T Configuration
conf = T Configuration -> T Configuration
forall ext. T ext -> T ext
ServerContext.config T Configuration
st
       dir :: String
dir  = T body -> String
forall body. T body -> String
ServerRequest.serverFilename T body
req
       uri :: URI
uri  = T body -> URI
forall body. T body -> URI
Request.uri (T body -> URI) -> T body -> URI
forall a b. (a -> b) -> a -> b
$ T body -> T body
forall body. T body -> T body
ServerRequest.clientRequest T body
req
   in  do -- liftIO $ print dir
          Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Configuration -> Bool
listing_ (Configuration -> Bool) -> Configuration -> Bool
forall a b. (a -> b) -> a -> b
$ T Configuration -> Configuration
forall ext. T ext -> ext
Config.extension T Configuration
conf
          Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> MaybeT IO Bool -> MaybeT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((FileStatus -> Bool) -> MaybeT IO FileStatus -> MaybeT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileStatus -> Bool
isDirectory (MaybeT IO FileStatus -> MaybeT IO Bool)
-> MaybeT IO FileStatus -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ String -> MaybeT IO FileStatus
statFile (String -> MaybeT IO FileStatus) -> String -> MaybeT IO FileStatus
forall a b. (a -> b) -> a -> b
$ String
dir)
          Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
hasTrailingSlash (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URI -> String
URI.uriPath URI
uri
          [String]
files <- IO [String] -> MaybeT IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> MaybeT IO [String])
-> IO [String] -> MaybeT IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
Dir.getDirectoryContents String
dir
          T body -> MaybeT IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> MaybeT IO (T body)) -> T body -> MaybeT IO (T body)
forall a b. (a -> b) -> a -> b
$ T Configuration -> URI -> Html -> T body
forall body ext. C body => T ext -> URI -> Html -> T body
htmlResponse T Configuration
conf URI
uri (Html -> T body) -> Html -> T body
forall a b. (a -> b) -> a -> b
$ [String] -> Html
htmlList ([String] -> Html) -> [String] -> Html
forall a b. (a -> b) -> a -> b
$
             [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool) -> [String] -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [String
".", String
".."]) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
files

htmlList :: [String] -> Html.Html
htmlList :: [String] -> Html
htmlList =
   [Html] -> Html
forall a. HTML a => [a] -> Html
Html.unordList ([Html] -> Html) -> ([String] -> [Html]) -> [String] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (String -> Html) -> [String] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> (Html -> Html
Html.anchor (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
s) Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
Html.! [String -> HtmlAttr
Html.href String
s])

htmlResponse :: (Stream.C body) =>
   Config.T ext -> URI.URI -> Html.Html -> Response.T body
htmlResponse :: T ext -> URI -> Html -> T body
htmlResponse T ext
conf URI
addr Html
body =
   T ext -> Bool -> Group -> Body body -> T body
forall ext body. T ext -> Bool -> Group -> Body body -> T body
Response.makeOk
      T ext
conf
      Bool
True
      ([T] -> Group
Header.group [String -> T
Header.makeContentType String
"text/html"])
      (body -> Body body
forall body. C body => body -> Body body
Response.bodyWithSizeFromString (body -> Body body) -> body -> Body body
forall a b. (a -> b) -> a -> b
$
       Int -> String -> body
forall stream. C stream => Int -> String -> stream
Stream.fromString (T ext -> Int
forall ext. T ext -> Int
Config.chunkSize T ext
conf) (String -> body) -> String -> body
forall a b. (a -> b) -> a -> b
$
       Html -> String
forall html. HTML html => html -> String
Html.renderHtml (Html -> String) -> Html -> String
forall a b. (a -> b) -> a -> b
$
       String -> Html -> Html
htmlDoc (String
"Directory listing of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
addr) Html
body)

htmlDoc :: String -> Html.Html -> Html.Html
htmlDoc :: String -> Html -> Html
htmlDoc String
title Html
body =
   Html -> Html
Html.header
      (Html
Html.meta Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
Html.! [String -> HtmlAttr
Html.httpequiv String
"content-type",
                         String -> HtmlAttr
Html.content String
"text/html; charset=ISO-8859-1"]
       Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
       Html -> Html
Html.thetitle (Html -> Html) -> String -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String
title)
   Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
   Html -> Html
Html.body Html
body