{-# 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)
-- copied from base
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

-- | The subsite for the embedded static file server.
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

-- | At compile time, one of these is created for every 'Entry' created by
-- the generators.  The cLink is a template haskell expression of type @Route EmbeddedStatic@.
data ComputedEntry = ComputedEntry {
      ComputedEntry -> Maybe Name
cHaskellName :: Maybe Name               -- ^ Optional haskell name to create a variable for the route
    , ComputedEntry -> EmbeddableEntry
cStEntry     :: Static.EmbeddableEntry   -- ^ The entry to be embedded into the executable
    , ComputedEntry -> ExpQ
cLink        :: ExpQ                     -- ^ The route for this entry
}

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

-- | Create a 'ComputedEntry' for development mode, reloading the content on every request.
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

-- | Create a 'ComputedEntry' for production mode, hashing and embedding the content into the executable.
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
tryExtraDevelFiles :: [[Text] -> IO (Maybe (ByteString, ByteString))] -> Application
tryExtraDevelFiles = (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
tryExtraDevelFiles' :: [[Text] -> IO (Maybe (ByteString, ByteString))]
-> Request -> IO Response
tryExtraDevelFiles' [] 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 -- drop the initial "res"
    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

-- | Helper to create the development application at runtime
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

-- | The type of 'addStaticContent'
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString
                          -> HandlerFor site (Maybe (Either T.Text (Route site, [(T.Text, T.Text)])))

-- | Helper for embedStaticContent and embedLicensedStaticContent.
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, [])

-- | Create a wai-app-static settings based on the IORef inside the EmbeddedStaic site.
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 -- The first part of the path is "widget"
            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