{- |
Copyright: 2002, Simon Marlow.
Copyright: 2006, Bjorn Bringert.
Copyright: 2009, Henning Thielemann.
-}
module Network.MoHWS.Part.File (Configuration, desc, ) where

import qualified Network.MoHWS.Module as Module
import qualified Network.MoHWS.Module.Description as ModuleDesc
import qualified Network.MoHWS.Configuration as Config
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.Server.Request as ServerRequest
import qualified Network.MoHWS.Server.Context as ServerContext
import Network.MoHWS.Logger.Error (abort, debugOnAbort, )
import Network.MoHWS.Utility (statFile, statSymLink, epochTimeToClockTime, )
import qualified System.IO as IO

import Data.Bool.HT (if', )
import Control.Monad.Trans.Maybe (MaybeT, )
import Control.Monad.Trans.Class (lift, )
import System.Posix (isRegularFile, isSymbolicLink,
          FileStatus, fileAccess, modificationTime, fileSize, )

desc :: (Stream.C body) => ModuleDesc.T body Configuration
desc :: T body Configuration
desc =
   T Any Configuration
forall body ext. T body ext
ModuleDesc.empty {
      name :: String
ModuleDesc.name = String
"file",
      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 ext. C body => T ext -> T body
funs,
      setDefltConfig :: Configuration -> Configuration
ModuleDesc.setDefltConfig = Configuration -> Configuration -> Configuration
forall a b. a -> b -> a
const Configuration
defltConfig
   }

{- |
Dummy Configuration that forces users
to use the lifting mechanism,
which in turn asserts that future extensions are respected.
-}
data Configuration =
   Configuration {
   }

defltConfig :: Configuration
defltConfig :: Configuration
defltConfig =
   Configuration :: Configuration
Configuration {
   }


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

handleRequest :: (Stream.C body) =>
   ServerContext.T ext -> ServerRequest.T body  -> MaybeT IO (Response.T body)
handleRequest :: T ext -> T body -> MaybeT IO (T body)
handleRequest T ext
st
     (ServerRequest.Cons {
        clientRequest :: forall body. T body -> T body
ServerRequest.clientRequest = T body
req,
        serverFilename :: forall body. T body -> String
ServerRequest.serverFilename = String
filename
      }) =
   let conf :: T ext
conf = T ext -> T ext
forall ext. T ext -> T ext
ServerContext.config T ext
st
       processFile :: MaybeT IO (T body)
processFile =
          do FileStatus
fstat <- String -> MaybeT IO FileStatus
statFile String
filename
             IO (T body) -> MaybeT IO (T body)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (T body) -> MaybeT IO (T body))
-> IO (T body) -> MaybeT IO (T body)
forall a b. (a -> b) -> a -> b
$
                case T body -> Command
forall body. T body -> Command
Request.command T body
req of
                   Command
Request.GET  -> T ext -> String -> FileStatus -> Bool -> IO (T body)
forall body ext.
C body =>
T ext -> String -> FileStatus -> Bool -> IO (T body)
serveFile T ext
st String
filename FileStatus
fstat Bool
False
                   Command
Request.HEAD -> T ext -> String -> FileStatus -> Bool -> IO (T body)
forall body ext.
C body =>
T ext -> String -> FileStatus -> Bool -> IO (T body)
serveFile T ext
st String
filename FileStatus
fstat Bool
True
                   Command
_ -> T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeNotImplemented T ext
conf)
       checkStat :: FileStatus -> MaybeT IO (T body)
checkStat FileStatus
stat =
          Bool
-> MaybeT IO (T body) -> MaybeT IO (T body) -> MaybeT IO (T body)
forall a. Bool -> a -> a -> a
if' (FileStatus -> Bool
isRegularFile FileStatus
stat) MaybeT IO (T body)
processFile (MaybeT IO (T body) -> MaybeT IO (T body))
-> MaybeT IO (T body) -> MaybeT IO (T body)
forall a b. (a -> b) -> a -> b
$
          Bool
