servant-static-th (empty) → 0.1.0.0

raw patch · 19 files changed

+1263/−0 lines, 19 filesdep +Globdep +basedep +blaze-htmlsetup-changed

Dependencies added: Glob, base, blaze-html, bytestring, containers, directory, doctest, filepath, hspec-wai, http-media, semigroups, servant, servant-blaze, servant-server, servant-static-th, tasty, tasty-hspec, tasty-hunit, template-haskell, text, wai, warp

Files

• LICENSE +30/−0
• README.md +15/−0
• Setup.hs +2/−0
• example/Example.hs +68/−0
• servant-static-th.cabal +101/−0
• src/Servant/Static/TH.hs +226/−0
• src/Servant/Static/TH/Internal.hs +14/−0
• src/Servant/Static/TH/Internal/Api.hs +100/−0
• src/Servant/Static/TH/Internal/FileTree.hs +86/−0
• src/Servant/Static/TH/Internal/Mime.hs +204/−0
• src/Servant/Static/TH/Internal/Server.hs +120/−0
• src/Servant/Static/TH/Internal/Util.hs +52/−0
• test/DocTest.hs +40/−0
• test/Spec.hs +21/−0
• test/Spec/ApiSpec.hs +41/−0
• test/Spec/HelperFuncSpec.hs +65/−0
• test/Spec/ServerSpec.hs +39/−0
• test/Spec/TastyHelpers.hs +32/−0
• test/Spec/TestDirLocation.hs +7/−0

