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.Time.Clock.POSIX
  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.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 exists <- liftIO $ fileExist path
  57          if exists then
  58              -- 存在はした。讀めるかどうかは知らない。
  59              do stat <- liftIO $ getFileStatus path
  60                 if isRegularFile stat then
  61                     do readable <- liftIO $ fileAccess path True False False
  62                        unless readable
  63                            -- 讀めない
  64                            $ abort Forbidden [] Nothing
  65                        -- 讀める
  66                        tag     <- liftIO $ generateETagFromFile path
  67                        lastMod <- return $ posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat
  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) >>= outputLBS
  78                   else
  79                     abort Forbidden [] Nothing
  80            else
  81              foundNoEntity Nothing
  82
  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)