git.iko.soy/typeable/wai
on master help sign in
Initial embedded support
cabf023Michael Snoyman
Network/Wai/Application/Static.hs+74−1
compare with master
unifiedsplit
@@ -36,8 +36,10 @@ module Network.Wai.Application.Static
36 , unfixPathName
36 , unfixPathName
37 -- new stuff to be sorted
37 -- new stuff to be sorted
38 , fileSystemLookup
38 , fileSystemLookup
39+ , embeddedLookup
39 , defaultMkRedirect
40 , defaultMkRedirect
40 , File (..)
41 , File (..)
42+ , toEmbedded
41 ) where
43 ) where
42
44
43import qualified Network.Wai as W
45import qualified Network.Wai as W
@@ -59,7 +61,7 @@ import qualified Text.Blaze.Html5 as H
59import qualified Text.Blaze.Renderer.Utf8 as HU
61import qualified Text.Blaze.Renderer.Utf8 as HU
60import qualified Text.Blaze.Html5.Attributes as A
62import qualified Text.Blaze.Html5.Attributes as A
61
63
62−import Blaze.ByteString.Builder (toByteString, copyByteString)
64+import Blaze.ByteString.Builder (toByteString, copyByteString, fromByteString)
63import Data.Monoid (mappend)
65import Data.Monoid (mappend)
64
66
65import Data.Time
67import Data.Time
@@ -73,6 +75,11 @@ import qualified Data.Text as T
73import qualified Data.Text.Encoding as TE
75import qualified Data.Text.Encoding as TE
74import qualified Data.Text.Encoding.Error as TEE
76import qualified Data.Text.Encoding.Error as TEE
75
77
78+import Control.Arrow ((&&&), second)
79+import Data.List (groupBy, sortBy)
80+import Data.Function (on)
81+import Data.Ord (comparing)
82+
76#ifdef PRINT
83#ifdef PRINT
77import Debug.Trace
84import Debug.Trace
78debug :: (Show a) => a -> a
85debug :: (Show a) => a -> a
@@ -377,6 +384,72 @@ fileSystemLookup prefix pieces = do
377 return $ FLFolder $ Folder entries
384 return $ FLFolder $ Folder entries
378 else return FLDoesNotExist
385 else return FLDoesNotExist
379
386
387+type Embedded = Map.Map T.Text EmbeddedEntry
388+
389+data EmbeddedEntry = EEFile S8.ByteString | EEFolder Embedded
390+
391+embeddedLookup :: Embedded -> Pieces -> IO FileLookup -- FIXME broken for unicode path names
392+embeddedLookup root pieces =
393+ return $ elookup pieces root
394+ where
395+ elookup [] x = FLFolder $ Folder $ map toEntry $ Map.toList x
396+ elookup (p:ps) x =
397+ case Map.lookup p x of
398+ Nothing -> FLDoesNotExist
399+ Just (EEFile f) ->
400+ case ps of
401+ [] -> FLFile $ bsToFile p f
402+ _ -> FLDoesNotExist
403+ Just (EEFolder y) -> elookup ps y
404+
405+toEntry :: (T.Text, EmbeddedEntry) -> FolderEntry
406+toEntry (name, ee) = FolderEntry
407+ { feName = name
408+ , feIsFile =
409+ case ee of
410+ EEFile{} -> True
411+ EEFolder{} -> False
412+ , feGetMetaData = return $ Just $
413+ case ee of
414+ EEFile bs -> FileMetaData
415+ { mdName = T.unpack name
416+ , mdModified = 0 -- FIXME
417+ , mdSize = fromIntegral $ S8.length bs
418+ }
419+ EEFolder _ -> FolderMetaData
420+ { mdName = T.unpack name
421+ }
422+ }
423+
424+toEmbedded :: [(FilePath, S8.ByteString)] -> Embedded
425+toEmbedded fps =
426+ go texts
427+ where
428+ texts = map (\(x, y) -> (filter (not . T.null) $ toPieces x, y)) fps
429+ toPieces "" = []
430+ toPieces x =
431+ let (y, z) = break (== '/') x
432+ in T.pack y : toPieces (drop 1 z)
433+ go :: [(Pieces, S8.ByteString)] -> Embedded
434+ go orig =
435+ Map.fromList $ map (second go') hoisted
436+ where
437+ next = map (\(x, y) -> (head x, (tail x, y))) orig
438+ grouped :: [[(T.Text, (Pieces, S8.ByteString))]]
439+ grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
440+ hoisted :: [(T.Text, [(Pieces, S8.ByteString)])]
441+ hoisted = map (fst . head &&& map snd) grouped
442+ go' :: [(Pieces, S8.ByteString)] -> EmbeddedEntry
443+ go' [([], content)] = EEFile content
444+ go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x
445+
446+bsToFile :: T.Text -> S8.ByteString -> File
447+bsToFile name bs = File
448+ { fileGetSize = return $ S8.length bs
449+ , fileToResponse = \s h -> W.ResponseBuilder s h $ fromByteString bs
450+ , fileName = name
451+ }
452+
380staticApp :: StaticSettings -> W.Application
453staticApp :: StaticSettings -> W.Application
381staticApp set req = do
454staticApp set req = do
382 let pieces = W.pathInfo req
455 let pieces = W.pathInfo req