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