wai-app-static 1.2.0.4 → 1.3.0

raw patch · 8 files changed

+749/−747 lines, 8 filesdep +cerealdep +crypto-conduitdep +mime-typesdep ~blaze-htmldep ~http-typesdep ~waiPVP ok

version bump matches the API change (PVP)

Dependencies added: cereal, crypto-conduit, mime-types, system-fileio, system-filepath

Dependency ranges changed: blaze-html, http-types, wai

API changes (from Hackage documentation)

Files

• Network/Wai/Application/Static.hs +156/−709
• Util.hs +38/−0
• WaiAppStatic/Listing.hs +126/−0
• WaiAppStatic/Storage/Embedded.hs +92/−0
• WaiAppStatic/Storage/Filesystem.hs +166/−0
• WaiAppStatic/Types.hs +144/−0
• test/WaiAppStaticTest.hs +12/−24
• wai-app-static.cabal +15/−14

@@ -1,663 +1,235 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell, CPP #-}+{-# LANGUAGE RecordWildCards #-} -- | Static file serving for WAI. module Network.Wai.Application.Static     ( -- * WAI application       staticApp-      -- ** Settings+      -- ** Default Settings     , defaultWebAppSettings-    , webAppSettingsWithLookup +    , webAppSettingsWithLookup     , defaultFileServerSettings+    , embeddedSettings+      -- ** Settings     , StaticSettings-    , ssFolder+    , ssLookupFile     , ssMkRedirect     , ssGetMimeType     , ssListing     , ssIndices     , ssMaxAge     , ssRedirectToIndex-      -- * Generic, non-WAI code-      -- ** Mime types-    , MimeType-    , defaultMimeType-      -- ** Mime type by file extension-    , Extension-    , MimeMap-    , takeExtensions-    , defaultMimeTypes-    , mimeTypeByExt-    , defaultMimeTypeByExt-      -- ** Finding files-    , Pieces-    , pathFromPieces-      -- ** Directory listings-    , Listing-    , defaultListing-      -- ** Lookup functions-    , fileSystemLookup-    , fileSystemLookupHash-    , embeddedLookup-      -- ** Embedded-    , Embedded-    , EmbeddedEntry (..)-    , toEmbedded-      -- ** Redirecting-    , defaultMkRedirect-      -- * Other data types-    , File (..)-    , FilePath (..)-    , toFilePath-    , fromFilePath-    , MaxAge (..)-    , ETagLookup     ) where  import Prelude hiding (FilePath)-import qualified Prelude import qualified Network.Wai as W import qualified Network.HTTP.Types as H-import Data.Map (Map)-import qualified Data.Map as Map import Data.ByteString (ByteString)-import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 ()-import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)-import System.Posix.Types (EpochTime) import Control.Monad.IO.Class (liftIO)-import qualified Crypto.Hash.MD5 as MD5-import Control.Monad (forM)-import Control.Exception (SomeException, try) -import           Text.Blaze                  ((!))-import qualified Text.Blaze.Html5            as H-#if MIN_VERSION_blaze_html(0,5,0)-import qualified Text.Blaze.Html.Renderer.Utf8 as HU-#else-import qualified Text.Blaze.Renderer.Utf8    as HU-#endif-import qualified Text.Blaze.Html5.Attributes as A--import Blaze.ByteString.Builder (toByteString, fromByteString)--import Data.Time-import Data.Time.Clock.POSIX-import System.Locale (defaultTimeLocale)+import Blaze.ByteString.Builder (toByteString)  import Data.FileEmbed (embedFile)  import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Encoding.Error as TEE -import Control.Arrow ((&&&), second)-import Data.List (groupBy, sortBy, find, foldl')-import Data.Function (on)-import Data.Ord (comparing)-import qualified Data.ByteString.Base64 as B64 import Data.Either (rights)-import Data.Maybe (isJust, fromJust, mapMaybe) import Network.HTTP.Date (parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)-import Data.String (IsString (..))--newtype FilePath = FilePath { unFilePath :: Text }-    deriving (Ord, Eq, Show)-instance IsString FilePath where-    fromString = toFilePath--(</>) :: FilePath -> FilePath -> FilePath-(FilePath a) </> (FilePath b) = FilePath $ T.concat [a, "/", b]---- | A list of all possible extensions, starting from the largest.-takeExtensions :: FilePath -> [FilePath]-takeExtensions (FilePath s) =-    case T.breakOn (".") s of-        (_, "") -> []-        (_, x) -> FilePath (T.drop 1 x) : takeExtensions (FilePath $ T.drop 1 x)--type MimeType = ByteString-type Extension = FilePath-type MimeMap = Map Extension MimeType--defaultMimeType :: MimeType-defaultMimeType = "application/octet-stream"---- taken from snap-core Snap.Util.FileServer-defaultMimeTypes :: MimeMap-defaultMimeTypes = Map.fromList [-  ( "apk"     , "application/vnd.android.package-archive" ),-  ( "asc"     , "text/plain"                        ),-  ( "asf"     , "video/x-ms-asf"                    ),-  ( "asx"     , "video/x-ms-asf"                    ),-  ( "avi"     , "video/x-msvideo"                   ),-  ( "bz2"     , "application/x-bzip"                ),-  ( "c"       , "text/plain"                        ),-  ( "class"   , "application/octet-stream"          ),-  ( "conf"    , "text/plain"                        ),-  ( "cpp"     , "text/plain"                        ),-  ( "css"     , "text/css"                          ),-  ( "cxx"     , "text/plain"                        ),-  ( "dtd"     , "text/xml"                          ),-  ( "dvi"     , "application/x-dvi"                 ),-  ( "epub"    , "application/epub+zip"              ),-  ( "gif"     , "image/gif"                         ),-  ( "gz"      , "application/x-gzip"                ),-  ( "hs"      , "text/plain"                        ),-  ( "htm"     , "text/html"                         ),-  ( "html"    , "text/html"                         ),-  ( "ico"     , "image/vnd.microsoft.icon"          ),-  ( "jar"     , "application/x-java-archive"        ),-  ( "jpeg"    , "image/jpeg"                        ),-  ( "jpg"     , "image/jpeg"                        ),-  ( "js"      , "text/javascript"                   ),-  ( "json"    , "application/json"                  ),-  ( "log"     , "text/plain"                        ),-  ( "manifest", "text/cache-manifest"               ),-  ( "m3u"     , "audio/x-mpegurl"                   ),-  ( "mov"     , "video/quicktime"                   ),-  ( "mp3"     , "audio/mpeg"                        ),-  ( "mpeg"    , "video/mpeg"                        ),-  ( "mpg"     , "video/mpeg"                        ),-  ( "ogg"     , "application/ogg"                   ),-  ( "pac"     , "application/x-ns-proxy-autoconfig" ),-  ( "pdf"     , "application/pdf"                   ),-  ( "png"     , "image/png"                         ),-  ( "bmp"     , "image/bmp"                         ),-  ( "ps"      , "application/postscript"            ),-  ( "qt"      , "video/quicktime"                   ),-  ( "sig"     , "application/pgp-signature"         ),-  ( "spl"     , "application/futuresplash"          ),-  ( "svg"     , "image/svg+xml"                     ),-  ( "swf"     , "application/x-shockwave-flash"     ),-  ( "tar"     , "application/x-tar"                 ),-  ( "tar.bz2" , "application/x-bzip-compressed-tar" ),-  ( "tar.gz"  , "application/x-tgz"                 ),-  ( "tbz"     , "application/x-bzip-compressed-tar" ),-  ( "text"    , "text/plain"                        ),-  ( "tgz"     , "application/x-tgz"                 ),-  ( "torrent" , "application/x-bittorrent"          ),-  ( "ttf"     , "application/x-font-truetype"       ),-  ( "txt"     , "text/plain"                        ),-  ( "wav"     , "audio/x-wav"                       ),-  ( "wax"     , "audio/x-ms-wax"                    ),-  ( "wma"     , "audio/x-ms-wma"                    ),-  ( "wmv"     , "video/x-ms-wmv"                    ),-  ( "xbm"     , "image/x-xbitmap"                   ),-  ( "xhtml"   , "application/xhtml+xml"             ),-  ( "xml"     , "text/xml"                          ),-  ( "xpm"     , "image/x-xpixmap"                   ),-  ( "xwd"     , "image/x-xwindowdump"               ),-  ( "zip"     , "application/zip"                   )]---- similar to Safe package-headDef :: a -> [a] -> a-headDef _ (x:_) = x-headDef def []  = def---- similar to Safe package-initSafe  :: [a] -> [a]-initSafe [] = []-initSafe xs = init xs--mimeTypeByExt :: MimeMap-              -> MimeType -- ^ default mime type-              -> FilePath-              -> MimeType-mimeTypeByExt mm def =-  headDef def . mapMaybe (flip Map.lookup mm) . takeExtensions--defaultMimeTypeByExt :: FilePath -> MimeType-defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType--filterButLast :: (a -> Bool) -> [a] -> [a]-filterButLast _ [] = []-filterButLast _ [x] = [x]-filterButLast f (x:xs)-    | f x = x : filterButLast f xs-    | otherwise = filterButLast f xs---unsafePiece :: FilePath -> Bool-unsafePiece (FilePath s)-    | T.null s = False-    | T.head s == '.' = True-    | otherwise = T.any (== '/') s--nullFilePath :: FilePath -> Bool-nullFilePath = T.null . unFilePath--{--stripTrailingSlash :: FilePath -> FilePath-stripTrailingSlash fp@(FilePath t)-    | T.null t || T.last t /= '/' = fp-    | otherwise = FilePath $ T.init t-    -}--type Pieces = [FilePath]--relativeDirFromPieces :: Pieces -> T.Text-relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir--pathFromPieces :: FilePath -> Pieces -> FilePath-pathFromPieces = foldl' (</>)+import Data.Monoid (First (First, getFirst), mconcat) -checkSpecialDirListing :: Pieces -> Maybe CheckPieces-checkSpecialDirListing [".hidden", "folder.png"]  =-    Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "images/folder.png")]-checkSpecialDirListing [".hidden", "haskell.png"] =-    Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "images/haskell.png")]-checkSpecialDirListing _ =  Nothing+import WaiAppStatic.Types+import Util+import WaiAppStatic.Storage.Filesystem+import WaiAppStatic.Storage.Embedded+import Network.Mime (MimeType) -data CheckPieces =+data StaticResponse =       -- | Just the etag hash or Nothing for no etag hash       Redirect Pieces (Maybe ByteString)-    | Forbidden     | NotFound     | FileResponse File H.ResponseHeaders     | NotModified-    | DirectoryResponse Folder     -- TODO: add file size     | SendContent MimeType L.ByteString--checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function-            -> [FilePath]                -- ^ List of default index files. Cannot contain slashes.-            -> Pieces                    -- ^ parsed request-            -> W.Request-            -> MaxAge-            -> Bool                      -- ^ use hash?-            -> Bool                      -- ^ Redirect to Index?-            -> IO CheckPieces-checkPieces fileLookup indices pieces req maxAge useHash redirectToIndex-    | any unsafePiece pieces = return Forbidden-    | any nullFilePath $ initSafe pieces =-        return $ Redirect (filterButLast (not . nullFilePath) pieces) Nothing-    | otherwise = do-        let (isFile, isFolder) =-              if        null pieces                then (True, True)-                else if nullFilePath (last pieces) then (False, True)-                                                   else (True, False)--        fl <- fileLookup pieces-        case (fl, isFile) of-            (Nothing, _) -> return NotFound-            (Just (Right file), True)  -> handleCache file-            (Just Right{}, False) -> return $ Redirect (init pieces) Nothing-            (Just (Left folder@(Folder _ contents)), _) -> do-                case checkIndices $ map fileName $ rights contents of-                    Just index -> -                      if redirectToIndex then-                        return $ Redirect (setLast pieces index) Nothing-                      else-                        checkPieces fileLookup indices (setLast pieces index) req maxAge useHash redirectToIndex-                    Nothing ->-                        if isFolder-                            then return $ DirectoryResponse folder-                            else return $ Redirect (pieces ++ [""]) Nothing-  where-    headers = W.requestHeaders req-    queryString = W.queryString req--    -- HTTP caching has a cache control header that you can set an expire time for a resource.-    --   Max-Age is easiest because it is a simple number-    --   a cache-control asset will only be downloaded once (if the browser maintains its cache)-    --   and the server will never be contacted for the resource again (until it expires)-    ---    -- A second caching mechanism is ETag and last-modified-    --   this form of caching is not as good as the static- the browser can avoid downloading the file, but it always need to send a request with the etag value or the last-modified value to the server to see if its copy is up to date-    ---    -- We should set a cache control and one of ETag or last-modifed whenever possible-    ---    -- In a Yesod web application we can append an etag parameter to static assets.-    -- This signals that both a max-age and ETag header should be set-    -- if there is no etag parameter-    -- * don't set the max-age-    -- * set ETag or last-modified-    --   * ETag must be calculated ahead of time.-    --   * last-modified is just the file mtime.-    handleCache file =-      if not useHash then lastModifiedCache file-        else do-          let etagParam = lookup "etag" queryString--          case etagParam of-            Nothing -> do -- no query parameter. Set appropriate ETag headers-                mHash <- fileGetHash file-                case mHash of-                    Nothing -> lastModifiedCache file-                    Just hash ->-                        case lookup "if-none-match" headers of-                            Just lastHash ->-                              if hash == lastHash-                                  then return NotModified-                                  else return $ FileResponse file $ [("ETag", hash)]-                            Nothing -> return $ FileResponse file $ [("ETag", hash)]--            Just mEtag -> do-                mHash <- fileGetHash file-                case mHash of-                  -- a file used to have an etag parameter, but no longer does-                  Nothing -> return $ Redirect pieces Nothing-                  Just hash ->-                    if isJust mEtag && hash == fromJust mEtag-                      then return $ FileResponse file $ ("ETag", hash):cacheControl-                      else return $ Redirect pieces (Just hash)+    | WaiResponse W.Response +safeInit  :: [a] -> [a]+safeInit [] = []+safeInit xs = init xs -    lastModifiedCache file =-      case (lookup "if-modified-since" headers >>= parseHTTPDate, fileGetModified file) of-          (mLastSent, Just modified) -> do-            let mdate = epochTimeToHTTPDate modified in-              case mLastSent of-                Just lastSent ->-                  if lastSent == mdate-                      then return NotModified-                      else return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]-                Nothing -> return $ FileResponse file $ [("last-modified", formatHTTPDate mdate)]-          _ -> return $ FileResponse file []+filterButLast :: (a -> Bool) -> [a] -> [a]+filterButLast _ [] = []+filterButLast _ [x] = [x]+filterButLast f (x:xs)+    | f x = x : filterButLast f xs+    | otherwise = filterButLast f xs -    setLast :: Pieces -> FilePath -> Pieces+-- | Serve an appropriate response for a folder request.+serveFolder :: StaticSettings -> Pieces -> W.Request -> Folder -> IO StaticResponse+serveFolder ss@StaticSettings {..} pieces req folder@Folder {..} =+    -- first check if there is an index file in this folder+    case getFirst $ mconcat $ map (findIndex $ rights folderContents) ssIndices of+        Just index -> do+            let pieces' = setLast pieces index+             in if ssRedirectToIndex+                    then return $ Redirect pieces' Nothing+                    -- start the checking process over, with a new set+                    else checkPieces ss pieces' req+        Nothing ->+            case ssListing of+                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"+  where+    setLast :: Pieces -> Piece -> Pieces     setLast [] x = [x]-    setLast [""] x = [x]+    setLast [t] x+        | fromPiece t == "" = [x]     setLast (a:b) x = a : setLast b x -    checkIndices :: [FilePath] -> Maybe FilePath-    checkIndices contents = find (flip elem indices) contents--    cacheControl = 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")--type Listing = (Pieces -> Folder -> IO L.ByteString)---type FileLookup = Maybe (Either Folder File)--data Folder = Folder-    { folderName :: FilePath-    , folderContents :: [Either Folder File]-    }--data File = File-    { fileGetSize :: Int-    , fileToResponse :: H.Status -> H.ResponseHeaders -> W.Response-    , fileName :: FilePath-    , fileGetHash :: IO (Maybe ByteString)-    , fileGetModified :: Maybe EpochTime-    }--data StaticSettings = StaticSettings-    { ssFolder :: Pieces -> IO FileLookup -- TODO: not a folder, so rename-    , ssMkRedirect :: Pieces -> ByteString -> ByteString-    , ssGetMimeType :: File -> IO MimeType-    , ssListing :: Maybe Listing-    , ssIndices :: [T.Text] -- index.html-    , ssRedirectToIndex :: Bool-    , ssMaxAge :: MaxAge-    , ssUseHash :: Bool-    }--data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever--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)--webAppSettingsWithLookup :: FilePath -> ETagLookup -> StaticSettings-webAppSettingsWithLookup dir etagLookup =-  defaultWebAppSettings { ssFolder = webAppLookup etagLookup dir}-+    findIndex :: [File] -> Piece -> First Piece+    findIndex files index+        | index `elem` map fileName files = First $ Just index+        | otherwise = First Nothing -defaultWebAppSettings :: StaticSettings-defaultWebAppSettings = StaticSettings-    { ssFolder = webAppLookup hashFileIfExists "static"-    , ssMkRedirect  = defaultMkRedirect-    , ssGetMimeType = return . defaultMimeTypeByExt . fileName-    , ssMaxAge  = MaxAgeForever-    , ssListing = Nothing-    , ssIndices = []-    , ssRedirectToIndex = False-    , ssUseHash = True-    }+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 -defaultFileServerSettings :: StaticSettings-defaultFileServerSettings = StaticSettings-    { ssFolder = fileSystemLookup "static"-    , ssMkRedirect = defaultMkRedirect-    , ssGetMimeType = return . defaultMimeTypeByExt . fileName-    , ssMaxAge = MaxAgeSeconds $ 60 * 60-    , ssListing = Just defaultListing-    , ssIndices = ["index.html", "index.htm"]-    , ssRedirectToIndex = False-    , ssUseHash = False-    }+checkPieces ss@StaticSettings {..} pieces req = do+    res <- ssLookupFile pieces+    case res of+        LRNotFound -> return NotFound+        LRFile file -> serveFile ss req file+        LRFolder folder -> serveFolder ss pieces req folder -fileHelper :: ETagLookup-           -> FilePath -> FilePath -> IO (Maybe File)-fileHelper hashFunc fp name = do-    efs <- try $ getFileStatus $ fromFilePath fp-    case efs of-        Left (_ :: SomeException) -> return Nothing-        Right fs -> return $ Just File-            { fileGetSize = fromIntegral $ fileSize fs-            , fileToResponse = \s h -> W.ResponseFile s h (fromFilePath fp) Nothing-            , fileName = name-            , fileGetHash = hashFunc fp-            , fileGetModified = Just $ modificationTime fs-            }+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 -type ETagLookup = (FilePath -> IO (Maybe ByteString))+            -- 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 anomolous, and should likely warrant a+            -- new file being sent anyway.+            (Just hash, _) -> respond [("ETag", hash)] -webAppLookup :: ETagLookup -> FilePath -> Pieces -> IO FileLookup-webAppLookup cachedLookupHash prefix pieces = do-    mfile <- fileHelper cachedLookupHash fp (last pieces)-    return $ fmap Right mfile+            -- No hash value available, fall back to last modified support.+            (Nothing, _) -> lastMod+    -- etag turned off, so jump straight to last modified+    | otherwise = lastMod   where-    fp = pathFromPieces prefix pieces--defaultFileSystemHash :: ETagLookup-defaultFileSystemHash fp = fmap Just $ hashFile fp---- FIXME replace lazy IO with enumerators--- FIXME let's use a dictionary to cache these values?-hashFile :: FilePath -> IO ByteString-hashFile fp = do-    l <- L.readFile $ fromFilePath fp-    return $ runHashL l--hashFileIfExists :: ETagLookup-hashFileIfExists fp = do-    fe <- doesFileExist $ fromFilePath fp-    if fe-      then return Nothing-      else defaultFileSystemHash fp--fileSystemLookup :: FilePath -> Pieces -> IO FileLookup-fileSystemLookup = fileSystemLookupHash defaultFileSystemHash--fileSystemLookupHash :: ETagLookup-                     -> FilePath -> Pieces -> IO FileLookup-fileSystemLookupHash hashFunc prefix pieces = do-    let fp = pathFromPieces prefix pieces-    fe <- doesFileExist $ fromFilePath fp-    if fe-        then (fmap . fmap) Right $ fileHelper hashFunc fp $ last pieces-        else do-            de <- doesDirectoryExist $ fromFilePath fp-            if de-                then do-                    let isVisible ('.':_) = False-                        isVisible "" = False-                        isVisible _ = True-                    entries' <- fmap (filter isVisible) $ getDirectoryContents (fromFilePath fp)-                    entries <- forM entries' $ \nameRaw -> do-                        let name = toFilePath nameRaw-                        let fp' = fp </> name-                        mfile' <- fileHelper hashFunc fp' name-                        case mfile' of-                            Nothing -> return $ Left $ Folder name []-                            Just file' -> return $ Right file'-                    return $ Just $ Left $ Folder (error "Network.Wai.Application.Static.fileSystemLookup") entries-                else return Nothing--type Embedded = Map.Map FilePath EmbeddedEntry+    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 -data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded+            -- Did not match, but we have a new last-modified header+            (Just mdate, _) -> respond [("last-modified", formatHTTPDate mdate)] -embeddedLookup :: Embedded -> Pieces -> IO FileLookup-embeddedLookup root pieces =-    return $ elookup "<root>" pieces root-  where-    elookup  :: FilePath -> [FilePath] -> Embedded -> FileLookup-    elookup p [] x = Just $ Left $ Folder p $ map toEntry $ Map.toList x-    elookup p [""] x = elookup p [] x-    elookup _ (p:ps) x =-        case Map.lookup p x of-            Nothing -> Nothing-            Just (EEFile f) ->-                case ps of-                    [] -> Just $ Right $ bsToFile p f-                    _ -> Nothing-            Just (EEFolder y) -> elookup p ps y+            -- No modification time available+            (Nothing, _) -> respond [] -toEntry :: (FilePath, EmbeddedEntry) -> Either Folder File-toEntry (name, EEFolder{}) = Left $ Folder name []-toEntry (name, EEFile bs) = Right $ File-    { fileGetSize = S8.length bs-    , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs-    , fileName = name-    , fileGetHash = return $ Just $ runHash bs-    , fileGetModified = Nothing-    }+    -- Send a file response with the additional weak headers provided.+    respond headers = return $ FileResponse file $ cacheControl ssMaxAge headers -toEmbedded :: [(Prelude.FilePath, S8.ByteString)] -> Embedded-toEmbedded fps =-    go texts+-- | 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-    texts = map (\(x, y) -> (filter (not . T.null . unFilePath) $ toPieces x, y)) fps-    toPieces "" = []-    toPieces x =-        let (y, z) = break (== '/') x-         in toFilePath y : toPieces (drop 1 z)-    go :: [([FilePath], S8.ByteString)] -> Embedded-    go orig =-        Map.fromList $ map (second go') hoisted-      where-        next = map (\(x, y) -> (head x, (tail x, y))) orig-        grouped :: [[(FilePath, ([FilePath], S8.ByteString))]]-        grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next-        hoisted :: [(FilePath, [([FilePath], S8.ByteString)])]-        hoisted = map (fst . head &&& map snd) grouped-    go' :: [([FilePath], S8.ByteString)] -> EmbeddedEntry-    go' [([], content)] = EEFile content-    go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x--bsToFile :: FilePath -> S8.ByteString -> File-bsToFile name bs = File-    { fileGetSize = S8.length bs-    , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs-    , fileName = name-    , fileGetHash = return $ Just $ runHash bs-    , fileGetModified = Nothing-    }--runHash :: S8.ByteString -> S8.ByteString-runHash = B64.encode . MD5.hash+    ccInt =+        case maxage of+            NoMaxAge -> Nothing+            MaxAgeSeconds i -> Just i+            MaxAgeForever -> Just oneYear+    oneYear :: Int+    oneYear = 60 * 60 * 24 * 365 -runHashL :: L.ByteString -> ByteString-runHashL = B64.encode . MD5.hashlazy+    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 (map FilePath $ W.pathInfo req) req--status304, statusNotModified :: H.Status-status304 = H.Status 304 "Not Modified"-statusNotModified = status304---- 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-+staticApp set req = staticAppPieces set (W.pathInfo req) req -staticAppPieces :: StaticSettings -> Pieces -> W.Application+staticAppPieces :: StaticSettings -> [Text] -> W.Application staticAppPieces _ _ req     | W.requestMethod req /= "GET" = return $ W.responseLBS         H.status405         [("Content-Type", "text/plain")]         "Only GET is supported"-staticAppPieces ss pieces req = liftIO $ do-    let indices = ssIndices ss-    case checkSpecialDirListing pieces of-         Just res ->  response res-         Nothing  ->  response =<< checkPieces (ssFolder ss)-                                  (map FilePath indices)-                                  pieces-                                  req-                                  (ssMaxAge ss)-                                  (ssUseHash ss)-                                  (ssRedirectToIndex ss)+staticAppPieces _ [".hidden", "folder.png"] _  = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")]+staticAppPieces _ [".hidden", "haskell.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")]+staticAppPieces ss rawPieces req = liftIO $ do+    case toPieces rawPieces of+        Just pieces -> checkPieces ss pieces req >>= response+        Nothing -> return $ W.responseLBS H.status403+            [ ("Content-Type", "text/plain")+            ] "Forbidden"   where-    response cp = case cp of-        FileResponse file ch -> do-            mimetype <- ssGetMimeType ss file-            let filesize = fileGetSize file-            let headers = ("Content-Type", mimetype)-                        : ("Content-Length", S8.pack $ show filesize)-                        : ch-            return $ fileToResponse file H.status200 headers-        NotModified ->-            return $ W.responseLBS statusNotModified+    response :: StaticResponse -> IO W.Response+    response (FileResponse file ch) = do+        mimetype <- ssGetMimeType ss file+        let filesize = fileGetSize file+        let headers = ("Content-Type", mimetype)+                    : ("Content-Length", S8.pack $ show filesize)+                    : ch+        return $ fileToResponse file H.status200 headers++    response NotModified =+            return $ W.responseLBS H.status304                         [ ("Content-Type", "text/plain")                         ] "Not Modified"-        DirectoryResponse fp -> do-            case ssListing ss of-                (Just f) -> do-                    lbs <- f pieces fp-                    return $ W.responseLBS H.status200-                        [ ("Content-Type", "text/html; charset=utf-8")-                        ] lbs-                Nothing -> return $ W.responseLBS H.status403-                        [ ("Content-Type", "text/plain")-                        ] "Directory listings disabled"-        SendContent mt lbs -> do++    response (SendContent mt lbs) = do             -- TODO: set caching headers             return $ W.responseLBS H.status200                 [ ("Content-Type", mt)                   -- TODO: set Content-Length                 ] lbs -        Redirect pieces' mHash -> do-            let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map unFilePath pieces')+    response (Redirect pieces' mHash) = do+            let loc = (ssMkRedirect ss) pieces' $ toByteString (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)@@ -666,134 +238,9 @@                 [ ("Content-Type", "text/plain")                 , ("Location", S8.append loc $ H.renderQuery True qString)                 ] "Redirect"-        Forbidden -> return $ W.responseLBS H.status403-                        [ ("Content-Type", "text/plain")-                        ] "Forbidden"-        NotFound -> return $ W.responseLBS H.status404++    response NotFound = return $ W.responseLBS H.status404                         [ ("Content-Type", "text/plain")                         ] "File not found" --- | System.Directory functions are a lie:--- they claim to be using String, but it's really just a raw byte sequence.--- We're assuming that non-Windows systems use UTF-8 encoding (there was--- a discussion regarding this, it wasn't an arbitrary decision). So we--- need to encode/decode the byte sequence to/from UTF8. That's the use--- case for fixPathName/unfixPathName. I'm starting to use John--- Millikin's system-filepath package for some stuff with work, and might--- consider migrating over to it for this in the future.-toFilePath :: Prelude.FilePath -> FilePath-#if defined(mingw32_HOST_OS)-toFilePath = FilePath . T.pack-#else-toFilePath = FilePath . TE.decodeUtf8With TEE.lenientDecode . S8.pack-#endif--fromFilePath :: FilePath -> Prelude.FilePath-#if defined(mingw32_HOST_OS)-fromFilePath = T.unpack . unFilePath-#else-fromFilePath = S8.unpack . TE.encodeUtf8 . unFilePath-#endif---- Code below taken from Happstack: http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs-defaultListing :: Listing-defaultListing pieces (Folder _ contents) = do-    let isTop = null pieces || pieces == [""]-    let fps'' :: [Either Folder File]-        fps'' = (if isTop then id else (Left (Folder ".." []) :)) contents-    return $ HU.renderHtml-           $ H.html $ do-             H.head $ do-                 let title = T.unpack $ T.intercalate "/" $ map unFilePath pieces-                 let title' = if 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-                 H.h1 $ showFolder $ map unFilePath $ filter (not . nullFilePath) pieces-                 renderDirectoryContentsTable 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-    showFolder [] = "/"-    showFolder [x] = H.toHtml $ showName x-    showFolder (x:xs) = do-        let href = concat $ replicate (length xs) "../" :: String-        H.a ! A.href (H.toValue href) $ H.toHtml $ showName x-        " / " :: H.Html-        showFolder 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 :: String-                             -> String-                             -> [Either Folder File]-                             -> H.Html-renderDirectoryContentsTable 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 Folder File -> Either Folder File -> Ordering-      sortMD Left{} Right{} = LT-      sortMD Right{} Left{} = GT-      sortMD (Left a) (Left b) = compare (folderName a) (folderName b)-      sortMD (Right a) (Right b) = compare (fileName a) (fileName b)-      mkRow :: (Either Folder 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 = either folderName fileName md-                   let isFile = either (const False) (const True) md-                   H.td (H.a ! A.href (H.toValue $ unFilePath name `T.append` if isFile then "" else "/") $ H.toHtml $ unFilePath 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+    response (WaiResponse r) = return r

