{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Deals with CSP without disabling it.
--   This is done by overriding the default yesod
--   provided addScript functionalities and adding
--   a nonce to the tag, and the right headers to the request.
module Yesod.Middleware.CSP
  ( CombineSettings (..)
  , CSPNonce (..)
  , Directive (..)
  , Source (..)
  , addCSP
  , addCSPMiddleware
  , addScript
  , addScriptAttrs
  , addScriptEither
  , addScriptRemote
  , addScriptRemoteAttrs
  , combineScripts'
  , combineStylesheets'
  , getRequestNonce
  ) where

import ClassyPrelude
import Conduit hiding (Source)
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.UUID (toASCIIBytes)
import Data.UUID.V4 (nextRandom)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax as TH
import System.Directory
import System.FilePath (takeDirectory)
import qualified System.FilePath as F
import Yesod.Core(HandlerSite, MonadWidget, MonadHandler, HandlerFor)
import qualified Yesod.Core as Core
import Yesod.Static hiding
       (CombineSettings, combineScripts', combineStylesheets')

type DirSet = Map Directive (Set Source)

newtype CSPNonce = CSPNonce { CSPNonce -> Text
unCSPNonce :: Text } deriving (CSPNonce -> CSPNonce -> Bool
(CSPNonce -> CSPNonce -> Bool)
-> (CSPNonce -> CSPNonce -> Bool) -> Eq CSPNonce
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CSPNonce -> CSPNonce -> Bool
$c/= :: CSPNonce -> CSPNonce -> Bool
== :: CSPNonce -> CSPNonce -> Bool
$c== :: CSPNonce -> CSPNonce -> Bool
Eq, Eq CSPNonce
Eq CSPNonce
-> (CSPNonce -> CSPNonce -> Ordering)
-> (CSPNonce -> CSPNonce -> Bool)
-> (CSPNonce -> CSPNonce -> Bool)
-> (CSPNonce -> CSPNonce -> Bool)
-> (CSPNonce -> CSPNonce -> Bool)
-> (CSPNonce -> CSPNonce -> CSPNonce)
-> (CSPNonce -> CSPNonce -> CSPNonce)
-> Ord CSPNonce
CSPNonce -> CSPNonce -> Bool
CSPNonce -> CSPNonce -> Ordering
CSPNonce -> CSPNonce -> CSPNonce
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CSPNonce -> CSPNonce -> CSPNonce
$cmin :: CSPNonce -> CSPNonce -> CSPNonce
max :: CSPNonce -> CSPNonce -> CSPNonce
$cmax :: CSPNonce -> CSPNonce -> CSPNonce
>= :: CSPNonce -> CSPNonce -> Bool
$c>= :: CSPNonce -> CSPNonce -> Bool
> :: CSPNonce -> CSPNonce -> Bool
$c> :: CSPNonce -> CSPNonce -> Bool
<= :: CSPNonce -> CSPNonce -> Bool
$c<= :: CSPNonce -> CSPNonce -> Bool
< :: CSPNonce -> CSPNonce -> Bool
$c< :: CSPNonce -> CSPNonce -> Bool
compare :: CSPNonce -> CSPNonce -> Ordering
$ccompare :: CSPNonce -> CSPNonce -> Ordering
$cp1Ord :: Eq CSPNonce
Ord)

data Source
  = Wildcard
  | None
  | Self
  | DataScheme
  | BlobScheme
  | Host Text
  | Https
  | Http
  | UnsafeInline
  | UnsafeEval
  | StrictDynamic
  | Nonce Text
  deriving (Source -> Source -> Bool
(Source -> Source -> Bool)
-> (Source -> Source -> Bool) -> Eq Source
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Source -> Source -> Bool
$c/= :: Source -> Source -> Bool
== :: Source -> Source -> Bool
$c== :: Source -> Source -> Bool
Eq, Eq Source
Eq Source
-> (Source -> Source -> Ordering)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Bool)
-> (Source -> Source -> Source)
-> (Source -> Source -> Source)
-> Ord Source
Source -> Source -> Bool
Source -> Source -> Ordering
Source -> Source -> Source
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Source -> Source -> Source
$cmin :: Source -> Source -> Source
max :: Source -> Source -> Source
$cmax :: Source -> Source -> Source
>= :: Source -> Source -> Bool
$c>= :: Source -> Source -> Bool
> :: Source -> Source -> Bool
$c> :: Source -> Source -> Bool
<= :: Source -> Source -> Bool
$c<= :: Source -> Source -> Bool
< :: Source -> Source -> Bool
$c< :: Source -> Source -> Bool
compare :: Source -> Source -> Ordering
$ccompare :: Source -> Source -> Ordering
$cp1Ord :: Eq Source
Ord)

