{-# 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 hdr :: RequestHeaders
hdr = (Path -> Lang) -> [Path] -> [Lang]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Path
x -> (Path -> Lang
<.> Path
x)) [Path]
langs [Lang] -> [Lang] -> [Lang]
forall a. [a] -> [a] -> [a]
++ [Lang
forall a. a -> a
id, (Path -> Lang
<.> "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 cspec :: ClassicAppSpec
cspec spec :: FileAppSpec
spec filei :: FileRoute
filei req :: Request
req respond :: Response -> IO ResponseReceived
respond = do
    RspSpec
rspspec <- case Either Path StdMethod
method of
        Right GET  -> HandlerInfo -> Bool -> Maybe Path -> IO RspSpec
processGET  HandlerInfo
hinfo Bool
ishtml Maybe Path
rfile
        Right HEAD -> HandlerInfo -> Bool -> Maybe Path -> IO RspSpec
processGET  HandlerInfo
hinfo Bool
ishtml Maybe Path
rfile
        _          -> RspSpec -> IO RspSpec
forall (m :: * -> *) a. Monad m => a -> m a
return RspSpec
notAllowed
    Response
response <- case RspSpec
rspspec of
            NoBody    st :: Status
st        -> Status -> IO Response
bodyStatus Status
st
            NoBodyHdr st :: Status
st hdr :: 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 ""
            BodyFile  st :: Status
st hdr :: RequestHeaders
hdr fl :: 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 st :: 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 [] ""
    bodyStatus :: Status -> IO Response
bodyStatus st :: 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 st :: Status
st StatusNone = Status -> m Response
forall (m :: * -> *). Monad m => Status -> m Response
noBody Status
st
    statusBody st :: Status
st (StatusByteString bd :: 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 st :: Status
st (StatusFile afile :: Path
afile len :: 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 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 hinfo :: HandlerInfo
hinfo ishtml :: Bool
ishtml rfile :: 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 _ _ _ langs :: [Lang]
langs) 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 hinfo :: HandlerInfo
hinfo 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 _ req :: Request
req file :: Path
file _) ishtml :: Bool
ishtml 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
        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 _ Nothing = IO RspSpec
forall (f :: * -> *) a. Alternative f => f a
empty
tryRedirect (HandlerInfo spec :: FileAppSpec
spec req :: Request
req _ langs :: [Lang]
langs) (Just file :: 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 _ req :: Request
req file :: 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 req :: Request
req = [Path] -> Path
BS.concat [
  -- Scheme must not be included because of no way to tell
  -- http or https.
    "//"
  -- Host includes ":<port>" if it is not 80.
  , Path
host
  , Request -> Path
rawPathInfo Request
req
  , "/"
  ]
  where
    host :: Path
host = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe "" (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