File.hs

-- | Stolen from rack: serves files below the +root+ given, according to the 
--   path info of the Rack request.

module Hack.Contrib.Middleware.File (file) where

import Data.Default
import Data.List (isInfixOf)
import Data.Maybe
import Hack
import Hack.Contrib.Constants
import Hack.Contrib.Mime
import Hack.Contrib.Response
import Hack.Contrib.Utils
import MPS
import Prelude hiding ((.), (^), (>), (+), (/), readFile)
import System.Directory
import System.FilePath
import qualified Data.ByteString.Lazy.Char8 as B


file :: Maybe String -> Middleware
file root _ = \env -> do
  let path = env.path_info .unescape_uri
  
  if ".." `isInfixOf` path
    then forbidden
    else path.serve root


serve :: Maybe String -> String -> IO Response
serve root fname = do
  cwd <- getCurrentDirectory
  let my_root = root.fromMaybe cwd
  let path = my_root / makeRelative "/" fname
  
  exist <- doesFileExist path

  if not exist
      then path.not_found
      else
        do 
          can_read <- path.getPermissions ^ readable
          if not can_read
            then path.no_permission
            else path.serving
    
    where 
      serving path = do
        content <- path.B.readFile
        size <- path.b2u.file_size ^ from_i
        mtime_str <- path.b2u.file_mtime ^ httpdate
        
        let default_content_type = "application/octet-stream"
        let safe_lookup = lookup_mime_type > fromMaybe default_content_type
        let content_type = path.takeExtension.safe_lookup
        
        return $ 
          def 
            .set_body content
            .set_content_length size
            .set_content_type content_type
            .set_last_modified mtime_str
            .set_status 200

no_permission :: String -> IO Response
no_permission path = return $
  def
    .set_status 404
    .set_content_type _TextPlain
    .set_content_length (msg.length)
    .set_body (B.pack msg)

  where msg = "No permission: " ++ path ++ "\n"

not_found :: String -> IO Response
not_found path = return $
  def
    .set_status 404
    .set_content_type _TextPlain
    .set_content_length (msg.length)
    .set_body (B.pack msg)
  
  where msg = "File not found: " ++ path ++ "\n"

forbidden :: IO Response
forbidden = return $ 
  def
    .set_status 403
    .set_content_type _TextPlain
    .set_content_length (msg.length)
    .set_body (B.pack msg)

  where msg = "Forbidden\n"