Network/HTTP/Lucu/StaticFile.hs

   1 -- | Handling static files on the filesystem.
   2 module Network.HTTP.Lucu.StaticFile
   3     ( staticFile
   4     , handleStaticFile
   5
   6     , staticDir
   7     , handleStaticDir
   8
   9     , generateETagFromFile
  10     )
  11     where
  12
  13 import           Control.Monad
  14 import           Control.Monad.Trans
  15 import qualified Data.ByteString.Lazy.Char8 as B
  16 import           Data.ByteString.Lazy.Char8 (ByteString)
  17 import           Network.HTTP.Lucu.Abortion
  18 import           Network.HTTP.Lucu.Config
  19 import           Network.HTTP.Lucu.ETag
  20 import           Network.HTTP.Lucu.Format
  21 import           Network.HTTP.Lucu.MIMEType.Guess
  22 import           Network.HTTP.Lucu.Resource
  23 import           Network.HTTP.Lucu.Resource.Tree
  24 import           Network.HTTP.Lucu.Response
  25 import           Network.HTTP.Lucu.Utils
  26 import           System.Directory
  27 import           System.Posix.Files
  28
  29
  30 -- | @'staticFile' fpath@ is a
  31 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which serves the file
  32 -- at @fpath@ on the filesystem.
  33 staticFile :: FilePath -> ResourceDef
  34 staticFile path
  35     = ResourceDef {
  36         resUsesNativeThread = False
  37       , resIsGreedy         = False
  38       , resGet              = Just $! handleStaticFile path
  39       , resHead             = Nothing
  40       , resPost             = Nothing
  41       , resPut              = Nothing
  42       , resDelete           = Nothing
  43       }
  44
  45 -- | Computation of @'handleStaticFile' fpath@ serves the file at
  46 -- @fpath@ on the filesystem. The
  47 -- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
  48 -- Request/ state before the computation. It will be in the /Done/
  49 -- state after the computation.
  50 --
  51 -- If you just want to place a static file on the
  52 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
  53 -- 'staticFile' instead of this.
  54 handleStaticFile :: FilePath -> Resource ()
  55 handleStaticFile path
  56     = path `seq`
  57       do isFile <- liftIO $ doesFileExist path
  58          if isFile then
  59              -- 存在はした。讀めるかどうかは知らない。
  60              do readable <- liftIO $ fileAccess path True False False
  61                 unless readable
  62                            -- 讀めない
  63                            $ abort Forbidden [] Nothing
  64
  65                 -- 讀める
  66                 tag      <- liftIO $ generateETagFromFile path
  67                 lastMod  <- liftIO $ getModificationTime path
  68                 foundEntity tag lastMod
  69
  70                 -- MIME Type を推定
  71                 conf <- getConfig
  72                 case guessTypeByFileName (cnfExtToMIMEType conf) path of
  73                   Nothing   -> return ()
  74                   Just mime -> setContentType mime
  75
  76                 -- 實際にファイルを讀んで送る
  77                 (liftIO $ B.readFile path) >>= outputBS
  78            else
  79              do isDir <- liftIO $ doesDirectoryExist path
  80                 if isDir then
  81                     abort Forbidden [] Nothing
  82                   else
  83                     foundNoEntity Nothing
  84
  85 -- |Computation of @'generateETagFromFile' fpath@ generates a strong
  86 -- entity tag from a file. The file doesn't necessarily have to be a
  87 -- regular file; it may be a FIFO or a device file. The tag is made of
  88 -- inode ID, size and modification time.
  89 --
  90 -- Note that the tag is not strictly strong because the file could be
  91 -- modified twice at a second without changing inode ID or size, but
  92 -- it's not really possible to generate a strict strong ETag from a
  93 -- file since we don't want to simply grab the entire file and use it
  94 -- as an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
  95 -- increase strictness, but it's too inefficient if the file is really
  96 -- large (say, 1 TiB).
  97 generateETagFromFile :: FilePath -> IO ETag
  98 generateETagFromFile path
  99     = path `seq`
 100       do stat <- getFileStatus path
 101          let inode   = fromEnum $! fileID   stat
 102              size    = fromEnum $! fileSize stat
 103              lastMod = fromEnum $! modificationTime stat
 104              tag     = fmtHex False 0 inode
 105                        ++ "-" ++
 106                        fmtHex False 0 size
 107                        ++ "-" ++
 108                        fmtHex False 0 lastMod
 109          return $! strongETag tag
 110
 111 -- | @'staticDir' dir@ is a
 112 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files
 113 -- in @dir@ and its subdirectories on the filesystem to the
 114 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
 115 staticDir :: FilePath -> ResourceDef
 116 staticDir path
 117     = ResourceDef {
 118         resUsesNativeThread = False
 119       , resIsGreedy         = True
 120       , resGet              = Just $! handleStaticDir path
 121       , resHead             = Nothing
 122       , resPost             = Nothing
 123       , resPut              = Nothing
 124       , resDelete           = Nothing
 125       }
 126
 127 -- | Computation of @'handleStaticDir' dir@ maps all files in @dir@
 128 -- and its subdirectories on the filesystem to the
 129 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The
 130 -- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
 131 -- Request/ state before the computation. It will be in the /Done/
 132 -- state after the computation.
 133 --
 134 -- If you just want to place a static directory tree on the
 135 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
 136 -- 'staticDir' instead of this.
 137 handleStaticDir :: FilePath -> Resource ()
 138 handleStaticDir basePath
 139     = basePath `seq`
 140       do extraPath <- getPathInfo
 141          securityCheck extraPath
 142          let path = basePath ++ "/" ++ joinWith "/" extraPath
 143
 144          handleStaticFile path
 145     where
 146       securityCheck :: Monad m => [String] -> m ()
 147       securityCheck pathElems
 148           = pathElems `seq`
 149             when (any (== "..") pathElems) $ fail ("security error: "
 150                                                    ++ joinWith "/" pathElems)