wai-app-static 0.1.0 → 0.2.0

raw patch · 2 files changed

+217/−77 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Network/Wai/Application/Static.hs +207/−75
• wai-app-static.cabal +10/−2

@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell, CPP #-} -- | Static file serving for WAI. module Network.Wai.Application.Static     ( -- * Generic, non-WAI code@@ -15,8 +14,8 @@     , mimeTypeByExt     , defaultMimeTypeByExt       -- ** Finding files-    , CheckPieces-    , checkPieces+    , Pieces+    , pathFromPieces       -- ** File/folder metadata     , MetaData (..)     , mdIsFile@@ -24,10 +23,17 @@       -- ** Directory listings     , Listing     , defaultListing+    , defaultDirListing       -- * WAI application-    , StaticSettings (..)     , staticApp     , staticAppPieces+      -- ** Settings+    , StaticSettings (..)+    , defaultStaticSettings+    , defaultPublicSettings+    , CacheSettings (..)+      -- should be moved to common helper+    , unfixPathName     ) where  import qualified Network.Wai as W@@ -42,7 +48,7 @@ import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime) import System.Posix.Types (FileOffset, EpochTime) import Control.Monad.IO.Class (liftIO)-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, isNothing, isJust)  import           Text.Blaze                  ((!)) import qualified Text.Blaze.Html5            as H@@ -56,13 +62,24 @@ import Data.Time.Clock.POSIX import System.Locale (defaultTimeLocale) -import Data.List (sortBy, intercalate)+import Data.List (sortBy) import Data.FileEmbed (embedFile)  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+ -- | A list of all possible extensions, starting from the largest. takeExtensions :: FilePath -> [String] takeExtensions s =@@ -157,20 +174,19 @@ defaultMimeTypeByExt = mimeTypeByExt defaultMimeTypes defaultMimeType  data CheckPieces-    = Redirect [String]+    = Redirect Pieces     | Forbidden     | NotFound     | FileResponse FilePath+    | NotModified     | DirectoryResponse FilePath+    -- TODO: add file size     | SendContent MimeType L.ByteString     deriving Show -anyButLast :: (a -> Bool) -> [a] -> Bool-anyButLast _ [] = False-anyButLast _ [_] = False-anyButLast p (x:xs)-    | p x == True = True-    | otherwise = anyButLast p xs+safeInit  :: [a] -> [a]+safeInit [] = []+safeInit xs = init xs  filterButLast :: (a -> Bool) -> [a] -> [a] filterButLast _ [] = []@@ -179,52 +195,86 @@     | f x = x : filterButLast f xs     | otherwise = filterButLast f xs -unsafe :: FilePath -> Bool-unsafe ('.':_) = True-unsafe s = any (== '/') s +unsafe :: T.Text -> Bool+unsafe s | T.null s = False+         | T.head s == '.' = True+         | otherwise = T.any (== '/') s+ stripTrailingSlash :: FilePath -> FilePath stripTrailingSlash "/" = "" stripTrailingSlash "" = "" stripTrailingSlash (x:xs) = x : stripTrailingSlash xs -checkPieces :: FilePath -- ^ static file prefix-            -> [FilePath] -- ^ List of default index files. Cannot contain slashes.-            -> [String] -- ^ parsed request+type Pieces = [T.Text]+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)++checkPieces :: FilePath      -- ^ static file prefix+            -> [FilePath]    -- ^ List of default index files. Cannot contain slashes.+            -> Pieces        -- ^ parsed request+            -> CacheSettings+            -> W.Request             -> IO CheckPieces-checkPieces _ _ [".hidden", "folder.png"] =+checkPieces _ _ [".hidden", "folder.png"] _ _ =     return $ SendContent "image/png" $ L.fromChunks [$(embedFile "folder.png")]-checkPieces _ _ [".hidden", "haskell.png"] =+checkPieces _ _ [".hidden", "haskell.png"] _ _ =     return $ SendContent "image/png" $ L.fromChunks [$(embedFile "haskell.png")]-checkPieces prefix indices pieces+checkPieces prefix indices pieces cache req     | any unsafe pieces = return Forbidden-    | anyButLast null pieces =-        return $ Redirect $ filterButLast (not . null) pieces+    | any T.null $ safeInit pieces =+        return $ Redirect $ filterButLast (not . T.null) pieces     | otherwise = do-        let fp = concat $ prefix : map ((:) '/') (map unfixPathName pieces)+        let fp = pathFromPieces prefix pieces         let (isFile, isFolder) =                 case () of                     ()                         | null pieces -> (True, True)-                        | null (last pieces) -> (False, True)+                        | T.null (last pieces) -> (False, True)                         | otherwise -> (True, False)-        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 de-                    then do-                        x <- checkIndices fp indices-                        case x of-                            Just index -> return $ Redirect $ setLast pieces index-                            Nothing ->-                                if isFolder-                                    then return $ DirectoryResponse fp-                                    else return $ Redirect $ pieces ++ [""]-                    else return NotFound++        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++   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 ++ [""]+     setLast [] x = [x]     setLast [""] x = [x]     setLast (a:b) x = a : setLast b x@@ -236,34 +286,112 @@             then return $ Just i             else checkIndices fp is -type Listing = [String] -> FilePath -> IO L.ByteString+type Listing = (Pieces -> FilePath -> IO L.ByteString) +data StaticDirListing = ListingForbidden | StaticDirListing {+    ssListing :: Listing+  , ssIndices :: [FilePath]+}++defaultDirListing :: StaticDirListing+defaultDirListing = StaticDirListing defaultListing []++-- 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+ data StaticSettings = StaticSettings     { ssFolder :: FilePath-    , ssIndices :: [FilePath]-    , ssListing :: Maybe Listing+    , ssMkRedirect :: Pieces -> ByteString -> S8.ByteString     , ssGetMimeType :: FilePath -> IO MimeType+    , ssDirListing :: StaticDirListing+    , ssCacheSettings :: CacheSettings     } +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)++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+}++ staticApp :: StaticSettings -> W.Application staticApp set req = do     let pieces = W.pathInfo req     staticAppPieces set pieces req -staticAppPieces :: StaticSettings -> [T.Text] -> W.Application+status304, statusNotModified :: H.Status+status304 = H.Status 304 "Not Modified"+statusNotModified = status304++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 (StaticSettings folder indices mlisting getmime) piecesT _ = liftIO $ do-    let pieces = map T.unpack piecesT -- FIXME stick with Text-    cp <- checkPieces folder indices pieces+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+        NotModified ->+            return $ W.responseLBS statusNotModified+                        [ ("Content-Type", "text/plain")+                        ] "Not Modified"+        DirectoryResponse fp ->+            case ssDirListing ss of+                StaticDirListing 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+                        [ ("Content-Type", "text/plain")+                        ] "Directory listings disabled"+        SendContent mt lbs -> do+            -- TODO: set caching headers+            return $ W.responseLBS H.status200+                [ ("Content-Type", mt)+                  -- TODO: set Content-Length+                ] lbs         Redirect pieces' -> do-            let loc =+            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 $ map T.pack pieces') -- FIXME use Text+                    foldr mappend (H.encodePathSegments pieces') -- FIXME use Text                     $ map (const $ copyByteString "../") $ drop 1 pieces             return $ W.responseLBS H.status301                 [ ("Content-Type", "text/plain")@@ -275,27 +403,30 @@         NotFound -> return $ W.responseLBS H.status404                         [ ("Content-Type", "text/plain")                         ] "File not found"-        FileResponse fp -> do-            mimetype <- getmime fp-            filesize <- fileSize `fmap` getFileStatus fp-            return $ W.ResponseFile H.status200-                        [ ("Content-Type", mimetype)-                        , ("Content-Length", S8.pack $ show filesize)-                        ] fp Nothing-        DirectoryResponse fp ->-            case mlisting of-                Just listing -> do-                    lbs <- listing 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 -> return $ W.responseLBS H.status200-                        [ ("Content-Type", mt)-                        ] lbs+    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+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.+-} fixPathName :: FilePath -> FilePath #if defined(mingw32_HOST_OS) fixPathName = id@@ -320,7 +451,7 @@     return $ HU.renderHtml            $ H.html $ do              H.head $ do-                 let title = intercalate "/" pieces+                 let title = T.unpack $ T.intercalate "/" 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'; }"@@ -338,10 +469,10 @@                                               , "a { text-decoration: none }"                                               ]              H.body $ do-                 H.h1 $ showFolder $ "" : filter (not . null) pieces+                 H.h1 $ showFolder $ map T.unpack $ filter (not . T.null) pieces                  renderDirectoryContentsTable haskellSrc folderSrc $ catMaybes fps''   where-    image x = concatMap (const "../") (drop 1 pieces) ++ ".hidden/" ++ x ++ ".png"+    image x = T.unpack $ T.concat [(relativeDirFromPieces pieces), ".hidden/", x, ".png"]     folderSrc = image "folder"     haskellSrc = image "haskell"     showName "" = "root"@@ -409,6 +540,7 @@       addCommas' (a:b:c:d:e) = a : b : c : ',' : addCommas' (d : e)       addCommas' x = x +mdName' :: MetaData -> FilePath mdName' = fixPathName . mdName  data MetaData =

@@ -1,5 +1,5 @@ name:            wai-app-static-version:         0.1.0+version:         0.2.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -8,11 +8,15 @@ description:     Also provides some helper functions and datatypes for use outside of WAI. category:        Web, Yesod stability:       Stable-cabal-version:   >= 1.6+cabal-version:   >= 1.8 build-type:      Simple homepage:        http://www.yesodweb.com/ Extra-source-files: folder.png, haskell.png +Flag print+    Description:   print debug info+    Default:       True+ library     build-depends:   base                      >= 4        && < 5                    , wai                       >= 0.4      && < 0.5@@ -30,6 +34,10 @@                    , blaze-builder             >= 0.2.1.4  && < 0.4     exposed-modules: Network.Wai.Application.Static     ghc-options:     -Wall+    extensions:     CPP++    if flag(print)+      cpp-options:  -DPRINT  source-repository head   type:     git