{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, MagicHash #-}
module WaiAppStatic.Storage.Embedded.TH(
Etag
, EmbeddableEntry(..)
, mkSettings
) where
import Data.ByteString.Builder.Extra (byteStringInsert)
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
#if !MIN_VERSION_template_haskell(2, 8, 0)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as BL8
#endif
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
type Etag = T.Text
data EmbeddableEntry = EmbeddableEntry {
EmbeddableEntry -> Text
eLocation :: T.Text
, EmbeddableEntry -> MimeType
eMimeType :: MimeType
, EmbeddableEntry -> Either (Text, ByteString) ExpQ
eContent :: Either (Etag, BL.ByteString) ExpQ
}
data EmbeddedEntry = EmbeddedEntry {
EmbeddedEntry -> Text
embLocation :: !T.Text
, EmbeddedEntry -> MimeType
embMime :: !MimeType
, EmbeddedEntry -> MimeType
embEtag :: !B.ByteString
, EmbeddedEntry -> Bool
embCompressed :: !Bool
, EmbeddedEntry -> MimeType
embContent :: !B.ByteString
}
data ReloadEntry = ReloadEntry {
ReloadEntry -> Text
reloadLocation :: !T.Text
, ReloadEntry -> MimeType
reloadMime :: !MimeType
, ReloadEntry -> IO (Text, ByteString)
reloadContent :: IO (T.Text, BL.ByteString)
}
bytestringE :: B.ByteString -> ExpQ
#if MIN_VERSION_template_haskell(2, 8, 0)
bytestringE :: MimeType -> ExpQ
bytestringE b :: MimeType
b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
where
lenE :: ExpQ
lenE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ MimeType -> Int
B.length MimeType
b
ctE :: ExpQ
ctE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
stringPrimL ([Word8] -> Lit) -> [Word8] -> Lit
forall a b. (a -> b) -> a -> b
$ MimeType -> [Word8]
B.unpack MimeType
b
#else
bytestringE b =
[| B8.pack $s |]
where
s = litE $ stringL $ B8.unpack b
#endif
bytestringLazyE :: BL.ByteString -> ExpQ
#if MIN_VERSION_template_haskell(2, 8, 0)
bytestringLazyE :: ByteString -> ExpQ
bytestringLazyE b :: ByteString
b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
where
lenE :: ExpQ
lenE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> Integer) -> Int64 -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
b
ctE :: ExpQ
ctE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
stringPrimL ([Word8] -> Lit) -> [Word8] -> Lit
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BL.unpack ByteString
b
#else
bytestringLazyE b =
[| B8.pack $s |]
where
s = litE $ stringL $ BL8.unpack b
#endif
mkEntry :: EmbeddableEntry -> ExpQ
mkEntry :: EmbeddableEntry -> ExpQ
mkEntry (EmbeddableEntry loc :: Text
loc mime :: MimeType
mime (Left (etag :: Text
etag, ct :: ByteString
ct))) =
[| Left $ EmbeddedEntry (T.pack $locE)
$(bytestringE mime)
$(bytestringE $ T.encodeUtf8 etag)
(1 == I# $compressedE)
$(bytestringLazyE ct')
|]
where
locE :: ExpQ
locE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
loc
(compressed :: Bool
compressed, ct' :: ByteString
ct') = MimeType -> ByteString -> (Bool, ByteString)
tryCompress MimeType
mime ByteString
ct
compressedE :: ExpQ
compressedE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ if Bool
compressed then 1 else 0
mkEntry (EmbeddableEntry loc :: Text
loc mime :: MimeType
mime (Right expr :: ExpQ
expr)) =
[| Right $ ReloadEntry (T.pack $locE)
$(bytestringE mime)
$expr
|]
where
locE :: ExpQ
locE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
loc
embeddedToFile :: EmbeddedEntry -> File
embeddedToFile :: EmbeddedEntry -> File
embeddedToFile entry :: EmbeddedEntry
entry = File :: Integer
-> (Status -> ResponseHeaders -> Response)
-> Piece
-> IO (Maybe MimeType)
-> Maybe EpochTime
-> File
File
{ fileGetSize :: Integer
fileGetSize = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ MimeType -> Int
B.length (MimeType -> Int) -> MimeType -> Int
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> MimeType
embContent EmbeddedEntry
entry
, fileToResponse :: Status -> ResponseHeaders -> Response
fileToResponse = \s :: Status
s h :: ResponseHeaders
h ->
let h' :: ResponseHeaders
h' = if EmbeddedEntry -> Bool
embCompressed EmbeddedEntry
entry
then ResponseHeaders
h ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++ [("Content-Encoding", "gzip")]
else ResponseHeaders
h
in Status -> ResponseHeaders -> Builder -> Response
W.responseBuilder Status
s ResponseHeaders
h' (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$ MimeType -> Builder
byteStringInsert (MimeType -> Builder) -> MimeType -> Builder
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> MimeType
embContent EmbeddedEntry
entry
, fileName :: Piece
fileName = Text -> Piece
unsafeToPiece (Text -> Piece) -> Text -> Piece
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> Text
embLocation EmbeddedEntry
entry
, fileGetHash :: IO (Maybe MimeType)
fileGetHash = Maybe MimeType -> IO (Maybe MimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MimeType -> IO (Maybe MimeType))
-> Maybe MimeType -> IO (Maybe MimeType)
forall a b. (a -> b) -> a -> b
$ if MimeType -> Bool
B.null (EmbeddedEntry -> MimeType
embEtag EmbeddedEntry
entry)
then Maybe MimeType
forall a. Maybe a
Nothing
else MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> MimeType
embEtag EmbeddedEntry
entry
, fileGetModified :: Maybe EpochTime
fileGetModified = Maybe EpochTime
forall a. Maybe a
Nothing
}
reloadToFile :: ReloadEntry -> IO File
reloadToFile :: ReloadEntry -> IO File
reloadToFile entry :: ReloadEntry
entry = do
(etag :: Text
etag, ct :: ByteString
ct) <- ReloadEntry -> IO (Text, ByteString)
reloadContent ReloadEntry
entry
let etag' :: MimeType
etag' = Text -> MimeType
T.encodeUtf8 Text
etag
File -> IO File
forall (m :: * -> *) a. Monad m => a -> m a
return (File -> IO File) -> File -> IO File
forall a b. (a -> b) -> a -> b
$ File :: Integer
-> (Status -> ResponseHeaders -> Response)
-> Piece
-> IO (Maybe MimeType)
-> Maybe EpochTime
-> File
File
{ fileGetSize :: Integer
fileGetSize = Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> Int64 -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
ct
, fileToResponse :: Status -> ResponseHeaders -> Response
fileToResponse = \s :: Status
s h :: ResponseHeaders
h -> Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
s ResponseHeaders
h ByteString
ct
, fileName :: Piece
fileName = Text -> Piece
unsafeToPiece (Text -> Piece) -> Text -> Piece
forall a b. (a -> b) -> a -> b
$ ReloadEntry -> Text
reloadLocation ReloadEntry
entry
, fileGetHash :: IO (Maybe MimeType)
fileGetHash = Maybe MimeType -> IO (Maybe MimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MimeType -> IO (Maybe MimeType))
-> Maybe MimeType -> IO (Maybe MimeType)
forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
etag then Maybe MimeType
forall a. Maybe a
Nothing else MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just MimeType
etag'
, fileGetModified :: Maybe EpochTime
fileGetModified = Maybe EpochTime
forall a. Maybe a
Nothing
}
filemapToSettings :: M.HashMap T.Text (MimeType, IO File) -> StaticSettings
filemapToSettings :: HashMap Text (MimeType, IO File) -> StaticSettings
filemapToSettings mfiles :: HashMap Text (MimeType, IO File)
mfiles = (String -> StaticSettings
defaultWebAppSettings "")
{ ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = Pieces -> IO LookupResult
lookupFile
, ssGetMimeType :: File -> IO MimeType
ssGetMimeType = File -> IO MimeType
forall (m :: * -> *). Monad m => File -> m MimeType
lookupMime
}
where
piecesToFile :: Pieces -> Text
piecesToFile p :: Pieces
p = Text -> [Text] -> Text
T.intercalate "/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Piece -> Text) -> Pieces -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Piece -> Text
fromPiece Pieces
p
lookupFile :: Pieces -> IO LookupResult
lookupFile [] = LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
LRNotFound
lookupFile p :: Pieces
p =
case Text
-> HashMap Text (MimeType, IO File) -> Maybe (MimeType, IO File)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (Pieces -> Text
piecesToFile Pieces
p) HashMap Text (MimeType, IO File)
mfiles of
Nothing -> LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
LRNotFound
Just (_,act :: IO File
act) -> File -> LookupResult
LRFile (File -> LookupResult) -> IO File -> IO LookupResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO File
act
lookupMime :: File -> m MimeType
lookupMime (File { fileName :: File -> Piece
fileName = Piece
p }) =
case Text
-> HashMap Text (MimeType, IO File) -> Maybe (MimeType, IO File)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (Piece -> Text
fromPiece Piece
p) HashMap Text (MimeType, IO File)
mfiles of
Just (mime :: MimeType
mime,_) -> MimeType -> m MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return MimeType
mime
Nothing -> MimeType -> m MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return (MimeType -> m MimeType) -> MimeType -> m MimeType
forall a b. (a -> b) -> a -> b
$ Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ Piece -> Text
fromPiece Piece
p
entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings
entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings
entriesToSt entries :: [Either EmbeddedEntry ReloadEntry]
entries = HashMap Text (MimeType, IO File)
hmap HashMap Text (MimeType, IO File)
-> StaticSettings -> StaticSettings
forall a b. a -> b -> b
`seq` HashMap Text (MimeType, IO File) -> StaticSettings
filemapToSettings HashMap Text (MimeType, IO File)
hmap
where
embFiles :: [(Text, (MimeType, IO File))]
embFiles = [ (EmbeddedEntry -> Text
embLocation EmbeddedEntry
e, (EmbeddedEntry -> MimeType
embMime EmbeddedEntry
e, File -> IO File
forall (m :: * -> *) a. Monad m => a -> m a
return (File -> IO File) -> File -> IO File
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> File
embeddedToFile EmbeddedEntry
e)) | EmbeddedEntry
e <- [Either EmbeddedEntry ReloadEntry] -> [EmbeddedEntry]
forall a b. [Either a b] -> [a]
lefts [Either EmbeddedEntry ReloadEntry]
entries]
reloadFiles :: [(Text, (MimeType, IO File))]
reloadFiles = [ (ReloadEntry -> Text
reloadLocation ReloadEntry
r, (ReloadEntry -> MimeType
reloadMime ReloadEntry
r, ReloadEntry -> IO File
reloadToFile ReloadEntry
r)) | ReloadEntry
r <- [Either EmbeddedEntry ReloadEntry] -> [ReloadEntry]
forall a b. [Either a b] -> [b]
rights [Either EmbeddedEntry ReloadEntry]
entries]
hmap :: HashMap Text (MimeType, IO File)
hmap = [(Text, (MimeType, IO File))] -> HashMap Text (MimeType, IO File)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Text, (MimeType, IO File))] -> HashMap Text (MimeType, IO File))
-> [(Text, (MimeType, IO File))]
-> HashMap Text (MimeType, IO File)
forall a b. (a -> b) -> a -> b
$ [(Text, (MimeType, IO File))]
embFiles [(Text, (MimeType, IO File))]
-> [(Text, (MimeType, IO File))] -> [(Text, (MimeType, IO File))]
forall a. [a] -> [a] -> [a]
++ [(Text, (MimeType, IO File))]
reloadFiles
mkSettings :: IO [EmbeddableEntry] -> ExpQ
mkSettings :: IO [EmbeddableEntry] -> ExpQ
mkSettings action :: IO [EmbeddableEntry]
action = do
[EmbeddableEntry]
entries <- IO [EmbeddableEntry] -> Q [EmbeddableEntry]
forall a. IO a -> Q a
runIO IO [EmbeddableEntry]
action
[| entriesToSt $(listE $ map mkEntry entries) |]
shouldCompress :: MimeType -> Bool
shouldCompress :: MimeType -> Bool
shouldCompress m :: MimeType
m = "text/" MimeType -> MimeType -> Bool
`B.isPrefixOf` MimeType
m Bool -> Bool -> Bool
|| MimeType
m MimeType -> [MimeType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MimeType]
extra
where
extra :: [MimeType]
extra = [ "application/json"
, "application/javascript"
, "application/ecmascript"
]
tryCompress :: MimeType -> BL.ByteString -> (Bool, BL.ByteString)
tryCompress :: MimeType -> ByteString -> (Bool, ByteString)
tryCompress mime :: MimeType
mime ct :: ByteString
ct
| MimeType -> Bool
shouldCompress MimeType
mime = (Bool
c, ByteString
ct')
| Bool
otherwise = (Bool
False, ByteString
ct)
where
compressed :: ByteString
compressed = ByteString -> ByteString
compress ByteString
ct
c :: Bool
c = ByteString -> Int64
BL.length ByteString
compressed Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int64
BL.length ByteString
ct
ct' :: ByteString
ct' = if Bool
c then ByteString
compressed else ByteString
ct