{- |
Copyright: 2009, Henning Thielemann

When we get a request for http://foo.com/bar,
where 'bar' is a directory and contains an index.html,
we need to send back a redirect for http://foo.com/bar/
(i.e. add the final slash),
otherwise relative links from index.html will be relative to http://foo.com/
instead of http://foo.com/bar/.
E.g. look at http://www.haskell.org/happy/.
-}
module Network.MoHWS.Part.AddSlash (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.URI as URI

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 Control.Monad.Trans.Maybe (MaybeT, )
import Control.Monad (guard, )
import Network.MoHWS.Utility (hasTrailingSlash, statFile, )

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
"add slash",
      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
addSlash_ :: Bool
   }

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

addSlash :: Accessor.T Configuration Bool
addSlash :: T Configuration Bool
addSlash =
   (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{addSlash_ :: Bool
addSlash_ = Bool
x}) Configuration -> Bool
addSlash_

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
"addslash" T st Configuration
forall st. T st Configuration
p_addSlash

p_addSlash :: ConfigParser.T st Configuration
p_addSlash :: T st Configuration
p_addSlash =
   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
addSlash) (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
       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
       path :: String
path = URI -> String
URI.uriPath URI
uri
   in  do 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
addSlash_ (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
$ T body -> String
forall body. T body -> String
ServerRequest.serverFilename T body
req)
          Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
hasTrailingSlash (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
path
          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 -> T body
forall body. C body => T Configuration -> URI -> T body
redirectResponse T Configuration
conf (URI -> T body) -> URI -> T body
forall a b. (a -> b) -> a -> b
$ URI
uri{uriPath :: String
URI.uriPath=String
pathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/"}

redirectResponse :: (Stream.C body) =>
   Config.T Configuration -> URI.URI -> Response.T body
redirectResponse :: T Configuration -> URI -> T body
redirectResponse T Configuration
conf =
   T Configuration -> Group -> Body body -> URI -> T body
forall ext body. T ext -> Group -> Body body -> URI -> T body
Response.makeMovedPermanently
      T Configuration
conf
      ([T] -> Group
Header.group [String -> T
Header.makeContentType String
"text/plain"])
      (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 Int
100 String
"add trailing slash to directory path")