wai-app-static-3.1.9/Network/0000755000000000000000000000000014445727313014200 5ustar0000000000000000wai-app-static-3.1.9/Network/Wai/0000755000000000000000000000000014445727313014720 5ustar0000000000000000wai-app-static-3.1.9/Network/Wai/Application/0000755000000000000000000000000014571305463017161 5ustar0000000000000000wai-app-static-3.1.9/WaiAppStatic/0000755000000000000000000000000014571305463015076 5ustar0000000000000000wai-app-static-3.1.9/WaiAppStatic/Storage/0000755000000000000000000000000014571305463016502 5ustar0000000000000000wai-app-static-3.1.9/WaiAppStatic/Storage/Embedded/0000755000000000000000000000000014571305463020173 5ustar0000000000000000wai-app-static-3.1.9/app/0000755000000000000000000000000014445727313013327 5ustar0000000000000000wai-app-static-3.1.9/images/0000755000000000000000000000000014445727313014014 5ustar0000000000000000wai-app-static-3.1.9/test/0000755000000000000000000000000014571305463013524 5ustar0000000000000000wai-app-static-3.1.9/test/a/0000755000000000000000000000000014445727313013746 5ustar0000000000000000wai-app-static-3.1.9/Network/Wai/Application/Static.hs0000644000000000000000000003075614571305463020757 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- | 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 Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () import qualified Network.HTTP.Types as H import qualified Network.Wai as W import Prelude hiding (FilePath) import Data.ByteString.Builder (toLazyByteString) import Data.FileEmbed (embedFile, makeRelativeToProject) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Network.HTTP.Date (epochTimeToHTTPDate, formatHTTPDate, parseHTTPDate) import Network.Mime (MimeType) import Util import WaiAppStatic.Storage.Embedded import WaiAppStatic.Storage.Filesystem import WaiAppStatic.Types 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 = 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 -- FIXME: Doesn't support multiple hashes in 'If-None-Match' header 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. -- -- RFC7232 (HTTP 1.1): -- > A recipient MUST ignore If-Modified-Since if the request contains an -- > If-None-Match header field; the condition in If-None-Match is -- > considered to be a more accurate replacement for the condition in -- > If-Modified-Since, and the two are only combined for the sake of -- > interoperating with older intermediaries that might not implement -- > If-None-Match. (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 oneYear :: Int oneYear = 60 * 60 * 24 * 365 maxAgeValue i = S8.append "public, max-age=" $ S8.pack $ show i headerCacheControl = case maxage of NoMaxAge -> id MaxAgeSeconds i -> (:) ("Cache-Control", maxAgeValue i) MaxAgeForever -> (:) ("Cache-Control", maxAgeValue oneYear) NoStore -> (:) ("Cache-Control", "no-store") NoCache -> (:) ("Cache-Control", "no-cache") headerExpires = case maxage of NoMaxAge -> id MaxAgeSeconds _ -> id -- FIXME MaxAgeForever -> (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT") NoStore -> id NoCache -> id -- | 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 [$(makeRelativeToProject "images/folder.png" >>= embedFile)] staticAppPieces _ [".hidden", "haskell.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(makeRelativeToProject "images/haskell.png" >>= embedFile)] 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.9/WaiAppStatic/Storage/Filesystem.hs0000644000000000000000000001543614571305463021173 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Access files on the filesystem. module WaiAppStatic.Storage.Filesystem ( -- * Types ETagLookup, -- * Settings defaultWebAppSettings, defaultFileServerSettings, webAppSettingsWithLookup, ) where import Control.Exception (SomeException, try) import Control.Monad (forM) import Data.ByteString (ByteString) import Data.List (foldl') import Data.Maybe (catMaybes) import Network.Mime import qualified Network.Wai as W import System.Directory ( doesDirectoryExist, doesFileExist, getDirectoryContents, ) import System.FilePath (()) import System.IO (IOMode (..), withBinaryFile) import System.PosixCompat.Files ( fileSize, getFileStatus, isRegularFile, modificationTime, ) import Util import WaiAppStatic.Listing import WaiAppStatic.Types #ifdef MIN_VERSION_crypton import Data.ByteArray.Encoding import Crypto.Hash (hashlazy, MD5, Digest) #else import Data.ByteString.Base64 (encode) import Crypto.Hash.MD5 (hashlazy) #endif 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 #ifdef MIN_VERSION_crypton let !hash = hashlazy f :: Digest MD5 return $ convertToBase Base64 hash #else let !hash = hashlazy f return . encode $ hash #endif 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.9/WaiAppStatic/Storage/Embedded.hs0000644000000000000000000000037114571305463020530 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.9/WaiAppStatic/Listing.hs0000644000000000000000000001622114571305463017045 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module WaiAppStatic.Listing ( defaultListing, ) where import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Text.Blaze ((!)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A 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 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.9/WaiAppStatic/Types.hs0000644000000000000000000001242314571305463016540 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.ByteString (ByteString) import Data.ByteString.Builder (Builder) import Data.Text (Text) import qualified Data.Text as T import qualified Network.HTTP.Types as H import Network.Mime (MimeType) import qualified Network.Wai as W import System.Posix.Types (EpochTime) -- | 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@. -- -- The root path is the empty list. type Pieces = [Piece] -- | Values for the max-age component of the cache-control response header. data MaxAge = -- | no cache-control set NoMaxAge | -- | set to the given number of seconds MaxAgeSeconds Int | -- | essentially infinite caching; in reality, probably one year MaxAgeForever | -- | set cache-control to no-store @since 3.1.8 NoStore | -- | set cache-control to no-cache @since 3.1.9 NoCache -- | 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 { fileGetSize :: Integer -- ^ Size of file in bytes , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response -- ^ 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@. , fileName :: Piece -- ^ Last component of the filename. , fileGetHash :: IO (Maybe ByteString) -- ^ Calculate a hash of the contents of this file, such as for etag. , fileGetModified :: Maybe EpochTime -- ^ Last modified time, used for both display in listings and if-modified-since. } -- | 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 { ssLookupFile :: Pieces -> IO LookupResult -- ^ Lookup a single file or folder. This is how you can control storage -- backend (filesystem, embedded, etc) and where to lookup. , ssGetMimeType :: File -> IO MimeType -- ^ 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. , ssIndices :: [Piece] -- ^ 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. , ssListing :: Maybe Listing -- ^ How to perform a directory listing. Optional. Will be used when the -- user requested a folder. , ssMaxAge :: MaxAge -- ^ Value to provide for max age in the cache-control. , ssMkRedirect :: Pieces -> ByteString -> ByteString -- ^ Given a requested path and a new destination, construct a string -- that will go there. Default implementation will use relative paths. , ssRedirectToIndex :: Bool -- ^ 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. , ssUseHash :: Bool -- ^ Prefer usage of etag caching to last-modified caching. , ssAddTrailingSlash :: Bool -- ^ Force a trailing slash at the end of directories , ss404Handler :: Maybe W.Application -- ^ Optional `W.Application` to be used in case of 404 errors -- -- Since 3.1.3 } wai-app-static-3.1.9/WaiAppStatic/CmdLine.hs0000644000000000000000000001074614571305463016755 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- | Command line version of wai-app-static, used for the warp-static server. module WaiAppStatic.CmdLine ( runCommandLine, Args (..), ) where import Control.Arrow (second, (***)) import Control.Monad (unless) import qualified Data.ByteString.Char8 as S8 import qualified Data.Map as Map import Data.Maybe (mapMaybe) import Data.String (fromString) import Data.Text (pack) import Network.Mime (defaultMimeMap, defaultMimeType, mimeByExt) import Network.Wai (Middleware) import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) import Network.Wai.Handler.Warp ( defaultSettings, runSettings, setHost, setPort, ) import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.RequestLogger (logStdout) import Options.Applicative import System.Directory (canonicalizePath) import Text.Printf (printf) import WaiAppStatic.Types ( fileName, fromPiece, ssGetMimeType, ssIndices, toPiece, ) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>)) #endif 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' :: Mod OptionFields Int -> Parser Int 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 clArgs@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 clArgs 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 = #if MIN_VERSION_optparse_applicative(0,16,0) abortOption (ShowHelpText Nothing) $ #else abortOption ShowHelpText $ #endif mconcat [long "help", help "Show this help text", hidden] wai-app-static-3.1.9/Util.hs0000644000000000000000000000267714571305463014032 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Util ( relativeDirFromPieces, defaultMkRedirect, replace, remove, dropLastIfNull, ) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.Text as T import qualified Data.Text.Encoding as TE import WaiAppStatic.Types -- 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.9/WaiAppStatic/Storage/Embedded/Runtime.hs0000644000000000000000000000732414571305463022160 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Lookup files stored in memory instead of from the filesystem. module WaiAppStatic.Storage.Embedded.Runtime ( -- * Settings embeddedSettings, ) where import Control.Arrow (second, (&&&)) import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString) import Data.Function (on) import Data.List (groupBy, sortBy) import qualified Data.Map as Map import Data.Ord import qualified Data.Text as T import qualified Network.Wai as W import WaiAppStatic.Types #ifdef MIN_VERSION_crypton import Crypto.Hash (hash, MD5, Digest) import Data.ByteArray.Encoding #else import Crypto.Hash.MD5 (hash) import Data.ByteString.Base64 (encode) #endif import System.FilePath (isPathSeparator) import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings) -- | 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 $ fmap 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 = fmap (\(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 #ifdef MIN_VERSION_crypton runHash = convertToBase Base64 . (hash :: S.ByteString -> Digest MD5) #else runHash = encode . hash #endif wai-app-static-3.1.9/WaiAppStatic/Storage/Embedded/TH.hs0000644000000000000000000002641714571305463021054 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module WaiAppStatic.Storage.Embedded.TH ( Etag, EmbeddableEntry (..), mkSettings, ) where import Codec.Compression.GZip (compress) import qualified Data.ByteString as B import Data.ByteString.Builder.Extra (byteStringInsert) import qualified Data.ByteString.Lazy as BL 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.Storage.Filesystem (defaultWebAppSettings) import WaiAppStatic.Types #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.9/app/warp-static.hs0000644000000000000000000000016714445727313016125 0ustar0000000000000000module Main (main) where import WaiAppStatic.CmdLine (runCommandLine) main :: IO () main = runCommandLine (const id) wai-app-static-3.1.9/tests.hs0000644000000000000000000000020314571305463014236 0ustar0000000000000000import Test.Hspec import WaiAppEmbeddedTest (embSpec) import WaiAppStaticTest (spec) main :: IO () main = hspec $ spec >> embSpec wai-app-static-3.1.9/test/EmbeddedTestEntries.hs0000644000000000000000000000347314571305463017752 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module EmbeddedTestEntries where import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import WaiAppStatic.Storage.Embedded body :: Int -> Char -> BL.ByteString body i c = TL.encodeUtf8 $ TL.pack $ replicate i 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.9/test/WaiAppEmbeddedTest.hs0000644000000000000000000000750714571305463017524 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} 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.9/test/WaiAppStaticTest.hs0000644000000000000000000002116214571305463017253 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} module WaiAppStaticTest (spec) where import Network.Wai.Application.Static import WaiAppStatic.Types import qualified Data.ByteString.Char8 as S8 import Test.Hspec import Test.Mockery.Directory -- import qualified Data.ByteString.Lazy.Char8 as L8 import System.FilePath import System.IO.Temp import System.PosixCompat.Files (getFileStatus, modificationTime) 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 (forM_) 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 $ forM_ ["..", "."] $ \path -> assertStatus 403 =<< request (setRawPathInfo defRequest path) it "200 for hidden paths" $ webApp $ forM_ [".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 $ forM_ ["/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 $ forM_ ["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 forM_ ["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.9/images/folder.png0000644000000000000000000000157314445727313016003 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.9/test/a/b0000644000000000000000000000000014445727313014100 0ustar0000000000000000wai-app-static-3.1.9/README.md0000644000000000000000000000020114445727313014017 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.9/ChangeLog.md0000644000000000000000000000410314571305463014714 0ustar0000000000000000# wai-app-static changelog ## 3.1.9 * Added `NoCache` constructor to `MaxAge` [#977](https://github.com/yesodweb/wai/pull/977) ## 3.1.8 * Added `NoStore` constructor to `MaxAge` [#938](https://github.com/yesodweb/wai/pull/938) ## 3.1.7.5 * Removed dependency of `time`, `old-locale` and `network` [#902](https://github.com/yesodweb/wai/pull/902) ## 3.1.7.4 * Fix a bug when the cryptonite flag is disabled. [#874](https://github.com/yesodweb/wai/pull/874) ## 3.1.7.3 * Introduce a flag to avoid the cryptonite dependency. [#871](https://github.com/yesodweb/wai/pull/871) ## 3.1.7.2 * `optparse-applicative-0.16.0.0` support ## 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 wai-app-static-3.1.9/LICENSE0000644000000000000000000000207514445727313013560 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.9/Setup.lhs0000755000000000000000000000016214445727313014361 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-app-static-3.1.9/wai-app-static.cabal0000644000000000000000000000772514571305463016367 0ustar0000000000000000name: wai-app-static version: 3.1.9 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.10 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 Flag crypton Description: Use the crypton library for MD5 computation Default: True library default-language: Haskell2010 build-depends: base >= 4.12 && < 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 , 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.2 , optparse-applicative >= 0.7 , warp >= 3.0.11 && < 3.5 if flag(crypton) build-depends: crypton >= 0.6 , memory >= 0.7 else build-depends: base64-bytestring >= 0.1 , cryptohash-md5 >= 0.11.101 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 if flag(print) cpp-options: -DPRINT Executable warp default-language: Haskell2010 Main-is: warp-static.hs hs-source-dirs: app Build-depends: base >= 4 && < 5 , wai-app-static test-suite runtests default-language: Haskell2010 hs-source-dirs: test other-modules: EmbeddedTestEntries , WaiAppEmbeddedTest , WaiAppStaticTest main-is: ../tests.hs type: exitcode-stdio-1.0 build-depends: base >= 4 && < 5 , hspec >= 1.3 , unix-compat , http-date , wai-app-static , wai-extra , wai , http-types , bytestring , text , transformers , mime-types , zlib , filepath , temporary , mockery ghc-options: -Wall source-repository head type: git location: git://github.com/yesodweb/wai.git