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