diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. 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/example/Example.hs b/example/Example.hs new file mode 100644 --- /dev/null +++ b/example/Example.hs @@ -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 diff --git a/servant-static-th.cabal b/servant-static-th.cabal new file mode 100644 --- /dev/null +++ b/servant-static-th.cabal @@ -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 . +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 diff --git a/src/Servant/Static/TH.hs b/src/Servant/Static/TH.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Static/TH.hs @@ -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 + \Hello World\ + $ 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' "\Hello World\" +@ + +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/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 + -- or + -- . + , 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 diff --git a/src/Servant/Static/TH/Internal.hs b/src/Servant/Static/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Static/TH/Internal.hs @@ -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 diff --git a/src/Servant/Static/TH/Internal/Api.hs b/src/Servant/Static/TH/Internal/Api.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Static/TH/Internal/Api.hs @@ -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) diff --git a/src/Servant/Static/TH/Internal/FileTree.hs b/src/Servant/Static/TH/Internal/FileTree.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Static/TH/Internal/FileTree.hs @@ -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 diff --git a/src/Servant/Static/TH/Internal/Mime.hs b/src/Servant/Static/TH/Internal/Mime.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Static/TH/Internal/Mime.hs @@ -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 diff --git a/src/Servant/Static/TH/Internal/Server.hs b/src/Servant/Static/TH/Internal/Server.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Static/TH/Internal/Server.hs @@ -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 +-- \Hello World\ +-- $ 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' "\Hello World\" +-- @ +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] diff --git a/src/Servant/Static/TH/Internal/Util.hs b/src/Servant/Static/TH/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Static/TH/Internal/Util.hs @@ -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 diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -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" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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] diff --git a/test/Spec/ApiSpec.hs b/test/Spec/ApiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ApiSpec.hs @@ -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] diff --git a/test/Spec/HelperFuncSpec.hs b/test/Spec/HelperFuncSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spec/HelperFuncSpec.hs @@ -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 + ] diff --git a/test/Spec/ServerSpec.hs b/test/Spec/ServerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ServerSpec.hs @@ -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 diff --git a/test/Spec/TastyHelpers.hs b/test/Spec/TastyHelpers.hs new file mode 100644 --- /dev/null +++ b/test/Spec/TastyHelpers.hs @@ -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 @! diff --git a/test/Spec/TestDirLocation.hs b/test/Spec/TestDirLocation.hs new file mode 100644 --- /dev/null +++ b/test/Spec/TestDirLocation.hs @@ -0,0 +1,7 @@ + +module Spec.TestDirLocation where + +import System.FilePath (()) + +testDir :: FilePath +testDir = "test" "test-dir"