@@ -0,0 +1,30 @@+Copyright Dennis Gosnell (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,15 @@++Servant.Static.TH+==================++[![Build Status](https://secure.travis-ci.org/cdepillabout/servant-static-th.svg)](http://travis-ci.org/cdepillabout/servant-static-th)+[![Hackage](https://img.shields.io/hackage/v/servant-static-th.svg)](https://hackage.haskell.org/package/servant-static-th)+[![Stackage LTS](http://stackage.org/package/servant-static-th/badge/lts)](http://stackage.org/lts/package/servant-static-th)+[![Stackage Nightly](http://stackage.org/package/servant-static-th/badge/nightly)](http://stackage.org/nightly/package/servant-static-th)+![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)++`servant-static-th` allows you to embed a directory of static files in your+application and serve them from your Servant server++For documentation and usage examples, see the+[documentation](https://hackage.haskell.org/package/servant-static-th) on Hackage.

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

@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Data.Proxy (Proxy(Proxy))+import Network.Wai (Application)+import Network.Wai.Handler.Warp (run)+import Servant.Server (serve)+import Servant.Static.TH (createApiAndServerDecs)++-- 'createApiAndServerDecs' will use the files in the directory @test/test-dir@+-- to create two things.+--+-- Let's assume that the @test/test-dir@ directory looks like this:+--+-- @+--   $ tree test/test-dir/+--   test/test-dir/+--   ├── dir+--   │   ├── inner-file.html+--   │   └── test.js+--   └── hello.html+-- @+--+-- First, the following API definition will be created:+--+-- @+--   type FrontEndApi =+--       "dir" :>+--         ( "inner-file.html" :> Get '[HTML] Html :<|>+--           "test.js" :> Get '[JS] ByteString+--         ) :<|>+--       "hello.html" :> Get '[HTML] Html+-- @+--+-- Next, the following function will be created.  This function represents a+-- Servant server for the @FrontEndApi@.  It basically just returns the content+-- from the files in the @test/test-dir@ directory.  The contents from the files+-- is statically embedded in the @frontEndServer@ function at compile fime:+--+-- @+--   frontEndServer :: Applicative m => ServerT FrontEndApi m+--   frontEndServer = ...+-- @+--+-- This @frontEndServer@ function can be passed to Servant's 'serve' function+-- in order to create a WAI application.+--+-- If this WAI application is running, it is possible to use @curl@ to access+-- the server:+--+-- @+--   $ curl localhost:8080/hello.html+--   Hello World+--   $ curl localhost:8080/dir/inner-file.html+--   Inner File+--   $ curl localhost:8080/dir/test.js+--   console.log(\"hello world\");+-- @++$(createApiAndServerDecs "FrontEndApi" "frontEndServer" "test/test-dir")++app :: Application+app = serve (Proxy :: Proxy FrontEndApi) frontEndServer++main :: IO ()+main = run 8080 app

@@ -0,0 +1,101 @@+name:                servant-static-th+version:             0.1.0.0+synopsis:            Embed a directory of static files in your application and serve them from your Servant server+description:         Please see <https://github.com/cdepillabout/servant-static-th#readme README.md>.+homepage:            https://github.com/cdepillabout/servant-static-th+license:             BSD3+license-file:        LICENSE+author:              Dennis Gosnell+maintainer:          cdep.illabout@gmail.com+copyright:           2017 Dennis Gosnell+category:            Text+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++flag buildexample+  description: Build a small example program+  default: False++library+  hs-source-dirs:      src+  exposed-modules:     Servant.Static.TH+                     , Servant.Static.TH.Internal+                     , Servant.Static.TH.Internal.Api+                     , Servant.Static.TH.Internal.FileTree+                     , Servant.Static.TH.Internal.Mime+                     , Servant.Static.TH.Internal.Server+                     , Servant.Static.TH.Internal.Util+  build-depends:       base >= 4.8 && < 5+                     , blaze-html+                     , bytestring+                     , containers+                     , directory >= 1.2.5.0+                     , filepath+                     , http-media+                     , semigroups+                     , servant >= 0.8+                     , servant-blaze >= 0.7+                     , servant-server >= 0.8+                     , template-haskell+                     , text+  default-language:    Haskell2010+  ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction+  other-extensions:    QuasiQuotes+                     , TemplateHaskell++executable servant-static-th-example+  main-is:             Example.hs+  hs-source-dirs:      example+  build-depends:       base+                     , servant-server+                     , servant-static-th+                     , wai+                     , warp+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N++  if flag(buildexample)+    buildable:         True+  else+    buildable:         False++test-suite servant-static-th-doctest+  type:                exitcode-stdio-1.0+  main-is:             DocTest.hs+  hs-source-dirs:      test+  build-depends:       base+                     , doctest+                     , Glob+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N++test-suite servant-static-th-test+  type:                exitcode-stdio-1.0+  main-is:             Spec.hs+  other-modules:       Spec.ApiSpec+                     , Spec.HelperFuncSpec+                     , Spec.ServerSpec+                     , Spec.TastyHelpers+                     , Spec.TestDirLocation+  hs-source-dirs:      test+  build-depends:       base+                     , blaze-html+                     , bytestring+                     , directory+                     , filepath+                     , hspec-wai+                     , tasty+                     , tasty-hspec+                     , tasty-hunit+                     , servant+                     , servant-blaze+                     , servant-static-th+                     , servant-server+                     , wai+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction++source-repository head+  type:     git+  location: git@github.com:cdepillabout/servant-static-th.git

@@ -0,0 +1,226 @@++{- |+Module      :  Servant.Static.TH++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module provides the 'createApiAndServerDecs' function.  At compile time,+it will read all the files under a specified directory, embed their contents,+create a Servant \"API\" type synonym representing their directory layout, and+create a 'ServerT' function for serving their contents statically.++Let's assume that we have a directory called @\"dir\"@ in the root of our+Haskell web API that looks like this:++@+  $ tree dir/+  dir/+  ├── js+  │   └── test.js+  └── hello.html+@++Here's the contents of @\"hello.html\"@ and @\"js/test.js\"@:++@+  $ cat dir/index.html+  \<p\>Hello World\</p\>+  $ cat dir\/js\/test.js+  console.log(\"hello world\");+@++The 'createApiAndServerDecs' function can be used like the following:++@+  \{\-\# LANGUAGE DataKinds \#\-\}+  \{\-\# LANGUAGE TemplateHaskell \#\-\}++  import "Data.Proxy" ('Data.Proxy.Proxy'('Data.Proxy.Proxy'))+  import "Network.Wai" ('Network.Wai.Application')+  import "Network.Wai.Handler.Warp" ('Network.Wai.Handler.Warp.run')+  import "Servant.Server" ('Servant.Server.serve')+  import "Servant.Static.TH" ('createApiAndServerDecs')++  $(createApiAndServerDecs \"FrontEndApi\" \"frontEndServer\" \"dir\")++  app :: 'Network.Wai.Application'+  app = 'Servant.Server.serve' ('Data.Proxy.Proxy' :: 'Data.Proxy.Proxy' FrontEndApi) frontEndServer++  main :: IO ()+  main = 'Network.Wai.Handler.Warp.run' 8080 app+@++'createApiAndServerDecs' will expand to something like the following at+compile time:++@+  type FrontEndAPI =+         \"js\" 'Servant.API.:>' \"test.js\" 'Servant.API.:>' 'Servant.API.Get' \'['JS'] 'Data.ByteString.ByteString'+    ':<|>' \"index.html\" 'Servant.API.:>' 'Servant.API.Get' \'['HTML'] 'Html'++  frontEndServer :: 'Applicative' m => 'Servant.Server.ServerT' FrontEndAPI m+  frontEndServer =+         'pure' "console.log(\\"hello world\\");"+    ':<|>' 'pure' "\<p\>Hello World\</p\>"+@++If this WAI application is running, it is possible to use @curl@ to access+the server:++@+  $ curl localhost:8080/hello.html+  \<p\>Hello World\</p\>+  $ curl localhost:8080/js/test.js+  console.log(\"hello world\");+@++This 'createApiAndServerDecs' function is convenient to use when you want to+make a Servant application easy to deploy.  All the static frontend files are+bundled into the Haskell binary at compile-time, so all you need to do is+deploy the Haskell binary.  This works well for low-traffic websites like+prototypes and internal applications.++This shouldn't be used for high-traffic websites.  Instead, you should serve+your static files from something like Apache, nginx, or a CDN.+-}++module Servant.Static.TH+  ( -- * Create API+    createApiType+  , createApiDec+    -- * Create Server+  , createServerExp+  , createServerDec+    -- * Create Both API and Server+  , createApiAndServerDecs+    -- * Mime Types++    -- | The following types are the mime types supported by servant-static-th.+    -- If you need additional MIME types supported, feel free to create an+    -- <https://github.com/cdepillabout/servant-static-th/issues issue> or+    -- <https://github.com/cdepillabout/servant-static-th/pulls PR>.+  , CSS+  , GIF+  , HTML+  , Html+  , JPEG+  , JS+  , PNG+  , SVG+  , TXT+    -- * Easy-To-Use Names and Paths++    -- | The functions in this section pick defaults for the template+    -- directory, api name, and the server function name. This makes it easy to+    -- use for quick-and-dirty code.++    -- ** Paths and Names+  , frontEndTemplateDir+  , frontEndApiName+  , frontEndServerName+    -- ** API+  , createApiFrontEndType+  , createApiFrontEndDec+    -- ** Server+  , createServerFrontEndExp+  , createServerFrontEndDec+    -- ** Server and API+  , createApiAndServerFrontEndDecs+  ) where++import Language.Haskell.TH (Dec, Exp, Q, Type, mkName, tySynD)+import System.FilePath ((</>))+import Servant.HTML.Blaze (HTML)+import Text.Blaze.Html (Html)++import Servant.Static.TH.Internal+       (CSS, GIF, JPEG, JS, PNG, SVG, TXT, createApiDec, createApiType,+        createServerDec, createServerExp)++------------------------------------+-- Hard-coded Frontend file paths --+------------------------------------++-- | This is the directory @\"frontend/dist\"@.+frontEndTemplateDir :: FilePath+frontEndTemplateDir = "frontend" </> "dist"++-- | This is the 'String' @\"FrontEnd\"@.+frontEndApiName :: String+frontEndApiName = "FrontEnd"++-- | This is the 'String' @\"frontEndServer\"@.+frontEndServerName :: String+frontEndServerName = "frontEndServer"++---------+-- Api --+---------++-- | This is the same as @'createApiType' 'frontEndTemplateDir'@.+createApiFrontEndType :: Q Type+createApiFrontEndType = createApiType frontEndTemplateDir++-- | This is the same as+-- @'createApiDec' 'frontEndApiName' 'frontEndTemplateDir'@.+createApiFrontEndDec :: Q [Dec]+createApiFrontEndDec =+  pure <$> tySynD (mkName "FrontEnd") [] createApiFrontEndType++------------+-- Server --+------------++-- | This is the same as @'createServerExp' 'frontEndTemplateDir'@.+createServerFrontEndExp :: Q Exp+createServerFrontEndExp = createServerExp frontEndTemplateDir++-- | This is the same as+-- @'createServerDec' 'frontEndApiName' 'frontEndServerName' 'frontEndTemplateDir'@.+createServerFrontEndDec :: Q [Dec]+createServerFrontEndDec =+  createServerDec frontEndApiName frontEndServerName frontEndTemplateDir++--------------------+-- Server and API --+--------------------++-- | This is a combination of 'createApiDec' and 'createServerDec'.  This+-- function is the one most users should use.+--+-- Given the following code:+--+-- @+--   \{\-\# LANGUAGE DataKinds \#\-\}+--   \{\-\# LANGUAGE TemplateHaskell \#\-\}+--+--   $('createApiAndServerDecs' \"FrontAPI\" \"frontServer\" \"dir\")+-- @+--+-- You can think of it as expanding to the following:+--+-- @+--   $('createApiDec' \"FrontAPI\" \"dir\")+--+--   $('createServerDec' \"FrontAPI\" \"frontServer\" \"dir\")+-- @+createApiAndServerDecs+  :: String   -- ^ name of the api type synonym+  -> String   -- ^ name of the server function+  -> FilePath -- ^ directory name to read files from+  -> Q [Dec]+createApiAndServerDecs apiName serverName templateDir =+  let apiDecs = createApiDec apiName templateDir+      serverDecs = createServerDec apiName serverName templateDir+  in mappend <$> apiDecs <*> serverDecs++-- | This is the same as+-- @'createApiAndServerDecs' 'frontEndApiName' 'frontEndServerName' 'frontEndTemplateDir'@.+createApiAndServerFrontEndDecs :: Q [Dec]+createApiAndServerFrontEndDecs =+  createApiAndServerDecs frontEndApiName frontEndServerName frontEndTemplateDir

@@ -0,0 +1,14 @@++module Servant.Static.TH.Internal+  ( module Servant.Static.TH.Internal.Api+  , module Servant.Static.TH.Internal.FileTree+  , module Servant.Static.TH.Internal.Mime+  , module Servant.Static.TH.Internal.Server+  , module Servant.Static.TH.Internal.Util+  ) where++import Servant.Static.TH.Internal.Api+import Servant.Static.TH.Internal.FileTree+import Servant.Static.TH.Internal.Mime+import Servant.Static.TH.Internal.Server+import Servant.Static.TH.Internal.Util

@@ -0,0 +1,100 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Static.TH.Internal.Api where++import Data.Foldable (foldl1)+import Data.List.NonEmpty (NonEmpty)+import Language.Haskell.TH+       (Dec, Q, Type, appT, litT, mkName,+        runIO, strTyLit, tySynD)+import Language.Haskell.TH.Syntax (addDependentFile)+import Servant.API (Get, (:<|>), (:>))+import System.FilePath (takeFileName)++import Servant.Static.TH.Internal.FileTree+import Servant.Static.TH.Internal.Mime++fileTreeToApiType :: FileTree -> Q Type+fileTreeToApiType (FileTreeFile filePath _) = do+  addDependentFile filePath+  MimeTypeInfo mimeT respT _ <- extensionToMimeTypeInfoEx filePath+  let fileNameLitT = litT $ strTyLit $ takeFileName filePath+  [t|$(fileNameLitT) :> Get '[$(mimeT)] $(respT)|]+fileTreeToApiType (FileTreeDir filePath fileTrees) =+  let fileNameLitT = litT $ strTyLit $ takeFileName filePath+  in [t|$(fileNameLitT) :> $(combineWithServantOrT nonEmptyApiTypesQ)|]+  where+    nonEmptyApiTypesQ :: NonEmpty (Q Type)+    nonEmptyApiTypesQ = fmap fileTreeToApiType fileTrees++-- | Given a list of @'Q' 'Type'@, combine them with Servant's '(:<|>)'+-- function and return the resulting @'Q' 'Type'@.+combineWithServantOrT :: NonEmpty (Q Type) -> Q Type+combineWithServantOrT = foldl1 $ combineWithType [t|(:<|>)|]++combineWithType :: Q Type -> Q Type -> Q Type -> Q Type+combineWithType combiningType = appT . appT combiningType++-- | Take a template directory argument as a 'FilePath' and create a Servant+-- type representing the files in the directory.  Empty directories will be+-- ignored.+--+-- For example, assume the following directory structure:+--+-- @+--   $ tree dir/+--   dir/+--   ├── js+--   │   └── test.js+--   └── index.html+-- @+--+-- 'createApiType' is used like the following:+--+-- @+--   \{\-\# LANGUAGE DataKinds \#\-\}+--   \{\-\# LANGUAGE TemplateHaskell \#\-\}+--+--   type FrontEndAPI = $('createApiType' \"dir\")+-- @+--+-- At compile time, it will expand to the following:+--+-- @+--   type FrontEndAPI =+--          \"js\" ':>' \"test.js\" ':>' 'Get' \'['JS'] 'Data.ByteString.ByteString'+--     ':<|>' \"index.html\" ':>' 'Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html'+-- @+createApiType+  :: FilePath -- ^ directory name to read files from+  -> Q Type+createApiType templateDir = do+  fileTree <- runIO $ getFileTreeIgnoreEmpty templateDir+  combineWithServantOrT $ fmap fileTreeToApiType fileTree++-- | This is similar to 'createApiType', but it creates the whole type synonym+-- declaration.+--+-- Given the following code:+--+-- @+--   \{\-\# LANGUAGE DataKinds \#\-\}+--   \{\-\# LANGUAGE TemplateHaskell \#\-\}+--+--   $('createApiDec' \"FrontAPI\" \"dir\")+-- @+--+-- You can think of it as expanding to the following:+--+-- @+--   type FrontAPI = $('createApiType' \"dir\")+-- @+createApiDec+  :: String   -- ^ name of the api type synonym+  -> FilePath -- ^ directory name to read files from+  -> Q [Dec]+createApiDec apiName templateDir =+  pure <$> tySynD (mkName apiName) [] (createApiType templateDir)

@@ -0,0 +1,86 @@+{- |+Module      :  Servant.Static.TH.Internal.FileTree++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++Read a directory and the contents of all the files in it as a 'FileTree'.+-}++module Servant.Static.TH.Internal.FileTree where++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.List (sort)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Maybe (catMaybes)+import Data.Monoid ((<>))+import System.Directory+       (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath ((</>))++-- | This tree structure represents the directory structure on disk.+data FileTree+  = FileTreeFile FilePath ByteString+  -- ^ A file with it's 'FilePath' and contents as a 'ByteString'.+  | FileTreeDir FilePath (NonEmpty FileTree)+  -- ^ A directory with it's 'FilePath' and the files under it.+  deriving (Eq, Read, Show)++-- | This is a simple version of 'FileTree', just used for tagging a given+-- 'FilePath' as a directory or a file.+data FileType+  = FileTypeFile FilePath+  | FileTypeDir FilePath+  deriving (Eq, Read, Show)++-- | Get the 'FileType' for a given 'FilePath'.  Calls 'fail' if it is not a+-- file or a directory.+getFileType :: FilePath -> IO FileType+getFileType path = do+  isFile <- doesFileExist path+  isDir <- doesDirectoryExist path+  case (isFile, isDir) of+    (True, _) -> pure $ FileTypeFile path+    (_, True) -> pure $ FileTypeDir path+    _ ->+      fail $+        "getFileType: Could not determine the type of file \"" <> path <> "\""++-- | Convert a 'FileType' to a 'FileTree'.  Return 'Nothing' if the input+-- 'FileType' is 'FileTypeDir', and that directory is empty.+fileTypeToFileTree :: FileType -> IO (Maybe FileTree)+fileTypeToFileTree (FileTypeFile filePath) =+  Just . FileTreeFile filePath <$> ByteString.readFile filePath+fileTypeToFileTree (FileTypeDir dir) = do+  fileTrees <- getFileTree dir+  pure $+    case fileTrees of+      [] -> Nothing+      (ft:fts) -> Just . FileTreeDir dir $ ft :| fts++-- | Convert an input directory 'FilePath' to a 'FileTree'.  Fails if the input+-- directory 'FilePath' is not a directory.+getFileTree :: FilePath -> IO [FileTree]+getFileTree templateDir = do+  filePaths <- sort <$> listDirectory templateDir+  let fullFilePaths = fmap (templateDir </>) filePaths+  fileTypes <- traverse getFileType fullFilePaths+  fileTreesWithMaybe <- traverse fileTypeToFileTree fileTypes+  pure $ catMaybes fileTreesWithMaybe++-- | Just like 'getFileTree', but returns an error with 'fail' if the input+-- directory is empty.+getFileTreeIgnoreEmpty :: FilePath -> IO (NonEmpty FileTree)+getFileTreeIgnoreEmpty templateDir = do+  fileTrees <- getFileTree templateDir+  case fileTrees of+    [] ->+      fail $+        "getFileTreeIgnoreEmpty: Top level template directory is empty: \"" <>+        templateDir <> "\""+    (ft:fts) -> pure $ ft :| fts

@@ -0,0 +1,204 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++{- |+Module      :  Servant.Static.TH.Internal.Mime++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module exports functions and datatypes for using many different mime+types.+-}++module Servant.Static.TH.Internal.Mime where++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LByteString+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid ((<>))+import Data.Proxy (Proxy)+import Data.Text (unpack)+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Typeable (Typeable)+import Language.Haskell.TH (Exp, Q, Type)+import Network.HTTP.Media (MediaType, (//))+import Servant.HTML.Blaze (HTML)+import Servant.API (Accept(contentType), MimeRender(mimeRender))+import System.FilePath (takeExtension)+import Text.Blaze.Html (Html, preEscapedToHtml)++import Servant.Static.TH.Internal.Util+       (getExtension, removeLeadingPeriod)++-- | Hold 'Type's and functions work working with a given file type, like+-- @html@ or @js@.+--+-- You can find examples of 'MimeTypeInfo' in the function+-- 'extensionMimeTypeMap'.+data MimeTypeInfo = MimeTypeInfo+  { mimeTypeInfoContentType :: Q Type+    -- ^ A @'Q' 'Type'@ representing a type to use for the content type of a+    -- Servant API.  For instance, HTML files will use something like+    -- @[t|'HTML'|]@, while Javascript files will use something like+    -- @[t|'JS'|]@.+  , mimeTypeInfoRespType :: Q Type+    -- ^ A @'Q' 'Type'@ representing the type to use for the return vale of a+    -- Servant API.  For instance, HTML files will use something like+    -- @[t|'Html'|]@, while JavascriptFiles will use something like+    -- @[t|'ByteString'|]@.+  , mimeTypeInfoToExpression :: ByteString -> Q Exp+    -- ^ A function that turns a 'ByteString' into an 'Exp'.  For an example,+    -- look at 'htmlToExp' and 'byteStringtoExp'.+  }++byteStringToExp :: ByteString -> Q Exp+byteStringToExp byteString =+  let word8List = ByteString.unpack byteString+  in [e|pure $ ByteString.pack word8List|]++htmlToExp :: ByteString -> Q Exp+htmlToExp byteString =+  let fileContentsString = unpack $ decodeUtf8With lenientDecode byteString+  in [e|pure $ (preEscapedToHtml :: String -> Html) fileContentsString|]++-- | A mapping from an extension like @html@ or @js@ to a 'MimeTypeInfo' for+-- that extension.+extensionMimeTypeMap :: Map String MimeTypeInfo+extensionMimeTypeMap =+  [ ("css", MimeTypeInfo [t|CSS|] [t|ByteString|] byteStringToExp)+  , ("gif", MimeTypeInfo [t|GIF|] [t|ByteString|] byteStringToExp)+  , ("htm", MimeTypeInfo [t|HTML|] [t|Html|] htmlToExp)+  , ("html", MimeTypeInfo [t|HTML|] [t|Html|] htmlToExp)+  , ("jpeg", MimeTypeInfo [t|JPEG|] [t|ByteString|] byteStringToExp)+  , ("jpg", MimeTypeInfo [t|JPEG|] [t|ByteString|] byteStringToExp)+  , ("js", MimeTypeInfo [t|JS|] [t|ByteString|] byteStringToExp)+  , ("png", MimeTypeInfo [t|PNG|] [t|ByteString|] byteStringToExp)+  , ("txt", MimeTypeInfo [t|TXT|] [t|ByteString|] byteStringToExp)+  ]++-- | Just like 'extensionToMimeTypeInfo', but throw an error using 'fail' if+-- the extension for the given 'FilePath' is not found.+extensionToMimeTypeInfoEx :: FilePath -> Q MimeTypeInfo+extensionToMimeTypeInfoEx file =+  case extensionToMimeTypeInfo file of+    Just mimeTypeInfo -> pure mimeTypeInfo+    Nothing ->+      let extension = getExtension file+      in fail $+        "Unknown extension type \"" <> extension <> "\".  Please report as bug."++-- | Lookup the 'MimeTypeInfo' for a given 'FilePath' (that has an extension+-- like @.html@ or @.js@).  Returns 'Nothing' if the 'MimeTypeInfo' for the+-- given extension is not found.+extensionToMimeTypeInfo :: FilePath -> Maybe MimeTypeInfo+extensionToMimeTypeInfo file =+  Map.lookup+    (removeLeadingPeriod $ takeExtension file)+    extensionMimeTypeMap++-------------------------+-- Supported MimeTypes --+-------------------------++-- CSS++data CSS deriving Typeable++-- | @text/css@+instance Accept CSS where+  contentType :: Proxy CSS -> MediaType+  contentType _ = "text" // "css"++instance MimeRender CSS ByteString where+  mimeRender :: Proxy CSS -> ByteString -> LByteString.ByteString+  mimeRender _ = LByteString.fromStrict++-- GIF++data GIF deriving Typeable++-- | @image/gif@+instance Accept GIF where+  contentType :: Proxy GIF -> MediaType+  contentType _ = "image" // "gif"++instance MimeRender GIF ByteString where+  mimeRender :: Proxy GIF -> ByteString -> LByteString.ByteString+  mimeRender _ = LByteString.fromStrict++-- JPEG++data JPEG deriving Typeable++-- | @image/jpeg@+instance Accept JPEG where+  contentType :: Proxy JPEG -> MediaType+  contentType _ = "image" // "jpeg"++instance MimeRender JPEG ByteString where+  mimeRender :: Proxy JPEG -> ByteString -> LByteString.ByteString+  mimeRender _ = LByteString.fromStrict++-- JS++data JS deriving Typeable++-- | @application/javascript@+instance Accept JS where+  contentType :: Proxy JS -> MediaType+  contentType _ = "application" // "javascript"++instance MimeRender JS ByteString where+  mimeRender :: Proxy JS -> ByteString -> LByteString.ByteString+  mimeRender _ = LByteString.fromStrict++-- PNG++data PNG deriving Typeable++-- | @image/png@+instance Accept PNG where+  contentType :: Proxy PNG -> MediaType+  contentType _ = "image" // "png"++instance MimeRender PNG ByteString where+  mimeRender :: Proxy PNG -> ByteString -> LByteString.ByteString+  mimeRender _ = LByteString.fromStrict++-- SVG++data SVG deriving Typeable++-- | @image/svg@+instance Accept SVG where+  contentType :: Proxy SVG -> MediaType+  contentType _ = "image" // "svg"++instance MimeRender SVG ByteString where+  mimeRender :: Proxy SVG -> ByteString -> LByteString.ByteString+  mimeRender _ = LByteString.fromStrict++-- TXT++data TXT deriving Typeable++-- | @text/plain@+instance Accept TXT where+  contentType :: Proxy TXT -> MediaType+  contentType _ = "text" // "plain"++instance MimeRender TXT ByteString where+  mimeRender :: Proxy TXT -> ByteString -> LByteString.ByteString+  mimeRender _ = LByteString.fromStrict

@@ -0,0 +1,120 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Servant.Static.TH.Internal.Server where++import Data.Foldable (foldl1)+import Data.List.NonEmpty (NonEmpty)+import Language.Haskell.TH+       (Dec, Exp, Q, appE, clause, conT, funD, mkName, normalB,+        runIO, sigD)+import Language.Haskell.TH.Syntax (addDependentFile)+import Servant.API ((:<|>)((:<|>)))+import Servant.Server (ServerT)++import Servant.Static.TH.Internal.FileTree+import Servant.Static.TH.Internal.Mime++combineWithExp :: Q Exp -> Q Exp -> Q Exp -> Q Exp+combineWithExp combiningExp = appE . appE combiningExp++combineWithServantOr :: NonEmpty (Q Exp) -> Q Exp+combineWithServantOr = foldl1 $ combineWithExp [e|(:<|>)|]++fileTreeToServer :: FileTree -> Q Exp+fileTreeToServer (FileTreeFile filePath fileContents) = do+  addDependentFile filePath+  MimeTypeInfo _ _ contentToExp <- extensionToMimeTypeInfoEx filePath+  contentToExp fileContents+fileTreeToServer (FileTreeDir _ fileTrees) =+  combineWithServantOr $ fmap fileTreeToServer fileTrees++-- | Take a template directory argument as a 'FilePath' and create a 'ServerT'+-- function that serves the files under the directory.  Empty directories will+-- be ignored.+--+-- Note that the file contents will be embedded in the function.  They will+-- not be served dynamically at runtime.  This makes it easy to create a+-- Haskell binary for a website with all static files completely baked-in.+--+-- For example, assume the following directory structure and file contents:+--+-- @+--   $ tree dir/+--   dir/+--   ├── js+--   │   └── test.js+--   └── index.html+-- @+--+-- @+--   $ cat dir/index.html+--   \<p\>Hello World\</p\>+--   $ cat dir\/js\/test.js+--   console.log(\"hello world\");+-- @+--+-- 'createServerExp' is used like the following:+--+-- @+--   \{\-\# LANGUAGE DataKinds \#\-\}+--   \{\-\# LANGUAGE TemplateHaskell \#\-\}+--+--   type FrontEndAPI = $('Servant.Static.TH.Internal.API.createApiType' \"dir\")+--+--   frontEndServer :: 'Applicative' m => 'ServerT' FrontEndAPI m+--   frontEndServer = $('createServerExp' \"dir\")+-- @+--+-- At compile time, this expands to something like the following.  This has+-- been slightly simplified to make it easier to understand:+--+-- @+--   type FrontEndAPI =+--          \"js\" 'Servant.API.:>' \"test.js\" 'Servant.API.:>' 'Servant.API.Get' \'['JS'] 'Data.ByteString.ByteString'+--     ':<|>' \"index.html\" 'Servant.API.:>' 'Servant.API.Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html'+--+--   frontEndServer :: 'Applicative' m => 'ServerT' FrontEndAPI m+--   frontEndServer =+--          'pure' "console.log(\\"hello world\\");"+--     ':<|>' 'pure' "\<p\>Hello World\</p\>"+-- @+createServerExp+  :: FilePath+  -> Q Exp+createServerExp templateDir = do+  fileTree <- runIO $ getFileTreeIgnoreEmpty templateDir+  combineWithServantOr $ fmap fileTreeToServer fileTree++-- | This is similar to 'createServerExp', but it creates the whole function+-- declaration.+--+-- Given the following code:+--+-- @+--   \{\-\# LANGUAGE DataKinds \#\-\}+--   \{\-\# LANGUAGE TemplateHaskell \#\-\}+--+--   $('createServerDec' \"FrontAPI\" \"frontServer\" \"dir\")+-- @+--+-- You can think of it as expanding to the following:+--+-- @+--   frontServer :: 'Applicative' m => 'ServerT' FrontAPI m+--   frontServer = $('createServerExp' \"dir\")+-- @+createServerDec+  :: String   -- ^ name of the api type synonym+  -> String   -- ^ name of the server function+  -> FilePath -- ^ directory name to read files from+  -> Q [Dec]+createServerDec apiName serverName templateDir =+  let funcName = mkName serverName+      sigTypeQ =+          [t|forall m. Applicative m => ServerT $(conT (mkName apiName)) m|]+      signatureQ = sigD funcName sigTypeQ+      clauses = [clause [] (normalB (createServerExp templateDir)) []]+      funcQ = funD funcName clauses+  in sequence [signatureQ, funcQ]

@@ -0,0 +1,52 @@+{- |+Module      :  Servant.Static.TH.Internal.Util++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++Utilities functions for use in this package.+-}++module Servant.Static.TH.Internal.Util where++import System.FilePath (takeExtension)++-- | Remove a leading period from a 'String'.+--+-- >>> removeLeadingPeriod ".jpg"+-- "jpg"+--+-- Just return the 'String' if it doesn't start with a period:+--+-- >>> removeLeadingPeriod "hello"+-- "hello"+--+-- Return an empty string if the only character in the string is a period:+--+-- >>> removeLeadingPeriod "."+-- ""+--+-- Remove at most one period:+--+-- >>> removeLeadingPeriod "..bye"+-- ".bye"+removeLeadingPeriod :: String -> String+removeLeadingPeriod ('.':chars) = chars+removeLeadingPeriod string = string++-- | Return an extension for a 'FilePath'.  Just like 'takeExtension', but+-- doesn't return the leading period.+--+-- >>> getExtension "/some/file.html"+-- "html"+--+-- Empty string is returned for files with no extension:+--+-- >>> getExtension "file"+-- ""+getExtension :: FilePath -> FilePath+getExtension = removeLeadingPeriod . takeExtension

@@ -0,0 +1,40 @@++module Main (main) where++import Prelude++import Data.Monoid ((<>))+import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doDocTest++doDocTest :: [String] -> IO ()+doDocTest options = doctest $ options <> ghcExtensions++ghcExtensions :: [String]+ghcExtensions =+    [+    --   "-XConstraintKinds"+    -- , "-XDataKinds"+      "-XDeriveDataTypeable"+    , "-XDeriveGeneric"+    -- , "-XEmptyDataDecls"+    , "-XFlexibleContexts"+    -- , "-XFlexibleInstances"+    -- , "-XGADTs"+    -- , "-XGeneralizedNewtypeDeriving"+    -- , "-XInstanceSigs"+    -- , "-XMultiParamTypeClasses"+    -- , "-XNoImplicitPrelude"+    , "-XOverloadedStrings"+    -- , "-XPolyKinds"+    -- , "-XRankNTypes"+    -- , "-XRecordWildCards"+    , "-XScopedTypeVariables"+    -- , "-XStandaloneDeriving"+    -- , "-XTupleSections"+    -- , "-XTypeFamilies"+    -- , "-XTypeOperators"+    ]

@@ -0,0 +1,21 @@+module Main where++import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import Test.Tasty (TestTree, defaultMain, testGroup)++import Spec.ApiSpec (apiTests)+import Spec.HelperFuncSpec (helperFuncTests)+import Spec.ServerSpec (serverTestsIO)+import Spec.TestDirLocation (testDir)++main :: IO ()+main = do+  createDirectoryIfMissing False (testDir </> "empty-dir")+  tests <- testsIO+  defaultMain tests++testsIO :: IO TestTree+testsIO = do+  serverTests <- serverTestsIO+  pure $ testGroup "tests" [helperFuncTests, apiTests, serverTests]

@@ -0,0 +1,41 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Spec.ApiSpec where++import Data.ByteString (ByteString)+import Data.Type.Equality ((:~:)(Refl))+import Servant.HTML.Blaze (HTML)+import Servant.API ((:<|>), (:>), Get)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)+import Text.Blaze.Html (Html)++import Servant.Static.TH.Internal (JS, createApiDec)++import Spec.TestDirLocation (testDir)++$(createApiDec "FrontEndApi" testDir)++type ExpectedFrontEndApi =+    (+      "dir" :>+        (+          ( "inner-file.html" :> Get '[HTML] Html )+        :<|>+          ( "test.js" :> Get '[JS] ByteString )+        )+    )+  :<|>+    ( "hello.html" :> Get '[HTML] Html )++checkFrontEndApiType :: ExpectedFrontEndApi :~: FrontEndApi+checkFrontEndApiType = Refl++createdCorrectlyTest :: TestTree+createdCorrectlyTest =+  testCase "created correctly" $ checkFrontEndApiType @?= Refl++apiTests :: TestTree+apiTests = testGroup "api" [createdCorrectlyTest]

@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Spec.HelperFuncSpec where++import System.FilePath ((</>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)++import Servant.Static.TH.Internal+       (FileTree(..), FileType(..), getFileTreeIgnoreEmpty, getFileType)++import Spec.TastyHelpers ((@!), anyException)+import Spec.TestDirLocation (testDir)++helperFuncTests :: TestTree+helperFuncTests =+  testGroup+    "helper functions"+    [ getFileTypeTests+    , getFileTreeIgnoreEmptyTests+    ]++getFileTypeTests :: TestTree+getFileTypeTests =+  testGroup+    "getFileType"+    [ testCase "correctly checks files" $ do+        let helloHtmlPath = testDir </> "hello.html"+        fileType <- getFileType helloHtmlPath+        FileTypeFile helloHtmlPath @?= fileType+    , testCase "correctly checks directories" $ do+        fileType <- getFileType testDir+        FileTypeDir testDir @?= fileType+    , testCase "fails for anything else" $+        getFileType "somelongfilethatdoesntexist" @! anyException+    ]++getFileTreeIgnoreEmptyTests :: TestTree+getFileTreeIgnoreEmptyTests =+  testGroup+    "getFileTreeIgnoreEmpty"+    [ testCase "correctly gets file tree" $ do+        actualFileTree <- getFileTreeIgnoreEmpty testDir+        let expectedFileTree =+              [ FileTreeDir+                  (testDir </> "dir")+                  [ FileTreeFile+                      (testDir </> "dir" </> "inner-file.html")+                      "Inner File\n"+                  , FileTreeFile+                      (testDir </> "dir" </> "test.js")+                      "console.log(\"hello world\");\n"+                  ]+              , FileTreeFile+                  (testDir </> "hello.html")+                  "Hello World\n"+              ]+        actualFileTree @?= expectedFileTree+    , testCase "fails on empty directory" $+        getFileTreeIgnoreEmpty (testDir </> "empty-dir") @! anyException+    ]

@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Spec.ServerSpec where++import Data.Proxy (Proxy(Proxy))+import Network.Wai (Application)+import Servant.Server (serve)+import Test.Hspec.Wai+       (ResponseMatcher(matchHeaders), (<:>), get, shouldRespondWith,+        with)+import Test.Tasty (TestTree)+import Test.Tasty.Hspec (testSpec, it)++import Servant.Static.TH (createApiAndServerDecs)++import Spec.TestDirLocation (testDir)++$(createApiAndServerDecs "FrontEndApi" "testDirServer" testDir)++app :: Application+app = serve (Proxy @FrontEndApi) testDirServer++serverTestsIO :: IO TestTree+serverTestsIO =+  testSpec "server" $+    with (pure app) $ do+      it "hello.html responds correctly and is html" $+        let expectedResp =+              "Hello World\n"+                { matchHeaders = ["Content-Type" <:> "text/html;charset=utf-8"]+                }+        in get "hello.html" `shouldRespondWith` expectedResp+      it "dir/inner-file.html responds correctly" $+        get "dir/inner-file.html" `shouldRespondWith` "Inner File\n"+      it "non existing file gives 404" $+        get "somefilethatdoesntexist.html" `shouldRespondWith` 404

@@ -0,0 +1,32 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Spec.TastyHelpers where++import Control.Exception (Exception, SomeException, catch)+import Data.Typeable (Typeable)+import Test.Tasty.HUnit (assertFailure)++type Selector e = e -> Bool++anyException :: Selector SomeException+anyException _ = True++-- | Extra HUnit assertion to make sure an expression throws an exception.+assertThrows+  :: forall e a.+     (Exception e, Typeable e)+  => IO a -> Selector e -> IO ()+assertThrows ioAction selector = do+  didCatch <- catch (ioAction *> pure False) (pure . selector)+  case didCatch of+    False ->+      assertFailure "expecting an exception, but no exception occurred"+    True -> pure ()++-- | Infix version of 'assertThrows'.+(@!)+  :: (Exception e, Typeable e)+  => IO a -> Selector e -> IO ()+(@!) = assertThrows++infix 1 @!

@@ -0,0 +1,7 @@++module Spec.TestDirLocation where++import System.FilePath ((</>))++testDir :: FilePath+testDir = "test" </> "test-dir"