Network/HTTP/Lucu/StaticFile.hs

   1 module Network.HTTP.Lucu.StaticFile
   2     ( staticFile       -- FilePath -> ResourceDef
   3     , handleStaticFile -- FilePath -> Resource ()
   4
   5     , staticDir       -- FilePath -> ResourceDef
   6     , handleStaticDir -- FilePath -> Resource ()
   7     )
   8     where
   9
  10 import           Control.Monad
  11 import           Control.Monad.Trans
  12 import qualified Data.ByteString.Lazy.Char8 as B
  13 import           Data.ByteString.Lazy.Char8 (ByteString)
  14 import           Network.HTTP.Lucu.Abortion
  15 import           Network.HTTP.Lucu.Config
  16 import           Network.HTTP.Lucu.ETag
  17 import           Network.HTTP.Lucu.MIMEType.Guess
  18 import           Network.HTTP.Lucu.Resource
  19 import           Network.HTTP.Lucu.Resource.Tree
  20 import           Network.HTTP.Lucu.Response
  21 import           Network.HTTP.Lucu.Utils
  22 import           System.Directory
  23 import           System.Posix.Files
  24 import           Text.Printf
  25
  26
  27 staticFile :: FilePath -> ResourceDef
  28 staticFile path
  29     = ResourceDef {
  30         resUsesNativeThread = False
  31       , resIsGreedy         = False
  32       , resGet              = Just $ handleStaticFile path
  33       , resHead             = Nothing
  34       , resPost             = Nothing
  35       , resPut              = Nothing
  36       , resDelete           = Nothing
  37       }
  38
  39
  40 handleStaticFile :: FilePath -> Resource ()
  41 handleStaticFile path
  42     = do isFile <- liftIO $ doesFileExist path
  43          if isFile then
  44              -- 存在はした。讀めるかどうかは知らない。
  45              do readable <- liftIO $ fileAccess path True False False
  46                 unless readable
  47                            -- 讀めない
  48                            $ abort Forbidden [] Nothing
  49
  50                 -- 讀める
  51                 tag      <- liftIO $ generateETagFromFile path
  52                 lastMod  <- liftIO $ getModificationTime path
  53                 foundEntity tag lastMod
  54
  55                 -- MIME Type を推定
  56                 conf <- getConfig
  57                 case guessTypeByFileName (cnfExtToMIMEType conf) path of
  58                   Nothing   -> return ()
  59                   Just mime -> setContentType mime
  60
  61                 -- 實際にファイルを讀んで送る
  62                 (liftIO $ B.readFile path) >>= outputBS
  63            else
  64              do isDir <- liftIO $ doesDirectoryExist path
  65                 if isDir then
  66                     abort Forbidden [] Nothing
  67                   else
  68                     foundNoEntity Nothing
  69
  70
  71 -- inode-size-lastmod
  72 generateETagFromFile :: FilePath -> IO ETag
  73 generateETagFromFile path
  74     = do stat <- getFileStatus path
  75          let inode   = fromEnum $ fileID   stat
  76              size    = fromEnum $ fileSize stat
  77              lastmod = fromEnum $ modificationTime stat
  78          return $ strongETag $ printf "%x-%x-%x" inode size lastmod
  79
  80
  81 staticDir :: FilePath -> ResourceDef
  82 staticDir path
  83     = ResourceDef {
  84         resUsesNativeThread = False
  85       , resIsGreedy         = True
  86       , resGet              = Just $ handleStaticDir path
  87       , resHead             = Nothing
  88       , resPost             = Nothing
  89       , resPut              = Nothing
  90       , resDelete           = Nothing
  91       }
  92
  93
  94 handleStaticDir :: FilePath -> Resource ()
  95 handleStaticDir basePath
  96     = do extraPath <- getPathInfo
  97          securityCheck extraPath
  98          let path = basePath ++ "/" ++ joinWith "/" extraPath
  99
 100          handleStaticFile path
 101     where
 102       securityCheck :: Monad m => [String] -> m ()
 103       securityCheck pathElems
 104           = when (any (== "..") pathElems) $ fail ("security error: "
 105                                                    ++ joinWith "/" pathElems)