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