@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}+module Util+    ( relativeDirFromPieces+    , defaultMkRedirect+    , replace+    , remove+    ) 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)

@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+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+import System.Locale (defaultTimeLocale)+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: <http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-server/src/Happstack/Server/FileServe/BuildingBlocks.hs>+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+                 H.h1 $ showFolder $ filter (not . T.null . fromPiece) pieces+                 renderDirectoryContentsTable 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++    showFolder :: Pieces -> H.Html+    showFolder [] = "/"+    showFolder [x] = H.toHtml $ showName $ fromPiece x+    showFolder (x:xs) = do+        let href = concat $ replicate (length xs) "../" :: String+        H.a ! A.href (H.toValue href) $ H.toHtml $ showName $ fromPiece x+        " / " :: H.Html+        showFolder 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 :: String+                             -> String+                             -> [Either FolderName File]+                             -> H.Html+renderDirectoryContentsTable 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 = either id fileName md+                   let isFile = either (const False) (const True) md+                   H.td (H.a ! A.href (H.toValue $ fromPiece name `T.append` if isFile then "" else "/") $ 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

@@ -0,0 +1,92 @@+-- | Lookup files stored in memory instead of from the filesystem.+module WaiAppStatic.Storage.Embedded+    ( -- * Settings+      embeddedSettings+    ) where++import WaiAppStatic.Types+import Data.ByteString (ByteString)+import Control.Arrow ((&&&), second)+import Data.List+import Blaze.ByteString.Builder (fromByteString)+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 qualified Crypto.Hash.MD5 as MD5+import qualified Data.ByteString.Base64 as B64+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 $ 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 = S.length bs+    , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString 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 =+        let (y, z) = break (== '/') 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 = S.length bs+    , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs+    , fileName = name+    , fileGetHash = return $ Just $ runHash bs+    , fileGetModified = Nothing+    }++runHash :: ByteString -> ByteString+runHash = B64.encode . MD5.hash