instance IsString Source where
  fromString :: String -> Source
fromString = Text -> Source
Host (Text -> Source) -> (String -> Text) -> String -> Source
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack

instance Show Source where
  show :: Source -> String
show Source
Wildcard = String
"*"
  show Source
None = String
"'none'"
  show Source
Self = String
"'self'"
  show Source
DataScheme = String
"data:"
  show Source
BlobScheme = String
"blob:"
  show (Host Text
h) = Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
h
  show Source
Https = String
"https:"
  show Source
Http = String
"http:"
  show Source
UnsafeInline = String
"'unsafe-inline'"
  show Source
UnsafeEval = String
"'unsafe-eval'"
  show Source
StrictDynamic = String
"'strict-dynamic'"
  show (Nonce Text
n) = String
"'nonce-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"

data Directive
  = DefaultSrc
  | StyleSrc
  | ScriptSrc
  | ObjectSrc
  | ImgSrc
  | FontSrc
  | ConnectSrc
  | MediaSrc
  | FrameSrc
  | FormAction
  | FrameAncestors
  | BaseURI
  | ReportURI
  | ManifestSrc
  deriving (Directive -> Directive -> Bool
(Directive -> Directive -> Bool)
-> (Directive -> Directive -> Bool) -> Eq Directive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Directive -> Directive -> Bool
$c/= :: Directive -> Directive -> Bool
== :: Directive -> Directive -> Bool
$c== :: Directive -> Directive -> Bool
Eq, Eq Directive
Eq Directive
-> (Directive -> Directive -> Ordering)
-> (Directive -> Directive -> Bool)
-> (Directive -> Directive -> Bool)
-> (Directive -> Directive -> Bool)
-> (Directive -> Directive -> Bool)
-> (Directive -> Directive -> Directive)
-> (Directive -> Directive -> Directive)
-> Ord Directive
Directive -> Directive -> Bool
Directive -> Directive -> Ordering
Directive -> Directive -> Directive
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Directive -> Directive -> Directive
$cmin :: Directive -> Directive -> Directive
max :: Directive -> Directive -> Directive
$cmax :: Directive -> Directive -> Directive
>= :: Directive -> Directive -> Bool
$c>= :: Directive -> Directive -> Bool
> :: Directive -> Directive -> Bool
$c> :: Directive -> Directive -> Bool
<= :: Directive -> Directive -> Bool
$c<= :: Directive -> Directive -> Bool
< :: Directive -> Directive -> Bool
$c< :: Directive -> Directive -> Bool
compare :: Directive -> Directive -> Ordering
$ccompare :: Directive -> Directive -> Ordering
$cp1Ord :: Eq Directive
Ord)

instance Show Directive where
  show :: Directive -> String
show Directive
DefaultSrc = String
"default-src"
  show Directive
StyleSrc = String
"style-src"
  show Directive
ScriptSrc = String
"script-src"
  show Directive
ObjectSrc = String
"object-src"
  show Directive
ImgSrc = String
"img-src"
  show Directive
FontSrc = String
"font-src"
  show Directive
ConnectSrc = String
"connect-src"
  show Directive
