{-# 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

----------------------------------------------------------------

{-|
  Handle GET and HEAD for a static file.

If 'pathInfo' ends with \'/\', 'indexFile' is automatically
added. In this case, "Acceptable-Language:" is also handled.  Suppose
'indexFile' is "index.html" and if the value is "ja,en", then
\"index.html.ja\", \"index.html.en\", and \"index.html\" are tried to be
opened in order.

If 'pathInfo' does not end with \'/\' and a corresponding index file
exist, redirection is specified in HTTP response.

Directory contents are NOT automatically listed. To list directory
contents, an index file must be created beforehand.

The following HTTP headers are handled: Acceptable-Language:,
If-Modified-Since:, Range:, If-Range:, If-Unmodified-Since:.
-}

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' -- expecting an error
    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' -- expecting an error
    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
redirectHeader :: Request -> ResponseHeaders
redirectHeader = 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 [
  -- Scheme must not be included because of no way to tell
  -- http or https.
    ByteString
"//"
  -- Host includes ":<port>" if it is not 80.
  , 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