@@ -0,0 +1,166 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Access files on the filesystem.+module WaiAppStatic.Storage.Filesystem+    ( -- * Types+      ETagLookup+      -- * Settings+    , defaultWebAppSettings+    , defaultFileServerSettings+    , webAppSettingsWithLookup+    ) where++import WaiAppStatic.Types+import Prelude hiding (FilePath)+import Filesystem.Path.CurrentOS (FilePath, (</>))+import qualified Filesystem.Path.CurrentOS as F+import qualified Filesystem as F+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)+import Data.Maybe (catMaybes)+import qualified Crypto.Conduit+import Data.Serialize (encode)+import Crypto.Hash.MD5 (MD5)+import qualified Data.ByteString.Base64 as B64++-- | Construct a new path from a root and some @Pieces@.+pathFromPieces :: FilePath -> Pieces -> FilePath+pathFromPieces = foldl' (\fp p -> fp </> F.fromText (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+    }++-- | 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 = MaxAgeSeconds $ 60 * 60+    , ssListing = Just defaultListing+    , ssIndices = map unsafeToPiece ["index.html", "index.htm"]+    , ssRedirectToIndex = False+    , ssUseHash = False+    }++-- | 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 $ F.encodeString fp+    case efs of+        Left (_ :: SomeException) -> return Nothing+        Right fs -> return $ Just File+            { fileGetSize = fromIntegral $ fileSize fs+            , fileToResponse = \s h -> W.ResponseFile s h (F.encodeString fp) Nothing+            , fileName = name+            , fileGetHash = hashFunc fp+            , fileGetModified = Just $ modificationTime fs+            }++-- | 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 = do+    h <- Crypto.Conduit.hashFile (F.encodeString fp)+    return $ B64.encode $ encode (h :: MD5)++hashFileIfExists :: ETagLookup+hashFileIfExists fp = do+    res <- try $ hashFile fp+    return $ case res of+        Left (_ :: SomeException) -> Nothing+        Right x -> Just x++isVisible :: FilePath -> Bool+isVisible =+    go . F.encodeString . F.filename+  where+    go ('.':_) = False+    go "" = False+    go _ = 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 <- F.isFile fp+    if fe+        then fileHelperLR hashFunc fp lastPiece+        else do+            de <- F.isDirectory fp+            if de+                then do+                    entries' <- fmap (filter isVisible) $ F.listDirectory fp+                    entries <- forM entries' $ \fp' -> do+                        let name = unsafeToPiece $ either id id $ F.toText $ F.filename fp'+                        de' <- F.isDirectory 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

