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
  26 import Network.HTTP.Lucu.MIMEType.Guess
  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. Thus
  76 -- having 'Network.HTTP.Lucu.nonGreedy' 'staticDir' in a tree makes no
  77 -- sense.
  78 --
  79 -- Note that 'staticDir' currently doesn't have a directory-listing
  80 -- capability. Requesting the content of a directory will end up being
  81 -- replied with /403 Forbidden/.
  82 staticDir ∷ FilePath → Resource
  83 staticDir path
  84     = (∅) {
  85         resGet  = Just $ handleStaticDir True  path
  86       , resHead = Just $ handleStaticDir False path
  87       }
  88
  89 -- TODO: implement directory listing.
  90 handleStaticDir ∷ Bool → FilePath → Rsrc ()
  91 handleStaticDir sendContent basePath
  92     = do extraPath ← getPathInfo
  93          securityCheck extraPath
  94          let path = basePath </> joinPath (map dec8 extraPath)
  95          handleStaticFile sendContent path
  96     where
  97       dec8 ∷ ByteString → String
  98       dec8 = cs ∘ T.decodeUtf8
  99
 100 securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
 101 securityCheck pathElems
 102     = when (any (≡ "..") pathElems)
 103           $ fail ("security error: " ⧺ show pathElems)