module Network.Wai.Application.Classic.File (
fileApp
, redirectHeader
) where
import Control.Applicative
import Control.Exception.IOChoice.Lifted
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import Data.Maybe
import qualified Data.ByteString.Char8 as BS (concat)
import qualified Data.ByteString.Lazy.Char8 as BL (length)
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.Header
import Network.Wai.Application.Classic.Path
import Network.Wai.Application.Classic.Status
import Network.Wai.Application.Classic.Types
type Rsp = IO RspSpec
data HandlerInfo = HandlerInfo FileAppSpec Request IndexedHeader Path [Lang]
langSuffixes :: IndexedHeader -> [Lang]
langSuffixes reqidx = map (\x -> (<.> x)) langs ++ [id, (<.> "en")]
where
langs = map fromByteString $ languages reqidx
fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application
fileApp cspec spec filei req respond = do
RspSpec st body <- case method of
Right GET -> processGET hinfo ishtml rfile
Right HEAD -> processHEAD hinfo ishtml rfile
_ -> return notAllowed
(response, mlen) <- case body of
NoBody -> noBody st
BodyStatus -> bodyStatus st
BodyFileNoBody hdr -> bodyFileNoBody st hdr
BodyFile hdr afile rng -> bodyFile st hdr afile rng
logger cspec req st mlen
respond response
where
reqidx = indexRequestHeader (requestHeaders req)
hinfo = HandlerInfo spec req reqidx file langs
method = parseMethod $ requestMethod req
path = pathinfoToFilePath req filei
file = addIndex spec path
ishtml = isHTML spec file
rfile = redirectPath spec path
langs = langSuffixes reqidx
noBody st = return (responseLBS st [] "", Nothing)
bodyStatus st = liftIO (getStatusInfo cspec spec langs st)
>>= statusBody st
statusBody st StatusNone = noBody st
statusBody st (StatusByteString bd) =
return (responseLBS st hdr bd, Just (len bd))
where
len = fromIntegral . BL.length
hdr = textPlainHeader
statusBody st (StatusFile afile len) =
return (ResponseFile st hdr fl mfp, Just len)
where
mfp = Just (FilePart 0 len len)
fl = pathString afile
hdr = textHtmlHeader
bodyFileNoBody st hdr =
return (responseLBS st hdr "", Nothing)
bodyFile st hdr afile rng =
return (ResponseFile st hdr fl mfp, Just len)
where
(len, mfp) = case rng of
Entire bytes -> (bytes, Just (FilePart 0 bytes bytes))
Part skip bytes total -> (bytes, Just (FilePart skip bytes total))
fl = pathString afile
processGET :: HandlerInfo -> Bool -> Maybe Path -> Rsp
processGET hinfo ishtml rfile = tryGet hinfo ishtml
||> tryRedirect hinfo rfile
||> return notFound
tryGet :: HandlerInfo -> Bool -> Rsp
tryGet hinfo@(HandlerInfo _ _ _ _ langs) True =
runAnyOne $ map (tryGetFile hinfo True) langs
tryGet hinfo False = tryGetFile hinfo False id
tryGetFile :: HandlerInfo -> Bool -> Lang -> Rsp
tryGetFile (HandlerInfo spec req reqidx file _) ishtml lang = do
finfo <- liftIO $ getFileInfo spec (lang file)
let mtime = fileInfoTime finfo
size = fileInfoSize finfo
sfile = fileInfoName finfo
date = fileInfoDate finfo
mrange = requestHeaderRange req
hdr = newHeader ishtml (pathByteString file) date
Just pst = ifmodified reqidx size mtime mrange
<|> ifunmodified reqidx size mtime mrange
<|> ifrange reqidx size mtime mrange
<|> unconditional reqidx size mtime mrange
case pst of
Full st
| st == ok200 -> return $ RspSpec ok200 (BodyFile hdr sfile (Entire size))
| otherwise -> return $ RspSpec st (BodyFileNoBody hdr)
Partial skip len -> return $ RspSpec partialContent206 (BodyFile hdr sfile (Part skip len size))
processHEAD :: HandlerInfo -> Bool -> Maybe Path -> Rsp
processHEAD hinfo ishtml rfile = tryHead hinfo ishtml
||> tryRedirect hinfo rfile
||> return notFoundNoBody
tryHead :: HandlerInfo -> Bool -> Rsp
tryHead hinfo@(HandlerInfo _ _ _ _ langs) True =
runAnyOne $ map (tryHeadFile hinfo True) langs
tryHead hinfo False= tryHeadFile hinfo False id
tryHeadFile :: HandlerInfo -> Bool -> Lang -> Rsp
tryHeadFile (HandlerInfo spec req reqidx file _) ishtml lang = do
finfo <- liftIO $ getFileInfo spec (lang file)
let mtime = fileInfoTime finfo
size = fileInfoSize finfo
date = fileInfoDate finfo
hdr = newHeader ishtml (pathByteString file) date
mrange = requestHeaderRange req
Just pst = ifmodified reqidx size mtime mrange
<|> Just (Full ok200)
case pst of
Full st -> return $ RspSpec st (BodyFileNoBody hdr)
_ -> goNext
tryRedirect :: HandlerInfo -> Maybe Path -> Rsp
tryRedirect _ Nothing = goNext
tryRedirect (HandlerInfo spec req reqidx _ langs) (Just file) =
runAnyOne $ map (tryRedirectFile hinfo) langs
where
hinfo = HandlerInfo spec req reqidx file langs
tryRedirectFile :: HandlerInfo -> Lang -> Rsp
tryRedirectFile (HandlerInfo spec req _ file _) lang = do
_ <- liftIO $ getFileInfo spec (lang file)
return $ RspSpec movedPermanently301 (BodyFileNoBody hdr)
where
hdr = redirectHeader req
redirectHeader :: Request -> ResponseHeaders
redirectHeader = locationHeader . redirectURL
redirectURL :: Request -> ByteString
redirectURL req = BS.concat [
"http://"
, host
, rawPathInfo req
, "/"
]
where
host = fromMaybe "" $ requestHeaderHost req
notFound :: RspSpec
notFound = RspSpec notFound404 BodyStatus
notFoundNoBody :: RspSpec
notFoundNoBody = RspSpec notFound404 NoBody
notAllowed :: RspSpec
notAllowed = RspSpec methodNotAllowed405 BodyStatus