{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}
-- | Assorted examples demonstrating different policies.
module Yesod.Csp.Example where

import           Data.List.NonEmpty
import           Data.Maybe
import           Yesod                       hiding (get)
import           Yesod.Csp
import           Yesod.Csp.TH

data Example = Example
mkYesod "Example" [parseRoutes|
  /1 Example1R GET
  /2 Example2R GET
  /3 Example3R GET
  /4 Example4R GET
  /5 Example5R GET
  /6 Example6R GET
  /7 Example7R GET POST
  /8 Example8R GET
  /9 Example9R GET
  /10 Example10R GET
  /11 Example11R GET
  /12 Example12R GET
|]

instance Yesod Example

-- | Allows scripts from self.
getExample1R :: Handler Html
getExample1R :: Handler Markup
getExample1R = do
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [SourceList -> Directive
ScriptSrc (Source
Self Source -> [Source] -> SourceList
forall a. a -> [a] -> NonEmpty a
:| [])]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ do
    Text -> WidgetFor Example ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addScriptRemote Text
"http://httpbin.org/i_am_external"
    [whamlet|hello|]

-- | Allows all styles over https.
getExample2R :: Handler Html
getExample2R :: Handler Markup
getExample2R = do
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [SourceList -> Directive
StyleSrc (Source
Https Source -> [Source] -> SourceList
forall a. a -> [a] -> NonEmpty a
:| [])]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ do
    Text -> WidgetFor Example ()
forall (m :: * -> *). MonadWidget m => Text -> m ()
addStylesheetRemote Text
"http://httpbin.org/i_am_not_https"
    [whamlet|hello|]

-- | Allows images from a certain uri.
getExample3R :: Handler Html
getExample3R :: Handler Markup
getExample3R = do
  let dom :: EscapedURI
dom = Maybe EscapedURI -> EscapedURI
forall a. HasCallStack => Maybe a -> a
fromJust (Text -> Maybe EscapedURI
escapeAndParseURI Text
"http://httpbin.org")
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [SourceList -> Directive
ImgSrc (EscapedURI -> Source
Host EscapedURI
dom Source -> [Source] -> SourceList
forall a. a -> [a] -> NonEmpty a
:| [])]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$
    [whamlet|
      <img src="http://httpbin.org/image">
      <!-- different scheme should not work: -->
      <img src="https://httpbin.org/image">
    |]

-- | Allows all images.
getExample4R :: Handler Html
getExample4R :: Handler Markup
getExample4R = do
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [SourceList -> Directive
ImgSrc (Source
Wildcard Source -> [Source] -> SourceList
forall a. a -> [a] -> NonEmpty a
:| [])]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$
    [whamlet|
      <img src="http://httpbin.org/image">
    |]

-- | Disallows images entirely.
getExample5R :: Handler Html
getExample5R :: Handler Markup
getExample5R = do
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [SourceList -> Directive
ImgSrc (Source
None Source -> [Source] -> SourceList
forall a. a -> [a] -> NonEmpty a
:| [])]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$
    [whamlet|
      <img src="http://httpbin.org/image">
    |]

-- | Blocks forms from being submitted
getExample6R :: Handler Html
getExample6R :: Handler Markup
getExample6R = do
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [[SandboxOptions] -> Directive
Sandbox []]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$
    [whamlet|
      <form method="post">
        <input type="submit">
    |]

getExample7R :: Handler Html
getExample7R :: Handler Markup
getExample7R = do
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [[SandboxOptions] -> Directive
Sandbox [SandboxOptions
AllowForms]]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$
    [whamlet|
      <form method="post">
        <input type="submit">
    |]

postExample7R :: Handler Html
postExample7R :: Handler Markup
postExample7R = do
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [[SandboxOptions] -> Directive
Sandbox [SandboxOptions
AllowForms]]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$
    [whamlet|yayyy|]

cdn :: Source
cdn :: Source
cdn = EscapedURI -> Source
Host (Maybe EscapedURI -> EscapedURI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe EscapedURI -> EscapedURI) -> Maybe EscapedURI -> EscapedURI
forall a b. (a -> b) -> a -> b
$ Text -> Maybe EscapedURI
escapeAndParseURI Text
"https://cdn.com")


getExample8R :: Handler Html
getExample8R :: Handler Markup
getExample8R = do
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [csp|script-src 'nonce-foo'|]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [whamlet|
    <script nonce="foo">
      alert("ayyyy");
  |]

getExample9R :: Handler Html
getExample9R :: Handler Markup
getExample9R = do
  let n :: Text
n = Text
"foo"
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [csp|script-src $nonce-n|]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [whamlet|
    <script nonce="foo">
      alert("ayyyy");
  |]

getExample10R :: Handler Html
getExample10R :: Handler Markup
getExample10R = do
  let n :: Text
n = Text
"bar"
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [csp|script-src $nonce-n|]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [whamlet|
    <script nonce="foo">
      alert("ayyyy");
  |]

getExample11R :: Handler Html
getExample11R :: Handler Markup
getExample11R = do
  let google :: EscapedURI
google = Maybe EscapedURI -> EscapedURI
forall a. HasCallStack => Maybe a -> a
fromJust (Text -> Maybe EscapedURI
escapeAndParseURI Text
"https://google.ie")
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [SourceList -> Directive
FrameAncestors (EscapedURI -> Source
Host EscapedURI
google Source -> [Source] -> SourceList
forall a. a -> [a] -> NonEmpty a
:| [])]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$
    [whamlet|
      I should only be iframe-able by Google!
    |]

getExample12R :: Handler Html
getExample12R :: Handler Markup
getExample12R = do
  let n :: Text
n = Text
"foo"
  DirectiveList -> HandlerFor Example ()
forall (m :: * -> *). MonadHandler m => DirectiveList -> m ()
cspPolicy [csp|script-src strict-dynamic unsafe-inline $nonce-n|]
  WidgetFor Example () -> Handler Markup
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Markup
defaultLayout (WidgetFor Example () -> Handler Markup)
-> WidgetFor Example () -> Handler Markup
forall a b. (a -> b) -> a -> b
$ [whamlet|
    <script nonce="foo">
      alert("ayyyy");
  |]

-- | Run a webserver to serve these examples at /1, /2, etc.
runExamples :: IO ()
runExamples :: IO ()
runExamples = Int -> Example -> IO ()
forall site. YesodDispatch site => Int -> site -> IO ()
warp Int
4567 Example
Example