wai-app-static 1.3.1.4 → 1.3.2

raw patch · 5 files changed

+370/−92 lines, 5 filesdep +template-haskelldep +unordered-containersdep +zlibPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell, unordered-containers, zlib

API changes (from Hackage documentation)

Files

• WaiAppStatic/Storage/Embedded.hs +9/−90
• WaiAppStatic/Storage/Embedded/Runtime.hs +93/−0
• WaiAppStatic/Storage/Embedded/TH.hs +259/−0
• tests.hs +2/−1
• wai-app-static.cabal +7/−1

@@ -1,93 +1,12 @@--- | Lookup files stored in memory instead of from the filesystem.-module WaiAppStatic.Storage.Embedded-    ( -- * Settings+module WaiAppStatic.Storage.Embedded(+    -- * Basic       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.Classes as CR-import Crypto.Hash.CryptoAPI (hash', 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-    }+    -- * Template Haskell+    , Etag+    , EmbeddableEntry(..)+    , mkSettings+    ) where -runHash :: ByteString -> ByteString-runHash = B64.encode . CR.encode . (hash' :: S.ByteString -> MD5)+import WaiAppStatic.Storage.Embedded.Runtime+import WaiAppStatic.Storage.Embedded.TH

@@ -0,0 +1,93 @@+-- | Lookup files stored in memory instead of from the filesystem.+module WaiAppStatic.Storage.Embedded.Runtime+    ( -- * Settings+      embeddedSettings+    ) where++import WaiAppStatic.Types+import Data.ByteString (ByteString)+import Control.Arrow ((&&&), second)+import Data.List+import 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.Classes as CR+import Crypto.Hash.CryptoAPI (hash', 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 . CR.encode . (hash' :: S.ByteString -> MD5)

@@ -0,0 +1,259 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, MagicHash #-}+module WaiAppStatic.Storage.Embedded.TH(+    Etag+  , EmbeddableEntry(..)+  , mkSettings+) where++import Blaze.ByteString.Builder.ByteString (insertByteString)+import Codec.Compression.GZip (compress)+import Control.Applicative+import Data.ByteString.Unsafe (unsafePackAddressLen)+import Data.Either (lefts, rights)+import GHC.Exts (Int(..))+import Language.Haskell.TH+import Network.Mime (MimeType, defaultMimeLookup)+import System.IO.Unsafe (unsafeDupablePerformIO)+import WaiAppStatic.Types+import WaiAppStatic.Storage.Filesystem (defaultWebAppSettings)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.Wai as W++-- | An Etag is used to return 304 Not Modified responses so the client does not need+--   to download resources a second time.  Usually the etag is built from a hash of+--   the content.  To disable Etags, you can pass the empty string.  This will cause the+--   content to be redownloaded on every request.+type Etag = T.Text++-- | Used at compile time to hold data about an entry to embed into the compiled executable.+data EmbeddableEntry = EmbeddableEntry {+    eLocation :: T.Text        -- ^ The location where this resource should be served from.  The+                               --   location can contain forward slashes (/) to simulate directories,+                               --   but must not end with a forward slash.+  , eMimeType :: MimeType      -- ^ The mime type.+  , eContent  :: Either (Etag, BL.ByteString) ExpQ+                    -- ^ The content itself.  The content can be given as a tag and bytestring,+                    --   in which case the content will be embedded directly into the execuatble.+                    --   Alternatively, the content can be given as a template haskell expression+                    --   returning @IO ('Etag', 'BL.ByteString')@ in which case this action will+                    --   be executed on every request to reload the content (this is useful+                    --   for a debugging mode).+}++-- | This structure is used at runtime to hold the entry.+data EmbeddedEntry = EmbeddedEntry {+    embLocation   :: !T.Text+  , embMime       :: !MimeType+  , embEtag       :: !B.ByteString+  , embCompressed :: !Bool+  , embContent    :: !B.ByteString+}++-- | This structure is used at runtime to hold the reload entries.+data ReloadEntry = ReloadEntry {+    reloadLocation :: !T.Text+  , reloadMime     :: !MimeType+  , reloadContent  :: IO (T.Text, BL.ByteString)+}++-- The use of unsafePackAddressLen is safe here because the length+-- is correct and we will only be reading from the bytestring, never+-- modifying it.+--+-- The only IO within unsafePackAddressLen is within newForeignPtr_ where+-- a new IORef is created as newIORef (NoFinalizers, []) to hold the finalizer+-- for the pointer.  Since the pointer for the content will never have a finalizer+-- added, we do not care if this finalizer IORef gets created more than once since+-- the IORef will always be holding (NoFinalizers, []).  Therefore+-- unsafeDupablePerformIO is safe.+bytestringE :: B.ByteString -> ExpQ+bytestringE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]+    where+        lenE = litE $ intPrimL $ toInteger $ B.length b+        ctE = litE $ stringPrimL $ B.unpack b+bytestringLazyE :: BL.ByteString -> ExpQ+bytestringLazyE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]+    where+        lenE = litE $ intPrimL $ toInteger $ BL.length b+        ctE = litE $ stringPrimL $ BL.unpack b++-- | A template haskell expression which creates either an EmbeddedEntry or ReloadEntry.+mkEntry :: EmbeddableEntry -> ExpQ+mkEntry (EmbeddableEntry loc mime (Left (etag, ct))) =+        [| Left $ EmbeddedEntry (T.pack $locE)+                                $(bytestringE mime)+                                $(bytestringE $ T.encodeUtf8 etag)+                                (1 == I# $compressedE)+                                $(bytestringLazyE ct')+        |]+    where+        locE = litE $ stringL $ T.unpack loc+        (compressed, ct') = tryCompress mime ct+        compressedE = litE $ intPrimL $ if compressed then 1 else 0++mkEntry (EmbeddableEntry loc mime (Right expr)) =+        [| Right $ ReloadEntry (T.pack $locE)+                               $(bytestringE mime)+                               $expr+        |]+    where+        locE = litE $ stringL $ T.unpack loc++-- | Converts an embedded entry to a file+embeddedToFile :: EmbeddedEntry -> File+embeddedToFile entry = File+    { fileGetSize = fromIntegral $ B.length $ embContent entry+    , fileToResponse = \s h ->+        let h' = if embCompressed entry+                    then h ++ [("Content-Encoding", "gzip")]+                    else h+         in W.ResponseBuilder s h' $ insertByteString $ embContent entry++    -- Usually the fileName should just be the filename not the entire path,+    -- but we need the whole path to make the lookup within lookupMime+    -- possible.  lookupMime is provided only with the File and from that+    -- we must find the mime type. Putting the path here is OK since+    -- within staticApp the fileName is used for directory listings which+    -- we have disabled.+    , fileName = unsafeToPiece $ embLocation entry+    , fileGetHash = return $ if B.null (embEtag entry)+                                 then Nothing+                                 else Just $ embEtag entry+    , fileGetModified = Nothing+    }++-- | Converts a reload entry to a file+reloadToFile :: ReloadEntry -> IO File+reloadToFile entry = do+    (etag, ct) <- reloadContent entry+    let etag' = T.encodeUtf8 etag+    return $ File+        { fileGetSize = fromIntegral $ BL.length ct+        , fileToResponse = \s h -> W.responseLBS s h ct+        -- Similar to above the entire path needs to be in the fileName.+        , fileName = unsafeToPiece $ reloadLocation entry+        , fileGetHash = return $ if T.null etag then Nothing else Just etag'+        , fileGetModified = Nothing+        }+++-- | Build a static settings based on a filemap.+filemapToSettings :: M.HashMap T.Text (MimeType, IO File) -> StaticSettings+filemapToSettings mfiles = (defaultWebAppSettings "")+                              { ssLookupFile = lookupFile+                              , ssGetMimeType = lookupMime+                              }+    where+        piecesToFile p = T.intercalate "/" $ map fromPiece p++        lookupFile [] = return LRNotFound+        lookupFile p =+            case M.lookup (piecesToFile p) mfiles of+                Nothing -> return LRNotFound+                Just (_,act) -> LRFile <$> act++        lookupMime (File { fileName = p }) =+            case M.lookup (fromPiece p) mfiles of+                Just (mime,_) -> return mime+                Nothing -> return $ defaultMimeLookup $ fromPiece p++-- | Create a 'StaticSettings' from a list of entries.  Executed at run time.+entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings+entriesToSt entries = hmap `seq` filemapToSettings hmap+    where+        embFiles = [ (embLocation e, (embMime e, return $ embeddedToFile e)) | e <- lefts entries]+        reloadFiles = [ (reloadLocation r, (reloadMime r, reloadToFile r)) | r <- rights entries]+        hmap = M.fromList $ embFiles ++ reloadFiles++-- | Create a 'StaticSettings' at compile time that embeds resources directly into the compiled+--   executable.  The embedded resources are precompressed (depending on mime type)+--   so that during runtime the resource can be served very quickly.+--+--   Because of GHC Template Haskell stage restrictions, you must define+--   the entries in a different module than where you create the 'StaticSettings'.+--   For example,+--+-- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}+-- > module A (mkEmbedded) where+-- > +-- > import WaiAppStatic.Storage.Embedded+-- > import Crypto.Hash.MD5 (hashlazy)+-- > import qualified Data.ByteString.Lazy as BL+-- > import qualified Data.ByteString.Base64 as B64+-- > import qualified Data.Text as T+-- > import qualified Data.Text.Encoding as T+-- > +-- > hash :: BL.ByteString -> T.Text+-- > hash = T.take 8 . T.decodeUtf8 . B64.encode . hashlazy+-- > +-- > mkEmbedded :: IO [EmbeddableEntry]+-- > mkEmbedded = do+-- >     file <- BL.readFile "test.css"+-- >     let emb = EmbeddableEntry {+-- >                   eLocation = "somedir/test.css"+-- >                 , eMimeType = "text/css"+-- >                 , eContent  = Left (hash file, file)+-- >                 }+-- > +-- >     let reload = EmbeddableEntry {+-- >                      eLocation = "anotherdir/test2.txt"+-- >                    , eMimeType = "text/plain"+-- >                    , eContent  = Right [| BL.readFile "test2.txt" >>= \c -> return (hash c, c) |]+-- >                    }+-- > +-- >     return [emb, reload]+--+-- The above @mkEmbedded@ will be executed at compile time.  It loads the contents of test.css and+-- computes the hash of test.css for the etag.  The content will be available at the URL somedir/test.css.+-- Internally, 'embedApp' below will attempt to compress the content at compile time. The compression will+-- only happen if the compressed content is shorter than the original and the mime type is either text or+-- javascript.  If the content is compressed, at runtime the precomputed compressed content will be served+-- with the appropriate HTTP header. If 'embedApp' decides not to compress the content, it will be+-- served directly.+--+-- Secondly, @mkEmbedded@ creates a reloadable entry.  This will be available at the URL anotherdir/test2.txt.+-- Whenver a request comes in for anotherdir/test2.txt, the action inside the quasiquote in eContent will+-- be executed.  This will re-read the test2.txt file and recompute its hash.+--+-- Finally, here is a module which uses the above action to create a 'W.Application'.+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- > module B where+-- > +-- > import A+-- > import Network.Wai (Application)+-- > import Network.Wai.Application.Static (staticApp)+-- > import WaiAppStatic.Storage.Embedded+-- > import Network.Wai.Handler.Warp (run)+-- > +-- > myApp :: Application+-- > myApp = staticApp $(mkSettings mkEmbedded)+-- > +-- > main :: IO ()+-- > main = run 3000 myApp+mkSettings :: IO [EmbeddableEntry] -> ExpQ+mkSettings action = do+    entries <- runIO action+    [| entriesToSt $(listE $ map mkEntry entries) |]++shouldCompress :: MimeType -> Bool+shouldCompress m = "text/" `B.isPrefixOf` m || m `elem` extra+    where+        extra = [ "application/json"+                , "application/javascript"+                , "application/ecmascript"+                ]++-- | Only compress if the mime type is correct and the compressed text is actually shorter.+tryCompress :: MimeType -> BL.ByteString -> (Bool, BL.ByteString)+tryCompress mime ct+        | shouldCompress mime = (c, ct')+        | otherwise = (False, ct)+    where+        compressed = compress ct+        c = BL.length compressed < BL.length ct+        ct' = if c then compressed else ct

@@ -1,5 +1,6 @@ import WaiAppStaticTest (spec)+import WaiAppEmbeddedTest (embSpec) import Test.Hspec.Monadic  main :: IO ()-main = hspec spec+main = hspec $ spec >> embSpec

@@ -1,5 +1,5 @@ name:            wai-app-static-version:         1.3.1.4+version:         1.3.2 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -47,6 +47,9 @@                    , crypto-conduit            >= 0.4                    , cereal                    >= 0.3.5                    , mime-types                >= 0.1      && < 0.2+                   , unordered-containers      >= 0.2+                   , template-haskell          >= 2.8+                   , zlib                      >= 0.5      exposed-modules: Network.Wai.Application.Static                      WaiAppStatic.Storage.Filesystem@@ -54,6 +57,8 @@                      WaiAppStatic.Listing                      WaiAppStatic.Types     other-modules:   Util+                     WaiAppStatic.Storage.Embedded.Runtime+                     WaiAppStatic.Storage.Embedded.TH     ghc-options:     -Wall     extensions:     CPP @@ -80,6 +85,7 @@                    , text                    , transformers                    , mime-types+                   , zlib                    -- , containers   ghc-options:   -Wall