module Network.Wai.Middleware.Static
(
static, staticPolicy, unsafeStaticPolicy
,
Policy, (<|>), (>->), policy, predicate
, addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, isNotAbsolute, only
,
tryPolicy
) where
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as B
import Data.List
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Monoid
import qualified Data.Text as T
import Network.HTTP.Types (status200)
import System.Directory (doesFileExist)
import qualified System.FilePath as FP
import Network.Wai
newtype Policy = Policy { tryPolicy :: String -> Maybe String
}
instance Monoid Policy where
mempty = policy Just
mappend p1 p2 = policy (maybe Nothing (tryPolicy p2) . tryPolicy p1)
policy :: (String -> Maybe String) -> Policy
policy = Policy
predicate :: (String -> Bool) -> Policy
predicate p = policy (\s -> if p s then Just s else Nothing)
infixr 5 >->
(>->) :: Policy -> Policy -> Policy
(>->) = mappend
infixr 4 <|>
(<|>) :: Policy -> Policy -> Policy
p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s))
addBase :: String -> Policy
addBase b = policy (Just . (b FP.</>))
addSlash :: Policy
addSlash = policy slashOpt
where slashOpt s@('/':_) = Just s
slashOpt s = Just ('/':s)
hasSuffix :: String -> Policy
hasSuffix = predicate . isSuffixOf
hasPrefix :: String -> Policy
hasPrefix = predicate . isPrefixOf
contains :: String -> Policy
contains = predicate . isInfixOf
noDots :: Policy
noDots = predicate (not . isInfixOf "..")
isNotAbsolute :: Policy
isNotAbsolute = predicate $ not . FP.isAbsolute
only :: [(String,String)] -> Policy
only al = policy (flip lookup al)
static :: Middleware
static = staticPolicy mempty
staticPolicy :: Policy -> Middleware
staticPolicy p = unsafeStaticPolicy $ noDots >-> isNotAbsolute >-> p
unsafeStaticPolicy :: Policy -> Middleware
unsafeStaticPolicy p app req =
maybe (app req)
(\fp -> do exists <- liftIO $ doesFileExist fp
if exists
then return $ responseFile status200
[("Content-Type", getMimeType fp)]
fp
Nothing
else app req)
(tryPolicy p $ T.unpack $ T.intercalate "/" $ pathInfo req)
type Ascii = B.ByteString
getMimeType :: FilePath -> Ascii
getMimeType = go . extensions
where go [] = defaultMimeType
go (ext:exts) = fromMaybe (go exts) $ M.lookup ext defaultMimeTypes
extensions :: FilePath -> [String]
extensions [] = []
extensions fp = case dropWhile (/= '.') fp of
[] -> []
s -> let ext = tail s
in ext : extensions ext
defaultMimeType :: Ascii
defaultMimeType = "application/octet-stream"
defaultMimeTypes :: M.Map String Ascii
defaultMimeTypes = M.fromList [
( "asc" , "text/plain" ),
( "asf" , "video/x-ms-asf" ),
( "asx" , "video/x-ms-asf" ),
( "avi" , "video/x-msvideo" ),
( "bz2" , "application/x-bzip" ),
( "c" , "text/plain" ),
( "class" , "application/octet-stream" ),
( "conf" , "text/plain" ),
( "cpp" , "text/plain" ),
( "css" , "text/css" ),
( "cxx" , "text/plain" ),
( "dtd" , "text/xml" ),
( "dvi" , "application/x-dvi" ),
( "gif" , "image/gif" ),
( "gz" , "application/x-gzip" ),
( "hs" , "text/plain" ),
( "htm" , "text/html" ),
( "html" , "text/html" ),
( "jar" , "application/x-java-archive" ),
( "jpeg" , "image/jpeg" ),
( "jpg" , "image/jpeg" ),
( "js" , "text/javascript" ),
( "json" , "application/json" ),
( "log" , "text/plain" ),
( "m3u" , "audio/x-mpegurl" ),
( "mov" , "video/quicktime" ),
( "mp3" , "audio/mpeg" ),
( "mpeg" , "video/mpeg" ),
( "mpg" , "video/mpeg" ),
( "ogg" , "application/ogg" ),
( "pac" , "application/x-ns-proxy-autoconfig" ),
( "pdf" , "application/pdf" ),
( "png" , "image/png" ),
( "ps" , "application/postscript" ),
( "qt" , "video/quicktime" ),
( "sig" , "application/pgp-signature" ),
( "spl" , "application/futuresplash" ),
( "svg" , "image/svg+xml" ),
( "swf" , "application/x-shockwave-flash" ),
( "tar" , "application/x-tar" ),
( "tar.bz2" , "application/x-bzip-compressed-tar" ),
( "tar.gz" , "application/x-tgz" ),
( "tbz" , "application/x-bzip-compressed-tar" ),
( "text" , "text/plain" ),
( "tgz" , "application/x-tgz" ),
( "torrent" , "application/x-bittorrent" ),
( "ttf" , "application/x-font-truetype" ),
( "txt" , "text/plain" ),
( "wav" , "audio/x-wav" ),
( "wax" , "audio/x-ms-wax" ),
( "wma" , "audio/x-ms-wma" ),
( "wmv" , "video/x-ms-wmv" ),
( "xbm" , "image/x-xbitmap" ),
( "xml" , "text/xml" ),
( "xpm" , "image/x-xpixmap" ),
( "xwd" , "image/x-xwindowdump" ),
( "zip" , "application/zip" ) ]