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
"GET" -> processGET hinfo ishtml rfile
"HEAD" -> processHEAD hinfo ishtml rfile
_ -> return notAllowed
(response, mlen) <- case body of
NoBody -> return $ noBody st
BodyStatus -> statusBody st <$> liftIO (getStatusInfo cspec spec langs st)
BodyFileNoBody hdr -> return $ bodyFileNoBody st hdr
BodyFile hdr afile rng -> return $ bodyFile st hdr afile rng
liftIO $ logger cspec req st mlen
return response
where
hinfo = HandlerInfo spec req file langs
method = requestMethod req
path = pathinfoToFilePath req filei
file = addIndex spec path
ishtml = isHTML spec file
rfile = redirectPath spec path
langs = langSuffixes req
noBody st = (responseLBS st hdr "", Nothing)
where
hdr = addServer cspec []
statusBody st StatusNone = noBody st
statusBody st (StatusByteString bd) = (responseLBS st hdr bd, Just (len bd))
where
len = fromIntegral . BL.length
hdr = addServer cspec textPlainHeader
statusBody st (StatusFile afile len) = (ResponseFile st hdr fl mfp, Just len)
where
hdr = addServer cspec textHtmlHeader
mfp = Just (FilePart 0 len)
fl = pathString afile
bodyFileNoBody st hdr = (responseLBS st hdr' "", Nothing)
where
hdr' = addServer cspec hdr
bodyFile st hdr afile rng = (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))
hdr' = addLength len $ addServer cspec hdr
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
hdr = newHeader ishtml (pathByteString file) mtime
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
hdr = newHeader ishtml (pathByteString file) mtime
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