    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE CPP #-}

    module Network.Wai.Application.Classic.Status (getStatusInfo) where

    import Control.Applicative
    import Control.Arrow
    import Control.Exception
    import qualified Data.ByteString.Lazy as BL
    import Data.ByteString.Lazy.Char8 ()
    import qualified Data.StaticHash as M
    import Network.HTTP.Types
    import Network.Wai (Request)
    import Network.Wai.Application.Classic.Path
    import Network.Wai.Application.Classic.Types
    import Network.Wai.Handler.Warp

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

    getStatusInfo :: ClassicAppSpec -> Request -> [Lang] -> Status -> IO StatusInfo
    getStatusInfo :: ClassicAppSpec -> Request -> [Lang] -> Status -> IO StatusInfo
    getStatusInfo ClassicAppSpec
    cspec Request
    req [Lang]
    langs Status
    st = (FilePath -> IO FileInfo) -> Path -> Int -> [Lang] -> IO StatusInfo
    getStatusFile FilePath -> IO FileInfo
    getF Path
    dir Int
    code [Lang]
    langs
                                   IO StatusInfo -> IO StatusInfo -> IO StatusInfo
    forall a. IO a -> IO a -> IO a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Int -> IO StatusInfo
    getStatusBS Int
    code
                                   IO StatusInfo -> IO StatusInfo -> IO StatusInfo
    forall a. IO a -> IO a -> IO a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> StatusInfo -> IO StatusInfo
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return StatusInfo
    StatusNone
      where
        dir :: Path
    dir = ClassicAppSpec -> Path
    statusFileDir ClassicAppSpec
    cspec
        getF :: FilePath -> IO FileInfo
    getF = Request -> FilePath -> IO FileInfo
    getFileInfo Request
    req
        code :: Int
    code = Status -> Int
    statusCode Status
    st

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

    statusList :: [Status]
    statusList :: [Status]
    statusList = [
        Status
    methodNotAllowed405    -- File
      , Status
    notFound404            -- File
      , Status
    internalServerError500 -- CGI
      , Status
    badGateway502          -- RevProxy
      ]

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

    statusBSMap :: M.StaticHash Int StatusInfo
    statusBSMap :: StaticHash Int StatusInfo
    statusBSMap = [(Int, StatusInfo)] -> StaticHash Int StatusInfo
    forall k v. (Eq k, Ord k, Hashable k) => [(k, v)] -> StaticHash k v
    M.fromList ([(Int, StatusInfo)] -> StaticHash Int StatusInfo)
    -> [(Int, StatusInfo)] -> StaticHash Int StatusInfo
    forall a b. (a -> b) -> a -> b
    $ (Status -> (Int, StatusInfo)) -> [Status] -> [(Int, StatusInfo)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Status -> Int
    statusCode (Status -> Int)
    -> (Status -> StatusInfo) -> Status -> (Int, StatusInfo)
    forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& Status -> StatusInfo
    toRspBody) [Status]
    statusList
      where
        toRspBody :: Status -> StatusInfo
    toRspBody Status
    s = ByteString -> StatusInfo
    StatusByteString (ByteString -> StatusInfo) -> ByteString -> StatusInfo
    forall a b. (a -> b) -> a -> b
    $ [Path] -> ByteString
    BL.fromChunks [Status -> Path
    statusMessage Status
    s, Path
    "\r\n"]

    getStatusBS :: Int -> IO StatusInfo
    getStatusBS :: Int -> IO StatusInfo
    getStatusBS Int
    code = case Int -> StaticHash Int StatusInfo -> Maybe StatusInfo
    forall k v.
    (Eq k, Ord k, Hashable k) =>
    k -> StaticHash k v -> Maybe v
    M.lookup Int
    code StaticHash Int StatusInfo
    statusBSMap of
        Maybe StatusInfo
    Nothing -> IOError -> IO StatusInfo
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (IOError -> IO StatusInfo) -> IOError -> IO StatusInfo
    forall a b. (a -> b) -> a -> b
    $ FilePath -> IOError
    userError FilePath
    "getStatusBS"
        Just StatusInfo
    x  -> StatusInfo -> IO StatusInfo
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return StatusInfo
    x

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

    statusFileMap :: M.StaticHash Int Path
    statusFileMap :: StaticHash Int Path
    statusFileMap = [(Int, Path)] -> StaticHash Int Path
    forall k v. (Eq k, Ord k, Hashable k) => [(k, v)] -> StaticHash k v
    M.fromList ([(Int, Path)] -> StaticHash Int Path)
    -> [(Int, Path)] -> StaticHash Int Path
    forall a b. (a -> b) -> a -> b
    $ (Status -> (Int, Path)) -> [Status] -> [(Int, Path)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Status -> Int
    statusCode (Status -> Int) -> (Status -> Path) -> Status -> (Int, Path)
    forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& Status -> Path
    forall {a}. IsString a => Status -> a
    toPath) [Status]
    statusList
      where
        toPath :: Status -> a
    toPath Status
    s = FilePath -> a
    forall a. IsString a => FilePath -> a
    fromString (FilePath -> a) -> FilePath -> a
    forall a b. (a -> b) -> a -> b
    $ Int -> FilePath
    forall a. Show a => a -> FilePath
    show (Status -> Int
    statusCode Status
    s) FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    ".html"

    getStatusFile :: (FilePath -> IO FileInfo) -> Path -> Int -> [Lang] -> IO StatusInfo
    getStatusFile :: (FilePath -> IO FileInfo) -> Path -> Int -> [Lang] -> IO StatusInfo
    getStatusFile FilePath -> IO FileInfo
    getF Path
    dir Int
    code [Lang]
    langs = [Path] -> IO StatusInfo
    tryFile [Path]
    mfiles
      where
        mfiles :: [Path]
    mfiles = case Int -> StaticHash Int Path -> Maybe Path
    forall k v.
    (Eq k, Ord k, Hashable k) =>
    k -> StaticHash k v -> Maybe v
    M.lookup Int
    code StaticHash Int Path
    statusFileMap of
            Maybe Path
    Nothing   -> []
            Just Path
    file -> (Lang -> Path) -> [Lang] -> [Path]
    forall a b. (a -> b) -> [a] -> [b]
    map (Lang -> Lang
    forall a b. (a -> b) -> a -> b
    $ (Path
    dir Path -> Lang
    </> Path
    file)) [Lang]
    langs
        tryFile :: [Path] -> IO StatusInfo
    tryFile = (Path -> IO StatusInfo -> IO StatusInfo)
    -> IO StatusInfo -> [Path] -> IO StatusInfo
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Path -> IO StatusInfo -> IO StatusInfo
    func IO StatusInfo
    forall a. IO a
    forall (f :: * -> *) a. Alternative f => f a
    empty
        func :: Path -> IO StatusInfo -> IO StatusInfo
    func Path
    f IO StatusInfo
    io = Path -> Integer -> StatusInfo
    StatusFile Path
    f (Integer -> StatusInfo)
    -> (FileInfo -> Integer) -> FileInfo -> StatusInfo
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FileInfo -> Integer
    fileInfoSize (FileInfo -> StatusInfo) -> IO FileInfo -> IO StatusInfo
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> IO FileInfo
    getF FilePath
    f' IO StatusInfo -> IO StatusInfo -> IO StatusInfo
    forall a. IO a -> IO a -> IO a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> IO StatusInfo
    io
          where
            f' :: FilePath
    f' = Path -> FilePath
    pathString Path
    f

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