{-# 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
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
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
Ord)

data Source
  = Wildcard
  | None
  | Self
  | DataScheme
  | BlobScheme
  | Host Text
  | Https
  | Http
  | UnsafeInline
  | UnsafeEval
  | StrictDynamic
  | Nonce Text
  deriving (Source -> Source -> Bool
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
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
Ord)

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

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

data Directive
  = DefaultSrc
  | StyleSrc
  | ScriptSrc
  | ObjectSrc
  | ImgSrc
  | FontSrc
  | ConnectSrc
  | MediaSrc
  | FrameSrc
  | FormAction
  | FrameAncestors
  | BaseURI
  | ReportURI
  | ManifestSrc
  deriving (Directive -> Directive -> Bool
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
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
Ord)

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

cachedDirectives :: MonadHandler m => m DirSet
cachedDirectives :: forall (m :: * -> *). MonadHandler m => m DirSet
cachedDirectives = forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
M.empty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *). MonadWidget m => Directive -> Source -> m ()
addCSP Directive
d Source
s = forall (m :: * -> *). MonadHandler m => m DirSet
cachedDirectives
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadHandler m, Typeable a) => a -> m ()
Core.cacheSet forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 (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 forall a. Set a -> [a]
S.toList Set Source
a of
  [ Source
None ]     -> Set Source
a
  [Source]
_            -> Set Source
a forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Bool) -> Set a -> Set a
S.filter (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 = forall seq. IsSequence seq => [Element seq] -> seq
pack forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a. Show a => a -> FilePath
show forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Set a -> [a]
S.toList

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

showDirectives :: DirSet -> Text
showDirectives :: DirSet -> Text
showDirectives = forall mono.
(MonoFoldable mono, Monoid (Element mono)) =>
Element mono -> mono -> Element mono
intercalate Element [Text]
"; " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Directive, Set Source) -> Text
showDirective forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 = forall a. Ord a => [a] -> Set a
S.fromList [ Text -> Source
Nonce Text
n ]
      existingScriptSrcs :: [Source]
existingScriptSrcs = forall a. Set a -> [a]
S.toList (forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
S.empty (forall map.
IsMap map =>
ContainerKey map -> map -> Maybe (MapValue map)
lookup Directive
ScriptSrc DirSet
d))
   in if forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
any (forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` [Source]
existingScriptSrcs) [ Source
None ]
      then DirSet
d
      else 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 :: forall m a. HandlerFor m a -> HandlerFor m a
addCSPMiddleware HandlerFor m a
handler = do
  (a
r, Maybe CSPNonce
n) <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor m a
handler forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. (MonadHandler m, Typeable a) => m (Maybe a)
Core.cacheGet
  DirSet
d <- Maybe CSPNonce -> DirSet -> DirSet
augment Maybe CSPNonce
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m DirSet
cachedDirectives
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall mono. MonoFoldable mono => mono -> Bool
null (DirSet -> Text
showDirectives DirSet
d))) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
Core.addHeader Text
cspHeaderName (DirSet -> Text
showDirectives DirSet
d)
  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 :: forall (m :: * -> *). MonadHandler m => m CSPNonce
getRequestNonce = forall (m :: * -> *) a. (MonadHandler m, Typeable a) => m (Maybe a)
Core.cacheGet forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe m CSPNonce
mkNonce forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where mkNonce :: m CSPNonce
mkNonce = do
          let decode :: UUID -> Text
decode = forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 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 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
nextRandom
          forall (m :: * -> *) a. (MonadHandler m, Typeable a) => a -> m ()
Core.cacheSet CSPNonce
nonce
          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 :: forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> m ()
addScript Route (HandlerSite m)
route = 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 :: forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> [(Text, Text)] -> m ()
addScriptAttrs Route (HandlerSite m)
route [(Text, Text)]
attrs = do
  CSPNonce
nonce <- forall (m :: * -> *). MonadHandler m => m CSPNonce
getRequestNonce
  forall (m :: * -> *).
MonadWidget m =>
Route (HandlerSite m) -> [(Text, Text)] -> m ()
Core.addScriptAttrs Route (HandlerSite m)
route forall a b. (a -> b) -> a -> b
$ (Text
"nonce", CSPNonce -> Text
unCSPNonce CSPNonce
nonce) 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 :: forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
uri = forall (m :: * -> *).
MonadWidget m =>
Text -> [(Text, Text)] -> m ()
addScriptRemoteAttrs Text
uri []

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

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

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

liftRoutes :: [Route Static] -> Q Exp
liftRoutes :: [Route Static] -> Q Exp
liftRoutes =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 [Text]
x [(Text, Text)]
y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|]

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

    liftPairs :: [(Text, Text)] -> Q Exp
liftPairs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {mono} {mono}.
(Quote m, Lift (Element mono), Lift (Element mono),
 MonoFoldable mono, MonoFoldable mono) =>
(mono, mono) -> m Exp
liftPair
    liftPair :: (mono, mono) -> m 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) |]