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