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 qualified Data.ByteString.Char8 as BS (pack, concat)
import qualified Data.ByteString.Lazy.Char8 as BL (length)
import Data.Conduit
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 Prelude hiding (catch)
type Rsp = ResourceT IO RspSpec
data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang]
langSuffixes :: Request -> [Lang]
langSuffixes req = map (\x -> (<.> x)) langs ++ [id, (<.> "en")]
where
langs = map fromByteString $ languages req
fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application
fileApp cspec spec filei req = 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
liftIO $ logger cspec req st mlen
return 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 req
zdater = dater cspec
noBody st = do
hdr <- liftIO . addDate zdater $ addServer cspec []
return (responseLBS st hdr "", Nothing)
bodyStatus st = liftIO (getStatusInfo cspec spec langs st)
>>= statusBody st
statusBody st StatusNone = noBody st
statusBody st (StatusByteString bd) = do
hdr <- liftIO . addDate zdater $ addServer cspec textPlainHeader
return (responseLBS st hdr bd, Just (len bd))
where
len = fromIntegral . BL.length
statusBody st (StatusFile afile len) = do
hdr <- liftIO . addDate zdater $ addServer cspec textHtmlHeader
return (ResponseFile st hdr fl mfp, Just len)
where
mfp = Just (FilePart 0 len)
fl = pathString afile
bodyFileNoBody st hdr = do
hdr' <- liftIO . addDate zdater $ addServer cspec hdr
return (responseLBS st hdr' "", Nothing)
bodyFile st hdr afile rng = do
hdr' <- liftIO . addDate zdater $ addLength len $ addServer cspec hdr
return (ResponseFile st hdr' fl mfp, Just len)
where
(len, mfp) = case rng of
Entire bytes -> (bytes, Just (FilePart 0 bytes))
Part skip bytes -> (bytes, Just (FilePart skip bytes))
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 file _) ishtml lang = do
finfo <- liftIO $ getFileInfo spec (lang file)
let mtime = fileInfoTime finfo
size = fileInfoSize finfo
sfile = fileInfoName finfo
date = fileInfoDate finfo
hdr = newHeader ishtml (pathByteString file) date
Just pst = ifmodified req size mtime
<|> ifunmodified req size mtime
<|> ifrange req size mtime
<|> unconditional req size mtime
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))
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 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
Just pst = ifmodified req size mtime
<|> 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 _ langs) (Just file) =
runAnyOne $ map (tryRedirectFile hinfo) langs
where
hinfo = HandlerInfo spec req 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://"
, serverName req
, ":"
, (BS.pack . show . serverPort) req
, rawPathInfo req
, "/"
]
notFound :: RspSpec
notFound = RspSpec notFound404 BodyStatus
notFoundNoBody :: RspSpec
notFoundNoBody = RspSpec notFound404 NoBody
notAllowed :: RspSpec
notAllowed = RspSpec methodNotAllowed405 BodyStatus