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

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

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