-- Copyright 2009, Henning Thielemann
module Network.MoHWS.Part.VirtualHost
          (Configuration, desc,
           virtualDocumentRoot, virtualFile, ) where

import qualified Network.MoHWS.Module as Module
import qualified Network.MoHWS.Module.Description as ModuleDesc
import qualified Network.MoHWS.Server.Context as ServerContext
import qualified Network.MoHWS.Utility as Util
import qualified System.FilePath as FilePath

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.ParserCombinators.Parsec as Parsec

import Network.Socket (HostName, )

import qualified Data.Map as Map
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), )
import Control.Monad (mplus, )


desc :: 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
"virtualhost",
      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. 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 -> Map String String
virtualDocumentRoot_   :: Map.Map HostName FilePath,
      Configuration -> Map String (Map String String)
virtualFile_           :: Map.Map HostName (Map.Map String FilePath)
   }

defltConfig :: Configuration
defltConfig :: Configuration
defltConfig =
   Configuration :: Map String String
-> Map String (Map String String) -> Configuration
Configuration {
      virtualDocumentRoot_ :: Map String String
virtualDocumentRoot_   = Map String String
forall k a. Map k a
Map.empty,
      virtualFile_ :: Map String (Map String String)
virtualFile_           = Map String (Map String String)
forall k a. Map k a
Map.empty
   }

virtualDocumentRoot :: Accessor.T Configuration (Map.Map HostName FilePath)
virtualDocumentRoot :: T Configuration (Map String String)
virtualDocumentRoot =
   (Map String String -> Configuration -> Configuration)
-> (Configuration -> Map String String)
-> T Configuration (Map String String)
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet (\Map String String
x Configuration
c -> Configuration
c{virtualDocumentRoot_ :: Map String String
virtualDocumentRoot_ = Map String String
x}) Configuration -> Map String String
virtualDocumentRoot_

virtualFile :: Accessor.T Configuration (Map.Map HostName (Map.Map String FilePath))
virtualFile :: T Configuration (Map String (Map String String))
virtualFile =
   (Map String (Map String String) -> Configuration -> Configuration)
-> (Configuration -> Map String (Map String String))
-> T Configuration (Map String (Map String String))
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet (\Map String (Map String String)
x Configuration
c -> Configuration
c{virtualFile_ :: Map String (Map String String)
virtualFile_ = Map String (Map String String)
x}) Configuration -> Map String (Map String String)
virtualFile_

parser :: ConfigParser.T st Configuration
parser :: T st Configuration
parser =
   [T st Configuration] -> T st Configuration
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
Parsec.choice ([T st Configuration] -> T st Configuration)
-> [T st Configuration] -> T st Configuration
forall a b. (a -> b) -> a -> b
$
   (String -> T st Configuration -> T st Configuration
forall st ext. String -> T st ext -> T st ext
ConfigParser.field String
"virtualdocumentroot"    T st Configuration
forall st. T st Configuration
p_virtualDocumentRoot) T st Configuration -> [T st Configuration] -> [T st Configuration]
forall a. a -> [a] -> [a]
:
   (String -> T st Configuration -> T st Configuration
forall st ext. String -> T st ext -> T st ext
ConfigParser.field String
"virtualfile"            T st Configuration
forall st. T st Configuration
p_virtualFile) T st Configuration -> [T st Configuration] -> [T st Configuration]
forall a. a -> [a] -> [a]
:
   []

p_virtualDocumentRoot :: ConfigParser.T st Configuration
p_virtualDocumentRoot :: T st Configuration
p_virtualDocumentRoot =
   do String
host <- GenParser Char st String
forall st. GenParser Char st String
ConfigParser.stringLiteral
      String
root <- GenParser Char st String
forall st. GenParser Char st String
ConfigParser.stringLiteral
      (T Configuration -> T Configuration) -> T st Configuration
forall (m :: * -> *) a. Monad m => a -> m a
return ((T Configuration -> T Configuration) -> T st Configuration)
-> (T Configuration -> T Configuration) -> T st Configuration
forall a b. (a -> b) -> a -> b
$
         T (T Configuration) (Map String String)
-> (Map String String -> Map String String)
-> T Configuration
-> T Configuration
forall r a. T r a -> (a -> a) -> r -> r
Accessor.modify (T (T Configuration) Configuration
forall ext. T (T ext) ext
ConfigA.extension T (T Configuration) Configuration
-> T Configuration (Map String String)
-> T (T Configuration) (Map String String)
forall a b c. T a b -> T b c -> T a c
.> T Configuration (Map String String)
virtualDocumentRoot)
            (String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
host String
root)

