{-# 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 (RspSpec -> RspSpec -> Bool
(RspSpec -> RspSpec -> Bool)
-> (RspSpec -> RspSpec -> Bool) -> Eq RspSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RspSpec -> RspSpec -> Bool
== :: RspSpec -> RspSpec -> Bool
$c/= :: RspSpec -> RspSpec -> Bool
/= :: RspSpec -> RspSpec -> Bool
Eq,Int -> RspSpec -> ShowS
[RspSpec] -> ShowS
RspSpec -> FilePath
(Int -> RspSpec -> ShowS)
-> (RspSpec -> FilePath) -> ([RspSpec] -> ShowS) -> Show RspSpec
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RspSpec -> ShowS
showsPrec :: Int -> RspSpec -> ShowS
$cshow :: RspSpec -> FilePath
show :: RspSpec -> FilePath
$cshowList :: [RspSpec] -> ShowS
showList :: [RspSpec] -> ShowS
Show)
data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang]
langSuffixes :: RequestHeaders -> [Lang]
langSuffixes :: ResponseHeaders -> [Lang]
langSuffixes ResponseHeaders
hdr = (ByteString -> Lang) -> [ByteString] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
x -> (ByteString -> Lang
<.> ByteString
x)) [ByteString]
langs [Lang] -> [Lang] -> [Lang]
forall a. [a] -> [a] -> [a]
++ [Lang
forall a. a -> a
id, (ByteString -> Lang
<.> ByteString
"en")]
where
langs :: [ByteString]
langs = ResponseHeaders -> [ByteString]
languages ResponseHeaders
hdr
fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application
fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application
fileApp ClassicAppSpec
cspec FileAppSpec
spec FileRoute
filei Request
req Response -> IO ResponseReceived
respond = do
RspSpec
rspspec <- case Either ByteString StdMethod
method of
Right StdMethod
GET -> HandlerInfo -> Bool -> Maybe ByteString -> IO RspSpec
processGET HandlerInfo
hinfo Bool
ishtml Maybe ByteString
rfile
Right StdMethod
HEAD -> HandlerInfo -> Bool -> Maybe ByteString -> IO RspSpec
processGET HandlerInfo
hinfo Bool
ishtml Maybe ByteString
rfile
Either ByteString StdMethod
_ -> RspSpec -> IO RspSpec
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RspSpec
notAllowed
Response
response <- case RspSpec
rspspec of
NoBody Status
st -> Status -> IO Response
bodyStatus Status
st
NoBodyHdr Status
st ResponseHeaders
hdr -> Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
st ResponseHeaders
hdr ByteString
""
BodyFile Status
st ResponseHeaders
hdr FilePath
fl -> Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
ResponseFile Status
st ResponseHeaders
hdr FilePath
fl Maybe FilePart
forall a. Maybe a
Nothing
Response -> IO ResponseReceived
respond Response
response
where
hinfo :: HandlerInfo
hinfo = FileAppSpec -> Request -> ByteString -> [Lang] -> HandlerInfo
HandlerInfo FileAppSpec
spec Request
req ByteString
file [Lang]
langs
method :: Either ByteString StdMethod
method = ByteString -> Either ByteString StdMethod
parseMethod (ByteString -> Either ByteString StdMethod)
-> ByteString -> Either ByteString StdMethod
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestMethod Request
req
path :: ByteString
path = Request -> FileRoute -> ByteString
pathinfoToFilePath Request
req FileRoute
filei
file :: ByteString
file = FileAppSpec -> Lang
addIndex FileAppSpec
spec ByteString
path
ishtml :: Bool
ishtml = FileAppSpec -> ByteString -> Bool
isHTML FileAppSpec
spec ByteString
file
rfile :: Maybe ByteString
rfile = FileAppSpec -> ByteString -> Maybe ByteString
redirectPath FileAppSpec
spec ByteString
path
langs :: [Lang]
langs = ResponseHeaders -> [Lang]
langSuffixes (ResponseHeaders -> [Lang]) -> ResponseHeaders -> [Lang]
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req
noBody :: Status -> m Response
noBody Status
st = Response -> m Response
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
st [] ByteString
""
bodyStatus :: Status -> IO Response
bodyStatus Status
st = ClassicAppSpec -> Request -> [Lang] -> Status -> IO StatusInfo
getStatusInfo ClassicAppSpec
cspec Request
req [Lang]
langs Status
st
IO StatusInfo -> (StatusInfo -> IO Response) -> IO Response
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Status -> StatusInfo -> IO Response
forall {m :: * -> *}. Monad m => Status -> StatusInfo -> m Response
statusBody Status
st
statusBody :: Status -> StatusInfo -> m Response
statusBody Status
st StatusInfo
StatusNone = Status -> m Response
forall {m :: * -> *}. Monad m => Status -> m Response
noBody Status
st
statusBody Status
st (StatusByteString ByteString
bd) =
Response -> m Response
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
st ResponseHeaders
hdr ByteString
bd
where
hdr :: ResponseHeaders
hdr = ResponseHeaders
textPlainHeader
statusBody Status
st (StatusFile ByteString
afile Integer
len) =
Response -> m Response
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
ResponseFile Status
st ResponseHeaders
hdr FilePath
fl Maybe FilePart
mfp
where
mfp :: Maybe FilePart
mfp = FilePart -> Maybe FilePart
forall a. a -> Maybe a
Just (Integer -> Integer -> Integer -> FilePart
FilePart Integer
0 Integer
len Integer
len)
fl :: FilePath
fl = ByteString -> FilePath
pathString ByteString
afile
hdr :: ResponseHeaders
hdr = ResponseHeaders
textHtmlHeader
processGET :: HandlerInfo -> Bool -> Maybe Path -> IO RspSpec
processGET :: HandlerInfo -> Bool -> Maybe ByteString -> IO RspSpec
processGET HandlerInfo
hinfo Bool
ishtml Maybe ByteString
rfile = HandlerInfo -> Bool -> IO RspSpec
tryGet HandlerInfo
hinfo Bool
ishtml
IO RspSpec -> IO RspSpec -> IO RspSpec
forall a. IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HandlerInfo -> Maybe ByteString -> IO RspSpec
tryRedirect HandlerInfo
hinfo Maybe ByteString
rfile
IO RspSpec -> IO RspSpec -> IO RspSpec
forall a. IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RspSpec -> IO RspSpec
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RspSpec
notFound
tryGet :: HandlerInfo -> Bool -> IO RspSpec
tryGet :: HandlerInfo -> Bool -> IO RspSpec
tryGet hinfo :: HandlerInfo
hinfo@(HandlerInfo FileAppSpec
_ Request
_ ByteString
_ [Lang]
langs) Bool
True =
[IO RspSpec] -> IO RspSpec
forall a. [IO a] -> IO a
runAnyOne ([IO RspSpec] -> IO RspSpec) -> [IO RspSpec] -> IO RspSpec
forall a b. (a -> b) -> a -> b
$ (Lang -> IO RspSpec) -> [Lang] -> [IO RspSpec]
forall a b. (a -> b) -> [a] -> [b]
map (HandlerInfo -> Bool -> Lang -> IO RspSpec
tryGetFile HandlerInfo
hinfo Bool
True) [Lang]
langs
tryGet HandlerInfo
hinfo Bool
False = HandlerInfo -> Bool -> Lang -> IO RspSpec
tryGetFile HandlerInfo
hinfo Bool
False Lang
forall a. a -> a
id
tryGetFile :: HandlerInfo -> Bool -> Lang -> IO RspSpec
tryGetFile :: HandlerInfo -> Bool -> Lang -> IO RspSpec
tryGetFile (HandlerInfo FileAppSpec
_ Request
req ByteString
file [Lang]
_) Bool
ishtml Lang
lang = do
let file' :: FilePath
file' = ByteString -> FilePath
pathString (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ Lang
lang ByteString
file
hdr :: ResponseHeaders
hdr = Bool -> ByteString -> ResponseHeaders
newHeader Bool
ishtml ByteString
file
FileInfo
_ <- Request -> FilePath -> IO FileInfo
getFileInfo Request
req FilePath
file'
RspSpec -> IO RspSpec
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RspSpec -> IO RspSpec) -> RspSpec -> IO RspSpec
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> FilePath -> RspSpec
BodyFile Status
ok200 ResponseHeaders
hdr FilePath
file'
tryRedirect :: HandlerInfo -> Maybe Path -> IO RspSpec
tryRedirect :: HandlerInfo -> Maybe ByteString -> IO RspSpec
tryRedirect HandlerInfo
_ Maybe ByteString
Nothing = IO RspSpec
forall a. IO a
forall (f :: * -> *) a. Alternative f => f a
empty
tryRedirect (HandlerInfo FileAppSpec
spec Request
req ByteString
_ [Lang]
langs) (Just ByteString
file) =
[IO RspSpec] -> IO RspSpec
forall a. [IO a] -> IO a
runAnyOne ([IO RspSpec] -> IO RspSpec) -> [IO RspSpec] -> IO RspSpec
forall a b. (a -> b) -> a -> b
$ (Lang -> IO RspSpec) -> [Lang] -> [IO RspSpec]
forall a b. (a -> b) -> [a] -> [b]
map (HandlerInfo -> Lang -> IO RspSpec
tryRedirectFile HandlerInfo
hinfo) [Lang]
langs
where
hinfo :: HandlerInfo
hinfo = FileAppSpec -> Request -> ByteString -> [Lang] -> HandlerInfo
HandlerInfo FileAppSpec
spec Request
req ByteString
file [Lang]
langs
tryRedirectFile :: HandlerInfo -> Lang -> IO RspSpec
tryRedirectFile :: HandlerInfo -> Lang -> IO RspSpec
tryRedirectFile (HandlerInfo FileAppSpec
_ Request
req ByteString
file [Lang]
_) Lang
lang = do
let file' :: FilePath
file' = ByteString -> FilePath
pathString (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ Lang
lang ByteString
file
FileInfo
_ <- Request -> FilePath -> IO FileInfo
getFileInfo Request
req FilePath
file'
RspSpec -> IO RspSpec
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RspSpec -> IO RspSpec) -> RspSpec -> IO RspSpec
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> RspSpec
NoBodyHdr Status
movedPermanently301 ResponseHeaders
hdr
where
hdr :: ResponseHeaders
hdr = Request -> ResponseHeaders
redirectHeader Request
req
redirectHeader :: Request -> ResponseHeaders
= ByteString -> ResponseHeaders
locationHeader (ByteString -> ResponseHeaders)
-> (Request -> ByteString) -> Request -> ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
redirectURL
redirectURL :: Request -> ByteString
redirectURL :: Request -> ByteString
redirectURL Request
req = [ByteString] -> ByteString
BS.concat [
ByteString
"//"
, ByteString
host
, Request -> ByteString
rawPathInfo Request
req
, ByteString
"/"
]
where
host :: ByteString
host = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Maybe ByteString
requestHeaderHost Request
req
notFound :: RspSpec
notFound :: RspSpec
notFound = Status -> RspSpec
NoBody Status
notFound404
notAllowed :: RspSpec
notAllowed :: RspSpec
notAllowed = Status -> RspSpec
NoBody Status
methodNotAllowed405
runAnyOne :: [IO a] -> IO a
runAnyOne :: forall a. [IO a] -> IO a
runAnyOne = (IO a -> IO a -> IO a) -> IO a -> [IO a] -> IO a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr IO a -> IO a -> IO a
forall a. IO a -> IO a -> IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) IO a
forall a. IO a
forall (f :: * -> *) a. Alternative f => f a
empty