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