Network/HTTP/Lucu/StaticFile.hs

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