    {-# 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 <- 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 <- case 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
        respond 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
        _ <- Request -> FilePath -> IO FileInfo
    getFileInfo Request
    req FilePath
    file' -- expecting an error
        return $ BodyFile ok200 hdr 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
        _ <- Request -> FilePath -> IO FileInfo
    getFileInfo Request
    req FilePath
    file' -- expecting an error
        return $ NoBodyHdr movedPermanently301 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