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