{-# LANGUAGE OverloadedStrings, CPP #-}
module Network.Wai.Application.Classic.File (
fileApp
, redirectHeader
) where
import Control.Applicative
import Data.ByteString (ByteString)
import Data.Maybe
import qualified Data.ByteString.Char8 as BS (concat)
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Internal
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)
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
fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application
fileApp cspec spec filei req respond = do
rspspec <- case method of
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'
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'
return $ NoBodyHdr movedPermanently301 hdr
where
hdr = redirectHeader req
redirectHeader :: Request -> ResponseHeaders
redirectHeader = locationHeader . redirectURL
redirectURL :: Request -> ByteString
redirectURL req = BS.concat [
"//"
, host
, rawPathInfo req
, "/"
]
where
host = fromMaybe "" $ requestHeaderHost req
notFound :: RspSpec
notFound = NoBody notFound404
notAllowed :: RspSpec
notAllowed = NoBody methodNotAllowed405
runAnyOne :: [IO a] -> IO a
runAnyOne = foldr (<|>) empty