MediaSrc = String
"media-src"
  show Directive
FrameSrc = String
"frame-src"
  show Directive
FormAction = String
"form-action"
  show Directive
FrameAncestors = String
"frame-ancestors"
  show Directive
BaseURI = String
"base-uri"
  show Directive
ReportURI = String
"report-uri"
  show Directive
ManifestSrc = String
"manifest-src"

cachedDirectives :: MonadHandler m => m DirSet
cachedDirectives :: m DirSet
cachedDirectives = DirSet -> Maybe DirSet -> DirSet
forall a. a -> Maybe a -> a
fromMaybe DirSet
forall k a. Map k a
M.empty (Maybe DirSet -> DirSet) -> m (Maybe DirSet) -> m DirSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe DirSet)
forall (m :: * -> *) a. (MonadHandler m, Typeable a) => m (Maybe a)
Core.cacheGet

-- | Add a directive to the current Content-Security Policy
addCSP :: MonadWidget m => Directive -> Source -> m ()
addCSP :: Directive -> Source -> m ()
addCSP Directive
d Source
s = m DirSet
forall (m :: * -> *). MonadHandler m => m DirSet
cachedDirectives
  m DirSet -> (DirSet -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DirSet -> m ()
forall (m :: * -> *) a. (MonadHandler m, Typeable a) => a -> m ()
Core.cacheSet (DirSet -> m ()) -> (DirSet -> DirSet) -> DirSet -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Set Source -> Set Source -> Set Source)
-> Directive -> Set Source -> DirSet -> DirSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set Source -> Set Source -> Set Source
insertSource Directive
d (Source -> Set Source
forall a. a -> Set a
S.singleton Source
s)

insertSource :: Set Source -> Set Source -> Set Source
insertSource :: Set Source -> Set Source -> Set Source
insertSource Set Source
a Set Source
b = case Set Source -> [Source]
forall a. Set a -> [a]
S.toList Set Source
a of
  [ Source
None ]     -> Set Source
a
  [Source]
_            -> Set Source
a Set Source -> Set Source -> Set Source
forall a. Semigroup a => a -> a -> a
<> (Source -> Bool) -> Set Source -> Set Source
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Element [Source] -> [Source] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`notElem` [Source
None]) Set Source
b

showSources :: Set Source -> Text
showSources :: Set Source -> Text
showSources = String -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack (String -> Text) -> (Set Source -> String) -> Set Source -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [String] -> String
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords ([String] -> String)
-> (Set Source -> [String]) -> Set Source -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Source -> String) -> [Source] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Source -> String
forall a. Show a => a -> String
show ([Source] -> [String])
-> (Set Source -> [Source]) -> Set Source -> [String]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Set Source -> [Source]
forall a. Set a -> [a]
S.toList

showDirective :: (Directive, Set Source) -> Text
showDirective :: (Directive, Set Source) -> Text
showDirective (Directive
d, Set Source
s) = Directive -> Text
forall a. Show a => a -> Text
tshow Directive
d Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Set Source -> Text
showSources Set Source
s

showDirectives :: DirSet -> Text
showDirectives :: DirSet -> Text
showDirectives = Element [Text] -> [Text] -> Element [Text]
forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
"; " ([Text] -> Text) -> (DirSet -> [Text]) -> DirSet -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((Directive, Set Source) -> Text)
-> [(Directive, Set Source)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Directive, Set Source) -> Text
showDirective ([(Directive, Set Source)] -> [Text])
-> (DirSet -> [(Directive, Set Source)]) -> DirSet -> [Text]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. DirSet -> [(Directive, Set Source)]
forall k a. Map k a -> [(k, a)]
M.toList

cspHeaderName :: Text
cspHeaderName :: Text
cspHeaderName = Text
"Content-Security-Policy"

augment :: Maybe CSPNonce -> DirSet -> DirSet
augment :: Maybe CSPNonce -> DirSet -> DirSet
augment Maybe CSPNonce
Nothing DirSet
d = DirSet
d
augment (Just (CSPNonce Text
n)) DirSet
d =
  let srcs :: Set Source