@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+module 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 Blaze.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 :: Int+      -- | 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 <http://www.yesodweb.com/book/settings-types> 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+    }

@@ -4,13 +4,10 @@ import Network.Wai.Application.Static  import Test.Hspec.Monadic-import Test.Hspec.QuickCheck import Test.Hspec.HUnit () import Test.HUnit ((@?=))-import Data.List (isInfixOf) import qualified Data.ByteString.Char8 as S8 -- import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.Text as T import System.PosixCompat.Files (getFileStatus, modificationTime)  import Network.HTTP.Date@@ -21,26 +18,27 @@ import Network.Wai.Test  import Control.Monad.IO.Class (liftIO)+import Network.Mime  defRequest :: Request defRequest = defaultRequest  specs :: Specs specs = do-  let webApp = flip runSession $ staticApp defaultWebAppSettings  {ssFolder = fileSystemLookup "test"}-  let fileServerApp = flip runSession $ staticApp defaultFileServerSettings  {ssFolder = fileSystemLookup "test"}+  let webApp = flip runSession $ staticApp $ defaultWebAppSettings "test"+  let fileServerApp = flip runSession $ staticApp $ defaultFileServerSettings "test"    let etag = "1B2M2Y8AsgTpgAmY7PhCfg=="   let file = "a/b"   let statFile = setRawPathInfo defRequest file -  describe "Pieces: pathFromPieces" $ do-    it "converts to a file path" $-      (pathFromPieces "prefix" ["a", "bc"]) @?= "prefix/a/bc"--    prop "each piece is in file path" $ \piecesS ->-      let pieces = map (FilePath . T.pack) piecesS-      in  all (\p -> ("/" ++ p) `isInfixOf` (T.unpack $ unFilePath $ pathFromPieces "root" $ pieces)) piecesS+  describe "mime types" $ do+    it "fileNameExtensions" $+        fileNameExtensions "foo.tar.gz" @?= ["tar.gz", "gz"]+    it "handles multi-extensions" $+        defaultMimeLookup "foo.tar.gz" @?= "application/x-tgz"+    it "defaults correctly" $+        defaultMimeLookup "foo.unknown" @?= "application/octet-stream"    describe "webApp" $ do     it "403 for unsafe paths" $ webApp $@@ -62,8 +60,8 @@       assertStatus 301 req       assertHeader "Location" "../../a/b/c" req -    let absoluteApp = flip runSession $ staticApp $ defaultWebAppSettings {-          ssFolder = fileSystemLookup "test", ssMkRedirect = \_ u -> S8.append "http://www.example.com" u+    let absoluteApp = flip runSession $ staticApp $ (defaultWebAppSettings "test") {+          ssMkRedirect = \_ u -> S8.append "http://www.example.com" u         }     it "301 redirect when multiple slashes" $ absoluteApp $       flip mapM_ ["/a//b/c", "a//b/c"] $ \path -> do@@ -75,18 +73,9 @@     it "200 and etag when no etag query parameters" $ webApp $ do       req <- request statFile       assertStatus 200 req-      assertNoHeader "Cache-Control" req       assertHeader "ETag" etag req       assertNoHeader "Last-Modified" req -    it "200 when no cache headers and bad cache query string" $ webApp $ do-      flip mapM_ [Just "cached", Nothing] $ \badETag -> do-        req <- request statFile { queryString = [("etag", badETag)] }-        assertStatus 301 req-        assertHeader "Location" "../a/b?etag=1B2M2Y8AsgTpgAmY7PhCfg%3D%3D" req-        assertNoHeader "Cache-Control" 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@@ -125,7 +114,6 @@           requestHeaders = [("If-Modified-Since", badDate)]         }         assertStatus 200 req-        assertNoHeader "Cache-Control" req         fdate <- fileDate         assertHeader "Last-Modified" fdate req 

