{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Yesod.EmbeddedStatic.Internal (
EmbeddedStatic(..)
, Route(..)
, ComputedEntry(..)
, devEmbed
, prodEmbed
, develApp
, AddStaticContent
, staticContentHelper
, widgetSettings
) where
import Control.Applicative as A ((<$>))
import Data.IORef
import Language.Haskell.TH
import Network.HTTP.Types (Status(..), status404, status200, status304)
import Network.Mime (MimeType)
import Network.Wai
import Network.Wai.Application.Static (defaultWebAppSettings, staticApp)
import WaiAppStatic.Types
import Yesod.Core
( HandlerFor
, ParseRoute(..)
, RenderRoute(..)
, getYesod
, liftIO
)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.HashMap.Strict as M
import qualified WaiAppStatic.Storage.Embedded as Static
import Yesod.Static (base64md5)
import Yesod.EmbeddedStatic.Types
#if !MIN_VERSION_base(4,6,0)
atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
atomicModifyIORef' ref f = do
b <- atomicModifyIORef ref
(\x -> let (a, b) = f x
in (a, a `seq` b))
b `seq` return b
#endif
data EmbeddedStatic = EmbeddedStatic {
EmbeddedStatic -> Application
stApp :: !Application
, EmbeddedStatic -> IORef (HashMap Text File)
widgetFiles :: !(IORef (M.HashMap T.Text File))
}
instance RenderRoute EmbeddedStatic where
data Route EmbeddedStatic = EmbeddedResourceR [T.Text] [(T.Text,T.Text)]
| EmbeddedWidgetR T.Text
deriving (Route EmbeddedStatic -> Route EmbeddedStatic -> Bool
(Route EmbeddedStatic -> Route EmbeddedStatic -> Bool)
-> (Route EmbeddedStatic -> Route EmbeddedStatic -> Bool)
-> Eq (Route EmbeddedStatic)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Route EmbeddedStatic -> Route EmbeddedStatic -> Bool
== :: Route EmbeddedStatic -> Route EmbeddedStatic -> Bool
$c/= :: Route EmbeddedStatic -> Route EmbeddedStatic -> Bool
/= :: Route EmbeddedStatic -> Route EmbeddedStatic -> Bool
Eq, Int -> Route EmbeddedStatic -> ShowS
[Route EmbeddedStatic] -> ShowS
Route EmbeddedStatic -> String
(Int -> Route EmbeddedStatic -> ShowS)
-> (Route EmbeddedStatic -> String)
-> ([Route EmbeddedStatic] -> ShowS)
-> Show (Route EmbeddedStatic)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Route EmbeddedStatic -> ShowS
showsPrec :: Int -> Route EmbeddedStatic -> ShowS
$cshow :: Route EmbeddedStatic -> String
show :: Route EmbeddedStatic -> String
$cshowList :: [Route EmbeddedStatic] -> ShowS
showList :: [Route EmbeddedStatic] -> ShowS
Show, ReadPrec [Route EmbeddedStatic]
ReadPrec (Route EmbeddedStatic)
Int -> ReadS (Route EmbeddedStatic)
ReadS [Route EmbeddedStatic]
(Int -> ReadS (Route EmbeddedStatic))
-> ReadS [Route EmbeddedStatic]
-> ReadPrec (Route EmbeddedStatic)
-> ReadPrec [Route EmbeddedStatic]
-> Read (Route EmbeddedStatic)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS (Route EmbeddedStatic)
readsPrec :: Int -> ReadS (Route EmbeddedStatic)
$creadList :: ReadS [Route EmbeddedStatic]
readList :: ReadS [Route EmbeddedStatic]
$creadPrec :: ReadPrec (Route EmbeddedStatic)
readPrec :: ReadPrec (Route EmbeddedStatic)
$creadListPrec :: ReadPrec [Route EmbeddedStatic]
readListPrec :: ReadPrec [Route EmbeddedStatic]
Read)
renderRoute :: Route EmbeddedStatic -> ([Text], [(Text, Text)])
renderRoute (EmbeddedResourceR [Text]
x [(Text, Text)]
y) = (Text
"res"Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
x, [(Text, Text)]
y)
renderRoute (EmbeddedWidgetR Text
h) = ([Text
"widget",Text
h], [])
instance ParseRoute EmbeddedStatic where
parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route EmbeddedStatic)
parseRoute ((Text
"res":[Text]
x), [(Text, Text)]
y) = Route EmbeddedStatic -> Maybe (Route EmbeddedStatic)
forall a. a -> Maybe a
Just (Route EmbeddedStatic -> Maybe (Route EmbeddedStatic))
-> Route EmbeddedStatic -> Maybe (Route EmbeddedStatic)
forall a b. (a -> b) -> a -> b
$ [Text] -> [(Text, Text)] -> Route EmbeddedStatic
EmbeddedResourceR [Text]
x [(Text, Text)]
y
parseRoute ([Text
"widget",Text
h], [(Text, Text)]
_) = Route EmbeddedStatic -> Maybe (Route EmbeddedStatic)
forall a. a -> Maybe a
Just (Route EmbeddedStatic -> Maybe (Route EmbeddedStatic))
-> Route EmbeddedStatic -> Maybe (Route EmbeddedStatic)
forall a b. (a -> b) -> a -> b
$ Text -> Route EmbeddedStatic
EmbeddedWidgetR Text
h
parseRoute ([Text], [(Text, Text)])
_ = Maybe (Route EmbeddedStatic)
forall a. Maybe a
Nothing
data ComputedEntry = ComputedEntry {
ComputedEntry -> Maybe Name
cHaskellName :: Maybe Name
, ComputedEntry -> EmbeddableEntry
cStEntry :: Static.EmbeddableEntry
, ComputedEntry -> ExpQ
cLink :: ExpQ
}
mkStr :: String -> ExpQ
mkStr :: String -> ExpQ
mkStr = Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> ExpQ) -> (String -> Lit) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL
devEmbed :: Entry -> IO ComputedEntry
devEmbed :: Entry -> IO ComputedEntry
devEmbed Entry
e = ComputedEntry -> IO ComputedEntry
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ComputedEntry
computed
where
st :: EmbeddableEntry
st = Static.EmbeddableEntry {
eLocation :: Text
Static.eLocation = Text
"res/" Text -> Text -> Text
`T.append` String -> Text
T.pack (Entry -> String
ebLocation Entry
e)
, eMimeType :: ByteString
Static.eMimeType = Entry -> ByteString
ebMimeType Entry
e
, eContent :: Either (Text, ByteString) ExpQ
Static.eContent = ExpQ -> Either (Text, ByteString) ExpQ
forall a b. b -> Either a b
Right [| $(Entry -> ExpQ
ebDevelReload Entry
e) >>= \c ->
return (T.pack (base64md5 c), c) |]
}
link :: ExpQ
link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(String -> ExpQ
mkStr (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Entry -> String
ebLocation Entry
e)) [] |]
computed :: ComputedEntry
computed = Maybe Name -> EmbeddableEntry -> ExpQ -> ComputedEntry
ComputedEntry (Entry -> Maybe Name
ebHaskellName Entry
e) EmbeddableEntry
st ExpQ
link
prodEmbed :: Entry -> IO ComputedEntry
prodEmbed :: Entry -> IO ComputedEntry
prodEmbed Entry
e = do
ct <- Entry -> IO ByteString
ebProductionContent Entry
e
let hash = ByteString -> String
base64md5 ByteString
ct
link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(String -> ExpQ
mkStr (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Entry -> String
ebLocation Entry
e))
[(T.pack "etag", T.pack $(String -> ExpQ
mkStr String
hash))] |]
st = Static.EmbeddableEntry {
eLocation :: Text
Static.eLocation = Text
"res/" Text -> Text -> Text
`T.append` String -> Text
T.pack (Entry -> String
ebLocation Entry
e)
, eMimeType :: ByteString
Static.eMimeType = Entry -> ByteString
ebMimeType Entry
e
, eContent :: Either (Text, ByteString) ExpQ
Static.eContent = (Text, ByteString) -> Either (Text, ByteString) ExpQ
forall a b. a -> Either a b
Left (String -> Text
T.pack String
hash, ByteString
ct)
}
return $ ComputedEntry (ebHaskellName e) st link
toApp :: (Request -> IO Response) -> Application
toApp :: (Request -> IO Response) -> Application
toApp Request -> IO Response
f Request
req Response -> IO ResponseReceived
g = Request -> IO Response
f Request
req IO Response
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
g
tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
= (Request -> IO Response) -> Application
toApp ((Request -> IO Response) -> Application)
-> ([[Text] -> IO (Maybe (ByteString, ByteString))]
-> Request -> IO Response)
-> [[Text] -> IO (Maybe (ByteString, ByteString))]
-> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text] -> IO (Maybe (ByteString, ByteString))]
-> Request -> IO Response
tryExtraDevelFiles'
tryExtraDevelFiles' :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Request -> IO Response
[] Request
_ = Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [] ByteString
""
tryExtraDevelFiles' ([Text] -> IO (Maybe (ByteString, ByteString))
f:[[Text] -> IO (Maybe (ByteString, ByteString))]
fs) Request
r = do
mct <- IO (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString)))
-> IO (Maybe (ByteString, ByteString))
-> IO (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ [Text] -> IO (Maybe (ByteString, ByteString))
f ([Text] -> IO (Maybe (ByteString, ByteString)))
-> [Text] -> IO (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
r
case mct of
Maybe (ByteString, ByteString)
Nothing -> [[Text] -> IO (Maybe (ByteString, ByteString))]
-> Request -> IO Response
tryExtraDevelFiles' [[Text] -> IO (Maybe (ByteString, ByteString))]
fs Request
r
Just (ByteString
mime, ByteString
ct) -> do
let hash :: ByteString
hash = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
base64md5 ByteString
ct
let headers :: ResponseHeaders
headers = [ (HeaderName
"Content-Type", ByteString
mime)
, (HeaderName
"ETag", ByteString
hash)
]
case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"If-None-Match" (Request -> ResponseHeaders
requestHeaders Request
r) of
Just ByteString
h | ByteString
hash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
h -> Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status304 ResponseHeaders
headers ByteString
""
Maybe ByteString
_ -> Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 ResponseHeaders
headers ByteString
ct
develApp :: StaticSettings -> [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
develApp :: StaticSettings
-> [[Text] -> IO (Maybe (ByteString, ByteString))] -> Application
develApp StaticSettings
settings [[Text] -> IO (Maybe (ByteString, ByteString))]
extra Request
req Response -> IO ResponseReceived
sendResponse = do
StaticSettings -> Application
staticApp StaticSettings
settings {ssMaxAge = NoMaxAge} Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
resp ->
if Status -> Int
statusCode (Response -> Status
responseStatus Response
resp) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
404
then [[Text] -> IO (Maybe (ByteString, ByteString))] -> Application
tryExtraDevelFiles [[Text] -> IO (Maybe (ByteString, ByteString))]
extra Request
req Response -> IO ResponseReceived
sendResponse
else Response -> IO ResponseReceived
sendResponse Response
resp
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString
-> HandlerFor site (Maybe (Either T.Text (Route site, [(T.Text, T.Text)])))
staticContentHelper :: (site -> EmbeddedStatic)
-> (Route EmbeddedStatic -> Route site)
-> (BL.ByteString -> Either a BL.ByteString)
-> AddStaticContent site
staticContentHelper :: forall site a.
(site -> EmbeddedStatic)
-> (Route EmbeddedStatic -> Route site)
-> (ByteString -> Either a ByteString)
-> AddStaticContent site
staticContentHelper site -> EmbeddedStatic
getStatic Route EmbeddedStatic -> Route site
staticR ByteString -> Either a ByteString
minify Text
ext Text
_ ByteString
ct = do
wIORef <- EmbeddedStatic -> IORef (HashMap Text File)
widgetFiles (EmbeddedStatic -> IORef (HashMap Text File))
-> (site -> EmbeddedStatic) -> site -> IORef (HashMap Text File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. site -> EmbeddedStatic
getStatic (site -> IORef (HashMap Text File))
-> HandlerFor site site
-> HandlerFor site (IORef (HashMap Text File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> HandlerFor site site
HandlerFor site (HandlerSite (HandlerFor site))
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
let hash = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
base64md5 ByteString
ct
hash' = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
hash
filename = [Text] -> Text
T.concat [Text
hash, Text
".", Text
ext]
content = case Text
ext of
Text
"js" -> (a -> ByteString)
-> (ByteString -> ByteString) -> Either a ByteString -> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> a -> ByteString
forall a b. a -> b -> a
const ByteString
ct) ByteString -> ByteString
forall a. a -> a
id (Either a ByteString -> ByteString)
-> Either a ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either a ByteString
minify ByteString
ct
Text
_ -> ByteString
ct
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
content
, fileToResponse :: Status -> ResponseHeaders -> Response
fileToResponse = \Status
s ResponseHeaders
h -> Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
s ResponseHeaders
h ByteString
content
, fileName :: Piece
fileName = Text -> Piece
unsafeToPiece Text
filename
, fileGetHash :: IO (Maybe ByteString)
fileGetHash = Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
hash'
, fileGetModified :: Maybe EpochTime
fileGetModified = Maybe EpochTime
forall a. Maybe a
Nothing
}
liftIO $ atomicModifyIORef' wIORef $ \HashMap Text File
m ->
((File -> File -> File)
-> Text -> File -> HashMap Text File -> HashMap Text File
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith (\File
old File
_ -> File
old) Text
filename File
file HashMap Text File
m, ())
return $ Just $ Right (staticR $ EmbeddedWidgetR filename, [])
widgetSettings :: EmbeddedStatic -> StaticSettings
widgetSettings :: EmbeddedStatic -> StaticSettings
widgetSettings EmbeddedStatic
es = (String -> StaticSettings
defaultWebAppSettings String
"") { ssLookupFile = lookupFile }
where
lookupFile :: [Piece] -> IO LookupResult
lookupFile [Piece
_,Piece
p] = do
m <- IORef (HashMap Text File) -> IO (HashMap Text File)
forall a. IORef a -> IO a
readIORef (IORef (HashMap Text File) -> IO (HashMap Text File))
-> IORef (HashMap Text File) -> IO (HashMap Text File)
forall a b. (a -> b) -> a -> b
$ EmbeddedStatic -> IORef (HashMap Text File)
widgetFiles EmbeddedStatic
es
return $ maybe LRNotFound LRFile $ M.lookup (fromPiece p) m
lookupFile [Piece]
_ = LookupResult -> IO LookupResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
LRNotFound