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     where
  13 import Control.Monad
  14 import Control.Monad.Unicode
  15 import Control.Monad.Trans
  16 import Data.ByteString (ByteString)
  17 import qualified Data.ByteString.Lazy.Char8 as LBS
  18 import Data.Convertible.Base
  19 import Data.Convertible.Instances.Text ()
  20 import Data.Monoid.Unicode
  21 import Data.String
  22 import qualified Data.Text as T
  23 import qualified Data.Text.Encoding as T
  24 import Network.HTTP.Lucu.Abortion
  25 import Network.HTTP.Lucu.Config
  26 import Network.HTTP.Lucu.MIMEType hiding (mimeType)
  27 import Network.HTTP.Lucu.MIMEType.Guess
  28 import Network.HTTP.Lucu.MIMEType.TH
  29 import Network.HTTP.Lucu.Resource
  30 import Network.HTTP.Lucu.Resource.Internal
  31 import Network.HTTP.Lucu.Response
  32 import Network.HTTP.Lucu.Utils
  33 import Prelude.Unicode
  34 import System.Directory
  35 import System.FilePath
  36
  37 -- | @'staticFile' fpath@ is a 'Resource' which serves the file at
  38 -- @fpath@ on the filesystem.
  39 staticFile ∷ FilePath → Resource
  40 staticFile path
  41     = (∅) {
  42         resGet  = Just $ handleStaticFile True  path
  43       , resHead = Just $ handleStaticFile False path
  44       }
  45
  46 octetStream ∷ MIMEType
  47 octetStream = [mimeType| application/octet-stream |]
  48
  49 handleStaticFile ∷ Bool → FilePath → Rsrc ()
  50 handleStaticFile sendContent path
  51     = do isDir ← liftIO $ doesDirectoryExist path
  52          when isDir
  53              $ abort
  54              $ mkAbortion Forbidden [] Nothing
  55
  56          isFile ← liftIO $ doesFileExist path
  57          unless isFile
  58              foundNoEntity'
  59
  60          perms ← liftIO $ getPermissions path
  61          unless (readable perms)
  62              $ abort
  63              $ mkAbortion Forbidden [] Nothing
  64
  65          lastMod ← liftIO $ getLastModified path
  66          foundTimeStamp lastMod
  67
  68          conf ← getConfig
  69          case guessTypeByFileName (cnfExtToMIMEType conf) path of
  70            Nothing   → setContentType octetStream
  71            Just mime → setContentType mime
  72
  73          when sendContent
  74              $ liftIO (LBS.readFile path) ≫= putChunks
  75
  76 -- | @'staticDir' dir@ is a 'Resource' which maps all files in @dir@
  77 -- and its subdirectories on the filesystem to the resource tree. Thus
  78 -- having 'Network.HTTP.Lucu.nonGreedy' 'staticDir' in a tree makes no
  79 -- sense.
  80 --
  81 -- Note that 'staticDir' currently doesn't have a directory-listing
  82 -- capability. Requesting the content of a directory will end up being
  83 -- replied with /403 Forbidden/.
  84 staticDir ∷ FilePath → Resource
  85 staticDir path
  86     = (∅) {
  87         resGet  = Just $ handleStaticDir True  path
  88       , resHead = Just $ handleStaticDir False path
  89       }
  90
  91 -- TODO: implement directory listing.
  92 handleStaticDir ∷ Bool → FilePath → Rsrc ()
  93 handleStaticDir sendContent basePath
  94     = do extraPath ← getPathInfo
  95          securityCheck extraPath
  96          let path = basePath </> joinPath (map dec8 extraPath)
  97          handleStaticFile sendContent path
  98     where
  99       dec8 ∷ ByteString → String
 100       dec8 = cs ∘ T.decodeUtf8
 101
 102 securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
 103 securityCheck pathElems
 104     = when (any (≡ "..") pathElems)
 105           $ fail ("security error: " ⧺ show pathElems)