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          tag  ← liftIO $ generateETagFromFile path
  70          let lastMod = posixSecondsToUTCTime
  71                        $ fromRational
  72                        $ toRational
  73                        $ modificationTime stat
  74          foundEntity tag lastMod
  75
  76          conf ← getConfig
  77          case guessTypeByFileName (cnfExtToMIMEType conf) path of
  78            Nothing   → setContentType octetStream
  79            Just mime → setContentType mime
  80
  81          when sendContent
  82              $ liftIO (LBS.readFile path) ≫= putChunks
  83
  84 -- |@'generateETagFromFile' fpath@ generates a strong entity tag from
  85 -- a file. The file doesn't necessarily have to be a regular file; it
  86 -- may be a FIFO or a device file. The tag is made of inode ID, size
  87 -- and modification time.
  88 --
  89 -- Note that the tag is not strictly strong because the file could be
  90 -- modified twice at a second without changing inode ID or size, but
  91 -- it's not really possible to generate a strictly strong ETag from a
  92 -- file as we don't want to simply grab the entire file and use it as
  93 -- an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
  94 -- increase strictness, but it's too inefficient if the file is really
  95 -- large (say, 1 TiB).
  96 generateETagFromFile ∷ FilePath → IO ETag
  97 generateETagFromFile path
  98     = do stat ← getFileStatus path
  99          let inode   = fileID   stat
 100              size    = fileSize stat
 101              lastMod = fromEnum $ modificationTime stat
 102              tag     = A.fromAsciiBuilder
 103                        $ A.unsafeFromBuilder
 104                        $ BT.integral inode
 105                        ⊕ BB.fromByteString "-"
 106                        ⊕ BT.integral size
 107                        ⊕ BB.fromByteString "-"
 108                        ⊕ BT.integral lastMod
 109          return $ strongETag tag
 110
 111 -- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in
 112 -- @dir@ and its subdirectories on the filesystem to the
 113 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
 114 --
 115 -- Note that 'staticDir' currently doesn't have a directory-listing
 116 -- capability. Requesting the content of a directory will end up being
 117 -- replied with /403 Forbidden/.
 118 staticDir ∷ FilePath → ResourceDef
 119 staticDir path
 120     = emptyResource {
 121         resIsGreedy = True
 122       , resGet      = Just $ handleStaticDir True  path
 123       , resHead     = Just $ handleStaticDir False path
 124       }
 125
 126 -- TODO: implement directory listing.
 127 handleStaticDir ∷ Bool → FilePath → Resource ()
 128 handleStaticDir sendContent basePath
 129     = do extraPath ← getPathInfo
 130          securityCheck extraPath
 131          let path = basePath </> joinPath (map dec8 extraPath)
 132          handleStaticFile sendContent path
 133     where
 134       dec8 ∷ ByteString → String
 135       dec8 = T.unpack ∘ T.decodeUtf8
 136
 137 securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
 138 securityCheck pathElems
 139     = when (any (≡ "..") pathElems)
 140           $ fail ("security error: " ⧺ show pathElems)