diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright 2016 Eduardo Trujillo + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/kawaii.cabal b/kawaii.cabal new file mode 100644 --- /dev/null +++ b/kawaii.cabal @@ -0,0 +1,81 @@ +-- This file has been generated from package.yaml by hpack version 0.14.0. +-- +-- see: https://github.com/sol/hpack + +name: kawaii +version: 0.0.1.0 +synopsis: Utilities for serving static sites and blogs with Wai/Warp +category: Web +homepage: https://phabricator.chromabits.com/diffusion/KWAI/ +maintainer: Eduardo Trujillo +license: Apache +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +library + hs-source-dirs: + src + default-extensions: LambdaCase + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , safe == 0.3.* + , text + , lens + , bytestring + , hakyll + , optparse-applicative + , warp == 3.* + , warp-tls == 3.* + , wai == 3.* + , wai-extra >= 3.0.14 + , wai-app-static == 3.* + , streaming-commons == 0.1.* + , containers + , data-default + , lifted-base + , mtl + , monad-logger + , monad-control + exposed-modules: + Hakyll.Serve.Main + Network.Wai.Serve + Network.Wai.Serve.Applications + Network.Wai.Serve.Listeners + Network.Wai.Serve.Main + Network.Wai.Serve.Middleware + Network.Wai.Serve.Types + default-language: Haskell2010 + +test-suite wai-static-extra-spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: LambdaCase + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , safe == 0.3.* + , text + , lens + , bytestring + , hakyll + , optparse-applicative + , warp == 3.* + , warp-tls == 3.* + , wai == 3.* + , wai-extra >= 3.0.14 + , wai-app-static == 3.* + , streaming-commons == 0.1.* + , containers + , data-default + , lifted-base + , mtl + , monad-logger + , monad-control + , hakyll-serve + , hspec + , QuickCheck + default-language: Haskell2010 diff --git a/src/Hakyll/Serve/Main.hs b/src/Hakyll/Serve/Main.hs new file mode 100644 --- /dev/null +++ b/src/Hakyll/Serve/Main.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- +-- Copyright: (c) Eduardo Trujillo, 2016 +-- License: Apache +-- Stability: experimental +-- +-- The Main module contains a wrapper function that can be used as your +-- program's main function. It encapsulates both the Hakyll commands and the +-- server functionality into a single application. +-- +-- Since this module mainly provides some glue for putting this two +-- applications together, the actual documentation for the server part is +-- available on 'Network.Wai.Serve'. +-- +module Hakyll.Serve.Main + ( -- * Main wrappers + hakyllServe + , hakyllServeWith + -- * Configuration + , HakyllServeConfiguration(..) + , -- * Lenses + hscHakyllConfiguration + , hscServeConfiguration + ) where + +import Options.Applicative +import System.Environment (getArgs, withArgs) + +import Control.Lens (makeLenses) +import Data.Default (Default, def) +import Hakyll (defaultConfiguration, hakyllWith) +import Hakyll.Core.Configuration (Configuration) +import Hakyll.Core.Rules (Rules) +import Options.Applicative.Arrows +import Safe (tailDef) + +import Network.Wai.Serve.Main (serve) +import Network.Wai.Serve.Types (ServeConfiguration (..)) + +-- | The configuration for the server process. +-- +-- The different transforms can be used to specify how the configuration +-- changes depending on the stage. While starting up, the server process will +-- take the base configuration, check the stage and pass the configuration +-- through the appropriate transformer. +-- +data HakyllServeConfiguration = HakyllServeConfiguration + { _hscHakyllConfiguration :: Configuration + , _hscServeConfiguration :: ServeConfiguration + } + +instance Default HakyllServeConfiguration where + def = HakyllServeConfiguration + { _hscHakyllConfiguration = defaultConfiguration + , _hscServeConfiguration = def + } + +data HakyllServeCommand + = HakyllCommand HakyllCommandOptions + | ServeCommand + deriving (Show) + +data HakyllCommandOptions = HakyllCommandOptions String Bool Bool Bool + deriving (Show) + +data HakyllServeOptions = HakyllServeOptions + { hsCommand :: HakyllServeCommand + } deriving (Show) + +hakyllServeOptions :: Parser HakyllServeOptions +hakyllServeOptions = runA $ proc () -> do + cmd <- (asA . hsubparser) hakyllServeCommand -< () + A helper -< HakyllServeOptions cmd + +hakyllServeCommand :: Mod CommandFields HakyllServeCommand +hakyllServeCommand + = command "hakyll" + (info hakyllCommandOptions (progDesc "Access hakyll commands")) + <> command "serve" + (info (pure ServeCommand) (progDesc "Start a server hosting the site")) + +hakyllCommandOptions :: Parser HakyllServeCommand +hakyllCommandOptions = HakyllCommand + <$> (HakyllCommandOptions + <$> strArgument (metavar "SUBCOMMAND") + <*> switch (long "verbose") + <*> switch (long "internal-links") + <*> switch (long "no-server")) + +pinfo :: ParserInfo HakyllServeOptions +pinfo = info hakyllServeOptions + $ progDesc "Hakyll static site compiler and server" + +-- | The __serve__ cousin of @Hakyll.hakyllWith@. It provides a wrapper of the +-- usual Hakyll commands and a command for serving the built site. +hakyllServeWith :: HakyllServeConfiguration -> Rules a -> IO () +hakyllServeWith conf rules = do + r <- execParser pinfo + + case hsCommand r of + HakyllCommand _ -> do + args <- getArgs + + withArgs (tailDef [] args) + $ hakyllWith (_hscHakyllConfiguration conf) rules + ServeCommand -> serve (_hscServeConfiguration conf) + +-- | The __serve__ cousin of `Hakyll.hakyll`. It provides a wrapper of the +-- usual Hakyll commands and a command for serving the built site. +hakyllServe :: Rules a -> IO () +hakyllServe = hakyllServeWith def + +makeLenses ''HakyllServeConfiguration diff --git a/src/Network/Wai/Serve.hs b/src/Network/Wai/Serve.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Serve.hs @@ -0,0 +1,128 @@ +-- | +-- +-- Copyright: (c) Eduardo Trujillo, 2016 +-- License: Apache +-- Stability: experimental +-- +-- Serve provides utilities for building custom servers for serving +-- static websites and blogs. +-- +-- If you are looking to setup a simple but custom static server, +-- "Network.Wai.Serve.Main" is a good starting point. +-- +-- The following is an example of the server code used for serving +-- . It makes use of most of the +-- middleware provided by this package. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Data.Maybe (fromMaybe) +-- > import Data.Monoid ((<>)) +-- > import System.Environment (lookupEnv) +-- > +-- > import Control.Lens +-- > import Data.Default (def) +-- > import Network.Wai.Serve.Listeners (TLSSettings, tlsSettingsChain) +-- > import Network.Wai.Serve.Main (serve) +-- > import Network.Wai.Serve.Middleware (cspHeadersMiddleware, +-- > deindexifyMiddleware, domainMiddleware, +-- > forceSSLMiddleware, gzipMiddleware, +-- > loggerMiddleware, +-- > securityHeadersMiddleware, +-- > stsHeadersMiddleware, (<#>)) +-- > import Network.Wai.Serve.Types (Directive (..), Stage (..), +-- > TLSConfiguration (..), scDevTransform, +-- > scMiddleware, scPath, scPort, +-- > scProdTransform, scStage, +-- > scStagingTransform, scTlsConfiguration, +-- > tlsPort, tlsSettings) +-- > +-- > directives :: [Directive] +-- > directives = +-- > [ DefaultSrc ["'self'"] +-- > , ScriptSrc [ +-- > "'self'", "'unsafe-inline'", "https://use.typekit.net", +-- > "https://cdn.mathkax.org", "https://connect.facebook.net", +-- > "https://*.twitter.com", "https://cdn.syndication.twimg.com", +-- > "https://gist.github.com" +-- > ] +-- > , ImgSrc ["'self'", "https:", "data:", "platform.twitter.com"] +-- > , FontSrc [ +-- > "'self'", "data:", "https://use.typekit.net", +-- > "https://cdn.mathjax.org", "https://fonts.typekit.net" +-- > ] +-- > , StyleSrc [ +-- > "'self'", "'unsafe-inline'", "https://use.typekit.net", +-- > "platform.twitter.com", "https://assets-cdn.github.com" +-- > ] +-- > , FrameSrc [ +-- > "https://www.youtube.com", "https://www.slideshare.net", +-- > "staticxx.facebook.com", "www.facebook.com" +-- > ] +-- > ] +-- > +-- > getTLSSettings :: IO TLSSettings +-- > getTLSSettings = do +-- > certPath <- lookupEnv "BLOG_TLS_CERT" +-- > chainPath <- lookupEnv "BLOG_TLS_CHAIN" +-- > keyPath <- lookupEnv "BLOG_TLS_KEY" +-- > +-- > return $ tlsSettingsChain +-- > (fromMaybe "cert.pem" certPath) +-- > [fromMaybe "fullchain.pem" chainPath] +-- > (fromMaybe "privkey.pem" keyPath) +-- > +-- > -- | The entry point of the server application. +-- > main :: IO () +-- > main = do +-- > rawStage <- lookupEnv "BLOG_STAGE" +-- > rawPath <- lookupEnv "BLOG_PATH" +-- > +-- > tlsSettings <- getTLSSettings +-- > +-- > let liveMiddleware +-- > = mempty +-- > <#> loggerMiddleware +-- > <#> cspHeadersMiddleware directives +-- > <#> securityHeadersMiddleware +-- > <#> domainMiddleware "chromabits.com" +-- > <#> forceSSLMiddleware +-- > <#> deindexifyMiddleware +-- > <#> gzipMiddleware +-- > prodMiddlware = (mempty <#> stsHeadersMiddleware) <> liveMiddleware +-- > +-- > let tlsConf = TLSConfiguration (const liveMiddleware) tlsSettings 8443 +-- > +-- > serve $ def +-- > & scStage .~ case rawStage of +-- > Just "live" -> Production +-- > Just "staging" -> Staging +-- > _ -> Development +-- > & scPort .~ 9090 +-- > & scMiddleware .~ mempty +-- > <#> loggerMiddleware +-- > <#> securityHeadersMiddleware +-- > <#> deindexifyMiddleware +-- > <#> gzipMiddleware +-- > & scPath .~ rawPath +-- > & scStagingTransform .~ +-- > ( (set scTlsConfiguration $ Just tlsConf) +-- > . (set scMiddleware liveMiddleware) +-- > . (set scPort 8080) +-- > ) +-- > & scProdTransform .~ +-- > ( (set scTlsConfiguration $ Just (tlsConf & tlsPort .~ 443)) +-- > . (set scMiddleware prodMiddlware) +-- > . (set scPort 80) +-- > ) +-- > +-- +module Network.Wai.Serve + ( module X + ) where + +import Network.Wai.Serve.Applications as X +import Network.Wai.Serve.Listeners as X +import Network.Wai.Serve.Main as X +import Network.Wai.Serve.Middleware as X +import Network.Wai.Serve.Types as X diff --git a/src/Network/Wai/Serve/Applications.hs b/src/Network/Wai/Serve/Applications.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Serve/Applications.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- +-- Copyright: (c) Eduardo Trujillo, 2016 +-- License: Apache +-- Stability: experimental +-- +-- Utility Wai applications. +module Network.Wai.Serve.Applications where + +import Data.Maybe (fromMaybe, mapMaybe) +import Data.String (fromString) + +import Data.Text (pack) +import Network.Wai (Application) +import Network.Wai.Application.Static (defaultWebAppSettings, ss404Handler, + ssAddTrailingSlash, ssIndices, ssMaxAge, + ssRedirectToIndex, staticApp) +import Network.Wai.Middleware.Vhost (redirectTo) +import WaiAppStatic.Types (MaxAge (MaxAgeSeconds), toPiece) + +-- | An application for static websites. +-- +-- It serves files from the provided path. It defaults to `_site` which is the +-- default location for Hakyll websites. +staticSite :: Maybe FilePath -> Application +staticSite path = staticApp + (defaultWebAppSettings . fromString $ fromMaybe "_site" path) + { ssIndices = mapMaybe (toPiece . pack) ["index.html"] + , ssRedirectToIndex = False + , ssAddTrailingSlash = True + , ss404Handler = Just redirectHome + , ssMaxAge = MaxAgeSeconds 604801 + } + +-- | Handler for redirecting requests to the root of the site. +-- +-- Useful for 404 handlers. +redirectHome :: Application +redirectHome _ sendResponse = sendResponse $ redirectTo "/" diff --git a/src/Network/Wai/Serve/Listeners.hs b/src/Network/Wai/Serve/Listeners.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Serve/Listeners.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- +-- Copyright: (c) Eduardo Trujillo, 2016 +-- License: Apache +-- Stability: experimental +-- +-- The Listeners module includes wrappers for starting TLS and non-TLS Warp +-- servers, with support for IPv4 and IPv6. +module Network.Wai.Serve.Listeners + ( -- * Listeners + listen + , listenTLS + -- * Re-exports + , TLSSettings + , tlsSettingsChain + ) where + +import Control.Monad.Logger (MonadLogger, logDebug) +import Control.Monad.Trans (MonadIO, liftIO) +import qualified Data.Text as T +import Network.Wai (Application) +import Network.Wai.Handler.Warp (defaultSettings, runSettings, + setHost, setPort) +import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS, + tlsSettingsChain) + +-- | Serves a WAI Application on the specified port. +-- The target port is printed to stdout before hand, which can be useful for +-- debugging purposes. +listen :: (MonadLogger m, MonadIO m) => Int -> Application -> m () +listen port app = do + let settings = setHost "*6" (setPort port defaultSettings) + + -- Inform which port we will be listening on. + $(logDebug) $ mconcat ["Listening on port ", T.pack $ show port, "..."] + + -- Serve the WAI app using Warp + liftIO $ runSettings settings app + +-- | Serves a WAI Application on the specified port. +-- The target port is printed to stdout before hand, which can be useful for +-- debugging purposes. +listenTLS + :: (MonadLogger m, MonadIO m) + => TLSSettings + -> Int + -> Application + -> m () +listenTLS tlsSettings port app = do + let settings = setHost "*6" (setPort port defaultSettings) + + -- Inform which port we will be listening on. + $(logDebug) $ mconcat ["Listening on port ", T.pack $ show port, " (TLS)..."] + + -- Serve the WAI app using Warp + liftIO $ runTLS tlsSettings settings app diff --git a/src/Network/Wai/Serve/Main.hs b/src/Network/Wai/Serve/Main.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Serve/Main.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- +-- Copyright: (c) Eduardo Trujillo, 2016 +-- License: Apache +-- Stability: experimental +-- +-- The Main module contains an implementation of a configurable static web +-- server with support for a middleware stack and different environments +-- (development, staging, production). +-- +-- Take a look at 'ServeConfiguration' for all the possible configuration +-- options or simply use it's 'Data.Default.Default' instance for a basic +-- server. +-- +module Network.Wai.Serve.Main + ( serve + , serve' + ) where + +import Control.Concurrent.Lifted (fork) +import Control.Monad.Logger (runStdoutLoggingT) +import Control.Monad.Trans (MonadIO) +import Control.Monad.Trans.Control (MonadBaseControl) + +import Network.Wai.Serve.Applications (staticSite) +import Network.Wai.Serve.Listeners (listen, listenTLS) +import Network.Wai.Serve.Middleware (wrap) +import Network.Wai.Serve.Types (ServeConfiguration (..), Stage (..), + TLSConfiguration (..)) + +-- | Starts a server with the provided @ServeConfiguration@. If TLS settings +-- are provided, an additional server is started for handling secure requests. +serve :: (MonadIO m, MonadBaseControl IO m) => ServeConfiguration -> m () +serve = serve' . transform + +-- | Starts a server with the provided @ServeConfiguration@. If TLS settings +-- are provided, an additional server is started for handling secure requests. +-- Unlike $serve'$, stage transforms are not applied on the provided +-- configuration. +serve' :: (MonadIO m, MonadBaseControl IO m) => ServeConfiguration -> m () +serve' ServeConfiguration{..} = runStdoutLoggingT $ do + let site = staticSite _scPath + + _ <- fork $ case _scTlsConfiguration of + Just TLSConfiguration{..} -> listenTLS + _tlsSettings + _tlsPort + (_tlsMiddleware _scMiddleware `wrap` site) + Nothing -> pure () + + listen _scPort (_scMiddleware `wrap` site) + +-- | Applies the respective configuration transform to the current stage. +transform :: ServeConfiguration -> ServeConfiguration +transform conf@ServeConfiguration{..} = transformer conf + where + transformer = case _scStage of + Development -> _scDevTransform + Staging -> _scStagingTransform + Production -> _scProdTransform diff --git a/src/Network/Wai/Serve/Middleware.hs b/src/Network/Wai/Serve/Middleware.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Serve/Middleware.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- +-- Copyright: (c) Eduardo Trujillo, 2016 +-- License: Apache +-- Stability: experimental +-- +-- A collection of middleware useful for static websites. +module Network.Wai.Serve.Middleware + ( -- * Middleware Stacks + MiddlewareStack(..) + , (<#>) + , flatten + , wrap + -- * Middleware + , loggerMiddleware + , forceSSLMiddleware + , gzipMiddleware + , domainMiddleware + , securityHeadersMiddleware + , stsHeadersMiddleware + , cspHeadersMiddleware + , deindexifyMiddleware + ) where + +import Data.ByteString (ByteString) +import Data.Monoid ((<>)) +import Prelude hiding (unwords) + +import Data.Text (Text, intercalate, + unwords) +import qualified Data.Text as T (concat) +import Data.Text.Encoding (encodeUtf8) +import Network.Wai (Application, Middleware, + pathInfo) +import Network.Wai.Middleware.AddHeaders (addHeaders) +import Network.Wai.Middleware.ForceDomain (forceDomain) +import Network.Wai.Middleware.ForceSSL (forceSSL) +import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress), + def, gzip, gzipFiles) +import Network.Wai.Middleware.RequestLogger (logStdout) +import Network.Wai.Middleware.Vhost (redirectTo) +import Safe (lastMay) + +import Network.Wai.Serve.Types + +infixl 5 <#> +-- | A combinator for adding a middleware to the bottom of a stack. +(<#>) :: MiddlewareStack -> Middleware -> MiddlewareStack +(<#>) (MiddlewareStack s) m = MiddlewareStack (s ++ [m]) + +-- | Combines the entire stack into a single middleware. +flatten :: MiddlewareStack -> Middleware +flatten (MiddlewareStack s) = foldr (.) id s + +-- | Wraps a WAI application in the stack. (Alias of 'flatten') +wrap :: MiddlewareStack -> Application -> Application +wrap = flatten + +dt :: Text -> [Text] -> Text +dt prefix [] = prefix +dt prefix xs = unwords (prefix : xs) + +showDirective :: Directive -> Text +showDirective (BaseURI xs) = dt "base-uri" xs +showDirective (ChildSrc xs) = dt "child-src" xs +showDirective (ConnectSrc xs) = dt "connect-src" xs +showDirective (DefaultSrc xs) = dt "default-src" xs +showDirective (FontSrc xs) = dt "font-src" xs +showDirective (FormAction xs) = dt "form-action" xs +showDirective (FrameAncestors xs) = dt "frame-ancestors" xs +showDirective (FrameSrc xs) = dt "frame-src" xs +showDirective (ImgSrc xs) = dt "img-src" xs +showDirective (ManifestSrc xs) = dt "manifest-src" xs +showDirective (MediaSrc xs) = dt "media-src" xs +showDirective (ObjectSrc xs) = dt "object-src" xs +showDirective (PluginTypes xs) = dt "plugin-types" xs +showDirective (Referrer x) = dt "referrer" [x] +showDirective (ReflectedXSS x) = dt "reflected-xss" [x] +showDirective (ReportURI x) = dt "report-uri" [x] +showDirective (Sandbox x) = dt "sandbox" [x] +showDirective (ScriptSrc xs) = dt "script-src" xs +showDirective (StyleSrc xs) = dt "style-src" xs +showDirective UpgradeInsecureRequests = dt "upgrade-insecure-requests" [] + +-- | Logger middleware. +loggerMiddleware :: Middleware +loggerMiddleware = logStdout + +-- | Middleware for forcing requests to be done through SSL. +forceSSLMiddleware :: Middleware +forceSSLMiddleware = forceSSL + +-- | Gzip compression middleware. +gzipMiddleware :: Middleware +gzipMiddleware = gzip $ def {gzipFiles = GzipCompress} + +-- | Domain redirection middleware. +-- +-- When the site is live, we want to redirect users to the right domain name +-- regarles of whether they arrive from a www. domain, the server's IP address +-- or a spoof domain which is pointing to this server. +domainMiddleware :: Domain -> Middleware +domainMiddleware target = forceDomain + $ \domain -> if domain `elem` [target, "localhost"] + then Nothing + else Just target + +-- | Common security headers middleware. +securityHeadersMiddleware :: Middleware +securityHeadersMiddleware = addHeaders + [ ("X-Frame-Options", "SAMEORIGIN") + , ("X-XSS-Protection", "1; mode=block") + , ("X-Content-Type-Options", "nosniff") + ] + +-- | Strict Transport Security middleware. +stsHeadersMiddleware :: Middleware +stsHeadersMiddleware = addHeaders + [("Strict-Transport-Security", "max-age=31536000; includeSubdomains")] + +-- | Content Security Policy middleware. +-- +-- Here we add the CSP header which includes the policies for this blog. +cspHeadersMiddleware :: [Directive] -> Middleware +cspHeadersMiddleware directives = addHeaders + [("Content-Security-Policy", encodeUtf8 $ glue directives)] + where + glue :: [Directive] -> Text + glue [] = showDirective $ DefaultSrc ["'none'"] + glue xs = intercalate "; " (map showDirective xs) + +-- | De-indexify middleware. +-- +-- Redirects any path ending in `/index.html` to just `/`. +deindexifyMiddleware :: Middleware +deindexifyMiddleware app req sendResponse + = if lastMay (pathInfo req) == Just "index.html" + then sendResponse $ redirectTo newPath + else app req sendResponse + + where + newPath :: ByteString + newPath = encodeUtf8 $ processPath oldPath + + processPath :: [Text] -> Text + processPath xs = case xs of + [] -> "/" + _ -> T.concat $ map prefixSlash xs + + oldPath :: [Text] + oldPath = init $ pathInfo req + + prefixSlash :: Text -> Text + prefixSlash = (<>) "/" diff --git a/src/Network/Wai/Serve/Types.hs b/src/Network/Wai/Serve/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Serve/Types.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- +-- Copyright: (c) Eduardo Trujillo, 2016 +-- License: Apache +-- Stability: experimental +-- +-- Types used by the Kawaii package. +module Network.Wai.Serve.Types + ( -- * Middleware Stack + MiddlewareStack(..) + , -- * Server configuration + ServeConfiguration(..) + , TLSConfiguration(..) + , -- * CSP + SourceList + , TypeList + , Directive(..) + , -- * Miscellaneous types + Domain + , Stage(..) + , -- * Lenses + scMiddleware + , scDevTransform + , scStagingTransform + , scProdTransform + , scTlsConfiguration + , scPort + , scStage + , scPath + , tlsMiddleware + , tlsSettings + , tlsPort + ) where + +import Data.ByteString (ByteString) + +import Control.Lens (makeLenses) +import Data.Default (Default, def) +import Data.Text (Text) +import Network.Wai (Middleware) +import Network.Wai.Handler.WarpTLS (TLSSettings) + +type Domain = ByteString + +type SourceList = [Text] +type TypeList = [Text] + +data Directive + = BaseURI SourceList + | ChildSrc SourceList + | ConnectSrc SourceList + | DefaultSrc SourceList + | FontSrc SourceList + | FormAction SourceList + | FrameAncestors SourceList + | FrameSrc SourceList + | ImgSrc SourceList + | ManifestSrc SourceList + | MediaSrc SourceList + | ObjectSrc SourceList + | PluginTypes TypeList + | Referrer Text + | ReflectedXSS Text + | ReportURI Text + | Sandbox Text + | ScriptSrc SourceList + | StyleSrc SourceList + | UpgradeInsecureRequests + +-- | A middleware stack is a simple container of Wai middleware. The top of the +-- stack is considered to be the outermost layer of middleware while the bottom +-- of the stack is the innermost layer of middleware. +-- +-- The stack is a 'Monoid', so it can be combined with other stacks using +-- 'Data.Monoid.<>', and an empty one can be obtained using 'mempty'. +-- +data MiddlewareStack + -- | The constructor takes a list of middleware, where the left-most item in + -- the list will end up at the top of the stack, and the right-most at the + -- bottom. + = MiddlewareStack [Middleware] + +instance Monoid MiddlewareStack where + mempty = MiddlewareStack [] + mappend (MiddlewareStack x) (MiddlewareStack y) = MiddlewareStack (x ++ y) + +-- | The development stage an application is executing in. +-- +-- This is used to alter the behavior of the server depending on the stage of +-- development. For example, a local development server might only have an +-- HTTP listener and a smaller middleware stack, while a production server +-- also listens for TLS connections and has additional middlewares that only +-- make sense on a public server. +-- +data Stage = Development | Staging | Production deriving (Show) + +-- | The configuration for the server process. +-- +-- The different transforms can be used to specify how the configuration +-- changes depending on the stage. While starting up, the server process will +-- take the base configuration, check the stage and pass the configuration +-- through the appropriate transformer. +-- +data ServeConfiguration = ServeConfiguration + { -- | Base middleware stack. + _scMiddleware :: MiddlewareStack + -- | @Developer@ stage configuration transformer. + , _scDevTransform :: ServeConfiguration -> ServeConfiguration + -- | @Staging@ stage configuration transfomer. + , _scStagingTransform :: ServeConfiguration -> ServeConfiguration + -- | @Production@ stage configuration transfomer. + , _scProdTransform :: ServeConfiguration -> ServeConfiguration + -- | TLS/SSL configuration. If it's not provided, a TLS listener will not + -- be started. + , _scTlsConfiguration :: Maybe TLSConfiguration + -- | Port to start the non-TLS server. + , _scPort :: Int + -- | The current stage. This selects which transformer is used before + -- starting the server. + , _scStage :: Stage + -- | Path where the source of built site is located. Defaults to `_site`. + , _scPath :: Maybe FilePath + } + +instance Default ServeConfiguration where + def = ServeConfiguration + { _scMiddleware = mempty + , _scDevTransform = id + , _scStagingTransform = id + , _scProdTransform = id + , _scTlsConfiguration = Nothing + , _scPort = 9119 + , _scStage = Development + , _scPath = Nothing + } + +-- | The configuration for the TLS/HTTPS server. +data TLSConfiguration = TLSConfiguration + { -- | A function for modifying or completely replacing the middleware stack + -- for the TLS server. + _tlsMiddleware :: MiddlewareStack -> MiddlewareStack + -- | Warp @TLSSettings@, which can be used to provide certificates. + , _tlsSettings :: TLSSettings + -- | Port to start the TLS server. + , _tlsPort :: Int + } + +makeLenses ''ServeConfiguration +makeLenses ''TLSConfiguration diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"