@@ -1,5 +1,5 @@ name:            wai-app-static-version:         1.2.0.4+version:         1.3.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -22,15 +22,11 @@     Description:   print debug info     Default:       False -flag blaze_html_0_5-    Description:   use blaze-html 0.5 and blaze-markup 0.5-    Default:       False- library     build-depends:   base                      >= 4        && < 5-                   , wai                       >= 1.2      && < 1.3+                   , wai                       >= 1.3      && < 1.4                    , bytestring                >= 0.9.1.4-                   , http-types                >= 0.6      && < 0.7+                   , http-types                >= 0.7      && < 0.8                    , transformers              >= 0.2.2    && < 0.4                    , unix-compat               >= 0.2                    , directory                 >= 1.0.1    && < 1.2@@ -42,17 +38,21 @@                    , blaze-builder             >= 0.2.1.4  && < 0.4                    , base64-bytestring         >= 0.1      && < 0.2                    , cryptohash                >= 0.7      && < 0.8+                   , system-filepath           >= 0.4      && < 0.5+                   , system-fileio             >= 0.3      && < 0.4                    , http-date--    if flag(blaze_html_0_5)-        build-depends:-                     blaze-html                >= 0.5      && < 0.6+                   , blaze-html                >= 0.5      && < 0.6                    , blaze-markup              >= 0.5.1    && < 0.6-    else-        build-depends:-                     blaze-html                >= 0.4      && < 0.5+                   , crypto-conduit            >= 0.4      && < 0.5+                   , cereal                    >= 0.3.5    && < 0.4+                   , mime-types                >= 0.1      && < 0.2      exposed-modules: Network.Wai.Application.Static+                     WaiAppStatic.Storage.Filesystem+                     WaiAppStatic.Storage.Embedded+                     WaiAppStatic.Listing+                     WaiAppStatic.Types+    other-modules:   Util     ghc-options:     -Wall     extensions:     CPP @@ -79,6 +79,7 @@                    , bytestring                    , text                    , transformers+                   , mime-types                    -- , containers   ghc-options:   -Wall