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

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