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 'ResourceDef' which serves the file at
  35 -- @fpath@ on the filesystem.
  36 staticFile ∷ FilePath → ResourceDef
  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 → Resource ()
  47 handleStaticFile sendContent path
  48     = do exists ← liftIO $ doesFileExist path
  49          unless exists
  50              foundNoEntity'
  51
  52          perms ← liftIO $ getPermissions path
  53          unless (readable perms)
  54              $ abort
  55              $ mkAbortion Forbidden [] Nothing
  56
  57          lastMod ← liftIO $ getLastModified path
  58          foundTimeStamp lastMod
  59
  60          conf ← getConfig
  61          case guessTypeByFileName (cnfExtToMIMEType conf) path of
  62            Nothing   → setContentType octetStream
  63            Just mime → setContentType mime
  64
  65          when sendContent
  66              $ liftIO (LBS.readFile path) ≫= putChunks
  67
  68 -- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in
  69 -- @dir@ and its subdirectories on the filesystem to the
  70 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
  71 --
  72 -- Note that 'staticDir' currently doesn't have a directory-listing
  73 -- capability. Requesting the content of a directory will end up being
  74 -- replied with /403 Forbidden/.
  75 staticDir ∷ FilePath → ResourceDef
  76 staticDir path
  77     = emptyResource {
  78         resIsGreedy = True
  79       , resGet      = Just $ handleStaticDir True  path
  80       , resHead     = Just $ handleStaticDir False path
  81       }
  82
  83 -- TODO: implement directory listing.
  84 handleStaticDir ∷ Bool → FilePath → Resource ()
  85 handleStaticDir sendContent basePath
  86     = do extraPath ← getPathInfo
  87          securityCheck extraPath
  88          let path = basePath </> joinPath (map dec8 extraPath)
  89          handleStaticFile sendContent path
  90     where
  91       dec8 ∷ ByteString → String
  92       dec8 = T.unpack ∘ T.decodeUtf8
  93
  94 securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
  95 securityCheck pathElems
  96     = when (any (≡ "..") pathElems)
  97           $ fail ("security error: " ⧺ show pathElems)