kawaii (empty) → 0.0.1.0

raw patch · 11 files changed

+813/−0 lines, 11 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, data-default, hakyll, hakyll-serve, hspec, lens, lifted-base, monad-control, monad-logger, mtl, optparse-applicative, safe, streaming-commons, text, wai, wai-app-static, wai-extra, warp, warp-tls

Files

• LICENSE +13/−0
• Setup.hs +2/−0
• kawaii.cabal +81/−0
• src/Hakyll/Serve/Main.hs +117/−0
• src/Network/Wai/Serve.hs +128/−0
• src/Network/Wai/Serve/Applications.hs +41/−0
• src/Network/Wai/Serve/Listeners.hs +59/−0
• src/Network/Wai/Serve/Main.hs +63/−0
• src/Network/Wai/Serve/Middleware.hs +156/−0
• src/Network/Wai/Serve/Types.hs +151/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,13 @@+Copyright 2016 Eduardo Trujillo <ed@chromabits.com>++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.<Paste>

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <ed@chromabits.com>+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

@@ -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

@@ -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+-- <https://chromabits.com chromabits.com>. 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

@@ -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 "/"

@@ -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

@@ -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

@@ -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 = (<>) "/"

@@ -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

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"