Network/HTTP/Lucu/StaticFile.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , UnicodeSyntax
   5   #-}
   6 -- | Handling static files on the filesystem.
   7 module Network.HTTP.Lucu.StaticFile
   8     ( staticFile
   9     , staticDir
  10
  11     , generateETagFromFile
  12     )
  13     where
  14 import qualified Blaze.ByteString.Builder.ByteString as BB
  15 import qualified Blaze.Text.Int as BT
  16 import Control.Monad
  17 import Control.Monad.Unicode
  18 import Control.Monad.Trans
  19 import qualified Data.Ascii as A
  20 import qualified Data.ByteString.Lazy.Char8 as B
  21 import Data.Monoid.Unicode
  22 import qualified Data.Text as T
  23 import Data.Time.Clock.POSIX
  24 import Network.HTTP.Lucu.Abortion
  25 import Network.HTTP.Lucu.Config
  26 import Network.HTTP.Lucu.ETag
  27 import Network.HTTP.Lucu.MIMEType
  28 import Network.HTTP.Lucu.MIMEType.Guess
  29 import Network.HTTP.Lucu.Resource
  30 import Network.HTTP.Lucu.Resource.Tree
  31 import Network.HTTP.Lucu.Response
  32 import Prelude.Unicode
  33 import System.FilePath
  34 import System.Posix.Files
  35
  36 -- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at
  37 -- @fpath@ on the filesystem.
  38 staticFile ∷ FilePath → ResourceDef
  39 staticFile path
  40     = emptyResource {
  41         resGet  = Just $ handleStaticFile True  path
  42       , resHead = Just $ handleStaticFile False path
  43       }
  44
  45 octetStream ∷ MIMEType
  46 octetStream = mkMIMEType "application" "octet-stream"
  47
  48 handleStaticFile ∷ Bool → FilePath → Resource ()
  49 handleStaticFile sendContent path
  50     = do exists ← liftIO $ fileExist path
  51          unless exists
  52              $ foundNoEntity Nothing
  53
  54          readable ← liftIO $ fileAccess path True False False
  55          unless readable
  56              $ abort Forbidden [] Nothing
  57
  58          stat ← liftIO $ getFileStatus path
  59          when (isDirectory stat)
  60              $ abort Forbidden [] Nothing
  61
  62          tag  ← liftIO $ generateETagFromFile path
  63          let lastMod = posixSecondsToUTCTime
  64                        $ fromRational
  65                        $ toRational
  66                        $ modificationTime stat
  67          foundEntity tag lastMod
  68
  69          conf ← getConfig
  70          case guessTypeByFileName (cnfExtToMIMEType conf) path of
  71            Nothing   → setContentType octetStream
  72            Just mime → setContentType mime
  73
  74          when sendContent
  75              $ liftIO (B.readFile path) ≫= output
  76
  77 -- |@'generateETagFromFile' fpath@ generates a strong entity tag from
  78 -- a file. The file doesn't necessarily have to be a regular file; it
  79 -- may be a FIFO or a device file. The tag is made of inode ID, size
  80 -- and modification time.
  81 --
  82 -- Note that the tag is not strictly strong because the file could be
  83 -- modified twice at a second without changing inode ID or size, but
  84 -- it's not really possible to generate a strictly strong ETag from a
  85 -- file as we don't want to simply grab the entire file and use it as
  86 -- an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
  87 -- increase strictness, but it's too inefficient if the file is really
  88 -- large (say, 1 TiB).
  89 generateETagFromFile ∷ FilePath → IO ETag
  90 generateETagFromFile path
  91     = do stat ← getFileStatus path
  92          let inode   = fileID   stat
  93              size    = fileSize stat
  94              lastMod = fromEnum $ modificationTime stat
  95              tag     = A.fromAsciiBuilder
  96                        $ A.unsafeFromBuilder
  97                        $ BT.integral inode
  98                        ⊕ BB.fromByteString "-"
  99                        ⊕ BT.integral size
 100                        ⊕ BB.fromByteString "-"
 101                        ⊕ BT.integral lastMod
 102          return $ strongETag tag
 103
 104 -- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in
 105 -- @dir@ and its subdirectories on the filesystem to the 'ResTree'.
 106 --
 107 -- Note that 'staticDir' currently doesn't have a directory-listing
 108 -- capability. Requesting the content of a directory will end up being
 109 -- replied with /403 Forbidden/.
 110 staticDir ∷ FilePath → ResourceDef
 111 staticDir path
 112     = emptyResource {
 113         resIsGreedy = True
 114       , resGet      = Just $ handleStaticDir True  path
 115       , resHead     = Just $ handleStaticDir False path
 116       }
 117
 118 handleStaticDir ∷ Bool → FilePath → Resource ()
 119 handleStaticDir sendContent basePath
 120     = do extraPath ← getPathInfo
 121          securityCheck extraPath
 122          let path = basePath </> joinPath (map T.unpack extraPath)
 123
 124          handleStaticFile sendContent path
 125     where
 126       securityCheck pathElems
 127           = when (any (≡ "..") pathElems)
 128                 $ fail ("security error: " ⧺ show pathElems)
 129 -- TODO: implement directory listing.