wai-app-static-3.1.7.1/Network/0000755000000000000000000000000012620000372014313 5ustar0000000000000000wai-app-static-3.1.7.1/Network/Wai/0000755000000000000000000000000012620000372015033 5ustar0000000000000000wai-app-static-3.1.7.1/Network/Wai/Application/0000755000000000000000000000000013607523324017313 5ustar0000000000000000wai-app-static-3.1.7.1/WaiAppStatic/0000755000000000000000000000000013432233620015221 5ustar0000000000000000wai-app-static-3.1.7.1/WaiAppStatic/Storage/0000755000000000000000000000000013224350543016630 5ustar0000000000000000wai-app-static-3.1.7.1/WaiAppStatic/Storage/Embedded/0000755000000000000000000000000013253726531020327 5ustar0000000000000000wai-app-static-3.1.7.1/app/0000755000000000000000000000000012620000372013442 5ustar0000000000000000wai-app-static-3.1.7.1/images/0000755000000000000000000000000012620000372014127 5ustar0000000000000000wai-app-static-3.1.7.1/test/0000755000000000000000000000000013607523663013664 5ustar0000000000000000wai-app-static-3.1.7.1/test/a/0000755000000000000000000000000012620000372014061 5ustar0000000000000000wai-app-static-3.1.7.1/Network/Wai/Application/Static.hs0000644000000000000000000002641413607523324021105 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell, CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} -- | Static file serving for WAI. module Network.Wai.Application.Static ( -- * WAI application staticApp -- ** Default Settings , defaultWebAppSettings , webAppSettingsWithLookup , defaultFileServerSettings , embeddedSettings -- ** Settings , StaticSettings , ssLookupFile , ssMkRedirect , ssGetMimeType , ssListing , ssIndices , ssMaxAge , ssRedirectToIndex , ssAddTrailingSlash , ss404Handler ) where import Prelude hiding (FilePath) import qualified Network.Wai as W import qualified Network.HTTP.Types as H import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () import Control.Monad.IO.Class (liftIO) import Data.ByteString.Builder (toLazyByteString) import Data.FileEmbed (embedFile) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate) import WaiAppStatic.Types import Util import WaiAppStatic.Storage.Filesystem import WaiAppStatic.Storage.Embedded import Network.Mime (MimeType) data StaticResponse = -- | Just the etag hash or Nothing for no etag hash Redirect Pieces (Maybe ByteString) | RawRedirect ByteString | NotFound | FileResponse File H.ResponseHeaders | NotModified -- TODO: add file size | SendContent MimeType L.ByteString | WaiResponse W.Response safeInit :: [a] -> [a] safeInit [] = [] safeInit xs = init xs filterButLast :: (a -> Bool) -> [a] -> [a] filterButLast _ [] = [] filterButLast _ [x] = [x] filterButLast f (x:xs) | f x = x : filterButLast f xs | otherwise = filterButLast f xs -- | Serve an appropriate response for a folder request. serveFolder :: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse serveFolder StaticSettings {..} pieces req folder@Folder {..} = case ssListing of Just _ | Just path <- addTrailingSlash req, ssAddTrailingSlash -> return $ RawRedirect path Just listing -> do -- directory listings turned on, display it builder <- listing pieces folder return $ WaiResponse $ W.responseBuilder H.status200 [ ("Content-Type", "text/html; charset=utf-8") ] builder Nothing -> return $ WaiResponse $ W.responseLBS H.status403 [ ("Content-Type", "text/plain") ] "Directory listings disabled" addTrailingSlash :: W.Request -> Maybe ByteString addTrailingSlash req | S8.null rp = Just "/" | S8.last rp == '/' = Nothing | otherwise = Just $ S8.snoc rp '/' where rp = W.rawPathInfo req checkPieces :: StaticSettings -> Pieces -- ^ parsed request -> W.Request -> IO StaticResponse -- If we have any empty pieces in the middle of the requested path, generate a -- redirect to get rid of them. checkPieces _ pieces _ | any (T.null . fromPiece) $ safeInit pieces = return $ Redirect (filterButLast (not . T.null . fromPiece) pieces) Nothing checkPieces ss@StaticSettings {..} pieces req = do res <- lookupResult case res of Left location -> return $ RawRedirect location Right LRNotFound -> return NotFound Right (LRFile file) -> serveFile ss req file Right (LRFolder folder) -> serveFolder ss pieces req folder where lookupResult :: IO (Either ByteString LookupResult) lookupResult = do nonIndexResult <- ssLookupFile pieces case nonIndexResult of LRFile{} -> return $ Right nonIndexResult _ -> do eIndexResult <- lookupIndices (map (\ index -> dropLastIfNull pieces ++ [index]) ssIndices) return $ case eIndexResult of Left redirect -> Left redirect Right indexResult -> case indexResult of LRNotFound -> Right nonIndexResult LRFile file | ssRedirectToIndex -> let relPath = case reverse pieces of -- Served at root [] -> fromPiece $ fileName file lastSegment:_ -> case fromPiece lastSegment of -- Ends with a trailing slash "" -> fromPiece $ fileName file -- Lacks a trailing slash lastSegment' -> T.concat [ lastSegment' , "/" , fromPiece $ fileName file ] in Left $ TE.encodeUtf8 relPath _ -> Right indexResult lookupIndices :: [Pieces] -> IO (Either ByteString LookupResult) lookupIndices (x : xs) = do res <- ssLookupFile x case res of LRNotFound -> lookupIndices xs _ -> return $ case (ssAddTrailingSlash, addTrailingSlash req) of (True, Just redirect) -> Left redirect _ -> Right res lookupIndices [] = return $ Right LRNotFound serveFile :: StaticSettings -> W.Request -> File -> IO StaticResponse serveFile StaticSettings {..} req file -- First check etag values, if turned on | ssUseHash = do mHash <- fileGetHash file case (mHash, lookup "if-none-match" $ W.requestHeaders req) of -- if-none-match matches the actual hash, return a 304 (Just hash, Just lastHash) | hash == lastHash -> return NotModified -- Didn't match, but we have a hash value. Send the file contents -- with an ETag header. -- -- Note: It would be arguably better to next check -- if-modified-since and return a 304 if that indicates a match as -- well. However, the circumstances under which such a situation -- could arise would be very anomalous, and should likely warrant a -- new file being sent anyway. (Just hash, _) -> respond [("ETag", hash)] -- No hash value available, fall back to last modified support. (Nothing, _) -> lastMod -- etag turned off, so jump straight to last modified | otherwise = lastMod where mLastSent = lookup "if-modified-since" (W.requestHeaders req) >>= parseHTTPDate lastMod = case (fmap epochTimeToHTTPDate $ fileGetModified file, mLastSent) of -- File modified time is equal to the if-modified-since header, -- return a 304. -- -- Question: should the comparison be, date <= lastSent? (Just mdate, Just lastSent) | mdate == lastSent -> return NotModified -- Did not match, but we have a new last-modified header (Just mdate, _) -> respond [("last-modified", formatHTTPDate mdate)] -- No modification time available (Nothing, _) -> respond [] -- Send a file response with the additional weak headers provided. respond headers = return $ FileResponse file $ cacheControl ssMaxAge headers -- | Return a difference list of headers based on the specified MaxAge. -- -- This function will return both Cache-Control and Expires headers, as -- relevant. cacheControl :: MaxAge -> (H.ResponseHeaders -> H.ResponseHeaders) cacheControl maxage = headerCacheControl . headerExpires where ccInt = case maxage of NoMaxAge -> Nothing MaxAgeSeconds i -> Just i MaxAgeForever -> Just oneYear oneYear :: Int oneYear = 60 * 60 * 24 * 365 headerCacheControl = case ccInt of Nothing -> id Just i -> (:) ("Cache-Control", S8.append "public, max-age=" $ S8.pack $ show i) headerExpires = case maxage of NoMaxAge -> id MaxAgeSeconds _ -> id -- FIXME MaxAgeForever -> (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT") -- | Turn a @StaticSettings@ into a WAI application. staticApp :: StaticSettings -> W.Application staticApp set req = staticAppPieces set (W.pathInfo req) req staticAppPieces :: StaticSettings -> [Text] -> W.Application staticAppPieces _ _ req sendResponse | notElem (W.requestMethod req) ["GET", "HEAD"] = sendResponse $ W.responseLBS H.status405 [("Content-Type", "text/plain")] "Only GET or HEAD is supported" staticAppPieces _ [".hidden", "folder.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")] staticAppPieces _ [".hidden", "haskell.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")] staticAppPieces ss rawPieces req sendResponse = liftIO $ do case toPieces rawPieces of Just pieces -> checkPieces ss pieces req >>= response Nothing -> sendResponse $ W.responseLBS H.status403 [ ("Content-Type", "text/plain") ] "Forbidden" where response :: StaticResponse -> IO W.ResponseReceived response (FileResponse file ch) = do mimetype <- ssGetMimeType ss file let filesize = fileGetSize file let headers = ("Content-Type", mimetype) -- Let Warp provide the content-length, since it takes -- range requests into account -- : ("Content-Length", S8.pack $ show filesize) : ch sendResponse $ fileToResponse file H.status200 headers response NotModified = sendResponse $ W.responseLBS H.status304 [] "" response (SendContent mt lbs) = do -- TODO: set caching headers sendResponse $ W.responseLBS H.status200 [ ("Content-Type", mt) -- TODO: set Content-Length ] lbs response (Redirect pieces' mHash) = do let loc = ssMkRedirect ss pieces' $ L.toStrict $ toLazyByteString (H.encodePathSegments $ map fromPiece pieces') let qString = case mHash of Just hash -> replace "etag" (Just hash) (W.queryString req) Nothing -> remove "etag" (W.queryString req) sendResponse $ W.responseLBS H.status302 [ ("Content-Type", "text/plain") , ("Location", S8.append loc $ H.renderQuery True qString) ] "Redirect" response (RawRedirect path) = sendResponse $ W.responseLBS H.status302 [ ("Content-Type", "text/plain") , ("Location", path) ] "Redirect" response NotFound = case (ss404Handler ss) of Just app -> app req sendResponse Nothing -> sendResponse $ W.responseLBS H.status404 [ ("Content-Type", "text/plain") ] "File not found" response (WaiResponse r) = sendResponse r wai-app-static-3.1.7.1/WaiAppStatic/Storage/Filesystem.hs0000644000000000000000000001455013114006440021305 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} -- | Access files on the filesystem. module WaiAppStatic.Storage.Filesystem ( -- * Types ETagLookup -- * Settings , defaultWebAppSettings , defaultFileServerSettings , webAppSettingsWithLookup ) where import WaiAppStatic.Types import System.FilePath (()) import System.IO (withBinaryFile, IOMode(..)) import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) import Data.List (foldl') import Control.Monad (forM) import Util import Data.ByteString (ByteString) import Control.Exception (SomeException, try) import qualified Network.Wai as W import WaiAppStatic.Listing import Network.Mime import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime, isRegularFile) import Data.Maybe (catMaybes) import Data.ByteArray.Encoding import Crypto.Hash (hashlazy, MD5, Digest) import qualified Data.ByteString.Lazy as BL (hGetContents) import qualified Data.Text as T -- | Construct a new path from a root and some @Pieces@. pathFromPieces :: FilePath -> Pieces -> FilePath pathFromPieces = foldl' (\fp p -> fp T.unpack (fromPiece p)) -- | Settings optimized for a web application. Files will have aggressive -- caching applied and hashes calculated, and indices and listings are disabled. defaultWebAppSettings :: FilePath -- ^ root folder to serve from -> StaticSettings defaultWebAppSettings root = StaticSettings { ssLookupFile = webAppLookup hashFileIfExists root , ssMkRedirect = defaultMkRedirect , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName , ssMaxAge = MaxAgeForever , ssListing = Nothing , ssIndices = [] , ssRedirectToIndex = False , ssUseHash = True , ssAddTrailingSlash = False , ss404Handler = Nothing } -- | Settings optimized for a file server. More conservative caching will be -- applied, and indices and listings are enabled. defaultFileServerSettings :: FilePath -- ^ root folder to serve from -> StaticSettings defaultFileServerSettings root = StaticSettings { ssLookupFile = fileSystemLookup (fmap Just . hashFile) root , ssMkRedirect = defaultMkRedirect , ssGetMimeType = return . defaultMimeLookup . fromPiece . fileName , ssMaxAge = NoMaxAge , ssListing = Just defaultListing , ssIndices = map unsafeToPiece ["index.html", "index.htm"] , ssRedirectToIndex = False , ssUseHash = False , ssAddTrailingSlash = False , ss404Handler = Nothing } -- | Same as @defaultWebAppSettings@, but additionally uses a specialized -- @ETagLookup@ in place of the standard one. This can allow you to cache your -- hash values, or even precompute them. webAppSettingsWithLookup :: FilePath -- ^ root folder to serve from -> ETagLookup -> StaticSettings webAppSettingsWithLookup dir etagLookup = (defaultWebAppSettings dir) { ssLookupFile = webAppLookup etagLookup dir} -- | Convenience wrapper for @fileHelper@. fileHelperLR :: ETagLookup -> FilePath -- ^ file location -> Piece -- ^ file name -> IO LookupResult fileHelperLR a b c = fmap (maybe LRNotFound LRFile) $ fileHelper a b c -- | Attempt to load up a @File@ from the given path. fileHelper :: ETagLookup -> FilePath -- ^ file location -> Piece -- ^ file name -> IO (Maybe File) fileHelper hashFunc fp name = do efs <- try $ getFileStatus fp case efs of Left (_ :: SomeException) -> return Nothing Right fs | isRegularFile fs -> return $ Just File { fileGetSize = fromIntegral $ fileSize fs , fileToResponse = \s h -> W.responseFile s h fp Nothing , fileName = name , fileGetHash = hashFunc fp , fileGetModified = Just $ modificationTime fs } Right _ -> return Nothing -- | How to calculate etags. Can perform filesystem reads on each call, or use -- some caching mechanism. type ETagLookup = FilePath -> IO (Maybe ByteString) -- | More efficient than @fileSystemLookup@ as it only concerns itself with -- finding files, not folders. webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO LookupResult webAppLookup hashFunc prefix pieces = fileHelperLR hashFunc fp lastPiece where fp = pathFromPieces prefix pieces lastPiece | null pieces = unsafeToPiece "" | otherwise = last pieces -- | MD5 hash and base64-encode the file contents. Does not check if the file -- exists. hashFile :: FilePath -> IO ByteString hashFile fp = withBinaryFile fp ReadMode $ \h -> do f <- BL.hGetContents h let !hash = hashlazy f :: Digest MD5 return $ convertToBase Base64 hash hashFileIfExists :: ETagLookup hashFileIfExists fp = do res <- try $ hashFile fp return $ case res of Left (_ :: SomeException) -> Nothing Right x -> Just x isVisible :: FilePath -> Bool isVisible ('.':_) = False isVisible "" = False isVisible _ = True -- | Get a proper @LookupResult@, checking if the path is a file or folder. -- Compare with @webAppLookup@, which only deals with files. fileSystemLookup :: ETagLookup -> FilePath -> Pieces -> IO LookupResult fileSystemLookup hashFunc prefix pieces = do let fp = pathFromPieces prefix pieces fe <- doesFileExist fp if fe then fileHelperLR hashFunc fp lastPiece else do de <- doesDirectoryExist fp if de then do entries' <- fmap (filter isVisible) $ getDirectoryContents fp entries <- forM entries' $ \fpRel' -> do let name = unsafeToPiece $ T.pack fpRel' fp' = fp fpRel' de' <- doesDirectoryExist fp' if de' then return $ Just $ Left name else do mfile <- fileHelper hashFunc fp' name case mfile of Nothing -> return Nothing Just file -> return $ Just $ Right file return $ LRFolder $ Folder $ catMaybes entries else return LRNotFound where lastPiece | null pieces = unsafeToPiece "" | otherwise = last pieces wai-app-static-3.1.7.1/WaiAppStatic/Storage/Embedded.hs0000644000000000000000000000037712620000372020653 0ustar0000000000000000module WaiAppStatic.Storage.Embedded( -- * Basic embeddedSettings -- * Template Haskell , Etag , EmbeddableEntry(..) , mkSettings ) where import WaiAppStatic.Storage.Embedded.Runtime import WaiAppStatic.Storage.Embedded.TH wai-app-static-3.1.7.1/WaiAppStatic/Listing.hs0000644000000000000000000001672313114006440017172 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module WaiAppStatic.Listing ( defaultListing ) where import qualified Text.Blaze.Html5.Attributes as A import qualified Text.Blaze.Html5 as H import Text.Blaze ((!)) import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import WaiAppStatic.Types #if !MIN_VERSION_time(1,5,0) import System.Locale (defaultTimeLocale) #endif import Data.List (sortBy) import Util import qualified Text.Blaze.Html.Renderer.Utf8 as HU -- | Provides a default directory listing, suitable for most apps. -- -- Code below taken from Happstack: defaultListing :: Listing defaultListing pieces (Folder contents) = do let isTop = null pieces || map Just pieces == [toPiece ""] let fps'' :: [Either FolderName File] fps'' = (if isTop then id else (Left (unsafeToPiece "") :)) contents -- FIXME emptyParentFolder feels like a bit of a hack return $ HU.renderHtmlBuilder $ H.html $ do H.head $ do let title = T.intercalate "/" $ map fromPiece pieces let title' = if T.null title then "root folder" else title H.title $ H.toHtml title' H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }" , "table, th, td { border: 1px solid #353948; }" , "td.size { text-align: right; font-size: 0.7em; width: 50px }" , "td.date { text-align: right; font-size: 0.7em; width: 130px }" , "td { padding-right: 1em; padding-left: 1em; }" , "th.first { background-color: white; width: 24px }" , "td.first { padding-right: 0; padding-left: 0; text-align: center }" , "tr { background-color: white; }" , "tr.alt { background-color: #A3B5BA}" , "th { background-color: #3C4569; color: white; font-size: 1.125em; }" , "h1 { width: 760px; margin: 1em auto; font-size: 1em; font-family: sans-serif }" , "img { width: 20px }" , "a { text-decoration: none }" ] H.body $ do let hasTrailingSlash = case map fromPiece $ reverse $ pieces of "":_ -> True _ -> False H.h1 $ showFolder' hasTrailingSlash $ filter (not . T.null . fromPiece) pieces renderDirectoryContentsTable (map fromPiece pieces) haskellSrc folderSrc fps'' where image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"] folderSrc = image "folder" haskellSrc = image "haskell" showName "" = "root" showName x = x -- Add a link to the root of the tree showFolder' :: Bool -> Pieces -> H.Html showFolder' hasTrailingSlash pieces = showFolder hasTrailingSlash (unsafeToPiece "root" : pieces) showFolder :: Bool -> Pieces -> H.Html showFolder _ [] = "/" -- won't happen showFolder _ [x] = H.toHtml $ showName $ fromPiece x showFolder hasTrailingSlash (x:xs) = do let len = length xs - (if hasTrailingSlash then 0 else 1) href | len == 0 = "." | otherwise = concat $ replicate len "../" :: String H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x " / " :: H.Html showFolder hasTrailingSlash xs -- | a function to generate an HTML table showing the contents of a directory on the disk -- -- This function generates most of the content of the -- 'renderDirectoryContents' page. If you want to style the page -- differently, or add google analytics code, etc, you can just create -- a new page template to wrap around this HTML. -- -- see also: 'getMetaData', 'renderDirectoryContents' renderDirectoryContentsTable :: [T.Text] -- ^ requested path info -> String -> String -> [Either FolderName File] -> H.Html renderDirectoryContentsTable pathInfo' haskellSrc folderSrc fps = H.table $ do H.thead $ do H.th ! (A.class_ "first") $ H.img ! (A.src $ H.toValue haskellSrc) H.th "Name" H.th "Modified" H.th "Size" H.tbody $ mapM_ mkRow (zip (sortBy sortMD fps) $ cycle [False, True]) where sortMD :: Either FolderName File -> Either FolderName File -> Ordering sortMD Left{} Right{} = LT sortMD Right{} Left{} = GT sortMD (Left a) (Left b) = compare a b sortMD (Right a) (Right b) = compare (fileName a) (fileName b) mkRow :: (Either FolderName File, Bool) -> H.Html mkRow (md, alt) = (if alt then (! A.class_ "alt") else id) $ H.tr $ do H.td ! A.class_ "first" $ case md of Left{} -> H.img ! A.src (H.toValue folderSrc) ! A.alt "Folder" Right{} -> return () let name = case either id fileName md of (fromPiece -> "") -> unsafeToPiece ".." x -> x let isFile = either (const False) (const True) md href = addCurrentDir $ fromPiece name addCurrentDir x = case reverse pathInfo' of "":_ -> x -- has a trailing slash [] -> x -- at the root currentDir:_ -> T.concat [currentDir, "/", x] H.td (H.a ! A.href (H.toValue href) $ H.toHtml $ fromPiece name) H.td ! A.class_ "date" $ H.toHtml $ case md of Right File { fileGetModified = Just t } -> formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" t _ -> "" H.td ! A.class_ "size" $ H.toHtml $ case md of Right File { fileGetSize = s } -> prettyShow s Left{} -> "" formatCalendarTime a b c = formatTime a b $ posixSecondsToUTCTime (realToFrac c :: POSIXTime) prettyShow x | x > 1024 = prettyShowK $ x `div` 1024 | otherwise = addCommas "B" x prettyShowK x | x > 1024 = prettyShowM $ x `div` 1024 | otherwise = addCommas "KB" x prettyShowM x | x > 1024 = prettyShowG $ x `div` 1024 | otherwise = addCommas "MB" x prettyShowG x = addCommas "GB" x addCommas s = (++ (' ' : s)) . reverse . addCommas' . reverse . show addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e) addCommas' x = x wai-app-static-3.1.7.1/WaiAppStatic/Types.hs0000644000000000000000000001232313253726531016673 0ustar0000000000000000module WaiAppStatic.Types ( -- * Pieces Piece , toPiece , fromPiece , unsafeToPiece , Pieces , toPieces -- * Caching , MaxAge (..) -- * File\/folder serving , FolderName , Folder (..) , File (..) , LookupResult (..) , Listing -- * Settings , StaticSettings (..) ) where import Data.Text (Text) import qualified Network.HTTP.Types as H import qualified Network.Wai as W import Data.ByteString (ByteString) import System.Posix.Types (EpochTime) import qualified Data.Text as T import Data.ByteString.Builder (Builder) import Network.Mime (MimeType) -- | An individual component of a path, or of a filepath. -- -- This is the core type used by wai-app-static for doing lookups. It provides -- a smart constructor to avoid the possibility of constructing unsafe path -- segments (though @unsafeToPiece@ can get around that as necessary). -- -- Individual file lookup backends must know how to convert from a @Piece@ to -- their storage system. newtype Piece = Piece { fromPiece :: Text } deriving (Show, Eq, Ord) -- | Smart constructor for a @Piece@. Won\'t allow unsafe components, such as -- pieces beginning with a period or containing a slash. This /will/, however, -- allow null pieces. toPiece :: Text -> Maybe Piece toPiece t | T.null t = Just $ Piece t | T.head t == '.' = Nothing | T.any (== '/') t = Nothing | otherwise = Just $ Piece t -- | Construct a @Piece@ without input validation. unsafeToPiece :: Text -> Piece unsafeToPiece = Piece -- | Call @toPiece@ on a list. -- -- > toPieces = mapM toPiece toPieces :: [Text] -> Maybe Pieces toPieces = mapM toPiece -- | Request coming from a user. Corresponds to @pathInfo@. type Pieces = [Piece] -- | Values for the max-age component of the cache-control response header. data MaxAge = NoMaxAge -- ^ no cache-control set | MaxAgeSeconds Int -- ^ set to the given number of seconds | MaxAgeForever -- ^ essentially infinite caching; in reality, probably one year -- | Just the name of a folder. type FolderName = Piece -- | Represent contents of a single folder, which can be itself either a file -- or a folder. data Folder = Folder { folderContents :: [Either FolderName File] } -- | Information on an individual file. data File = File { -- | Size of file in bytes fileGetSize :: Integer -- | How to construct a WAI response for this file. Some files are stored -- on the filesystem and can use @ResponseFile@, while others are stored -- in memory and should use @ResponseBuilder@. , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response -- | Last component of the filename. , fileName :: Piece -- | Calculate a hash of the contents of this file, such as for etag. , fileGetHash :: IO (Maybe ByteString) -- | Last modified time, used for both display in listings and if-modified-since. , fileGetModified :: Maybe EpochTime } -- | Result of looking up a file in some storage backend. -- -- The lookup is either a file or folder, or does not exist. data LookupResult = LRFile File | LRFolder Folder | LRNotFound -- | How to construct a directory listing page for the given request path and -- the resulting folder. type Listing = Pieces -> Folder -> IO Builder -- | All of the settings available to users for tweaking wai-app-static. -- -- Note that you should use the settings type approach for modifying values. -- See for more information. data StaticSettings = StaticSettings { -- | Lookup a single file or folder. This is how you can control storage -- backend (filesystem, embedded, etc) and where to lookup. ssLookupFile :: Pieces -> IO LookupResult -- | Determine the mime type of the given file. Note that this function -- lives in @IO@ in case you want to perform more complicated mimetype -- analysis, such as via the @file@ utility. , ssGetMimeType :: File -> IO MimeType -- | Ordered list of filenames to be used for indices. If the user -- requests a folder, and a file with the given name is found in that -- folder, that file is served. This supercedes any directory listing. , ssIndices :: [Piece] -- | How to perform a directory listing. Optional. Will be used when the -- user requested a folder. , ssListing :: Maybe Listing -- | Value to provide for max age in the cache-control. , ssMaxAge :: MaxAge -- | Given a requested path and a new destination, construct a string -- that will go there. Default implementation will use relative paths. , ssMkRedirect :: Pieces -> ByteString -> ByteString -- | If @True@, send a redirect to the user when a folder is requested -- and an index page should be displayed. When @False@, display the -- content immediately. , ssRedirectToIndex :: Bool -- | Prefer usage of etag caching to last-modified caching. , ssUseHash :: Bool -- | Force a trailing slash at the end of directories , ssAddTrailingSlash :: Bool -- | Optional `W.Application` to be used in case of 404 errors -- -- Since 3.1.3 , ss404Handler :: Maybe W.Application } wai-app-static-3.1.7.1/WaiAppStatic/CmdLine.hs0000644000000000000000000000731513432233620017076 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} -- | Command line version of wai-app-static, used for the warp-static server. module WaiAppStatic.CmdLine ( runCommandLine , Args (..) ) where import Network.Wai (Middleware) import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) import Network.Wai.Handler.Warp ( runSettings, defaultSettings, setHost, setPort ) import Options.Applicative import Text.Printf (printf) import System.Directory (canonicalizePath) import Control.Monad (unless) import Network.Wai.Middleware.RequestLogger (logStdout) import Network.Wai.Middleware.Gzip import qualified Data.Map as Map import qualified Data.ByteString.Char8 as S8 import Control.Arrow ((***)) import Data.Text (pack) import Data.String (fromString) import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType) import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece) import Data.Maybe (mapMaybe) import Control.Arrow (second) import Data.Monoid ((<>)) data Args = Args { docroot :: FilePath , index :: [FilePath] , port :: Int , noindex :: Bool , quiet :: Bool , verbose :: Bool , mime :: [(String, String)] , host :: String } #if MIN_VERSION_optparse_applicative(0, 10, 0) option' = option auto #else option' = option #endif args :: Parser Args args = Args <$> strOption ( long "docroot" <> short 'd' <> metavar "DOCROOT" <> value "." <> help "directory containing files to serve") <*> (defIndex <$> many (strOption ( long "index" <> short 'i' <> metavar "INDEX" <> help "index files to serve when a directory is required" ))) <*> option' ( long "port" <> short 'p' <> metavar "PORT" <> value 3000) <*> switch ( long "noindex" <> short 'n') <*> switch ( long "quiet" <> short 'q') <*> switch ( long "verbose" <> short 'v') <*> many (toPair <$> strOption ( long "mime" <> short 'm' <> metavar "MIME" <> help "extra file extension/mime type mappings")) <*> strOption ( long "host" <> short 'h' <> metavar "HOST" <> value "*" <> help "interface to bind to, special values: *, *4, *6") where toPair = second (drop 1) . break (== '=') defIndex [] = ["index.html", "index.htm"] defIndex x = x -- | Run with the given middleware and parsing options from the command line. -- -- Since 2.0.1 runCommandLine :: (Args -> Middleware) -> IO () runCommandLine middleware = do args@Args {..} <- execParser $ info (helperOption <*> args) fullDesc let mime' = map (pack *** S8.pack) mime let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap docroot' <- canonicalizePath docroot unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index) let middle = gzip def { gzipFiles = GzipCompress } . (if verbose then logStdout else id) . (middleware args) runSettings ( setPort port $ setHost (fromString host) defaultSettings ) $ middle $ staticApp (defaultFileServerSettings $ fromString docroot) { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName } where helperOption :: Parser (a -> a) helperOption = abortOption ShowHelpText $ mconcat [long "help", help "Show this help text", hidden] wai-app-static-3.1.7.1/Util.hs0000644000000000000000000000265613114006440014145 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, ViewPatterns #-} module Util ( relativeDirFromPieces , defaultMkRedirect , replace , remove , dropLastIfNull ) where import WaiAppStatic.Types import qualified Data.Text as T import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.Text.Encoding as TE -- alist helper functions replace :: Eq a => a -> b -> [(a, b)] -> [(a, b)] replace k v [] = [(k,v)] replace k v (x:xs) | fst x == k = (k,v):xs | otherwise = x:replace k v xs remove :: Eq a => a -> [(a, b)] -> [(a, b)] remove _ [] = [] remove k (x:xs) | fst x == k = xs | otherwise = x:remove k xs -- | Turn a list of pieces into a relative path to the root folder. relativeDirFromPieces :: Pieces -> T.Text relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir -- | Construct redirects with relative paths. defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString defaultMkRedirect pieces newPath | S8.null newPath || S8.null relDir || S8.last relDir /= '/' || S8.head newPath /= '/' = relDir `S8.append` newPath | otherwise = relDir `S8.append` S8.tail newPath where relDir = TE.encodeUtf8 (relativeDirFromPieces pieces) dropLastIfNull :: [Piece] -> [Piece] dropLastIfNull pieces = case pieces of [fromPiece -> ""] -> [] (a : r) -> a : dropLastIfNull r [] -> [] wai-app-static-3.1.7.1/WaiAppStatic/Storage/Embedded/Runtime.hs0000644000000000000000000000663513253726531022320 0ustar0000000000000000-- | Lookup files stored in memory instead of from the filesystem. module WaiAppStatic.Storage.Embedded.Runtime ( -- * Settings embeddedSettings ) where import WaiAppStatic.Types import Data.ByteString (ByteString) import Control.Arrow ((&&&), second) import Data.List import Data.ByteString.Builder (byteString) import qualified Network.Wai as W import qualified Data.Map as Map import Data.Function (on) import qualified Data.Text as T import Data.Ord import qualified Data.ByteString as S import Crypto.Hash (hash, MD5, Digest) import Data.ByteArray.Encoding import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings) import System.FilePath (isPathSeparator) -- | Serve the list of path/content pairs directly from memory. embeddedSettings :: [(Prelude.FilePath, ByteString)] -> StaticSettings embeddedSettings files = (defaultFileServerSettings $ error "unused") { ssLookupFile = embeddedLookup $ toEmbedded files } type Embedded = Map.Map Piece EmbeddedEntry data EmbeddedEntry = EEFile ByteString | EEFolder Embedded embeddedLookup :: Embedded -> Pieces -> IO LookupResult embeddedLookup root pieces = return $ elookup pieces root where elookup :: Pieces -> Embedded -> LookupResult elookup [] x = LRFolder $ Folder $ map toEntry $ Map.toList x elookup [p] x | T.null (fromPiece p) = elookup [] x elookup (p:ps) x = case Map.lookup p x of Nothing -> LRNotFound Just (EEFile f) -> case ps of [] -> LRFile $ bsToFile p f _ -> LRNotFound Just (EEFolder y) -> elookup ps y toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File toEntry (name, EEFolder{}) = Left name toEntry (name, EEFile bs) = Right File { fileGetSize = fromIntegral $ S.length bs , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs , fileName = name , fileGetHash = return $ Just $ runHash bs , fileGetModified = Nothing } toEmbedded :: [(Prelude.FilePath, ByteString)] -> Embedded toEmbedded fps = go texts where texts = map (\(x, y) -> (filter (not . T.null . fromPiece) $ toPieces' x, y)) fps toPieces' "" = [] toPieces' x = -- See https://github.com/yesodweb/yesod/issues/626 -- -- We want to separate on the forward slash on *all* OSes, and on -- Windows, also separate on a backslash. let (y, z) = break isPathSeparator x in unsafeToPiece (T.pack y) : toPieces' (drop 1 z) go :: [(Pieces, ByteString)] -> Embedded go orig = Map.fromList $ map (second go') hoisted where next = map (\(x, y) -> (head x, (tail x, y))) orig grouped :: [[(Piece, ([Piece], ByteString))]] grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next hoisted :: [(Piece, [([Piece], ByteString)])] hoisted = map (fst . head &&& map snd) grouped go' :: [(Pieces, ByteString)] -> EmbeddedEntry go' [([], content)] = EEFile content go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x bsToFile :: Piece -> ByteString -> File bsToFile name bs = File { fileGetSize = fromIntegral $ S.length bs , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs , fileName = name , fileGetHash = return $ Just $ runHash bs , fileGetModified = Nothing } runHash :: ByteString -> ByteString runHash = convertToBase Base64 . (hash :: S.ByteString -> Digest MD5) wai-app-static-3.1.7.1/WaiAppStatic/Storage/Embedded/TH.hs0000644000000000000000000002670313253726531021206 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, MagicHash #-} module WaiAppStatic.Storage.Embedded.TH( Etag , EmbeddableEntry(..) , mkSettings ) where import Data.ByteString.Builder.Extra (byteStringInsert) import Codec.Compression.GZip (compress) import Control.Applicative import Data.ByteString.Unsafe (unsafePackAddressLen) import Data.Either (lefts, rights) import GHC.Exts (Int(..)) import Language.Haskell.TH import Network.Mime (MimeType, defaultMimeLookup) import System.IO.Unsafe (unsafeDupablePerformIO) import WaiAppStatic.Types import WaiAppStatic.Storage.Filesystem (defaultWebAppSettings) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL #if !MIN_VERSION_template_haskell(2, 8, 0) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as BL8 #endif import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.Wai as W -- | An Etag is used to return 304 Not Modified responses so the client does not need -- to download resources a second time. Usually the etag is built from a hash of -- the content. To disable Etags, you can pass the empty string. This will cause the -- content to be redownloaded on every request. type Etag = T.Text -- | Used at compile time to hold data about an entry to embed into the compiled executable. data EmbeddableEntry = EmbeddableEntry { eLocation :: T.Text -- ^ The location where this resource should be served from. The -- location can contain forward slashes (/) to simulate directories, -- but must not end with a forward slash. , eMimeType :: MimeType -- ^ The mime type. , eContent :: Either (Etag, BL.ByteString) ExpQ -- ^ The content itself. The content can be given as a tag and bytestring, -- in which case the content will be embedded directly into the execuatble. -- Alternatively, the content can be given as a template haskell expression -- returning @IO ('Etag', 'BL.ByteString')@ in which case this action will -- be executed on every request to reload the content (this is useful -- for a debugging mode). } -- | This structure is used at runtime to hold the entry. data EmbeddedEntry = EmbeddedEntry { embLocation :: !T.Text , embMime :: !MimeType , embEtag :: !B.ByteString , embCompressed :: !Bool , embContent :: !B.ByteString } -- | This structure is used at runtime to hold the reload entries. data ReloadEntry = ReloadEntry { reloadLocation :: !T.Text , reloadMime :: !MimeType , reloadContent :: IO (T.Text, BL.ByteString) } -- The use of unsafePackAddressLen is safe here because the length -- is correct and we will only be reading from the bytestring, never -- modifying it. -- -- The only IO within unsafePackAddressLen is within newForeignPtr_ where -- a new IORef is created as newIORef (NoFinalizers, []) to hold the finalizer -- for the pointer. Since the pointer for the content will never have a finalizer -- added, we do not care if this finalizer IORef gets created more than once since -- the IORef will always be holding (NoFinalizers, []). Therefore -- unsafeDupablePerformIO is safe. bytestringE :: B.ByteString -> ExpQ #if MIN_VERSION_template_haskell(2, 8, 0) bytestringE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |] where lenE = litE $ intPrimL $ toInteger $ B.length b ctE = litE $ stringPrimL $ B.unpack b #else bytestringE b = [| B8.pack $s |] where s = litE $ stringL $ B8.unpack b #endif bytestringLazyE :: BL.ByteString -> ExpQ #if MIN_VERSION_template_haskell(2, 8, 0) bytestringLazyE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |] where lenE = litE $ intPrimL $ toInteger $ BL.length b ctE = litE $ stringPrimL $ BL.unpack b #else bytestringLazyE b = [| B8.pack $s |] where s = litE $ stringL $ BL8.unpack b #endif -- | A template haskell expression which creates either an EmbeddedEntry or ReloadEntry. mkEntry :: EmbeddableEntry -> ExpQ mkEntry (EmbeddableEntry loc mime (Left (etag, ct))) = [| Left $ EmbeddedEntry (T.pack $locE) $(bytestringE mime) $(bytestringE $ T.encodeUtf8 etag) (1 == I# $compressedE) $(bytestringLazyE ct') |] where locE = litE $ stringL $ T.unpack loc (compressed, ct') = tryCompress mime ct compressedE = litE $ intPrimL $ if compressed then 1 else 0 mkEntry (EmbeddableEntry loc mime (Right expr)) = [| Right $ ReloadEntry (T.pack $locE) $(bytestringE mime) $expr |] where locE = litE $ stringL $ T.unpack loc -- | Converts an embedded entry to a file embeddedToFile :: EmbeddedEntry -> File embeddedToFile entry = File { fileGetSize = fromIntegral $ B.length $ embContent entry , fileToResponse = \s h -> let h' = if embCompressed entry then h ++ [("Content-Encoding", "gzip")] else h in W.responseBuilder s h' $ byteStringInsert $ embContent entry -- Usually the fileName should just be the filename not the entire path, -- but we need the whole path to make the lookup within lookupMime -- possible. lookupMime is provided only with the File and from that -- we must find the mime type. Putting the path here is OK since -- within staticApp the fileName is used for directory listings which -- we have disabled. , fileName = unsafeToPiece $ embLocation entry , fileGetHash = return $ if B.null (embEtag entry) then Nothing else Just $ embEtag entry , fileGetModified = Nothing } -- | Converts a reload entry to a file reloadToFile :: ReloadEntry -> IO File reloadToFile entry = do (etag, ct) <- reloadContent entry let etag' = T.encodeUtf8 etag return $ File { fileGetSize = fromIntegral $ BL.length ct , fileToResponse = \s h -> W.responseLBS s h ct -- Similar to above the entire path needs to be in the fileName. , fileName = unsafeToPiece $ reloadLocation entry , fileGetHash = return $ if T.null etag then Nothing else Just etag' , fileGetModified = Nothing } -- | Build a static settings based on a filemap. filemapToSettings :: M.HashMap T.Text (MimeType, IO File) -> StaticSettings filemapToSettings mfiles = (defaultWebAppSettings "") { ssLookupFile = lookupFile , ssGetMimeType = lookupMime } where piecesToFile p = T.intercalate "/" $ map fromPiece p lookupFile [] = return LRNotFound lookupFile p = case M.lookup (piecesToFile p) mfiles of Nothing -> return LRNotFound Just (_,act) -> LRFile <$> act lookupMime (File { fileName = p }) = case M.lookup (fromPiece p) mfiles of Just (mime,_) -> return mime Nothing -> return $ defaultMimeLookup $ fromPiece p -- | Create a 'StaticSettings' from a list of entries. Executed at run time. entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings entriesToSt entries = hmap `seq` filemapToSettings hmap where embFiles = [ (embLocation e, (embMime e, return $ embeddedToFile e)) | e <- lefts entries] reloadFiles = [ (reloadLocation r, (reloadMime r, reloadToFile r)) | r <- rights entries] hmap = M.fromList $ embFiles ++ reloadFiles -- | Create a 'StaticSettings' at compile time that embeds resources directly into the compiled -- executable. The embedded resources are precompressed (depending on mime type) -- so that during runtime the resource can be served very quickly. -- -- Because of GHC Template Haskell stage restrictions, you must define -- the entries in a different module than where you create the 'StaticSettings'. -- For example, -- -- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} -- > module A (mkEmbedded) where -- > -- > import WaiAppStatic.Storage.Embedded -- > import Crypto.Hash.MD5 (hashlazy) -- > import qualified Data.ByteString.Lazy as BL -- > import qualified Data.ByteString.Base64 as B64 -- > import qualified Data.Text as T -- > import qualified Data.Text.Encoding as T -- > -- > hash :: BL.ByteString -> T.Text -- > hash = T.take 8 . T.decodeUtf8 . B64.encode . hashlazy -- > -- > mkEmbedded :: IO [EmbeddableEntry] -- > mkEmbedded = do -- > file <- BL.readFile "test.css" -- > let emb = EmbeddableEntry { -- > eLocation = "somedir/test.css" -- > , eMimeType = "text/css" -- > , eContent = Left (hash file, file) -- > } -- > -- > let reload = EmbeddableEntry { -- > eLocation = "anotherdir/test2.txt" -- > , eMimeType = "text/plain" -- > , eContent = Right [| BL.readFile "test2.txt" >>= \c -> return (hash c, c) |] -- > } -- > -- > return [emb, reload] -- -- The above @mkEmbedded@ will be executed at compile time. It loads the contents of test.css and -- computes the hash of test.css for the etag. The content will be available at the URL somedir/test.css. -- Internally, 'embedApp' below will attempt to compress the content at compile time. The compression will -- only happen if the compressed content is shorter than the original and the mime type is either text or -- javascript. If the content is compressed, at runtime the precomputed compressed content will be served -- with the appropriate HTTP header. If 'embedApp' decides not to compress the content, it will be -- served directly. -- -- Secondly, @mkEmbedded@ creates a reloadable entry. This will be available at the URL anotherdir/test2.txt. -- Whenver a request comes in for anotherdir/test2.txt, the action inside the quasiquote in eContent will -- be executed. This will re-read the test2.txt file and recompute its hash. -- -- Finally, here is a module which uses the above action to create a 'W.Application'. -- -- > {-# LANGUAGE TemplateHaskell #-} -- > module B where -- > -- > import A -- > import Network.Wai (Application) -- > import Network.Wai.Application.Static (staticApp) -- > import WaiAppStatic.Storage.Embedded -- > import Network.Wai.Handler.Warp (run) -- > -- > myApp :: Application -- > myApp = staticApp $(mkSettings mkEmbedded) -- > -- > main :: IO () -- > main = run 3000 myApp mkSettings :: IO [EmbeddableEntry] -> ExpQ mkSettings action = do entries <- runIO action [| entriesToSt $(listE $ map mkEntry entries) |] shouldCompress :: MimeType -> Bool shouldCompress m = "text/" `B.isPrefixOf` m || m `elem` extra where extra = [ "application/json" , "application/javascript" , "application/ecmascript" ] -- | Only compress if the mime type is correct and the compressed text is actually shorter. tryCompress :: MimeType -> BL.ByteString -> (Bool, BL.ByteString) tryCompress mime ct | shouldCompress mime = (c, ct') | otherwise = (False, ct) where compressed = compress ct c = BL.length compressed < BL.length ct ct' = if c then compressed else ct wai-app-static-3.1.7.1/app/warp-static.hs0000644000000000000000000000025412620000372016235 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} module Main (main) where import WaiAppStatic.CmdLine (runCommandLine) main :: IO () main = runCommandLine (const id) wai-app-static-3.1.7.1/tests.hs0000644000000000000000000000020312620000372014353 0ustar0000000000000000import WaiAppStaticTest (spec) import WaiAppEmbeddedTest (embSpec) import Test.Hspec main :: IO () main = hspec $ spec >> embSpec wai-app-static-3.1.7.1/LICENSE0000644000000000000000000000207512620000372013673 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. wai-app-static-3.1.7.1/Setup.lhs0000755000000000000000000000016212620000372014474 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-app-static-3.1.7.1/wai-app-static.cabal0000644000000000000000000000757713607523665016536 0ustar0000000000000000name: wai-app-static version: 3.1.7.1 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman , Greg Weber synopsis: WAI application for static serving description: API docs and the README are available at . category: Web, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/web-application-interface Extra-source-files: images/folder.png images/haskell.png test/*.hs test/a/b tests.hs README.md ChangeLog.md Flag print Description: print debug info Default: False library build-depends: base >= 4 && < 5 , wai >= 3.0 && < 3.3 , bytestring >= 0.10.4 , http-types >= 0.7 , transformers >= 0.2.2 , unix-compat >= 0.2 , directory >= 1.0.1 , containers >= 0.2 , time >= 1.1.4 , old-locale >= 1.0.0.2 , file-embed >= 0.0.3.1 , text >= 0.7 , cryptonite >= 0.6 , memory >= 0.7 , http-date , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , mime-types >= 0.1 && < 0.2 , unordered-containers >= 0.2 , template-haskell >= 2.7 , zlib >= 0.5 , filepath , wai-extra >= 3.0 && < 3.1 , optparse-applicative >= 0.7 , warp >= 3.0.11 && < 3.4 exposed-modules: Network.Wai.Application.Static WaiAppStatic.Storage.Filesystem WaiAppStatic.Storage.Embedded WaiAppStatic.Listing WaiAppStatic.Types WaiAppStatic.CmdLine other-modules: Util WaiAppStatic.Storage.Embedded.Runtime WaiAppStatic.Storage.Embedded.TH ghc-options: -Wall extensions: CPP if flag(print) cpp-options: -DPRINT Executable warp Main-is: warp-static.hs hs-source-dirs: app Build-depends: base >= 4 && < 5 , wai-app-static , directory >= 1.0 , containers >= 0.2 , bytestring >= 0.10.4 , text >= 0.7 , mime-types >= 0.1 && < 0.2 test-suite runtests hs-source-dirs: test main-is: ../tests.hs type: exitcode-stdio-1.0 build-depends: base >= 4 && < 5 , hspec >= 1.3 , unix-compat , time , old-locale , http-date , wai-app-static , wai-extra , wai , http-types , network , bytestring , text , transformers , mime-types , zlib , filepath , temporary , mockery -- , containers ghc-options: -Wall source-repository head type: git location: git://github.com/yesodweb/wai.git wai-app-static-3.1.7.1/images/folder.png0000644000000000000000000000157312620000372016116 0ustar0000000000000000PNG  IHDRDsBIT|d pHYs|StEXtSoftwarewww.inkscape.org<tEXtTitleFolder Icon^8;YtEXtAuthorJakub Steiner/!tEXtSourcehttp://jimmac.musichall.czif^ItEXtCopyrightPublic Domain http://creativecommons.org/licenses/publicdomain/Y9IDAT8n1%!IQhyD&B)(IC Dd/{(.\r\زbfloo]]]13̌3u]677 7l{9S U>. .:n("+֑sND9G]^#))ب뚢((, Uc\N.CUU|]#&:b3HA *Pn>{׍0mƥ%R4$K}hc;0*Ux{]Di)45 N^"h/&#4DG6$z3m)Ѿ %CsFdsMS>LM7fW&&S`!uQ($$s 4`Ɠ)0TR$!^h?Lf׻h|^zT 9\Q>*x4p"w  A3AmnD5b&

Y|iTw;nXuwh!߾oV+7Ƹq+ igHR!\efn+j $}$RT͋\ [^֨R$&R@n2Y)/dx=m/ OILbl qzҙ*jj Jh8aEgO9F]EQ}?aae H{ʯT*N0~Y^_3|\*b4`10"8?.Ir?V/ry +vF_ƙOg7HD[^5'#ir۰YԙsvĢHr&4HIENDB`wai-app-static-3.1.7.1/test/WaiAppStaticTest.hs0000644000000000000000000001601113607523656017412 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-} module WaiAppStaticTest (spec) where import Network.Wai.Application.Static import WaiAppStatic.Types import Test.Hspec import Test.Mockery.Directory import qualified Data.ByteString.Char8 as S8 -- import qualified Data.ByteString.Lazy.Char8 as L8 import System.PosixCompat.Files (getFileStatus, modificationTime) import System.FilePath import System.IO.Temp import Network.HTTP.Date import Network.HTTP.Types (status500) {-import System.Locale (defaultTimeLocale)-} {-import Data.Time.Format (formatTime)-} import Network.Wai import Network.Wai.Test import Control.Monad.IO.Class (liftIO) import Network.Mime defRequest :: Request defRequest = defaultRequest spec :: Spec spec = do let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test" let fileServerAppWithSettings settings = flip runSession $ staticApp settings let fileServerApp = fileServerAppWithSettings (defaultFileServerSettings "test") { ssAddTrailingSlash = True } let etag = "1B2M2Y8AsgTpgAmY7PhCfg==" let file = "a/b" let statFile = setRawPathInfo defRequest file describe "mime types" $ do it "fileNameExtensions" $ fileNameExtensions "foo.tar.gz" `shouldBe` ["tar.gz", "gz"] it "handles multi-extensions" $ defaultMimeLookup "foo.tar.gz" `shouldBe` "application/x-tgz" it "defaults correctly" $ defaultMimeLookup "foo.unknown" `shouldBe` "application/octet-stream" describe "webApp" $ do it "403 for unsafe paths" $ webApp $ flip mapM_ ["..", "."] $ \path -> assertStatus 403 =<< request (setRawPathInfo defRequest path) it "200 for hidden paths" $ webApp $ flip mapM_ [".hidden/folder.png", ".hidden/haskell.png"] $ \path -> assertStatus 200 =<< request (setRawPathInfo defRequest path) it "404 for non-existent files" $ webApp $ assertStatus 404 =<< request (setRawPathInfo defRequest "doesNotExist") it "302 redirect when multiple slashes" $ webApp $ do req <- request (setRawPathInfo defRequest "a//b/c") assertStatus 302 req assertHeader "Location" "../../a/b/c" req let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") { ssMkRedirect = \_ u -> S8.append "http://www.example.com" u } it "302 redirect when multiple slashes" $ absoluteApp $ flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do req <- request (setRawPathInfo defRequest path) assertStatus 302 req assertHeader "Location" "http://www.example.com/a/b/c" req describe "webApp when requesting a static asset" $ do it "200 and etag when no etag query parameters" $ webApp $ do req <- request statFile assertStatus 200 req assertHeader "ETag" etag req assertNoHeader "Last-Modified" req it "Cache-Control set when etag parameter is correct" $ webApp $ do req <- request statFile { queryString = [("etag", Just etag)] } assertStatus 200 req assertHeader "Cache-Control" "public, max-age=31536000" req assertNoHeader "Last-Modified" req it "200 when invalid in-none-match sent" $ webApp $ flip mapM_ ["cached", ""] $ \badETag -> do req <- request statFile { requestHeaders = [("If-None-Match", badETag)] } assertStatus 200 req assertHeader "ETag" etag req assertNoHeader "Last-Modified" req it "304 when valid if-none-match sent" $ webApp $ do req <- request statFile { requestHeaders = [("If-None-Match", etag)] } assertStatus 304 req assertNoHeader "Etag" req assertNoHeader "Last-Modified" req describe "fileServerApp" $ do let fileDate = do stat <- liftIO $ getFileStatus $ "test/" ++ file return $ formatHTTPDate . epochTimeToHTTPDate $ modificationTime stat it "directory listing for index" $ fileServerApp $ do resp <- request (setRawPathInfo defRequest "a/") assertStatus 200 resp -- note the unclosed img tags so both /> and > will pass assertBodyContains "\"Folder\""b" resp it "200 when invalid if-modified-since header" $ fileServerApp $ do flip mapM_ ["123", ""] $ \badDate -> do req <- request statFile { requestHeaders = [("If-Modified-Since", badDate)] } assertStatus 200 req fdate <- fileDate assertHeader "Last-Modified" fdate req it "304 when if-modified-since matches" $ fileServerApp $ do fdate <- fileDate req <- request statFile { requestHeaders = [("If-Modified-Since", fdate)] } assertStatus 304 req assertNoHeader "Cache-Control" req context "302 redirect to add a trailing slash on directories if missing" $ do it "works at the root" $ fileServerApp $ do req <- request (setRawPathInfo defRequest "/a") assertStatus 302 req assertHeader "Location" "/a/" req it "works when an index.html is delivered" $ do let settings = (defaultFileServerSettings "."){ ssAddTrailingSlash = True } inTempDirectory $ fileServerAppWithSettings settings $ do liftIO $ touch "foo/index.html" req <- request (setRawPathInfo defRequest "/foo") assertStatus 302 req assertHeader "Location" "/foo/" req let urlMapApp = flip runSession $ \req send -> case pathInfo req of "subPath":rest -> let req' = req { pathInfo = rest } in (staticApp (defaultFileServerSettings "test") { ssAddTrailingSlash = True }) req' send _ -> send $ responseLBS status500 [] "urlMapApp: only works at subPath" it "works with subpath at the root of the file server" $ urlMapApp $ do req <- request (setRawPathInfo defRequest "/subPath") assertStatus 302 req assertHeader "Location" "/subPath/" req context "with defaultWebAppSettings" $ do it "ssIndices works" $ do withSystemTempDirectory "wai-app-static-test" $ \ dir -> do writeFile (dir "index.html") "foo" let testSettings = (defaultWebAppSettings dir) { ssIndices = [unsafeToPiece "index.html"] } fileServerAppWithSettings testSettings $ do resp <- request (setRawPathInfo defRequest "/") assertStatus 200 resp assertBody "foo" resp context "with defaultFileServerSettings" $ do it "prefers ssIndices over ssListing" $ do withSystemTempDirectory "wai-app-static-test" $ \ dir -> do writeFile (dir "index.html") "foo" let testSettings = defaultFileServerSettings dir fileServerAppWithSettings testSettings $ do resp <- request (setRawPathInfo defRequest "/") assertStatus 200 resp assertBody "foo" resp wai-app-static-3.1.7.1/test/WaiAppEmbeddedTest.hs0000644000000000000000000000721513114006440017636 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} module WaiAppEmbeddedTest (embSpec) where import Codec.Compression.GZip (compress) import EmbeddedTestEntries import Network.Wai import Network.Wai.Application.Static (staticApp) import Network.Wai.Test import Test.Hspec import WaiAppStatic.Storage.Embedded import WaiAppStatic.Types defRequest :: Request defRequest = defaultRequest embSpec :: Spec embSpec = do let embedSettings settings = flip runSession (staticApp settings) let embed = embedSettings $(mkSettings mkEntries) describe "embedded, compressed entry" $ do it "served correctly" $ embed $ do req <- request (setRawPathInfo defRequest "e1.txt") assertStatus 200 req assertHeader "Content-Type" "text/plain" req assertHeader "Content-Encoding" "gzip" req assertHeader "ETag" "Etag 1" req assertNoHeader "Last-Modified req" req assertBody (compress $ body 1000 'A') req it "304 when valid if-none-match sent" $ embed $ do req <- request (setRawPathInfo defRequest "e1.txt") { requestHeaders = [("If-None-Match", "Etag 1")] } assertStatus 304 req it "ssIndices works" $ do let testSettings = $(mkSettings mkEntries){ ssIndices = [unsafeToPiece "index.html"] } embedSettings testSettings $ do req <- request defRequest assertStatus 200 req assertBody "index file" req it "ssIndices works with trailing slashes" $ do let testSettings = $(mkSettings mkEntries){ ssIndices = [unsafeToPiece "index.html"] } embedSettings testSettings $ do req <- request (setRawPathInfo defRequest "/foo/") assertStatus 200 req assertBody "index file in subdir" req describe "embedded, uncompressed entry" $ do it "too short" $ embed $ do req <- request (setRawPathInfo defRequest "e2.txt") assertStatus 200 req assertHeader "Content-Type" "text/plain" req assertNoHeader "Content-Encoding" req assertHeader "ETag" "Etag 2" req assertBody "ABC" req it "wrong mime" $ embed $ do req <- request (setRawPathInfo defRequest "somedir/e3.txt") assertStatus 200 req assertHeader "Content-Type" "xxx" req assertNoHeader "Content-Encoding" req assertHeader "ETag" "Etag 3" req assertBody (body 1000 'A') req describe "reloadable entry" $ it "served correctly" $ embed $ do req <- request (setRawPathInfo defRequest "e4.css") assertStatus 200 req assertHeader "Content-Type" "text/css" req assertNoHeader "Content-Encoding" req assertHeader "ETag" "Etag 4" req assertBody (body 2000 'Q') req describe "entries without etags" $ do it "embedded entry" $ embed $ do req <- request (setRawPathInfo defRequest "e5.txt") assertStatus 200 req assertHeader "Content-Type" "text/plain" req assertHeader "Content-Encoding" "gzip" req assertNoHeader "ETag" req assertBody (compress $ body 1000 'Z') req it "reload entry" $ embed $ do req <- request (setRawPathInfo defRequest "e6.txt") assertStatus 200 req assertHeader "Content-Type" "text/plain" req assertNoHeader "Content-Encoding" req assertNoHeader "ETag" req assertBody (body 1000 'W') req wai-app-static-3.1.7.1/test/EmbeddedTestEntries.hs0000644000000000000000000000335313114006440020065 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} module EmbeddedTestEntries where import WaiAppStatic.Storage.Embedded import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.ByteString.Lazy as BL body :: Int -> Char -> BL.ByteString body i c = TL.encodeUtf8 $ TL.pack $ take i $ repeat c mkEntries :: IO [EmbeddableEntry] mkEntries = return -- An entry that should be compressed [ EmbeddableEntry "e1.txt" "text/plain" (Left ("Etag 1", body 1000 'A')) -- An entry so short that the compressed text is longer , EmbeddableEntry "e2.txt" "text/plain" (Left ("Etag 2", "ABC")) -- An entry that is not compressed because of the mime , EmbeddableEntry "somedir/e3.txt" "xxx" (Left ("Etag 3", body 1000 'A')) -- A reloadable entry , EmbeddableEntry "e4.css" "text/css" (Right [| return ("Etag 4" :: T.Text, body 2000 'Q') |]) -- An entry without etag , EmbeddableEntry "e5.txt" "text/plain" (Left ("", body 1000 'Z')) -- A reloadable entry without etag , EmbeddableEntry "e6.txt" "text/plain" (Right [| return ("" :: T.Text, body 1000 'W') |] ) -- An index file , EmbeddableEntry "index.html" "text/html" (Right [| return ("" :: T.Text, "index file") |] ) -- An index file in a subdir , EmbeddableEntry "foo/index.html" "text/html" (Right [| return ("" :: T.Text, "index file in subdir") |] ) ] wai-app-static-3.1.7.1/test/a/b0000644000000000000000000000000012620000372014213 0ustar0000000000000000wai-app-static-3.1.7.1/README.md0000644000000000000000000000020112620000372014132 0ustar0000000000000000## wai-app-static WAI application for static serving Also provides some helper functions and datatypes for use outside of WAI. wai-app-static-3.1.7.1/ChangeLog.md0000644000000000000000000000274013607523674015063 0ustar0000000000000000# wai-app-static changelog ## 3.1.7.1 * Update the test suite too ## 3.1.7 * Use 302 instead of 301 redirect, to avoid caching the presence of an index.html file ## 3.1.6.3 * The executable warp obeys `-h` option properly for host now. Previously this used to invoke the help option. That can be reached via `--help` as before. ## 3.1.6.2 * Drop dependency on blaze-builder ## 3.1.6.1 * Add `<>` import ## 3.1.6 * Make ssAddTrailingSlash work in combination with ssIndices [#569](https://github.com/yesodweb/wai/pull/569) * Make ssIndices work with ssLookupFile and trailing slashes [#570](https://github.com/yesodweb/wai/pull/570) ## 3.1.5 * Switch to cryponite ## 3.1.4.1 * Support wai/warp 3.2 ## 3.1.4 * Reinstate redirectToIndex ## 3.1.3 * Add 404 handler [#467](https://github.com/yesodweb/wai/pull/467) ## 3.1.2 * Honor ssIndices when used with defaultWebAppSettings [#460](https://github.com/yesodweb/wai/pull/460) ## 3.1.1 * Make adding a trailing slash optional [#327](https://github.com/yesodweb/wai/issues/327) [yesod#988](https://github.com/yesodweb/yesod/issues/988) ## 3.1.0 * Drop system-filepath ## 3.0.1.1 * Fix root links ## 3.0.1 * Better HEAD support [#354](https://github.com/yesodweb/wai/issues/354) ## 3.0.0.6 Fix trailing slashes for `UrlMap` and other non-root setups [#325](https://github.com/yesodweb/wai/issues/325) ## 3.0.0.4 Add missing trailing slashes [#312](https://github.com/yesodweb/wai/issues/312) ## 3.0.0.3 Support for time 1.5