{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.EmbeddedStatic (
EmbeddedStatic
, embeddedResourceR
, mkEmbeddedStatic
, embedStaticContent
, module Yesod.EmbeddedStatic.Generators
) where
import Control.Applicative as A ((<$>))
import Data.IORef
import Data.Maybe (catMaybes)
import Language.Haskell.TH
import Network.HTTP.Types.Status (status404)
import Network.Wai (responseLBS, pathInfo)
import Network.Wai.Application.Static (staticApp)
import System.IO.Unsafe (unsafePerformIO)
import Yesod.Core (YesodSubDispatch(..))
import Yesod.Core.Types
( YesodSubRunnerEnv(..)
, YesodRunnerEnv(..)
)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.HashMap.Strict as M
import qualified WaiAppStatic.Storage.Embedded as Static
import Yesod.EmbeddedStatic.Types
import Yesod.EmbeddedStatic.Internal
import Yesod.EmbeddedStatic.Generators
embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic
embeddedResourceR :: [Text] -> [(Text, Text)] -> Route EmbeddedStatic
embeddedResourceR = [Text] -> [(Text, Text)] -> Route EmbeddedStatic
EmbeddedResourceR
instance YesodSubDispatch EmbeddedStatic master where
yesodSubDispatch :: YesodSubRunnerEnv EmbeddedStatic master -> Application
yesodSubDispatch YesodSubRunnerEnv {YesodRunnerEnv master
master -> EmbeddedStatic
ParentRunner master
Route EmbeddedStatic -> Route master
ysreParentRunner :: ParentRunner master
ysreGetSub :: master -> EmbeddedStatic
ysreToParentRoute :: Route EmbeddedStatic -> Route master
ysreParentEnv :: YesodRunnerEnv master
ysreGetSub :: forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreParentEnv :: forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
ysreParentRunner :: forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
ysreToParentRoute :: forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
..} Request
req = (Response -> IO ResponseReceived) -> IO ResponseReceived
resp
where
master :: master
master = YesodRunnerEnv master -> master
forall site. YesodRunnerEnv site -> site
yreSite YesodRunnerEnv master
ysreParentEnv
site :: EmbeddedStatic
site = master -> EmbeddedStatic
ysreGetSub master
master
resp :: (Response -> IO ResponseReceived) -> IO ResponseReceived
resp = case Request -> [Text]
pathInfo Request
req of
(Text
"res":[Text]
_) -> EmbeddedStatic -> Application
stApp EmbeddedStatic
site Request
req
(Text
"widget":[Text]
_) -> StaticSettings -> Application
staticApp (EmbeddedStatic -> StaticSettings
widgetSettings EmbeddedStatic
site) Request
req
[Text]
_ -> ((Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 [] ByteString
"Not Found")
mkRoute :: ComputedEntry -> Q [Dec]
mkRoute :: ComputedEntry -> Q [Dec]
mkRoute (ComputedEntry { cHaskellName :: ComputedEntry -> Maybe Name
cHaskellName = Maybe Name
Nothing }) = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkRoute (c :: ComputedEntry
c@ComputedEntry { cHaskellName :: ComputedEntry -> Maybe Name
cHaskellName = Just Name
name }) = do
routeType <- [t| Route EmbeddedStatic |]
link <- [| $(cLink c) |]
return [ SigD name routeType
, ValD (VarP name) (NormalB link) []
]
mkEmbeddedStatic :: Bool
-> String
-> [Generator]
-> Q [Dec]
mkEmbeddedStatic :: Bool -> String -> [Generator] -> Q [Dec]
mkEmbeddedStatic Bool
dev String
esName [Generator]
gen = do
entries <- [[Entry]] -> [Entry]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Entry]] -> [Entry]) -> Q [[Entry]] -> Generator
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> [Generator] -> Q [[Entry]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Generator]
gen
computed <- runIO $ mapM (if dev then devEmbed else prodEmbed) entries
let settings = IO [EmbeddableEntry] -> Q Exp
Static.mkSettings (IO [EmbeddableEntry] -> Q Exp) -> IO [EmbeddableEntry] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [EmbeddableEntry] -> IO [EmbeddableEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EmbeddableEntry] -> IO [EmbeddableEntry])
-> [EmbeddableEntry] -> IO [EmbeddableEntry]
forall a b. (a -> b) -> a -> b
$ (ComputedEntry -> EmbeddableEntry)
-> [ComputedEntry] -> [EmbeddableEntry]
forall a b. (a -> b) -> [a] -> [b]
map ComputedEntry -> EmbeddableEntry
cStEntry [ComputedEntry]
computed
devExtra = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Maybe (Q Exp)] -> [Q Exp]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Q Exp)] -> [Q Exp]) -> [Maybe (Q Exp)] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$ (Entry -> Maybe (Q Exp)) -> [Entry] -> [Maybe (Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> Maybe (Q Exp)
ebDevelExtraFiles [Entry]
entries
ioRef = [| unsafePerformIO $ newIORef M.empty |]
esType <- [t| EmbeddedStatic |]
esCreate <- if dev
then [| EmbeddedStatic (develApp $settings $devExtra) $ioRef |]
else [| EmbeddedStatic (staticApp $! $settings) $ioRef |]
let es = [ Name -> Type -> Dec
SigD (String -> Name
mkName String
esName) Type
esType
, Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
esName) (Exp -> Body
NormalB Exp
esCreate) []
]
routes <- mapM mkRoute computed
return $ es ++ concat routes
embedStaticContent :: (site -> EmbeddedStatic)
-> (Route EmbeddedStatic -> Route site)
-> (BL.ByteString -> Either a BL.ByteString)
-> AddStaticContent site
embedStaticContent :: forall site a.
(site -> EmbeddedStatic)
-> (Route EmbeddedStatic -> Route site)
-> (ByteString -> Either a ByteString)
-> AddStaticContent site
embedStaticContent = (site -> EmbeddedStatic)
-> (Route EmbeddedStatic -> Route site)
-> (ByteString -> Either a ByteString)
-> AddStaticContent site
forall site a.
(site -> EmbeddedStatic)
-> (Route EmbeddedStatic -> Route site)
-> (ByteString -> Either a ByteString)
-> AddStaticContent site
staticContentHelper