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