diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Changelog +## v1.0.0.0 + +- Serve any files called `index.html` on the root `/` as well as the path + `/index.html`. This makes servant-static-th operate similar to how web + servers like Apache or nginx work. + [#19](https://github.com/cdepillabout/servant-static-th/pull/19). + Thanks [@vendamere](https://github.com/vendamere)! + ## v0.2.4.0 - Add a mime type for .wasm files diff --git a/servant-static-th.cabal b/servant-static-th.cabal --- a/servant-static-th.cabal +++ b/servant-static-th.cabal @@ -1,5 +1,5 @@ name: servant-static-th -version: 0.2.4.0 +version: 1.0.0.0 synopsis: Embed a directory of static files in your Servant server description: Please see . homepage: https://github.com/cdepillabout/servant-static-th diff --git a/src/Servant/Static/TH.hs b/src/Servant/Static/TH.hs --- a/src/Servant/Static/TH.hs +++ b/src/Servant/Static/TH.hs @@ -22,14 +22,17 @@ dir\/ ├── js │   └── test.js - └── hello.html + ├── hello.html + └── index.html @ -Here's the contents of @\"hello.html\"@ and @\"js\/test.js\"@: +Here's the contents of @\"hello.html\"@, @\"index.html\"@, and @\"js\/test.js\"@: @ - $ cat dir\/index.html + $ cat dir\/hello.html \Hello World\<\/p\> + $ cat dir\/index.html + \This is the index\<\/p\> $ cat dir\/js\/test.js console.log(\"hello world\"); @ @@ -60,19 +63,30 @@ @ type FrontEndAPI = - \"js\" 'Servant.API.:>' \"test.js\" 'Servant.API.:>' 'Servant.API.Get' \'['JS'] 'Data.ByteString.ByteString' + -- index.html is served on the root, as well as from the path \"/index.html\". + 'Servant.API.Get' \'['HTML'] 'Html' ':<|>' \"index.html\" 'Servant.API.:>' 'Servant.API.Get' \'['HTML'] 'Html' + -- hello.html is served from the path \"/hello.html\". + ':<|>' \"hello.html\" 'Servant.API.:>' 'Servant.API.Get' \'['HTML'] 'Html' + -- js/test.js is served from the path \"/js/test.js\". + ':<|>' \"js\" 'Servant.API.:>' \"test.js\" 'Servant.API.:>' 'Servant.API.Get' \'['JS'] 'Data.ByteString.ByteString' frontEndServer :: 'Applicative' m => 'Servant.Server.ServerT' FrontEndAPI m frontEndServer = - 'pure' "console.log(\\"hello world\\");" + 'pure' "\This is the index\<\/p\>" + ':<|>' 'pure' "\This is the index\<\/p\>" ':<|>' 'pure' "\Hello World\<\/p\>" + ':<|>' 'pure' "console.log(\\"hello world\\");" @ If this WAI application is running, it is possible to use @curl@ to access the server: @ + $ curl localhost:8080\/ + \This is the index\<\/p\> + $ curl localhost:8080\/index.html + \This is the index\<\/p\> $ curl localhost:8080\/hello.html \Hello World\<\/p\> $ curl localhost:8080\/js\/test.js diff --git a/src/Servant/Static/TH/Internal/Api.hs b/src/Servant/Static/TH/Internal/Api.hs --- a/src/Servant/Static/TH/Internal/Api.hs +++ b/src/Servant/Static/TH/Internal/Api.hs @@ -21,8 +21,13 @@ fileTreeToApiType (FileTreeFile filePath _) = do addDependentFile filePath MimeTypeInfo mimeT respT _ <- extensionToMimeTypeInfoEx filePath - let fileNameLitT = litT $ strTyLit $ takeFileName filePath - [t|$(fileNameLitT) :> Get '[$(mimeT)] $(respT)|] + let fileName = takeFileName filePath + let fileNameLitT = litT $ strTyLit fileName + case fileName of + -- We special-case files called "index.html" and generate a type that serves on both + -- the root, and under the path "index.html". + "index.html" -> [t|Get '[$(mimeT)] $(respT) :<|> $(fileNameLitT) :> Get '[$(mimeT)] $(respT)|] + _ -> [t|$(fileNameLitT) :> Get '[$(mimeT)] $(respT)|] fileTreeToApiType (FileTreeDir filePath fileTrees) = let fileNameLitT = litT $ strTyLit $ takeFileName filePath in [t|$(fileNameLitT) :> $(combineWithServantOrT nonEmptyApiTypesQ)|] @@ -40,7 +45,7 @@ -- | Take a template directory argument as a 'FilePath' and create a Servant -- type representing the files in the directory. Empty directories will be --- ignored. +-- ignored. @index.html@ files will also be served at the root. -- -- For example, assume the following directory structure: -- @@ -66,6 +71,7 @@ -- @ -- type FrontEndAPI = -- \"js\" ':>' \"test.js\" ':>' 'Get' \'['JS'] 'Data.ByteString.ByteString' +-- ':<|>' 'Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html' -- ':<|>' \"index.html\" ':>' 'Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html' -- @ createApiType diff --git a/src/Servant/Static/TH/Internal/Server.hs b/src/Servant/Static/TH/Internal/Server.hs --- a/src/Servant/Static/TH/Internal/Server.hs +++ b/src/Servant/Static/TH/Internal/Server.hs @@ -5,34 +5,47 @@ module Servant.Static.TH.Internal.Server where import Data.Foldable (foldl1) -import Data.List.NonEmpty (NonEmpty) +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 System.FilePath (takeFileName) + 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|(:<|>)|] +combineWithServantOr :: Q Exp -> Q Exp -> Q Exp +combineWithServantOr = combineWithExp [e|(:<|>)|] +combineMultiWithServantOr :: NonEmpty (Q Exp) -> Q Exp +combineMultiWithServantOr = foldl1 combineWithServantOr + fileTreeToServer :: FileTree -> Q Exp fileTreeToServer (FileTreeFile filePath fileContents) = do addDependentFile filePath MimeTypeInfo _ _ contentToExp <- extensionToMimeTypeInfoEx filePath - contentToExp fileContents + let fileName = takeFileName filePath + case fileName of + "index.html" -> + combineWithServantOr + -- content to serve on the root + (contentToExp fileContents) + -- content to serve on the path "index.html" + (contentToExp fileContents) + _ -> contentToExp fileContents fileTreeToServer (FileTreeDir _ fileTrees) = - combineWithServantOr $ fmap fileTreeToServer fileTrees + combineMultiWithServantOr $ 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. +-- be ignored. 'index.html' files will also be served at the root. -- -- 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 @@ -73,6 +86,7 @@ -- @ -- type FrontEndAPI = -- \"js\" 'Servant.API.:>' \"test.js\" 'Servant.API.:>' 'Servant.API.Get' \'['JS'] 'Data.ByteString.ByteString' +-- ':<|>' 'Servant.API.Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html' -- ':<|>' \"index.html\" 'Servant.API.:>' 'Servant.API.Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html' -- -- frontEndServer :: 'Applicative' m => 'ServerT' FrontEndAPI m @@ -85,7 +99,7 @@ -> Q Exp createServerExp templateDir = do fileTree <- runIO $ getFileTreeIgnoreEmpty templateDir - combineWithServantOr $ fmap fileTreeToServer fileTree + combineMultiWithServantOr $ fmap fileTreeToServer fileTree -- | This is similar to 'createServerExp', but it creates the whole function -- declaration. diff --git a/test/Spec/ApiSpec.hs b/test/Spec/ApiSpec.hs --- a/test/Spec/ApiSpec.hs +++ b/test/Spec/ApiSpec.hs @@ -19,7 +19,7 @@ $(createApiDec "FrontEndApi" testDir) type ExpectedFrontEndApi = - ( + (( "dir" :> ( ( "inner-file.html" :> Get '[HTML] Html ) @@ -28,7 +28,9 @@ ) ) :<|> - ( "hello.html" :> Get '[HTML] Html ) + ( "hello.html" :> Get '[HTML] Html )) + :<|> + ( Get '[HTML] Html :<|> "index.html" :> Get '[HTML] Html ) checkFrontEndApiType :: ExpectedFrontEndApi :~: FrontEndApi checkFrontEndApiType = Refl diff --git a/test/Spec/HelperFuncSpec.hs b/test/Spec/HelperFuncSpec.hs --- a/test/Spec/HelperFuncSpec.hs +++ b/test/Spec/HelperFuncSpec.hs @@ -58,6 +58,9 @@ , FileTreeFile (testDir "hello.html") "Hello World\n" + , FileTreeFile + (testDir "index.html") + "Index\n" ] actualFileTree @?= expectedFileTree , testCase "fails on empty directory" $ diff --git a/test/Spec/ServerSpec.hs b/test/Spec/ServerSpec.hs --- a/test/Spec/ServerSpec.hs +++ b/test/Spec/ServerSpec.hs @@ -33,6 +33,18 @@ { matchHeaders = ["Content-Type" <:> "text/html;charset=utf-8"] } in get "hello.html" `shouldRespondWith` expectedResp + it "index.html responds correctly and is html" $ + let expectedResp = + "Index\n" + { matchHeaders = ["Content-Type" <:> "text/html;charset=utf-8"] + } + in get "index.html" `shouldRespondWith` expectedResp + it "root responds with index.html contents" $ + let expectedResp = + "Index\n" + { matchHeaders = ["Content-Type" <:> "text/html;charset=utf-8"] + } + in get "" `shouldRespondWith` expectedResp it "dir/inner-file.html responds correctly" $ get "dir/inner-file.html" `shouldRespondWith` "Inner File\n" it "non existing file gives 404" $