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.FilePath.Posix
  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 exists <- liftIO $ fileExist path
  58          if exists then
  59              -- 存在はした。讀めるかどうかは知らない。
  60              do stat <- liftIO $ getFileStatus path
  61                 if isRegularFile stat then
  62                     do readable <- liftIO $ fileAccess path True False False
  63                        unless readable
  64                            -- 讀めない
  65                            $ abort Forbidden [] Nothing
  66                        -- 讀める
  67                        tag     <- liftIO $ generateETagFromFile path
  68                        let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat
  69                        foundEntity tag lastMod
  70
  71                        -- MIME Type を推定
  72                        conf <- getConfig
  73                        case guessTypeByFileName (cnfExtToMIMEType conf) path of
  74                          Nothing   -> return ()
  75                          Just mime -> setContentType mime
  76
  77                        -- 實際にファイルを讀んで送る
  78                        liftIO (B.readFile path) >>= outputLBS
  79                   else
  80                     abort Forbidden [] Nothing
  81            else
  82              foundNoEntity Nothing
  83
  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     = do extraPath <- getPathInfo
 140          securityCheck extraPath
 141          let path = basePath </> joinPath extraPath
 142
 143          handleStaticFile path
 144     where
 145       securityCheck :: Monad m => [String] -> m ()
 146       securityCheck !pathElems
 147           = when (any (== "..") pathElems) $ fail ("security error: "
 148                                                    ++ joinWith "/" pathElems)
 149 -- TODO: implement directory listing.