@@ -11,24 +11,35 @@
1111-- Originally from waitra package:
1212-- <http://hackage.haskell.org/package/waitra-0.0.4.0/docs/Network-Waitra-Embedded.html>
1313----------------------------------------------------------------------------
14−module Servant.Swagger.UI.Internal (mkRecursiveEmbedded) where
14+module Servant.Swagger.UI.Internal (mkRecursiveEmbedded, embedText) where
1515
16−import qualified Codec.Compression.Lzma as LZMA
17−import Control.Arrow (first)
18−import Control.Monad (forM)
19−import qualified Data.ByteString as BS
20−import qualified Data.ByteString.Lazy as BSL
21−import qualified Data.ByteString.Unsafe as BS.Unsafe
22−import Language.Haskell.TH
23−import System.Directory
24− (doesDirectoryExist, getDirectoryContents)
25−import System.FilePath (makeRelative, (</>))
26−import System.IO.Unsafe (unsafePerformIO)
16+import Prelude ()
17+import Prelude.Compat
18+
19+import Control.Arrow (first)
20+import Control.Monad (forM)
21+import Control.Monad.Trans.State.Strict (runState, state)
22+import Data.Functor.Compose (Compose (..))
23+import Data.Int (Int64)
24+import Language.Haskell.TH
25+import System.Directory
26+ (doesDirectoryExist, getDirectoryContents)
27+import System.FilePath (makeRelative, (</>))
28+import System.IO.Unsafe (unsafePerformIO)
29+
30+import qualified Codec.Compression.Lzma as LZMA
31+import qualified Data.ByteString as BS
32+import qualified Data.ByteString.Lazy as BSL
33+import qualified Data.ByteString.Unsafe as BS.Unsafe
34+import qualified Data.Text.Lazy as TL
35+import qualified Data.Text.Lazy.Encoding as TLE
36+
37+import Instances.TH.Lift ()
2738
2839getRecursiveContents :: FilePath -> IO [(FilePath, BSL.ByteString)]
2940getRecursiveContents topdir = do
3041 names <- getDirectoryContents topdir
31− let properNames = Prelude.filter (`notElem` [".", ".."]) names
42+ let properNames = filter (`notElem` [".", ".."]) names
3243 paths <- forM properNames $ \name -> do
3344 let path = topdir </> name
3445 isDirectory <- doesDirectoryExist path
@@ -51,12 +62,33 @@ lazyBytestringE lbs =
5162 $ BS.Unsafe.unsafePackAddressLen $l $s
5263 |]
5364 where
54− bs = BSL.toStrict $ LZMA.compress lbs
65+ bs = BSL.toStrict $ LZMA.compressWith params lbs
5566 s = litE $ stringPrimL $ BS.unpack bs
5667 l = litE $ integerL $ fromIntegral $ BS.length bs
5768
58−makeEmbeddedEntry :: (FilePath, BSL.ByteString) -> Q Exp
59−makeEmbeddedEntry (path, bs) = [| (path, BSL.toStrict $(lazyBytestringE bs)) |]
69+ params = LZMA.defaultCompressParams
70+ {- doesn't seem to affect much
71+ { LZMA.compressLevel = LZMA.CompressionLevel9
72+ , LZMA.compressLevelExtreme = True
73+ }
74+ -}
75+
76+makeEmbeddedEntry :: Name -> (FilePath, (Int64, Int64)) -> Q Exp
77+makeEmbeddedEntry name (path, (off, len)) =
78+ [| (path, BSL.toStrict $ BSL.take len $ BSL.drop off $(varE name)) |]
79+
80+concatEntries :: Traversable t => t BSL.ByteString -> (BSL.ByteString, t (Int64, Int64))
81+concatEntries xs = (bslEndo BSL.empty, ys)
82+ where
83+ (ys, (_, bslEndo)) = runState (traverse (state . single) xs) (0, id)
84+
85+ single
86+ :: BSL.ByteString -- file bytestring
87+ -> (Int64, BSL.ByteString -> BSL.ByteString) -- current offset, buffer so far
88+ -> ((Int64, Int64), (Int64, BSL.ByteString -> BSL.ByteString))
89+ single bsl (off, endo) = ((off, l), (off + l, endo . BSL.append bsl))
90+ where
91+ l = fromIntegral $ BSL.length bsl
6092
6193-- | Create a @[('FilePath', 'BSL.ByteString')]@ list, recursively traversing given directory path.
6294--
@@ -65,5 +97,20 @@ makeEmbeddedEntry (path, bs) = [| (path, BSL.toStrict $(lazyBytestringE bs)) |]
6597-- > staticApp $ defaultFileServerSettings "static"
6698mkRecursiveEmbedded :: FilePath -> Q Exp
6799mkRecursiveEmbedded topdir = do
68− pairs <- runIO $ fmap (makeAllRelative topdir) $ getRecursiveContents topdir
69− listE $ map makeEmbeddedEntry pairs
100+ pairs <- runIO $ fmap (makeAllRelative topdir) $ getRecursiveContents topdir
101+ -- we do a hop to only embed single big bytestring.
102+ -- it's beneficial as lzma have more stuff to compress
103+ let (bsl, Compose offsets) = concatEntries (Compose pairs)
104+ bslName <- newName "embedBsl"
105+ bslExpr <- lazyBytestringE bsl
106+ letE [ return $ ValD (VarP bslName) (NormalB bslExpr) [] ] $
107+ listE $ map (makeEmbeddedEntry bslName) offsets
108+
109+-- | Create a textual 'T.Text' from a UTF8-encoded file.
110+embedText :: FilePath -> Q Exp
111+embedText fp = do
112+ bsl <- runIO $ BSL.readFile fp
113+ case TLE.decodeUtf8' bsl of
114+ Left e -> reportError (show e)
115+ Right _ -> return ()
116+ [| TL.toStrict $ TLE.decodeUtf8 $ $(lazyBytestringE bsl) |]