Network/HTTP/Lucu/StaticFile.hs

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