@@ -0,0 +1,259 @@
1+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, MagicHash #-}
2+module WaiAppStatic.Storage.Embedded.TH(
3+ Etag
4+ , EmbeddableEntry(..)
5+ , mkSettings
6+) where
7+
8+import Blaze.ByteString.Builder.ByteString (insertByteString)
9+import Codec.Compression.GZip (compress)
10+import Control.Applicative
11+import Data.ByteString.Unsafe (unsafePackAddressLen)
12+import Data.Either (lefts, rights)
13+import GHC.Exts (Int(..))
14+import Language.Haskell.TH
15+import Network.Mime (MimeType, defaultMimeLookup)
16+import System.IO.Unsafe (unsafeDupablePerformIO)
17+import WaiAppStatic.Types
18+import WaiAppStatic.Storage.Filesystem (defaultWebAppSettings)
19+import qualified Data.ByteString as B
20+import qualified Data.ByteString.Lazy as BL
21+import qualified Data.HashMap.Strict as M
22+import qualified Data.Text as T
23+import qualified Data.Text.Encoding as T
24+import qualified Network.Wai as W
25+
26+-- | An Etag is used to return 304 Not Modified responses so the client does not need
27+-- to download resources a second time. Usually the etag is built from a hash of
28+-- the content. To disable Etags, you can pass the empty string. This will cause the
29+-- content to be redownloaded on every request.
30+type Etag = T.Text
31+
32+-- | Used at compile time to hold data about an entry to embed into the compiled executable.
33+data EmbeddableEntry = EmbeddableEntry {
34+ eLocation :: T.Text -- ^ The location where this resource should be served from. The
35+ -- location can contain forward slashes (/) to simulate directories,
36+ -- but must not end with a forward slash.
37+ , eMimeType :: MimeType -- ^ The mime type.
38+ , eContent :: Either (Etag, BL.ByteString) ExpQ
39+ -- ^ The content itself. The content can be given as a tag and bytestring,
40+ -- in which case the content will be embedded directly into the execuatble.
41+ -- Alternatively, the content can be given as a template haskell expression
42+ -- returning @IO ('Etag', 'BL.ByteString')@ in which case this action will
43+ -- be executed on every request to reload the content (this is useful
44+ -- for a debugging mode).
45+}
46+
47+-- | This structure is used at runtime to hold the entry.
48+data EmbeddedEntry = EmbeddedEntry {
49+ embLocation :: !T.Text
50+ , embMime :: !MimeType
51+ , embEtag :: !B.ByteString
52+ , embCompressed :: !Bool
53+ , embContent :: !B.ByteString
54+}
55+
56+-- | This structure is used at runtime to hold the reload entries.
57+data ReloadEntry = ReloadEntry {
58+ reloadLocation :: !T.Text
59+ , reloadMime :: !MimeType
60+ , reloadContent :: IO (T.Text, BL.ByteString)
61+}
62+
63+-- The use of unsafePackAddressLen is safe here because the length
64+-- is correct and we will only be reading from the bytestring, never
65+-- modifying it.
66+--
67+-- The only IO within unsafePackAddressLen is within newForeignPtr_ where
68+-- a new IORef is created as newIORef (NoFinalizers, []) to hold the finalizer
69+-- for the pointer. Since the pointer for the content will never have a finalizer
70+-- added, we do not care if this finalizer IORef gets created more than once since
71+-- the IORef will always be holding (NoFinalizers, []). Therefore
72+-- unsafeDupablePerformIO is safe.
73+bytestringE :: B.ByteString -> ExpQ
74+bytestringE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
75+ where
76+ lenE = litE $ intPrimL $ toInteger $ B.length b
77+ ctE = litE $ stringPrimL $ B.unpack b
78+bytestringLazyE :: BL.ByteString -> ExpQ
79+bytestringLazyE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
80+ where
81+ lenE = litE $ intPrimL $ toInteger $ BL.length b
82+ ctE = litE $ stringPrimL $ BL.unpack b
83+
84+-- | A template haskell expression which creates either an EmbeddedEntry or ReloadEntry.
85+mkEntry :: EmbeddableEntry -> ExpQ
86+mkEntry (EmbeddableEntry loc mime (Left (etag, ct))) =
87+ [| Left $ EmbeddedEntry (T.pack $locE)
88+ $(bytestringE mime)
89+ $(bytestringE $ T.encodeUtf8 etag)
90+ (1 == I# $compressedE)
91+ $(bytestringLazyE ct')
92+ |]
93+ where
94+ locE = litE $ stringL $ T.unpack loc
95+ (compressed, ct') = tryCompress mime ct
96+ compressedE = litE $ intPrimL $ if compressed then 1 else 0
97+
98+mkEntry (EmbeddableEntry loc mime (Right expr)) =
99+ [| Right $ ReloadEntry (T.pack $locE)
100+ $(bytestringE mime)
101+ $expr
102+ |]
103+ where
104+ locE = litE $ stringL $ T.unpack loc
105+
106+-- | Converts an embedded entry to a file
107+embeddedToFile :: EmbeddedEntry -> File
108+embeddedToFile entry = File
109+ { fileGetSize = fromIntegral $ B.length $ embContent entry
110+ , fileToResponse = \s h ->
111+ let h' = if embCompressed entry
112+ then h ++ [("Content-Encoding", "gzip")]
113+ else h
114+ in W.ResponseBuilder s h' $ insertByteString $ embContent entry
115+
116+ -- Usually the fileName should just be the filename not the entire path,
117+ -- but we need the whole path to make the lookup within lookupMime
118+ -- possible. lookupMime is provided only with the File and from that
119+ -- we must find the mime type. Putting the path here is OK since
120+ -- within staticApp the fileName is used for directory listings which
121+ -- we have disabled.
122+ , fileName = unsafeToPiece $ embLocation entry
123+ , fileGetHash = return $ if B.null (embEtag entry)
124+ then Nothing
125+ else Just $ embEtag entry
126+ , fileGetModified = Nothing
127+ }
128+
129+-- | Converts a reload entry to a file
130+reloadToFile :: ReloadEntry -> IO File
131+reloadToFile entry = do
132+ (etag, ct) <- reloadContent entry
133+ let etag' = T.encodeUtf8 etag
134+ return $ File
135+ { fileGetSize = fromIntegral $ BL.length ct
136+ , fileToResponse = \s h -> W.responseLBS s h ct
137+ -- Similar to above the entire path needs to be in the fileName.
138+ , fileName = unsafeToPiece $ reloadLocation entry
139+ , fileGetHash = return $ if T.null etag then Nothing else Just etag'
140+ , fileGetModified = Nothing
141+ }
142+
143+
144+-- | Build a static settings based on a filemap.
145+filemapToSettings :: M.HashMap T.Text (MimeType, IO File) -> StaticSettings
146+filemapToSettings mfiles = (defaultWebAppSettings "")
147+ { ssLookupFile = lookupFile
148+ , ssGetMimeType = lookupMime
149+ }
150+ where
151+ piecesToFile p = T.intercalate "/" $ map fromPiece p
152+
153+ lookupFile [] = return LRNotFound
154+ lookupFile p =
155+ case M.lookup (piecesToFile p) mfiles of
156+ Nothing -> return LRNotFound
157+ Just (_,act) -> LRFile <$> act
158+
159+ lookupMime (File { fileName = p }) =
160+ case M.lookup (fromPiece p) mfiles of
161+ Just (mime,_) -> return mime
162+ Nothing -> return $ defaultMimeLookup $ fromPiece p
163+
164+-- | Create a 'StaticSettings' from a list of entries. Executed at run time.
165+entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings
166+entriesToSt entries = hmap `seq` filemapToSettings hmap
167+ where
168+ embFiles = [ (embLocation e, (embMime e, return $ embeddedToFile e)) | e <- lefts entries]
169+ reloadFiles = [ (reloadLocation r, (reloadMime r, reloadToFile r)) | r <- rights entries]
170+ hmap = M.fromList $ embFiles ++ reloadFiles
171+
172+-- | Create a 'StaticSettings' at compile time that embeds resources directly into the compiled
173+-- executable. The embedded resources are precompressed (depending on mime type)
174+-- so that during runtime the resource can be served very quickly.
175+--
176+-- Because of GHC Template Haskell stage restrictions, you must define
177+-- the entries in a different module than where you create the 'StaticSettings'.
178+-- For example,
179+--
180+-- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
181+-- > module A (mkEmbedded) where
182+-- >
183+-- > import WaiAppStatic.Storage.Embedded
184+-- > import Crypto.Hash.MD5 (hashlazy)
185+-- > import qualified Data.ByteString.Lazy as BL
186+-- > import qualified Data.ByteString.Base64 as B64
187+-- > import qualified Data.Text as T
188+-- > import qualified Data.Text.Encoding as T
189+-- >
190+-- > hash :: BL.ByteString -> T.Text
191+-- > hash = T.take 8 . T.decodeUtf8 . B64.encode . hashlazy
192+-- >
193+-- > mkEmbedded :: IO [EmbeddableEntry]
194+-- > mkEmbedded = do
195+-- > file <- BL.readFile "test.css"
196+-- > let emb = EmbeddableEntry {
197+-- > eLocation = "somedir/test.css"
198+-- > , eMimeType = "text/css"
199+-- > , eContent = Left (hash file, file)
200+-- > }
201+-- >
202+-- > let reload = EmbeddableEntry {
203+-- > eLocation = "anotherdir/test2.txt"
204+-- > , eMimeType = "text/plain"
205+-- > , eContent = Right [| BL.readFile "test2.txt" >>= \c -> return (hash c, c) |]
206+-- > }
207+-- >
208+-- > return [emb, reload]
209+--
210+-- The above @mkEmbedded@ will be executed at compile time. It loads the contents of test.css and
211+-- computes the hash of test.css for the etag. The content will be available at the URL somedir/test.css.
212+-- Internally, 'embedApp' below will attempt to compress the content at compile time. The compression will
213+-- only happen if the compressed content is shorter than the original and the mime type is either text or
214+-- javascript. If the content is compressed, at runtime the precomputed compressed content will be served
215+-- with the appropriate HTTP header. If 'embedApp' decides not to compress the content, it will be
216+-- served directly.
217+--
218+-- Secondly, @mkEmbedded@ creates a reloadable entry. This will be available at the URL anotherdir/test2.txt.
219+-- Whenver a request comes in for anotherdir/test2.txt, the action inside the quasiquote in eContent will
220+-- be executed. This will re-read the test2.txt file and recompute its hash.
221+--
222+-- Finally, here is a module which uses the above action to create a 'W.Application'.
223+--
224+-- > {-# LANGUAGE TemplateHaskell #-}
225+-- > module B where
226+-- >
227+-- > import A
228+-- > import Network.Wai (Application)
229+-- > import Network.Wai.Application.Static (staticApp)
230+-- > import WaiAppStatic.Storage.Embedded
231+-- > import Network.Wai.Handler.Warp (run)
232+-- >
233+-- > myApp :: Application
234+-- > myApp = staticApp $(mkSettings mkEmbedded)
235+-- >
236+-- > main :: IO ()
237+-- > main = run 3000 myApp
238+mkSettings :: IO [EmbeddableEntry] -> ExpQ
239+mkSettings action = do
240+ entries <- runIO action
241+ [| entriesToSt $(listE $ map mkEntry entries) |]
242+
243+shouldCompress :: MimeType -> Bool
244+shouldCompress m = "text/" `B.isPrefixOf` m || m `elem` extra
245+ where
246+ extra = [ "application/json"
247+ , "application/javascript"
248+ , "application/ecmascript"
249+ ]
250+
251+-- | Only compress if the mime type is correct and the compressed text is actually shorter.
252+tryCompress :: MimeType -> BL.ByteString -> (Bool, BL.ByteString)
253+tryCompress mime ct
254+ | shouldCompress mime = (c, ct')
255+ | otherwise = (False, ct)
256+ where
257+ compressed = compress ct
258+ c = BL.length compressed < BL.length ct
259+ ct' = if c then compressed else ct