wai-app-static 0.2.0 → 0.3.0

raw patch · 2 files changed

+457/−251 lines, 2 filesdep +Cabaldep +HUnitdep +base64-bytestringdep ~bytestringdep ~http-typesdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, HUnit, base64-bytestring, cryptohash, hspec, http-date, network, wai-app-static, wai-test

Dependency ranges changed: bytestring, http-types, text, transformers, wai

API changes (from Hackage documentation)

Files

• Network/Wai/Application/Static.hs +428/−249
• wai-app-static.cabal +29/−2

@@ -2,9 +2,21 @@ {-# LANGUAGE TemplateHaskell, CPP #-} -- | Static file serving for WAI. module Network.Wai.Application.Static-    ( -- * Generic, non-WAI code+    ( -- * WAI application+      staticApp+      -- ** Settings+    , defaultWebAppSettings+    , defaultFileServerSettings+    , StaticSettings+    , ssFolder+    , ssMkRedirect+    , ssGetMimeType+    , ssListing+    , ssIndices+    , ssMaxAge+      -- * Generic, non-WAI code       -- ** Mime types-      MimeType+    , MimeType     , defaultMimeType       -- ** Mime type by file extension     , Extension@@ -16,26 +28,28 @@       -- ** Finding files     , Pieces     , pathFromPieces-      -- ** File/folder metadata-    , MetaData (..)-    , mdIsFile-    , getMetaData       -- ** Directory listings     , Listing     , defaultListing-    , defaultDirListing-      -- * WAI application-    , staticApp-    , staticAppPieces-      -- ** Settings-    , StaticSettings (..)-    , defaultStaticSettings-    , defaultPublicSettings-    , CacheSettings (..)-      -- should be moved to common helper-    , unfixPathName+      -- ** Lookup functions+    , fileSystemLookup+    , embeddedLookup+      -- ** Embedded+    , Embedded+    , EmbeddedEntry (..)+    , toEmbedded+      -- ** Redirecting+    , defaultMkRedirect+      -- * Other data types+    , File (..)+    , FilePath (..)+    , toFilePath+    , fromFilePath+    , MaxAge (..)     ) 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)@@ -46,49 +60,56 @@ import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)-import System.Posix.Types (FileOffset, EpochTime)+import System.Posix.Types (EpochTime) import Control.Monad.IO.Class (liftIO)-import Data.Maybe (catMaybes, isNothing, isJust)+import qualified Crypto.Hash.MD5 as MD5+import Control.Monad (filterM)  import           Text.Blaze                  ((!)) import qualified Text.Blaze.Html5            as H import qualified Text.Blaze.Renderer.Utf8    as HU import qualified Text.Blaze.Html5.Attributes as A -import Blaze.ByteString.Builder (toByteString, copyByteString)-import Data.Monoid (mappend)+import Blaze.ByteString.Builder (toByteString, fromByteString)  import Data.Time import Data.Time.Clock.POSIX import System.Locale (defaultTimeLocale) -import Data.List (sortBy) 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 -#ifdef PRINT-import Debug.Trace-debug :: (Show a) => a -> a-debug a = trace ("DEBUG: " ++ show a) a-#else-trace :: String -> a -> a -trace _ x = x-debug :: a -> a-debug = id-#endif+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)+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 -> [String]-takeExtensions s =-    case break (== '.') s of-        (_, '.':x) -> x : takeExtensions x-        (_, _) -> []+takeExtensions :: FilePath -> [FilePath]+takeExtensions (FilePath s) =+    case T.break (== '.') s of+        (_, "") -> []+        (_, x) -> FilePath (T.drop 1 x) : takeExtensions (FilePath $ T.drop 1 x)  type MimeType = ByteString-type Extension = String+type Extension = FilePath type MimeMap = Map Extension MimeType  defaultMimeType :: MimeType@@ -132,6 +153,7 @@   ( "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"         ),@@ -152,6 +174,7 @@   ( "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"               ),@@ -173,16 +196,16 @@ defaultMimeTypeByExt :: FilePath -> MimeType defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType -data CheckPieces-    = Redirect Pieces+data CheckPieces =+      -- | Just the etag hash or Nothing for no etag hash+      Redirect Pieces (Maybe ByteString)     | Forbidden     | NotFound-    | FileResponse FilePath+    | FileResponse File H.ResponseHeaders     | NotModified-    | DirectoryResponse FilePath+    | DirectoryResponse Folder     -- TODO: add file size     | SendContent MimeType L.ByteString-    deriving Show  safeInit  :: [a] -> [a] safeInit [] = []@@ -196,186 +219,364 @@     | otherwise = filterButLast f xs  -unsafe :: T.Text -> Bool-unsafe s | T.null s = False-         | T.head s == '.' = True-         | otherwise = T.any (== '/') s+unsafe :: FilePath -> Bool+unsafe (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 "/" = ""-stripTrailingSlash "" = ""-stripTrailingSlash (x:xs) = x : stripTrailingSlash xs+stripTrailingSlash fp@(FilePath t)+    | T.null t || T.last t /= '/' = fp+    | otherwise = FilePath $ T.init t -type Pieces = [T.Text]+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 prefix pieces =-        concat $ prefix : map ((:) '/') (map unfixPathName $ map T.unpack pieces)+pathFromPieces = foldl' (</>) -checkPieces :: FilePath      -- ^ static file prefix-            -> [FilePath]    -- ^ List of default index files. Cannot contain slashes.-            -> Pieces        -- ^ parsed request-            -> CacheSettings+checkSpecialDirListing :: Pieces -> Maybe CheckPieces+checkSpecialDirListing [".hidden", "folder.png"]  =+    Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]+checkSpecialDirListing [".hidden", "haskell.png"] =+    Just $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]+checkSpecialDirListing _ =  Nothing++checkPieces :: (Pieces -> IO FileLookup) -- ^ file lookup function+            -> [FilePath]                -- ^ List of default index files. Cannot contain slashes.+            -> Pieces                    -- ^ parsed request             -> W.Request+            -> MaxAge+            -> Bool             -> IO CheckPieces-checkPieces _ _ [".hidden", "folder.png"] _ _ =-    return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]-checkPieces _ _ [".hidden", "haskell.png"] _ _ =-    return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]-checkPieces prefix indices pieces cache req+checkPieces fileLookup indices pieces req maxAge useHash     | any unsafe pieces = return Forbidden-    | any T.null $ safeInit pieces =-        return $ Redirect $ filterButLast (not . T.null) pieces+    | any nullFilePath $ safeInit pieces =+        return $ Redirect (filterButLast (not . nullFilePath) pieces) Nothing     | otherwise = do-        let fp = pathFromPieces prefix pieces         let (isFile, isFolder) =                 case () of                     ()                         | null pieces -> (True, True)-                        | T.null (last pieces) -> (False, True)+                        | nullFilePath (last pieces) -> (False, True)                         | otherwise -> (True, False) -        if not isFile then uncached fp isFile isFolder-           else-             case cache of-               ETag ioLookup -> do-                 -- No support for If-Match-                 let mlastEtag = lookup "If-None-Match" (W.requestHeaders req)-                 metag <- ioLookup fp-                 case debug (metag, mlastEtag) of-                   (Just hash, Just lastHash) | hash == lastHash -> return NotModified-                   _ -> trace "ETAG: no cache match" uncached fp isFile isFolder-               Forever isStaticFile -> -                   if isStaticFile fp (S8.drop 1 $ W.rawQueryString req) &&-                       (isJust $ lookup "If-Modified-Since" (W.requestHeaders req)) &&-                       (isNothing $ lookup "If-Unmodified-Since" (W.requestHeaders req))-                       then return NotModified-                       else trace "Static: no cache match" uncached fp isFile isFolder-               NoCache    -> trace "NoCache" uncached fp isFile isFolder+        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 -> return $ Redirect (setLast pieces index) Nothing+                    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 mGetHash  = fileGetHash file+          let etagParam = lookup "etag" queryString -  where-    uncached fp isFile isFolder = do-      fe <- doesFileExist $ stripTrailingSlash fp-      case (fe, isFile) of-          (True, True)  -> return $ FileResponse fp-          (True, False) -> return $ Redirect $ init pieces-          (False, _) -> do-              de <- doesDirectoryExist fp-              if not de-                  then return NotFound-                  else do-                      x <- checkIndices fp indices-                      case x of-                          Just index -> return $ Redirect $ setLast pieces (T.pack index)-                          Nothing ->-                              if isFolder-                                  then return $ DirectoryResponse fp-                                  else return $ Redirect $ pieces ++ [""]+          case (etagParam, mGetHash) of+            (Just mEtag, Just getHash) -> do+                hash <- getHash+                if isJust mEtag && hash == fromJust mEtag+                  then return $ FileResponse file $ ("ETag", hash):cacheControl+                  else return $ Redirect pieces (Just hash)+            -- a file used to have an etag parameter, but no longer does+            (Just _, Nothing) -> return $ Redirect pieces Nothing +            _ -> +                case (lookup "if-none-match" headers, mGetHash) of+                    -- etag+                    (mLastHash, Just getHash) -> do+                        hash <- getHash+                        case mLastHash of+                          Just lastHash ->+                            if hash == lastHash+                                then return NotModified+                                else return $ FileResponse file $ [("ETag", hash)]+                          Nothing -> return $ FileResponse file $ [("ETag", hash)]+                    (_, Nothing) -> lastModifiedCache file++    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 []++    setLast :: Pieces -> FilePath -> Pieces     setLast [] x = [x]     setLast [""] x = [x]     setLast (a:b) x = a : setLast b x-    checkIndices _ [] = return Nothing-    checkIndices fp (i:is) = do-        let fp' = fp ++ '/' : i-        fe <- doesFileExist fp'-        if fe-            then return $ Just i-            else checkIndices fp is -type Listing = (Pieces -> FilePath -> IO L.ByteString)+    checkIndices :: [FilePath] -> Maybe FilePath+    checkIndices contents = find (flip elem indices) contents -data StaticDirListing = ListingForbidden | StaticDirListing {-    ssListing :: Listing-  , ssIndices :: [FilePath]-}+    cacheControl = case ccInt of+        Nothing -> []+        Just i  -> [("Cache-Control", S8.append "max-age=" $ S8.pack $ show i)]+      where+        ccInt =+            case maxAge of+                NoMaxAge -> Nothing+                MaxAgeSeconds i -> Just i+                MaxAgeForever -> Just oneYear+        oneYear :: Int+        oneYear = 60 * 60 * 24 * 365 -defaultDirListing :: StaticDirListing-defaultDirListing = StaticDirListing defaultListing []+type Listing = (Pieces -> Folder -> IO L.ByteString) --- IO is for development mode-type CheckHashParam = (FilePath -> S8.ByteString -> Bool)-data CacheSettings = NoCache | Forever CheckHashParam | ETag (FilePath -> IO (Maybe S8.ByteString)) -oneYear :: Int-oneYear = 60 * 60 * 24 * 365+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 :: Maybe (IO ByteString)+    , fileGetModified :: Maybe EpochTime+    }+ data StaticSettings = StaticSettings-    { ssFolder :: FilePath-    , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString-    , ssGetMimeType :: FilePath -> IO MimeType-    , ssDirListing :: StaticDirListing-    , ssCacheSettings :: CacheSettings+    { ssFolder :: Pieces -> IO FileLookup+    , ssMkRedirect :: Pieces -> ByteString -> ByteString+    , ssGetMimeType :: File -> IO MimeType+    , ssListing :: Maybe Listing+    , ssIndices :: [T.Text] -- index.html+    , ssMaxAge :: MaxAge+    , ssUseHash :: Bool     } +data MaxAge = NoMaxAge | MaxAgeSeconds Int | MaxAgeForever+ defaultMkRedirect :: Pieces -> ByteString -> S8.ByteString-defaultMkRedirect pieces newPath =-  let relDir = TE.encodeUtf8 (relativeDirFromPieces pieces) in-    S8.append relDir (if (S8.last relDir) == '/' && (S8.head newPath) == '/'-                       then S8.tail newPath-                       else newPath)+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) -defaultStaticSettings :: CacheSettings -> StaticSettings-defaultStaticSettings isStaticFile = StaticSettings { ssFolder = "static"-  , ssMkRedirect = defaultMkRedirect-  , ssGetMimeType = return . defaultMimeTypeByExt-  , ssDirListing = defaultDirListing-  , ssCacheSettings = isStaticFile-}-defaultPublicSettings :: CacheSettings -> StaticSettings-defaultPublicSettings etags = StaticSettings { ssFolder = "public"-  , ssMkRedirect = defaultMkRedirect-  , ssGetMimeType = return . defaultMimeTypeByExt-  , ssDirListing = ListingForbidden-  , ssCacheSettings = etags-}+defaultWebAppSettings :: StaticSettings+defaultWebAppSettings = StaticSettings+    { ssFolder = fileSystemLookup "static"+    , ssMkRedirect  = defaultMkRedirect+    , ssGetMimeType = return . defaultMimeTypeByExt . fileName+    , ssMaxAge  = MaxAgeForever+    , ssListing = Nothing+    , ssIndices = []+    , ssUseHash = True+    } +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"]+    , ssUseHash = False+    } +fileHelper :: FilePath -> FilePath -> IO File+fileHelper fp name = do+    fs <- getFileStatus $ fromFilePath fp+    return File+        { fileGetSize = fromIntegral $ fileSize fs+        , fileToResponse = \s h -> W.ResponseFile s h (fromFilePath fp) Nothing+        , fileName = name+        , fileGetHash = Just $ do+            -- FIXME replace lazy IO with enumerators+            -- FIXME let's use a dictionary to cache these values?+            l <- L.readFile $ fromFilePath fp+            return $ runHashL l+        , fileGetModified = Just $ modificationTime fs+        }++fileSystemLookup :: FilePath -> Pieces -> IO FileLookup+fileSystemLookup prefix pieces = do+    let fp = pathFromPieces prefix pieces+    fe <- doesFileExist $ fromFilePath fp+    if fe+        then fmap (Just . Right) $ fileHelper fp $ last pieces+        else do+            de <- doesDirectoryExist $ fromFilePath fp+            if de+                then do+                    let isVisible ('.':_) = return False+                        isVisible "" = return False+                        isVisible _ = return True+                    entries <- getDirectoryContents (fromFilePath fp) >>= filterM isVisible >>= mapM (\nameRaw -> do+                        let name = toFilePath nameRaw+                        let fp' = fp </> name+                        fe' <- doesFileExist $ fromFilePath fp'+                        if fe'+                            then fmap Right $ fileHelper fp' name+                            else return $ Left $ Folder name [])+                    return $ Just $ Left $ Folder (error "413") entries+                else return Nothing++type Embedded = Map.Map FilePath EmbeddedEntry++data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded++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++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 = Just $ return $ runHash bs+    , fileGetModified = Nothing+    }++toEmbedded :: [(Prelude.FilePath, S8.ByteString)] -> Embedded+toEmbedded fps =+    go texts+  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 = Just $ return $ runHash bs+    , fileGetModified = Nothing+    }++runHash :: S8.ByteString -> S8.ByteString+runHash = B64.encode . MD5.hash++runHashL :: L.ByteString -> ByteString+runHashL = B64.encode . MD5.hashlazy+ staticApp :: StaticSettings -> W.Application-staticApp set req = do-    let pieces = W.pathInfo req-    staticAppPieces set pieces req+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++ staticAppPieces :: StaticSettings -> Pieces -> W.Application staticAppPieces _ _ req     | W.requestMethod req /= "GET" = return $ W.responseLBS         H.status405         [("Content-Type", "text/plain")]         "Only GET is supported"-staticAppPieces ss@StaticSettings{} pieces req = liftIO $ do-    let cache = ssCacheSettings ss-    let indices = case ssDirListing ss of-                      StaticDirListing _ is -> is-                      ListingForbidden      -> []-    cp <- checkPieces (ssFolder ss) indices pieces cache req-    case cp of-        FileResponse fp -> do-            mimetype <- (ssGetMimeType ss) fp-            filesize <- fileSize `fmap` getFileStatus fp-            ch <- setCacheHeaders cache fp-            return $ W.ResponseFile H.status200-                        ( [ ("Content-Type", mimetype)-                          , ("Content-Length", S8.pack $ show filesize)-                          ] ++ ch ) fp Nothing+staticAppPieces ss pieces req = liftIO $ do+    let indices = ssIndices ss+    case checkSpecialDirListing pieces of+         Just res ->  response res+         Nothing  ->  checkPieces (ssFolder ss) (map FilePath indices) pieces req (ssMaxAge ss) (ssUseHash ss) >>= response+  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                         [ ("Content-Type", "text/plain")                         ] "Not Modified"-        DirectoryResponse fp ->-            case ssDirListing ss of-                StaticDirListing f _ -> do+        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-                ListingForbidden -> return $ W.responseLBS H.status403+                Nothing -> return $ W.responseLBS H.status403                         [ ("Content-Type", "text/plain")                         ] "Directory listings disabled"         SendContent mt lbs -> do@@ -384,18 +585,16 @@                 [ ("Content-Type", mt)                   -- TODO: set Content-Length                 ] lbs-        Redirect pieces' -> do-            let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments pieces') -            let loc' =-                    -- relativeDirFromPieces pieces = T.concat $ map (const "../") (drop 1 pieces) -- last piece is not a dir-                    -- (ssMkRedirect ss) pieces' $ encodePathInfo pieces' [] -                    toByteString $-                    foldr mappend (H.encodePathSegments pieces') -- FIXME use Text-                    $ map (const $ copyByteString "../") $ drop 1 pieces+        Redirect pieces' mHash -> do+            let loc = (ssMkRedirect ss) pieces' $ toByteString (H.encodePathSegments $ map unFilePath pieces')+            let qString = case mHash of+                  Just hash -> replace "etag" (Just hash) (W.queryString req)+                  Nothing   -> remove "etag" (W.queryString req)+             return $ W.responseLBS H.status301                 [ ("Content-Type", "text/plain")-                , ("Location", loc)+                , ("Location", S8.append loc $ H.renderQuery True qString)                 ] "Redirect"         Forbidden -> return $ W.responseLBS H.status403                         [ ("Content-Type", "text/plain")@@ -403,19 +602,6 @@         NotFound -> return $ W.responseLBS H.status404                         [ ("Content-Type", "text/plain")                         ] "File not found"-    where-      -- expires header: formatTime "%a, %d-%b-%Y %X GMT"-        setCacheHeaders :: CacheSettings -> FilePath -> IO H.ResponseHeaders-        setCacheHeaders (Forever isStaticFile) fp = return $-            if isStaticFile fp (S8.drop 1 $ W.rawQueryString req)-              then [("Cache-Control", S8.append "max-age=" $ S8.pack $ show oneYear)]-              else []-        setCacheHeaders NoCache _ = return []-        setCacheHeaders (ETag ioLookup) fp = do-            etag <- ioLookup fp-            return $ case etag of-              Just hash -> [("ETag", hash)]-              Nothing -> []  {- The problem is that the System.Directory functions are a lie: they@@ -427,35 +613,34 @@ Millikin's system-filepath package for some stuff with work, and might consider migrating over to it for this in the future. -}-fixPathName :: FilePath -> FilePath+toFilePath :: Prelude.FilePath -> FilePath #if defined(mingw32_HOST_OS)-fixPathName = id+toFilePath = FilePath . T.pack #else-fixPathName = T.unpack . TE.decodeUtf8With TEE.lenientDecode . S8.pack+toFilePath = FilePath . TE.decodeUtf8With TEE.lenientDecode . S8.pack #endif -unfixPathName :: FilePath -> FilePath+fromFilePath :: FilePath -> Prelude.FilePath #if defined(mingw32_HOST_OS)-unfixPathName = id+fromFilePath = T.unpack . unFilePath #else-unfixPathName = S8.unpack . TE.encodeUtf8 . T.pack+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 localPath = do-    fps <- getDirectoryContents localPath-    fps' <- mapM (getMetaData localPath) fps+defaultListing pieces (Folder _ contents) = do     let isTop = null pieces || pieces == [""]-    let fps'' = if isTop then fps' else Just (FolderMetaData "..") : fps'+    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 "/" pieces+                 let title = T.unpack $ T.intercalate "/" $ map unFilePath pieces                  let title' = if null title then "root folder" else title-                 H.title $ H.string title'-                 H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"-                                              , "table, th, td { border: 1px solid #353948; }" +                 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; }"@@ -469,20 +654,20 @@                                               , "a { text-decoration: none }"                                               ]              H.body $ do-                 H.h1 $ showFolder $ map T.unpack $ filter (not . T.null) pieces-                 renderDirectoryContentsTable haskellSrc folderSrc $ catMaybes fps''+                 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 [] = H.string "error: Unexpected showFolder []"-    showFolder [x] = H.string $ showName x+    showFolder [] = "/"+    showFolder [x] = H.toHtml $ showName x     showFolder (x:xs) = do-        let href = concat $ replicate (length xs) "../"-        H.a ! A.href (H.stringValue href) $ H.string $ showName x-        H.string " / "+        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@@ -495,36 +680,41 @@ -- see also: 'getMetaData', 'renderDirectoryContents' renderDirectoryContentsTable :: String                              -> String-                             -> [MetaData] -- ^ list of files+meta data, see 'getMetaData'+                             -> [Either Folder File]                              -> H.Html renderDirectoryContentsTable haskellSrc folderSrc fps =-           H.table $ do H.thead $ do H.th ! (A.class_ $ H.stringValue "first") $ H.img ! (A.src $ H.stringValue haskellSrc)-                                     H.th $ H.string "Name"-                                     H.th $ H.string "Modified"-                                     H.th $ H.string "Size"+           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 FolderMetaData{} FileMetaData{} = LT-      sortMD FileMetaData{} FolderMetaData{} = GT-      sortMD x y = mdName x `compare` mdName y-      mkRow :: (MetaData, Bool) -> H.Html+      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_ (H.stringValue "alt")) else id) $+          (if alt then (! A.class_ "alt") else id) $           H.tr $ do-                   H.td ! A.class_ (H.stringValue "first")-                        $ if mdIsFile md-                              then return ()-                              else H.img ! A.src (H.stringValue folderSrc)-                                         ! A.alt (H.stringValue "Folder")-                   H.td (H.a ! A.href (H.stringValue $ mdName' md ++ if mdIsFile md then "" else "/")  $ H.string $ mdName' md)-                   H.td ! A.class_ (H.stringValue "date") $ H.string $-                       if mdIsFile md-                           then formatCalendarTime defaultTimeLocale "%d-%b-%Y %X" $ mdModified md-                           else ""-                   H.td ! A.class_ (H.stringValue "size") $ H.string $-                       if mdIsFile md-                           then prettyShow $ mdSize md-                           else ""+                   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@@ -540,20 +730,7 @@       addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)       addCommas' x = x -mdName' :: MetaData -> FilePath-mdName' = fixPathName . mdName--data MetaData =-    FileMetaData-        { mdName :: FilePath-        , mdModified :: EpochTime-        , mdSize :: FileOffset-        }-  | FolderMetaData-        { mdName :: FilePath-        }-  deriving Show-+{- mdIsFile :: MetaData -> Bool mdIsFile FileMetaData{} = True mdIsFile FolderMetaData{} = False@@ -566,12 +743,14 @@ getMetaData localPath fp = do     let fp' = localPath ++ '/' : fp     fe <- doesFileExist fp'+    let fpPretty = T.pack $ fixPathName fp     if fe         then do             fs <- getFileStatus fp'             let modTime = modificationTime fs             let count = fileSize fs-            return $ Just $ FileMetaData fp modTime count+            return $ Just $ FileMetaData fpPretty (Just modTime) count         else do             de <- doesDirectoryExist fp'-            return $ if de then Just (FolderMetaData fp) else Nothing+            return $ if de then Just (FolderMetaData fpPretty) else Nothing+-}

@@ -1,5 +1,5 @@ name:            wai-app-static-version:         0.2.0+version:         0.3.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -15,7 +15,7 @@  Flag print     Description:   print debug info-    Default:       True+    Default:       False  library     build-depends:   base                      >= 4        && < 5@@ -32,12 +32,39 @@                    , file-embed                >= 0.0.3.1  && < 0.1                    , text                      >= 0.5      && < 1.0                    , blaze-builder             >= 0.2.1.4  && < 0.4+                   , base64-bytestring         >= 0.1      && < 0.2+                   , cryptohash                >= 0.7      && < 0.8+                   , http-date     exposed-modules: Network.Wai.Application.Static     ghc-options:     -Wall     extensions:     CPP      if flag(print)       cpp-options:  -DPRINT++test-suite runtests+    hs-source-dirs: tests+    main-is: runtests.hs+    type: exitcode-stdio-1.0++    build-depends:   base                      >= 4        && < 5+                   , hspec >= 0.6+                   , HUnit+                   , unix-compat               >= 0.2      && < 0.3+                   , time                      >= 1.1.4    && < 1.3+                   , old-locale                >= 1.0.0.2  && < 1.1+                   , http-date+                   , Cabal+                   , wai-app-static >= 0.3+                   , wai-test+                   , wai+                   , http-types+                   , network+                   , bytestring+                   , text+                   , transformers+                   -- , containers+  ghc-options:   -Wall  source-repository head   type:     git