diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Zalora South East Asia Pte Ltd + +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 Zalora South East Asia Pte Ltd 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/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/greet.hs b/example/greet.hs new file mode 100644 --- /dev/null +++ b/example/greet.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} + +import Data.Aeson +import Data.Monoid +import Data.Proxy +import Data.Text +import GHC.Generics +import Network.Wai +import Network.Wai.Handler.Warp + +import Servant + +-- * Example + +-- | A greet message data type +newtype Greet = Greet { msg :: Text } + deriving (Generic, Show) + +instance FromJSON Greet +instance ToJSON Greet + +-- API specification +type TestApi = + -- GET /hello/:name?capital={true, false} returns a Greet as JSON + "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet + + -- POST /greet with a Greet as JSON in the request body, + -- returns a Greet as JSON + :<|> "greet" :> ReqBody Greet :> Post Greet + + -- DELETE /greet/:greetid + :<|> "greet" :> Capture "greetid" Text :> Delete + +testApi :: Proxy TestApi +testApi = Proxy + +-- Server-side handlers. +-- +-- There's one handler per endpoint, which, just like in the type +-- that represents the API, are glued together using :<|>. +-- +-- Each handler runs in the 'EitherT (Int, String) IO' monad. +server :: Server TestApi +server = helloH :<|> postGreetH :<|> deleteGreetH + + where helloH name Nothing = helloH name (Just False) + helloH name (Just False) = return . Greet $ "Hello, " <> name + helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name + + postGreetH greet = return greet + + deleteGreetH _ = return () + +-- Turn the server into a WAI app. 'serve' is provided by servant, +-- more precisely by the Servant.Server module. +test :: Application +test = serve testApi server + +-- Run the server. +-- +-- 'run' comes from Network.Wai.Handler.Warp +runTestServer :: Port -> IO () +runTestServer port = run port test + +-- Put this all to work! +main :: IO () +main = runTestServer 8001 diff --git a/servant-server.cabal b/servant-server.cabal new file mode 100644 --- /dev/null +++ b/servant-server.cabal @@ -0,0 +1,96 @@ +name: servant-server +version: 0.2.1 +synopsis: A family of combinators for defining webservices APIs and serving them +description: + A family of combinators for defining webservices APIs and serving them + . + You can learn about the basics in guide. + . + 's a runnable example, with comments, that defines a dummy API and + implements a webserver that serves this API, using this package. +homepage: http://haskell-servant.github.io/ +Bug-reports: http://github.com/haskell-servant/servant-server/issues +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni +maintainer: alpmestan@gmail.com +copyright: 2014 Zalora South East Asia Pte Ltd +category: Web +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >= 7.8 +source-repository head + type: git + location: http://github.com/haskell-servant/servant-server.git + +library + exposed-modules: + Servant + Servant.Server + Servant.Utils.StaticFiles + other-modules: Servant.Server.Internal + build-depends: + base >=4.7 && <5 + , aeson + , attoparsec + , bytestring + , either + , http-types + , network-uri >= 2.6 + , safe + , servant >= 0.2 + , split + , string-conversions + , system-filepath + , text + , transformers + , wai + , wai-app-static + , warp + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable greet + main-is: greet.hs + hs-source-dirs: example + ghc-options: -Wall + default-language: Haskell2010 + build-depends: + base + , servant + , servant-server + , aeson + , warp + , wai + , text + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: + -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base == 4.* + , aeson + , bytestring + , directory + , either + , exceptions + , hspec == 2.* + , hspec-wai + , http-types + , network >= 2.6 + , QuickCheck + , parsec + , servant + , servant-server + , string-conversions + , temporary + , text + , transformers + , wai + , wai-extra + , warp diff --git a/src/Servant.hs b/src/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Servant.hs @@ -0,0 +1,24 @@ +module Servant ( + -- | This module and its submodules can be used to define servant APIs. Note + -- that these API definitions don't directly implement a server (or anything + -- else). + module Servant.API, + -- | For implementing servers for servant APIs. + module Servant.Server, + -- | Using your types in request paths and query string parameters + module Servant.Common.Text, + -- | Utilities on top of the servant core + module Servant.QQ, + module Servant.Utils.Links, + module Servant.Utils.StaticFiles, + -- | Useful re-exports + Proxy(..), + ) where + +import Data.Proxy +import Servant.API +import Servant.Common.Text +import Servant.Server +import Servant.QQ +import Servant.Utils.Links +import Servant.Utils.StaticFiles diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module lets you implement 'Server's for defined APIs. You'll +-- most likely just need 'serve'. +module Servant.Server + ( -- * Implementing an API + serve + + , -- * Handlers for all standard combinators + HasServer(..) + ) where + +import Data.Proxy +import Network.Wai +import Servant.Server.Internal + +-- * Implementing Servers + +-- | 'serve' allows you to implement an API and produce a wai 'Application'. +-- +-- Example: +-- +-- > type MyApi = "books" :> Get [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > +-- > server :: Server MyApi +-- > server = listAllBooks :<|> postBook +-- > where listAllBooks = ... +-- > postBook book = ... +-- > +-- > app :: Application +-- > app = serve myApi server +-- > +-- > main :: IO () +-- > main = Network.Wai.Handler.Warp.run 8080 app +serve :: HasServer layout => Proxy layout -> Server layout -> Application +serve p server = toApplication (route p server) + diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.Server.Internal where + +import Control.Applicative +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Proxy +import Data.String +import Data.String.Conversions +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import GHC.TypeLits +import Network.HTTP.Types hiding (Header) +import Network.Wai +import Servant.API +import Servant.Common.Text + +toApplication :: RoutingApplication -> Application +toApplication ra request respond = do + ra request (routingRespond . routeResult) + where + routingRespond :: Either RouteMismatch Response -> IO ResponseReceived + routingRespond (Left NotFound) = + respond $ responseLBS notFound404 [] "not found" + routingRespond (Left WrongMethod) = + respond $ responseLBS methodNotAllowed405 [] "method not allowed" + routingRespond (Left InvalidBody) = + respond $ responseLBS badRequest400 [] "Invalid JSON in request body" + routingRespond (Right response) = + respond response + +-- * Route mismatch +data RouteMismatch = + NotFound -- ^ the usual "not found" error + | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error + | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error + deriving (Eq, Show) + +-- | +-- @ +-- > mempty = NotFound +-- > +-- > NotFound `mappend` x = x +-- > WrongMethod `mappend` InvalidBody = InvalidBody +-- > WrongMethod `mappend` _ = WrongMethod +-- > InvalidBody `mappend` _ = InvalidBody +-- @ +instance Monoid RouteMismatch where + mempty = NotFound + + NotFound `mappend` x = x + WrongMethod `mappend` InvalidBody = InvalidBody + WrongMethod `mappend` _ = WrongMethod + InvalidBody `mappend` _ = InvalidBody + +-- | A wrapper around @'Either' 'RouteMismatch' a@. +newtype RouteResult a = + RR { routeResult :: Either RouteMismatch a } + deriving (Eq, Show) + +failWith :: RouteMismatch -> RouteResult a +failWith = RR . Left + +succeedWith :: a -> RouteResult a +succeedWith = RR . Right + +isMismatch :: RouteResult a -> Bool +isMismatch (RR (Left _)) = True +isMismatch _ = False + +-- | If we get a `Right`, it has precedence over everything else. +-- +-- This in particular means that if we could get several 'Right's, +-- only the first we encounter would be taken into account. +instance Monoid (RouteResult a) where + mempty = RR $ Left mempty + + RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y) + RR (Left _) `mappend` RR (Right y) = RR $ Right y + r `mappend` _ = r + +type RoutingApplication = + Request -- ^ the request, the field 'pathInfo' may be modified by url routing + -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived + +class HasServer layout where + type Server layout :: * + route :: Proxy layout -> Server layout -> RoutingApplication + +-- * Instances + +-- | A server for @a ':<|>' b@ first tries to match the request again the route +-- represented by @a@ and if it fails tries @b@. You must provide a request +-- handler for each route. +-- +-- > type MyApi = "books" :> Get [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > +-- > server :: Server MyApi +-- > server = listAllBooks :<|> postBook +-- > where listAllBooks = ... +-- > postBook book = ... +instance (HasServer a, HasServer b) => HasServer (a :<|> b) where + type Server (a :<|> b) = Server a :<|> Server b + route Proxy (a :<|> b) request respond = + route pa a request $ \ mResponse -> + if isMismatch mResponse + then route pb b request $ \mResponse' -> respond (mResponse <> mResponse') + else respond mResponse + + where pa = Proxy :: Proxy a + pb = Proxy :: Proxy b + +captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a +captured _ = fromText + +-- | If you use 'Capture' in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of the type specified by the 'Capture'. +-- This lets servant worry about getting it from the URL and turning +-- it into a value of the type you specify. +-- +-- You can control how it'll be converted from 'Text' to your type +-- by simply providing an instance of 'FromText' for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book +-- > +-- > server :: Server MyApi +-- > server = getBook +-- > where getBook :: Text -> EitherT (Int, String) IO Book +-- > getBook isbn = ... +instance (KnownSymbol capture, FromText a, HasServer sublayout) + => HasServer (Capture capture a :> sublayout) where + + type Server (Capture capture a :> sublayout) = + a -> Server sublayout + + route Proxy subserver request respond = case pathInfo request of + (first : rest) + -> case captured captureProxy first of + Nothing -> respond $ failWith NotFound + Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ + pathInfo = rest + } respond + _ -> respond $ failWith NotFound + + where captureProxy = Proxy :: Proxy (Capture capture a) + +-- | If you have a 'Delete' endpoint in your API, +-- the handler for this endpoint is meant to delete +-- a resource. +-- +-- The code of the handler will, just like +-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and +-- 'Servant.API.Put.Put', run in @EitherT (Int, String) IO ()@. +-- The 'Int' represents the status code and the 'String' a message +-- to be returned. You can use 'Control.Monad.Trans.Either.left' to +-- painlessly error out if the conditions for a successful deletion +-- are not met. +instance HasServer Delete where + type Server Delete = EitherT (Int, String) IO () + + route Proxy action request respond + | null (pathInfo request) && requestMethod request == methodDelete = do + e <- runEitherT action + respond $ succeedWith $ case e of + Right () -> + responseLBS status204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | null (pathInfo request) && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + +-- | When implementing the handler for a 'Get' endpoint, +-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' +-- and 'Servant.API.Put.Put', the handler code runs in the +-- @EitherT (Int, String) IO@ monad, where the 'Int' represents +-- the status code and the 'String' a message, returned in case of +-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' +-- to quickly fail if some conditions are not met. +-- +-- If successfully returning a value, we just require that its type has +-- a 'ToJSON' instance and servant takes care of encoding it for you, +-- yielding status code 200 along the way. +instance ToJSON result => HasServer (Get result) where + type Server (Get result) = EitherT (Int, String) IO result + route Proxy action request respond + | null (pathInfo request) && requestMethod request == methodGet = do + e <- runEitherT action + respond . succeedWith $ case e of + Right output -> + responseLBS ok200 [("Content-Type", "application/json")] (encode output) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | null (pathInfo request) && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + +-- | If you use 'Header' in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of the type specified by 'Header'. +-- This lets servant worry about extracting it from the request and turning +-- it into a value of the type you specify. +-- +-- All it asks is for a 'FromText' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer Text +-- > deriving (Eq, Show, FromText, ToText) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer +-- > +-- > server :: Server MyApi +-- > server = viewReferer +-- > where viewReferer :: Referer -> EitherT (Int, String) IO referer +-- > viewReferer referer = return referer +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (Header sym a :> sublayout) where + + type Server (Header sym a :> sublayout) = + Maybe a -> Server sublayout + + route Proxy subserver request respond = do + let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) + route (Proxy :: Proxy sublayout) (subserver mheader) request respond + + where str = fromString $ symbolVal (Proxy :: Proxy sym) + +-- | When implementing the handler for a 'Post' endpoint, +-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' +-- and 'Servant.API.Put.Put', the handler code runs in the +-- @EitherT (Int, String) IO@ monad, where the 'Int' represents +-- the status code and the 'String' a message, returned in case of +-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' +-- to quickly fail if some conditions are not met. +-- +-- If successfully returning a value, we just require that its type has +-- a 'ToJSON' instance and servant takes care of encoding it for you, +-- yielding status code 201 along the way. +instance ToJSON a => HasServer (Post a) where + type Server (Post a) = EitherT (Int, String) IO a + + route Proxy action request respond + | null (pathInfo request) && requestMethod request == methodPost = do + e <- runEitherT action + respond . succeedWith $ case e of + Right out -> + responseLBS status201 [("Content-Type", "application/json")] (encode out) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | null (pathInfo request) && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + +-- | When implementing the handler for a 'Put' endpoint, +-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' +-- and 'Servant.API.Post.Post', the handler code runs in the +-- @EitherT (Int, String) IO@ monad, where the 'Int' represents +-- the status code and the 'String' a message, returned in case of +-- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' +-- to quickly fail if some conditions are not met. +-- +-- If successfully returning a value, we just require that its type has +-- a 'ToJSON' instance and servant takes care of encoding it for you, +-- yielding status code 200 along the way. +instance ToJSON a => HasServer (Put a) where + type Server (Put a) = EitherT (Int, String) IO a + + route Proxy action request respond + | null (pathInfo request) && requestMethod request == methodPut = do + e <- runEitherT action + respond . succeedWith $ case e of + Right out -> + responseLBS ok200 [("Content-Type", "application/json")] (encode out) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | null (pathInfo request) && requestMethod request /= methodPut = + respond $ failWith WrongMethod + + | otherwise = respond $ failWith NotFound + +-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @'Maybe' 'Text'@. +-- +-- This lets servant worry about looking it up in the query string +-- and turning it into a value of the type you specify, enclosed +-- in 'Maybe', because it may not be there and servant would then +-- hand you 'Nothing'. +-- +-- You can control how it'll be converted from 'Text' to your type +-- by simply providing an instance of 'FromText' for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: Maybe Text -> EitherT (Int, String) IO [Book] +-- > getBooksBy Nothing = ...return all books... +-- > getBooksBy (Just author) = ...return books by the given author... +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (QueryParam sym a :> sublayout) where + + type Server (QueryParam sym a :> sublayout) = + Maybe a -> Server sublayout + + route Proxy subserver request respond = do + let querytext = parseQueryText $ rawQueryString request + param = + case lookup paramname querytext of + Nothing -> Nothing -- param absent from the query string + Just Nothing -> Nothing -- param present with no value -> Nothing + Just (Just v) -> fromText v -- if present, we try to convert to + -- the right type + + route (Proxy :: Proxy sublayout) (subserver param) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + +-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @['Text']@. +-- +-- This lets servant worry about looking up 0 or more values in the query string +-- associated to @authors@ and turning each of them into a value of +-- the type you specify. +-- +-- You can control how the individual values are converted from 'Text' to your type +-- by simply providing an instance of 'FromText' for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: [Text] -> EitherT (Int, String) IO [Book] +-- > getBooksBy authors = ...return all books by these authors... +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (QueryParams sym a :> sublayout) where + + type Server (QueryParams sym a :> sublayout) = + [a] -> Server sublayout + + route Proxy subserver request respond = do + let querytext = parseQueryText $ rawQueryString request + -- if sym is "foo", we look for query string parameters + -- named "foo" or "foo[]" and call fromText on the + -- corresponding values + parameters = filter looksLikeParam querytext + values = catMaybes $ map (convert . snd) parameters + + route (Proxy :: Proxy sublayout) (subserver values) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") + convert Nothing = Nothing + convert (Just v) = fromText v + +-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type 'Bool'. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooks +-- > where getBooks :: Bool -> EitherT (Int, String) IO [Book] +-- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... +instance (KnownSymbol sym, HasServer sublayout) + => HasServer (QueryFlag sym :> sublayout) where + + type Server (QueryFlag sym :> sublayout) = + Bool -> Server sublayout + + route Proxy subserver request respond = do + let querytext = parseQueryText $ rawQueryString request + param = case lookup paramname querytext of + Just Nothing -> True -- param is there, with no value + Just (Just v) -> examine v -- param with a value + Nothing -> False -- param not in the query string + + route (Proxy :: Proxy sublayout) (subserver param) request respond + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + examine v | v == "true" || v == "1" || v == "" = True + | otherwise = False + +-- | Just pass the request to the underlying application and serve its response. +-- +-- Example: +-- +-- > type MyApi = "images" :> Raw +-- > +-- > server :: Server MyApi +-- > server = serveDirectory "/var/www/images" +instance HasServer Raw where + type Server Raw = Application + route Proxy rawApplication request respond = + rawApplication request (respond . succeedWith) + +-- | If you use 'ReqBody' in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of the type specified by 'ReqBody'. +-- This lets servant worry about extracting it from the request and turning +-- it into a value of the type you specify. +-- +-- All it asks is for a 'FromJSON' instance. +-- +-- Example: +-- +-- > type MyApi = "books" :> ReqBody Book :> Post Book +-- > +-- > server :: Server MyApi +-- > server = postBook +-- > where postBook :: Book -> EitherT (Int, String) IO Book +-- > postBook book = ...insert into your db... +instance (FromJSON a, HasServer sublayout) + => HasServer (ReqBody a :> sublayout) where + + type Server (ReqBody a :> sublayout) = + a -> Server sublayout + + route Proxy subserver request respond = do + mrqbody <- decode' <$> lazyRequestBody request + case mrqbody of + Nothing -> respond $ failWith InvalidBody + Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond + +-- | Make sure the incoming request starts with @"/path"@, strip it and +-- pass the rest of the request path to @sublayout@. +instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where + type Server (path :> sublayout) = Server sublayout + route Proxy subserver request respond = case pathInfo request of + (first : rest) + | first == cs (symbolVal proxyPath) + -> route (Proxy :: Proxy sublayout) subserver request{ + pathInfo = rest + } respond + _ -> respond $ failWith NotFound + + where proxyPath = Proxy :: Proxy path diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Utils/StaticFiles.hs @@ -0,0 +1,36 @@ +-- | This module defines a sever-side handler that lets you serve static files. +-- +-- - 'serveDirectory' lets you serve anything that lives under a particular +-- directory on your filesystem. +module Servant.Utils.StaticFiles ( + serveDirectory, + ) where + +import Filesystem.Path.CurrentOS (decodeString) +import Network.Wai.Application.Static +import Servant.API.Raw +import Servant.Server.Internal + +-- | Serve anything under the specified directory as a 'Raw' endpoint. +-- +-- @ +-- type MyApi = "static" :> Raw +-- +-- server :: Server MyApi +-- server = serveDirectory "\/var\/www" +-- @ +-- +-- would capture any request to @\/static\/\@ and look for +-- @\@ under @\/var\/www@. +-- +-- It will do its best to guess the MIME type for that file, based on the extension, +-- and send an appropriate /Content-Type/ header if possible. +-- +-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API +-- as a webapp backend, you will most likely not want the static files to be hidden +-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory' +-- handler in the last position, because /servant/ will try to match the handlers +-- in order. +serveDirectory :: FilePath -> Server Raw +serveDirectory documentRoot = + staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/"))) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}