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