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