StaticFile.hs

-- | Handling static files on the filesystem.
module Network.HTTP.Lucu.StaticFile
    ( staticFile
    , handleStaticFile

    , staticDir
    , handleStaticDir

    , generateETagFromFile
    )
    where

import           Control.Monad
import           Control.Monad.Trans
import qualified Data.ByteString.Lazy.Char8 as B
import           Data.Time.Clock.POSIX
import           Network.HTTP.Lucu.Abortion
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.ETag
import           Network.HTTP.Lucu.Format
import           Network.HTTP.Lucu.MIMEType.Guess
import           Network.HTTP.Lucu.Resource
import           Network.HTTP.Lucu.Resource.Tree
import           Network.HTTP.Lucu.Response
import           Network.HTTP.Lucu.Utils
import           System.Posix.Files


-- | @'staticFile' fpath@ is a
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which serves the file
-- at @fpath@ on the filesystem.
staticFile :: FilePath -> ResourceDef
staticFile path
    = ResourceDef {
        resUsesNativeThread = False
      , resIsGreedy         = False
      , resGet              = Just $! handleStaticFile path
      , resHead             = Nothing
      , resPost             = Nothing
      , resPut              = Nothing
      , resDelete           = Nothing
      }

-- | Computation of @'handleStaticFile' fpath@ serves the file at
-- @fpath@ on the filesystem. The
-- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
-- Request/ state before the computation. It will be in the /Done/
-- state after the computation.
--
-- If you just want to place a static file on the
-- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
-- 'staticFile' instead of this.
handleStaticFile :: FilePath -> Resource ()
handleStaticFile path
    = path `seq`
      do exists <- liftIO $ fileExist path
         if exists then
             -- 存在はした。讀めるかどうかは知らない。
             do stat <- liftIO $ getFileStatus path
                if isRegularFile stat then
                    do readable <- liftIO $ fileAccess path True False False
                       unless readable
                           -- 讀めない
                           $ abort Forbidden [] Nothing
                       -- 讀める
                       tag     <- liftIO $ generateETagFromFile path
                       lastMod <- return $ posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat
                       foundEntity tag lastMod

                       -- MIME Type を推定
                       conf <- getConfig
                       case guessTypeByFileName (cnfExtToMIMEType conf) path of
                         Nothing   -> return ()
                         Just mime -> setContentType mime

                       -- 實際にファイルを讀んで送る
                       (liftIO $ B.readFile path) >>= outputLBS
                  else
                    abort Forbidden [] Nothing
           else
             foundNoEntity Nothing


-- |Computation of @'generateETagFromFile' fpath@ generates a strong
-- entity tag from a file. The file doesn't necessarily have to be a
-- regular file; it may be a FIFO or a device file. The tag is made of
-- inode ID, size and modification time.
--
-- Note that the tag is not strictly strong because the file could be
-- modified twice at a second without changing inode ID or size, but
-- it's not really possible to generate a strict strong ETag from a
-- file since we don't want to simply grab the entire file and use it
-- as an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
-- increase strictness, but it's too inefficient if the file is really
-- large (say, 1 TiB).
generateETagFromFile :: FilePath -> IO ETag
generateETagFromFile path
    = path `seq`
      do stat <- getFileStatus path
         let inode   = fromEnum $! fileID   stat
             size    = fromEnum $! fileSize stat
             lastMod = fromEnum $! modificationTime stat
             tag     = fmtHex False 0 inode
                       ++ "-" ++
                       fmtHex False 0 size
                       ++ "-" ++
                       fmtHex False 0 lastMod
         return $! strongETag tag

-- | @'staticDir' dir@ is a
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files
-- in @dir@ and its subdirectories on the filesystem to the
-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
staticDir :: FilePath -> ResourceDef
staticDir path
    = ResourceDef {
        resUsesNativeThread = False
      , resIsGreedy         = True
      , resGet              = Just $! handleStaticDir path
      , resHead             = Nothing
      , resPost             = Nothing
      , resPut              = Nothing
      , resDelete           = Nothing
      }

-- | Computation of @'handleStaticDir' dir@ maps all files in @dir@
-- and its subdirectories on the filesystem to the
-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The
-- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
-- Request/ state before the computation. It will be in the /Done/
-- state after the computation.
--
-- If you just want to place a static directory tree on the
-- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
-- 'staticDir' instead of this.
handleStaticDir :: FilePath -> Resource ()
handleStaticDir basePath
    = basePath `seq`
      do extraPath <- getPathInfo
         securityCheck extraPath
         let path = basePath ++ "/" ++ joinWith "/" extraPath

         handleStaticFile path
    where
      securityCheck :: Monad m => [String] -> m ()
      securityCheck pathElems
          = pathElems `seq`
            when (any (== "..") pathElems) $ fail ("security error: "
                                                   ++ joinWith "/" pathElems)