p_virtualFile :: ConfigParser.T st Configuration
p_virtualFile :: T st Configuration
p_virtualFile =
   do String
host        <- GenParser Char st String
forall st. GenParser Char st String
ConfigParser.stringLiteral
      String
virtualPath <- GenParser Char st String
forall st. GenParser Char st String
ConfigParser.stringLiteral
      String
realPath    <- GenParser Char st String
forall st. GenParser Char st String
ConfigParser.stringLiteral
      (T Configuration -> T Configuration) -> T st Configuration
forall (m :: * -> *) a. Monad m => a -> m a
return ((T Configuration -> T Configuration) -> T st Configuration)
-> (T Configuration -> T Configuration) -> T st Configuration
forall a b. (a -> b) -> a -> b
$
         T (T Configuration) (Map String (Map String String))
-> (Map String (Map String String)
    -> Map String (Map String String))
-> T Configuration
-> T Configuration
forall r a. T r a -> (a -> a) -> r -> r
Accessor.modify (T (T Configuration) Configuration
forall ext. T (T ext) ext
ConfigA.extension T (T Configuration) Configuration
-> T Configuration (Map String (Map String String))
-> T (T Configuration) (Map String (Map String String))
forall a b c. T a b -> T b c -> T a c
.> T Configuration (Map String (Map String String))
virtualFile)
            ((Map String String -> Map String String -> Map String String)
-> String
-> Map String String
-> Map String (Map String String)
-> Map String (Map String String)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Map String String -> Map String String -> Map String String
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union String
host (String -> String -> Map String String
forall k a. k -> a -> Map k a
Map.singleton String
virtualPath String
realPath))

funs :: ServerContext.T Configuration -> Module.T body
funs :: T Configuration -> T body
funs T Configuration
st =
   T body
forall body. T body
Module.empty {
      isServerHost :: String -> Bool
Module.isServerHost  = T Configuration -> String -> Bool
isServerHost T Configuration
st,
      translatePath :: String -> String -> MaybeT IO String
Module.translatePath = T Configuration -> String -> String -> MaybeT IO String
translatePath T Configuration
st
   }

{- |
In earlier versions we did just add the virtual hosts to the ServerAliases
in the configuration step.
I think this solution is cleaner.
-}
isServerHost :: ServerContext.T Configuration -> HostName -> Bool
isServerHost :: T Configuration -> String -> Bool
isServerHost T Configuration
st String
host =
   let ext :: Configuration
ext = T Configuration -> Configuration
forall ext. T ext -> ext
Config.extension (T Configuration -> Configuration)
-> T Configuration -> Configuration
forall a b. (a -> b) -> a -> b
$ T Configuration -> T Configuration
forall ext. T ext -> T ext
ServerContext.config T Configuration
st
   in  String -> Map String (Map String String) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member String
host (Configuration -> Map String (Map String String)
virtualFile_ Configuration
ext) Bool -> Bool -> Bool
||
       String -> Map String String -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member String
host (Configuration -> Map String String
virtualDocumentRoot_ Configuration
ext)

translatePath :: ServerContext.T Configuration -> String -> String -> MaybeT IO FilePath
translatePath :: T Configuration -> String -> String -> MaybeT IO String
translatePath T Configuration
st String
host String
path =
--   (\x -> print (host,path) >> print x >> return x) $
   let conf :: T Configuration
conf = T Configuration -> T Configuration
forall ext. T ext -> T ext
ServerContext.config T Configuration
st
       ext :: Configuration
ext  = T Configuration -> Configuration
forall ext. T ext -> ext
Config.extension T Configuration
conf
   in  MaybeT IO String -> MaybeT IO String -> MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
          (IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> IO (Maybe String) -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
           (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
FilePath.combine (T Configuration -> String
forall ext. T ext -> String
Config.documentRoot T Configuration
conf)) (Maybe String -> Maybe String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> a -> b
$
           String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
path (Map String String -> Maybe String)
-> Maybe (Map String String) -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> Map String (Map String String) -> Maybe (Map String String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
host (Configuration -> Map String (Map String String)
virtualFile_ Configuration
ext))
          {-
          If a path contains too many '..'
          then Util.localPath will refuse to translate the path.
          However, later stages will still try to translate.
          -}
          (do
            String
root <- IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> IO (Maybe String) -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
host (Configuration -> Map String String
virtualDocumentRoot_ Configuration
ext)
            IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> IO (Maybe String) -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO (Maybe String)
Util.localPath String
root String
path)