srcs = [Source] -> Set Source
forall a. Ord a => [a] -> Set a
S.fromList [ Text -> Source
Nonce Text
n ]
      existingScriptSrcs :: [Source]
existingScriptSrcs = Set Source -> [Source]
forall a. Set a -> [a]
S.toList (Set Source -> Maybe (Set Source) -> Set Source
forall a. a -> Maybe a -> a
fromMaybe Set Source
forall a. Set a
S.empty (ContainerKey DirSet -> DirSet -> Maybe (MapValue DirSet)
forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup ContainerKey DirSet
Directive
ScriptSrc DirSet
d))
   in if (Element [Source] -> Bool) -> [Source] -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
any (Element [Source] -> [Source] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` [Source]
existingScriptSrcs) [ Source
None ]
      then DirSet
d
      else (Set Source -> Set Source -> Set Source)
-> Directive -> Set Source -> DirSet -> DirSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set Source -> Set Source -> Set Source
insertSource Directive
ScriptSrc Set Source
srcs DirSet
d

addCSPMiddleware :: (HandlerFor m) a -> (HandlerFor m) a
addCSPMiddleware :: HandlerFor m a -> HandlerFor m a
addCSPMiddleware HandlerFor m a
handler = do
  (a
r, Maybe CSPNonce
n) <- (,) (a -> Maybe CSPNonce -> (a, Maybe CSPNonce))
-> HandlerFor m a
-> HandlerFor m (Maybe CSPNonce -> (a, Maybe CSPNonce))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor m a
handler HandlerFor m (Maybe CSPNonce -> (a, Maybe CSPNonce))
-> HandlerFor m (Maybe CSPNonce)
-> HandlerFor m (a, Maybe CSPNonce)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HandlerFor m (Maybe CSPNonce)
forall (m :: * -> *) a. (MonadHandler m, Typeable a) => m (Maybe a)
Core.cacheGet
  DirSet
d <- Maybe CSPNonce -> DirSet -> DirSet
augment Maybe CSPNonce
n (DirSet -> DirSet) -> HandlerFor m DirSet -> HandlerFor m DirSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor m DirSet
forall (m :: * -> *). MonadHandler m => m DirSet
cachedDirectives
  Bool -> HandlerFor m () -> HandlerFor m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Text -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null (DirSet -> Text
showDirectives DirSet
d))) (HandlerFor m () -> HandlerFor m ())
-> HandlerFor m () -> HandlerFor m ()
forall a b. (a -> b) -> a -> b
$
    Text -> Text -> HandlerFor m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
Core.addHeader Text
cspHeaderName (DirSet -> Text
showDirectives DirSet
d)
  a -> HandlerFor m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r

-- | Get a nonce for the request
--
-- CSP nonces must be unique per request, but they do not need to be unique
-- amongst themselves. This function checks the per-request cache to see if we
-- have already generated a nonce. If we have, we use the cached value. If this
-- is the first call to this function for the request, we generate a new
-- @CSPNonce@ by base64-encoding a UUIDV4 value.
--
-- n.b. It is not important to use a high-quality random value to generate the
-- nonce, but @Data.UUID.V4.nextRandom@ just happens to be faster than
-- @System.Random.randomIO@.
getRequestNonce :: MonadHandler m => m CSPNonce
getRequestNonce :: m CSPNonce
getRequestNonce = m (Maybe CSPNonce)
forall (m :: * -> *) a. (MonadHandler m, Typeable a) => m (Maybe a)
Core.cacheGet m (Maybe CSPNonce) -> (Maybe CSPNonce -> m CSPNonce) -> m CSPNonce
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m CSPNonce
-> (CSPNonce -> m CSPNonce) -> Maybe CSPNonce -> m CSPNonce
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m CSPNonce
mkNonce CSPNonce -> m CSPNonce
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where mkNonce :: m CSPNonce
mkNonce = do
          let decode :: UUID -> Text
decode = ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 (ByteString -> Text) -> (UUID -> ByteString) -> UUID -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
B64.encode (ByteString -> ByteString)
-> (UUID -> ByteString) -> UUID -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UUID -> ByteString
toASCIIBytes
          CSPNonce
nonce <- Text -> CSPNonce
CSPNonce (Text -> CSPNonce) -> (UUID -> Text) -> UUID -> CSPNonce
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UUID -> Text
decode (UUID -> CSPNonce) -> m UUID -> m CSPNonce
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> m UUID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
nextRandom
          CSPNonce -> m ()
forall (m :: * -> *) a. (MonadHandler m, Typeable a) => a -> m ()
Core.cacheSet CSPNonce
nonce
          CSPNonce -> m CSPNonce
forall (f :: * -> *) a. Applicative f => a -> f a
pure CSPNonce
nonce

-- | Add a local JavaScript asset to the widget
--
-- This is intended to a be a drop-in replacement for
-- @Yesod.Core.Widget.addScript@. It takes the nonce generated for the current
-- request and embeds it as an HTML attribute in the script tag.
addScript :: MonadWidget m => Route (HandlerSite m) -> m ()
addScript :: Route (HandlerSite m) -> m ()
addScript Route (HandlerSite m)
route = Route (HandlerSite m) -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> [(Text, Text)] -> m ()
addScriptAttrs Route (HandlerSite m)
route []

addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
addScriptAttrs :: Route (HandlerSite m) -> [(Text, Text)] -> m ()
addScriptAttrs Route (HandlerSite m)
route [(Text, Text)]
attrs = do
  CSPNonce
nonce <- m CSPNonce
forall (m :: * -> *). MonadHandler m => m CSPNonce
getRequestNonce
  Route (HandlerSite m) -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> [(Text, Text)] -> m ()
Core.addScriptAttrs Route (HandlerSite m)
route ([(Text, Text)] -> m ()) -> [(Text, Text)] -> m ()
forall a b. (a -> b) -> a -> b
$ (Text
"nonce", CSPNonce -> Text
unCSPNonce CSPNonce
nonce) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
attrs

-- | Add a remote JavaScript asset to the widget
--
-- The same notes for @addScript@ apply here.
addScriptRemote :: MonadWidget m => Text -> m ()
addScriptRemote :: Text -> m ()
addScriptRemote Text
uri = Text -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadWidget m =>
Text -> [(Text, Text)] -> m ()
addScriptRemoteAttrs Text
uri []

addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
addScriptRemoteAttrs :: Text -> [(Text, Text)] -> m ()
addScriptRemoteAttrs Text
uri [(Text, Text)]
attrs = do
  CSPNonce
nonce <- m CSPNonce
forall (m :: * -> *). MonadHandler m => m CSPNonce
getRequestNonce
  Text -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadWidget m =>
Text -> [(Text, Text)] -> m ()
Core.addScriptRemoteAttrs Text
uri ([(Text, Text)] -> m ()) -> [(Text, Text)] -> m ()
forall a b. (a -> b) -> a -> b
$ (Text
"nonce", CSPNonce -> Text
unCSPNonce CSPNonce
nonce) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
attrs

addScriptEither :: MonadWidget m => Either (Route (HandlerSite m)) Text -> m ()
addScriptEither :: Either (Route (HandlerSite m)) Text -> m ()
addScriptEither = (Route (HandlerSite m) -> m ())
-> (Text -> m ()) -> Either (Route (HandlerSite m)) Text -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Route (HandlerSite m) -> m ()
forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript Text -> m ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote

data CombineSettings = CombineSettings
  { CombineSettings -> String
csStaticDir :: FilePath
  -- ^ File path containing static files.
  , CombineSettings -> [String] -> ByteString -> IO ByteString
csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
  -- ^ Post processing to be performed on CSS files.
  , CombineSettings -> [String] -> ByteString -> IO ByteString
csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
  -- ^ Post processing to be performed on Javascript files.
  , CombineSettings -> Text -> IO Text
csCssPreProcess :: TL.Text -> IO TL.Text
  -- ^ Pre-processing to be performed on CSS files.
  , CombineSettings -> Text -> IO Text
csJsPreProcess :: TL.Text -> IO TL.Text
  -- ^ Pre-processing to be performed on Javascript files.
  , CombineSettings -> String
csCombinedFolder :: FilePath
  -- ^ Subfolder to put combined files into.
  }

data CombineType = JS | CSS

combineStatics' :: CombineType
                -> CombineSettings
                -> [Route Static] -- ^ files to combine
                -> Q Exp
combineStatics' :: CombineType -> CombineSettings -> [Route Static] -> Q Exp
combineStatics' CombineType
combineType CombineSettings {String
[String] -> ByteString -> IO ByteString
Text -> IO Text
csCombinedFolder :: String
csJsPreProcess :: Text -> IO Text
csCssPreProcess :: Text -> IO Text
csJsPostProcess :: [String] -> ByteString -> IO ByteString
csCssPostProcess :: [String] -> ByteString -> IO ByteString
csStaticDir :: String
csCombinedFolder :: CombineSettings -> String
csJsPreProcess :: CombineSettings -> Text -> IO Text
csCssPreProcess :: CombineSettings -> Text -> IO Text
csJsPostProcess :: CombineSettings -> [String] -> ByteString -> IO ByteString
csCssPostProcess :: CombineSettings -> [String] -> ByteString -> IO ByteString
csStaticDir :: CombineSettings -> String
..} [Route Static]
routes = do
    Text
texts <- IO Text -> Q Text
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ ConduitT () Void (ResourceT IO) Text -> IO Text
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
                    (ConduitT () Void (ResourceT IO) Text -> IO Text)
-> ConduitT () Void (ResourceT IO) Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [String] -> ConduitT () (Element [String]) (ResourceT IO) ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [String]
fps
                   ConduitT () String (ResourceT IO) ()
-> ConduitM String Void (ResourceT IO) Text
-> ConduitT () Void (ResourceT IO) Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (String -> ConduitT String Text (ResourceT IO) ())
-> ConduitT String Text (ResourceT IO) ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever String -> ConduitT String Text (ResourceT IO) ()
forall (m :: * -> *) a.
(MonadResource m, MonadThrow m) =>
String -> ConduitM a Text m ()
readUTFFile
                   ConduitT String Text (ResourceT IO) ()
-> ConduitM Text Void (ResourceT IO) Text
-> ConduitM String Void (ResourceT IO) Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Text Void (ResourceT IO) Text
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
    Text
ltext <- IO Text -> Q Text
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ Text -> IO Text
preProcess Text
texts
    ByteString
bs    <- IO ByteString -> Q ByteString
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> ByteString -> IO ByteString
postProcess [String]
fps (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 Text
ltext
    let hash' :: String
hash' = ByteString -> String
base64md5 ByteString
bs
        suffix :: String
suffix = String
csCombinedFolder String -> ShowS
</> String
hash' String -> ShowS
<.> String
extension
        fp :: String
fp = String
csStaticDir String -> ShowS
</> String
suffix
    IO () -> Q ()
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
fp
        String -> ByteString -> IO ()
L.writeFile String
fp ByteString
bs
    let pieces :: [String]
pieces = (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> String
T.unpack ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
suffix
    [|StaticRoute (map pack pieces) []|]
  where
    fps :: [FilePath]
    fps :: [String]
fps = (Route Static -> String) -> [Route Static] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Route Static -> String
toFP [Route Static]
routes
    toFP :: Route Static -> String
toFP (StaticRoute pieces _) = String
csStaticDir String -> ShowS
</> [String] -> String
F.joinPath ((Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> String
T.unpack [Text]
pieces)
    readUTFFile :: String -> ConduitM a Text m ()
readUTFFile String
fp = String -> ConduitT a ByteString m ()
forall (m :: * -> *) i.
MonadResource m =>
String -> ConduitT i ByteString m ()
sourceFile String
fp ConduitT a ByteString m ()
-> ConduitM ByteString Text m () -> ConduitM a Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Text m ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8C
    postProcess :: [String] -> ByteString -> IO ByteString
postProcess =
        case CombineType
combineType of
            CombineType
JS -> [String] -> ByteString -> IO ByteString
csJsPostProcess
            CombineType
CSS -> [String] -> ByteString -> IO ByteString
csCssPostProcess
    preProcess :: Text -> IO Text
preProcess =
        case CombineType
combineType of
            CombineType
JS -> Text -> IO Text
csJsPreProcess
            CombineType
CSS -> Text -> IO Text
csCssPreProcess
    extension :: String
extension =
        case CombineType
combineType of
            CombineType
JS -> String
"js"
            CombineType
CSS -> String
"css"

liftRoutes :: [Route Static] -> Q Exp
liftRoutes :: [Route Static] -> Q Exp
liftRoutes =
    ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp)
-> ([Route Static] -> Q [Exp]) -> [Route Static] -> Q Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Route Static -> Q Exp) -> [Route Static] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Route Static -> Q Exp
go
  where
    go :: Route Static -> Q Exp
    go :: Route Static -> Q Exp
go (StaticRoute x y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|]

    liftTexts :: [Text] -> Q Exp
liftTexts = ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp) -> ([Text] -> Q [Exp]) -> [Text] -> Q Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text -> Q Exp) -> [Text] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Q Exp
forall mono.
(Lift (Element mono), MonoFoldable mono) =>
mono -> Q Exp
liftT
    liftT :: mono -> Q Exp
liftT mono
t = [|pack $(TH.lift $ unpack t)|]

    liftPairs :: [(Text, Text)] -> Q Exp
liftPairs = ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp)
-> ([(Text, Text)] -> Q [Exp]) -> [(Text, Text)] -> Q Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((Text, Text) -> Q Exp) -> [(Text, Text)] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text, Text) -> Q Exp
forall mono mono.
(Lift (Element mono), Lift (Element mono), MonoFoldable mono,
 MonoFoldable mono) =>
(mono, mono) -> Q Exp
liftPair
    liftPair :: (mono, mono) -> Q Exp
liftPair (mono
x, mono
y) = [|($(liftT x), $(liftT y))|]

-- | Combine multiple CSS files together
combineStylesheets' :: Bool -- ^ development? if so, perform no combining
                    -> CombineSettings
                    -> Name -- ^ Static route constructor name, e.g. \'StaticR
                    -> [Route Static] -- ^ files to combine
                    -> Q Exp
combineStylesheets' :: Bool -> CombineSettings -> Name -> [Route Static] -> Q Exp
combineStylesheets' Bool
development CombineSettings
cs Name
con [Route Static]
routes
    | Bool
development = [| mapM_ (addStylesheet . $(return $ ConE con)) $(liftRoutes routes) |]
    | Bool
otherwise = [| addStylesheet $ $(return $ ConE con) $(combineStatics' CSS cs routes) |]


-- | Combine multiple JS files together
combineScripts' :: Bool -- ^ development? if so, perform no combining
                -> CombineSettings
                -> Name -- ^ Static route constructor name, e.g. \'StaticR
                -> [Route Static] -- ^ files to combine
                -> Q Exp
combineScripts' :: Bool -> CombineSettings -> Name -> [Route Static] -> Q Exp
combineScripts' Bool
development CombineSettings
cs Name
con [Route Static]
routes
    | Bool
development = [| mapM_ (addScript . $(return $ ConE con)) $(liftRoutes routes) |]
    | Bool
otherwise = [| addScript $ $(return $ ConE con) $(combineStatics' JS cs routes) |]