Network/HTTP/Lucu/StaticFile.hs

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