-> MaybeT IO (T body) -> MaybeT IO (T body) -> MaybeT IO (T body)
forall a. Bool -> a -> a -> a
if' (FileStatus -> Bool
isSymbolicLink FileStatus
stat)
             (if T ext -> Bool
forall ext. T ext -> Bool
Config.followSymbolicLinks T ext
conf
                then MaybeT IO (T body)
processFile
                else T ext -> String -> MaybeT IO (T body)
forall h a. HasHandle h => h -> String -> MaybeT IO a
abort T ext
st (String -> MaybeT IO (T body)) -> String -> MaybeT IO (T body)
forall a b. (a -> b) -> a -> b
$ String
"findFile: Not following symlink: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
filename) (MaybeT IO (T body) -> MaybeT IO (T body))
-> MaybeT IO (T body) -> MaybeT IO (T body)
forall a b. (a -> b) -> a -> b
$
          (T ext -> String -> MaybeT IO (T body)
forall h a. HasHandle h => h -> String -> MaybeT IO a
abort T ext
st (String -> MaybeT IO (T body)) -> String -> MaybeT IO (T body)
forall a b. (a -> b) -> a -> b
$ String
"Strange file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
filename)
   in  T ext -> String -> MaybeT IO FileStatus -> MaybeT IO FileStatus
forall h a.
HasHandle h =>
h -> String -> MaybeT IO a -> MaybeT IO a
debugOnAbort T ext
st (String
"File not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
filename)
          (String -> MaybeT IO FileStatus
statSymLink String
filename) MaybeT IO FileStatus
-> (FileStatus -> MaybeT IO (T body)) -> MaybeT IO (T body)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       FileStatus -> MaybeT IO (T body)
checkStat

serveFile :: (Stream.C body) =>
   ServerContext.T ext -> FilePath -> FileStatus -> Bool -> IO (Response.T body)
serveFile :: T ext -> String -> FileStatus -> Bool -> IO (T body)
serveFile T ext
st String
filename FileStatus
stat Bool
is_head =
   do
     let conf :: T ext
conf = T ext -> T ext
forall ext. T ext -> T ext
ServerContext.config T ext
st
     -- check we can actually read this file
     Bool
access <- String -> Bool -> Bool -> Bool -> IO Bool
fileAccess String
filename Bool
True{-read-} Bool
False Bool
False
     case Bool
access of
       Bool
False -> T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T ext -> T body
forall body ext. C body => T ext -> T body
Response.makeNotFound T ext
conf)
         -- not "permission denied", we're being paranoid about security.
       Bool
True ->
         do let contentType :: String
contentType = T ext -> String -> String
forall ext. T ext -> String -> String
ServerContext.getMimeType T ext
st String
filename

            let lastModified :: ClockTime
lastModified = EpochTime -> ClockTime
epochTimeToClockTime (FileStatus -> EpochTime
modificationTime FileStatus
stat)

            let size :: Integer
size = FileOffset -> Integer
forall a. Integral a => a -> Integer
toInteger (FileStatus -> FileOffset
fileSize FileStatus
stat)

            Handle
h <- String -> IOMode -> IO Handle
IO.openFile String
filename IOMode
IO.ReadMode
            body
content <- Int -> Handle -> IO body
forall stream. C stream => Int -> Handle -> IO stream
Stream.readAll (T ext -> Int
forall ext. T ext -> Int
Config.chunkSize T ext
conf) Handle
h

            let body :: Body body
body =
                   Body :: forall body. String -> Maybe Integer -> IO () -> body -> Body body
Response.Body {
                      size :: Maybe Integer
Response.size = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
size,
                      source :: String
Response.source = String
filename,
                      close :: IO ()
Response.close = Handle -> IO ()
IO.hClose Handle
h,
                      content :: body
Response.content = body
content
                   }

            T body -> IO (T body)
forall (m :: * -> *) a. Monad m => a -> m a
return (T body -> IO (T body)) -> T body -> IO (T body)
forall a b. (a -> b) -> a -> b
$
               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 -> Bool
not Bool
is_head) {- send body -}
                  ([T] -> Group
Header.group
                     [String -> T
Header.makeContentType String
contentType,
                      ClockTime -> T
Header.makeLastModified ClockTime
lastModified])
                  Body body
body