File.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Application.Classic.File (
    fileApp,
    redirectHeader,
) where

import Control.Applicative
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS (concat)
import Data.Maybe
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Application.Classic.Field
import Network.Wai.Application.Classic.FileInfo
import Network.Wai.Application.Classic.Path
import Network.Wai.Application.Classic.Status
import Network.Wai.Application.Classic.Types
import Network.Wai.Handler.Warp (getFileInfo)
import Network.Wai.Internal

----------------------------------------------------------------

data RspSpec
    = NoBody Status
    | NoBodyHdr Status ResponseHeaders
    | BodyFile Status ResponseHeaders FilePath
    deriving (Eq, Show)

----------------------------------------------------------------

data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang]

langSuffixes :: RequestHeaders -> [Lang]
langSuffixes hdr = map (\x -> (<.> x)) langs ++ [id, (<.> "en")]
  where
    langs = languages hdr

----------------------------------------------------------------

-- |
--   Handle GET and HEAD for a static file.
--
-- If 'pathInfo' ends with \'/\', 'indexFile' is automatically
-- added. In this case, "Acceptable-Language:" is also handled.  Suppose
-- 'indexFile' is "index.html" and if the value is "ja,en", then
-- \"index.html.ja\", \"index.html.en\", and \"index.html\" are tried to be
-- opened in order.
--
-- If 'pathInfo' does not end with \'/\' and a corresponding index file
-- exist, redirection is specified in HTTP response.
--
-- Directory contents are NOT automatically listed. To list directory
-- contents, an index file must be created beforehand.
--
-- The following HTTP headers are handled: Acceptable-Language:,
-- If-Modified-Since:, Range:, If-Range:, If-Unmodified-Since:.
fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application
fileApp cspec spec filei req respond = do
    rspspec <- case method of
        _ | hasDotDotSegment (rawPathInfo req) -> return badRequest
        Right GET -> processGET hinfo ishtml rfile
        Right HEAD -> processGET hinfo ishtml rfile
        _ -> return notAllowed
    response <- case rspspec of
        NoBody st -> bodyStatus st
        NoBodyHdr st hdr -> return $ responseLBS st hdr ""
        BodyFile st hdr fl -> return $ ResponseFile st hdr fl Nothing
    respond response
  where
    hinfo = HandlerInfo spec req file langs
    method = parseMethod $ requestMethod req
    path = pathinfoToFilePath req filei
    file = addIndex spec path
    ishtml = isHTML spec file
    rfile = redirectPath spec path
    langs = langSuffixes $ requestHeaders req
    noBody st = return $ responseLBS st [] ""
    bodyStatus st =
        getStatusInfo cspec req langs st
            >>= statusBody st
    statusBody st StatusNone = noBody st
    statusBody st (StatusByteString bd) =
        return $ responseLBS st hdr bd
      where
        hdr = textPlainHeader
    statusBody st (StatusFile afile len) =
        return $ ResponseFile st hdr fl mfp
      where
        mfp = Just (FilePart 0 len len)
        fl = pathString afile
        hdr = textHtmlHeader

----------------------------------------------------------------

processGET :: HandlerInfo -> Bool -> Maybe Path -> IO RspSpec
processGET hinfo ishtml rfile =
    tryGet hinfo ishtml
        <|> tryRedirect hinfo rfile
        <|> return notFound

tryGet :: HandlerInfo -> Bool -> IO RspSpec
tryGet hinfo@(HandlerInfo _ _ _ langs) True =
    runAnyOne $ map (tryGetFile hinfo True) langs
tryGet hinfo False = tryGetFile hinfo False id

tryGetFile :: HandlerInfo -> Bool -> Lang -> IO RspSpec
tryGetFile (HandlerInfo _ req file _) ishtml lang = do
    let file' = pathString $ lang file
        hdr = newHeader ishtml file
    _ <- getFileInfo req file' -- expecting an error
    return $ BodyFile ok200 hdr file'

----------------------------------------------------------------

tryRedirect :: HandlerInfo -> Maybe Path -> IO RspSpec
tryRedirect _ Nothing = empty
tryRedirect (HandlerInfo spec req _ langs) (Just file) =
    runAnyOne $ map (tryRedirectFile hinfo) langs
  where
    hinfo = HandlerInfo spec req file langs

tryRedirectFile :: HandlerInfo -> Lang -> IO RspSpec
tryRedirectFile (HandlerInfo _ req file _) lang = do
    let file' = pathString $ lang file
    _ <- getFileInfo req file' -- expecting an error
    return $ NoBodyHdr movedPermanently301 hdr
  where
    hdr = redirectHeader req

redirectHeader :: Request -> ResponseHeaders
redirectHeader = locationHeader . redirectURL

redirectURL :: Request -> ByteString
redirectURL req =
    BS.concat
        [ -- Scheme must not be included because of no way to tell
          -- http or https.
          "//"
        , -- Host includes ":<port>" if it is not 80.
          host
        , rawPathInfo req
        , "/"
        , rawQueryString req
        ]
  where
    host = fromMaybe "" $ requestHeaderHost req

----------------------------------------------------------------

badRequest :: RspSpec
badRequest = NoBody badRequest400

notFound :: RspSpec
notFound = NoBody notFound404

notAllowed :: RspSpec
notAllowed = NoBody methodNotAllowed405

----------------------------------------------------------------

runAnyOne :: [IO a] -> IO a
runAnyOne = foldr (<|>) empty