{- |
Copyright: 2002, Simon Marlow.
Copyright: 2006, Bjorn Bringert.
Copyright: 2009, Henning Thielemann.
-}
module Network.MoHWS.Part.UserDirectory (Configuration, desc, ) 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 Network.MoHWS.Logger.Error (debug, )

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 (mzero, guard, )
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), )

import System.IO.Error (catchIOError, )
import System.Posix (homeDirectory, getUserEntryForName, )


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
"userdirectory",
      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 -> String
userDir_ :: String
   }

defltConfig :: Configuration
defltConfig :: Configuration
defltConfig =
   Configuration :: String -> Configuration
Configuration {
      userDir_ :: String
userDir_ = String
""
   }

userDir :: Accessor.T Configuration String
userDir :: T Configuration String
userDir =
   (String -> Configuration -> Configuration)
-> (Configuration -> String) -> T Configuration String
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Accessor.fromSetGet (\String
x Configuration
c -> Configuration
c{userDir_ :: String
userDir_ = String
x}) Configuration -> String
userDir_

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
"userdirectory" T st Configuration
forall st. T st Configuration
p_userDir

p_userDir :: ConfigParser.T st Configuration
p_userDir :: T st Configuration
p_userDir =
   T (T Configuration) String
-> GenParser Char st String -> 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 String -> T (T Configuration) String
forall a b c. T a b -> T b c -> T a c
.> T Configuration String
userDir) (GenParser Char st String -> T st Configuration)
-> GenParser Char st String -> T st Configuration
forall a b. (a -> b) -> a -> b
$ GenParser Char st String
forall st. GenParser Char st String
ConfigParser.stringLiteral

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

translatePath :: ServerContext.T Configuration -> String -> String -> MaybeT IO FilePath
translatePath :: T Configuration -> String -> String -> MaybeT IO String
translatePath T Configuration
st String
_host (Char
'/':Char
'~':String
userpath) =
  do let conf :: T Configuration
conf = T Configuration -> T Configuration
forall ext. T ext -> T ext
ServerContext.config T Configuration
st
         (String
usr, String
path) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') String
userpath
         dir :: String
dir = Configuration -> String
userDir_ (Configuration -> String) -> Configuration -> String
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 ()) -> 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
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
dir
     T Configuration -> String -> MaybeT IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T Configuration
st (String -> MaybeT IO ()) -> String -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ String
"looking for user: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
usr
     UserEntry
ent <-
        IO (Maybe UserEntry) -> MaybeT IO UserEntry
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe UserEntry) -> MaybeT IO UserEntry)
-> IO (Maybe UserEntry) -> MaybeT IO UserEntry
forall a b. (a -> b) -> a -> b
$ (IO (Maybe UserEntry)
 -> (IOError -> IO (Maybe UserEntry)) -> IO (Maybe UserEntry))
-> (IOError -> IO (Maybe UserEntry))
-> IO (Maybe UserEntry)
-> IO (Maybe UserEntry)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Maybe UserEntry)
-> (IOError -> IO (Maybe UserEntry)) -> IO (Maybe UserEntry)
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError (IO (Maybe UserEntry) -> IOError -> IO (Maybe UserEntry)
forall a b. a -> b -> a
const (IO (Maybe UserEntry) -> IOError -> IO (Maybe UserEntry))
-> IO (Maybe UserEntry) -> IOError -> IO (Maybe UserEntry)
forall a b. (a -> b) -> a -> b
$ Maybe UserEntry -> IO (Maybe UserEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserEntry
forall a. Maybe a
Nothing) (IO (Maybe UserEntry) -> IO (Maybe UserEntry))
-> IO (Maybe UserEntry) -> IO (Maybe UserEntry)
forall a b. (a -> b) -> a -> b
$
        (UserEntry -> Maybe UserEntry)
-> IO UserEntry -> IO (Maybe UserEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UserEntry -> Maybe UserEntry
forall a. a -> Maybe a
Just (String -> IO UserEntry
getUserEntryForName String
usr)
     let p :: String
p = Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
: UserEntry -> String
homeDirectory UserEntry
ent String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
     T Configuration -> String -> MaybeT IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug T Configuration
st (String -> MaybeT IO ()) -> String -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ String
"userdir path: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p
     String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p
translatePath T Configuration
_ String
_ String
_ = MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero