diff --git a/example/greet.hs b/example/greet.hs new file mode 100644 index 00000000..4a02e67b --- /dev/null +++ b/example/greet.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Concurrent (forkIO, killThread) +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Monoid +import Data.Proxy +import Data.Text +import GHC.Generics +import Network.URI +import Network.Wai +import Network.Wai.Handler.Warp + +import Servant.API +import Servant.Client +import Servant.Server + +-- * Example + +data Greet = Greet { msg :: Text } + deriving (Generic, Show) + +instance FromJSON Greet +instance ToJSON Greet + +-- API specification +type TestApi = + "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet + :<|> "greet" :> RQBody Greet :> Post Greet + +testApi :: Proxy TestApi +testApi = Proxy + +-- Server-side handlers +server :: Server TestApi +server = hello :<|> greet + + where hello name Nothing = hello name (Just False) + hello name (Just False) = return . Greet $ "Hello, " <> name + hello name (Just True) = return . Greet . toUpper $ "Hello, " <> name + + greet = return + +-- Client-side query functions +clientApi :: Client TestApi +clientApi = client testApi + +getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet +postGreet :: Greet -> URI -> EitherT String IO Greet +getGreet :<|> postGreet = clientApi + +-- Turn the server into a WAI app +test :: Application +test = serve testApi server + +-- Run the server +runTestServer :: Port -> IO () +runTestServer port = run port test + +-- Run some queries against the server +main :: IO () +main = do + tid <- forkIO $ runTestServer 8001 + let Just uri = parseURI "http://localhost:8001" + print =<< runEitherT (getGreet "alp" (Just True) uri) + print =<< runEitherT (getGreet "alp" (Just False) uri) + let g = Greet "yo" + print =<< runEitherT (postGreet g uri) + killThread tid diff --git a/servant.cabal b/servant.cabal index 4365333c..dcd2f797 100644 --- a/servant.cabal +++ b/servant.cabal @@ -4,7 +4,7 @@ version: 0.2 -- description: license: BSD3 license-file: LICENSE -author: Alp Mestanogullari +author: Alp Mestanogullari, Soenke Hahn maintainer: alpmestan@gmail.com -- copyright: category: Web @@ -13,7 +13,19 @@ build-type: Simple cabal-version: >=1.10 library - exposed-modules: Servant Soenke + exposed-modules: + Servant + Servant.Client + Servant.Server + Servant.Text + Servant.API + Servant.API.Capture + Servant.API.Get + Servant.API.GetParam + Servant.API.Post + Servant.API.RQBody + Servant.API.Sub + Servant.API.Union -- other-modules: -- other-extensions: build-depends: @@ -30,6 +42,21 @@ library , warp , transformers , text - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -O2 \ No newline at end of file + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -O0 -Wall + +executable greet + main-is: greet.hs + hs-source-dirs: example + ghc-options: -O0 -Wall + default-language: Haskell2010 + build-depends: + base + , servant + , aeson + , warp + , wai + , either + , text + , network-uri diff --git a/src/Servant.hs b/src/Servant.hs index 2159813b..ac2e4a1e 100644 --- a/src/Servant.hs +++ b/src/Servant.hs @@ -1,202 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Servant where +module Servant + ( module Servant.API + , module Servant.Client + , module Servant.Server + , module Servant.Text + ) where -import Control.Applicative -import Control.Concurrent (forkIO, killThread) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Either -import Data.Aeson -import Data.ByteString.Lazy (ByteString) -import Data.Monoid -import Data.Proxy -import Data.String.Conversions -import Data.Text -import GHC.Generics -import GHC.TypeLits -import Network.HTTP.Types -import Network.URI -import Network.Wai -import Network.Wai.Handler.Warp -import Soenke - -import qualified Network.HTTP.Client as Http.Client - -class FromText a where - fromText :: Text -> Maybe a - -class ToText a where - toText :: a -> Text - -instance FromText Text where - fromText = Just - -instance ToText Text where - toText = id - -instance FromText Bool where - fromText "true" = Just True - fromText "false" = Just False - fromText _ = Nothing - -instance ToText Bool where - toText True = "true" - toText False = "false" - --- * Captures -data Capture sym a - -captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a -captured _ = fromText - -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 = case pathInfo request of - (first : rest) - -> case captured captureProxy first of - Nothing -> return Nothing - Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ - pathInfo = rest - } - _ -> return Nothing - - where captureProxy = Proxy :: Proxy (Capture capture a) - -instance (KnownSymbol capture, ToText a, HasClient sublayout) - => HasClient (Capture capture a :> sublayout) where - - type Client (Capture capture a :> sublayout) = - a -> Client sublayout - - clientWithRoute Proxy req val = - clientWithRoute (Proxy :: Proxy sublayout) $ - appendToPath p req - - where p = unpack (toText val) - --- * Request Body support -data RQBody a - -instance (FromJSON a, HasServer sublayout) - => HasServer (RQBody a :> sublayout) where - - type Server (RQBody a :> sublayout) = - a -> Server sublayout - - route Proxy subserver request = do - mrqbody <- decode' <$> lazyRequestBody request - case mrqbody of - Nothing -> return Nothing - Just v -> route (Proxy :: Proxy sublayout) (subserver v) request - -instance (ToJSON a, HasClient sublayout) - => HasClient (RQBody a :> sublayout) where - - type Client (RQBody a :> sublayout) = - a -> Client sublayout - - clientWithRoute Proxy req body = - clientWithRoute (Proxy :: Proxy sublayout) $ - setRQBody (encode body) req - --- * GET params support (i.e query string arguments) -data GetParam sym a - -instance (KnownSymbol sym, FromText a, HasServer sublayout) - => HasServer (GetParam sym a :> sublayout) where - - type Server (GetParam sym a :> sublayout) = - Maybe a -> Server sublayout - - route Proxy subserver request = 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 - - where paramName = cs $ symbolVal (Proxy :: Proxy sym) - -instance (KnownSymbol sym, ToText a, HasClient sublayout) - => HasClient (GetParam sym a :> sublayout) where - - type Client (GetParam sym a :> sublayout) = - Maybe a -> Client sublayout - - -- if mparam = Nothing, we don't add it to the query string - clientWithRoute Proxy req mparam = - clientWithRoute (Proxy :: Proxy sublayout) $ - appendToQueryString pname mparamText req - - where pname = pack pname' - pname' = symbolVal (Proxy :: Proxy sym) - mparamText = fmap toText mparam - --- * Example - -data Greet = Greet { msg :: Text } - deriving (Generic, Show) - -instance FromJSON Greet -instance ToJSON Greet - --- API specification -type TestApi = - "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet - :<|> "greet" :> RQBody Greet :> Post Greet - -testApi :: Proxy TestApi -testApi = Proxy - --- Server-side handlers -server :: Server TestApi -server = hello :<|> greet - - where hello name Nothing = hello name (Just False) - hello name (Just False) = return . Greet $ "Hello, " <> name - hello name (Just True) = return . Greet . toUpper $ "Hello, " <> name - - greet = return - --- Client-side query functions -clientApi :: Client TestApi -clientApi = client testApi - -getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet -postGreet :: Greet -> URI -> EitherT String IO Greet -getGreet :<|> postGreet = clientApi - --- Turn the server into a WAI app -test :: Application -test = serve testApi server - --- Run the server -runTestServer :: Port -> IO () -runTestServer port = run port test - --- Run some queries against the server -runTest :: IO () -runTest = do - tid <- forkIO $ runTestServer 8001 - let Just uri = parseURI "http://localhost:8001" - print =<< runEitherT (getGreet "alp" (Just True) uri) - print =<< runEitherT (getGreet "alp" (Just False) uri) - let g = Greet "yo" - print =<< runEitherT (postGreet g uri) - killThread tid +import Servant.API +import Servant.Client +import Servant.Server +import Servant.Text diff --git a/src/Servant/API.hs b/src/Servant/API.hs new file mode 100644 index 00000000..c35d845e --- /dev/null +++ b/src/Servant/API.hs @@ -0,0 +1,17 @@ +module Servant.API + ( module Servant.API.Capture + , module Servant.API.Get + , module Servant.API.GetParam + , module Servant.API.Post + , module Servant.API.RQBody + , module Servant.API.Sub + , module Servant.API.Union + ) where + +import Servant.API.Capture +import Servant.API.Get +import Servant.API.GetParam +import Servant.API.Post +import Servant.API.RQBody +import Servant.API.Sub +import Servant.API.Union \ No newline at end of file diff --git a/src/Servant/API/Capture.hs b/src/Servant/API/Capture.hs new file mode 100644 index 00000000..c6f2c38c --- /dev/null +++ b/src/Servant/API/Capture.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.API.Capture where + +import Data.Proxy +import Data.Text +import GHC.TypeLits +import Network.Wai +import Servant.API.Sub +import Servant.Client +import Servant.Server +import Servant.Text + +-- * Captures +data Capture sym a + +captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a +captured _ = fromText + +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 = case pathInfo request of + (first : rest) + -> case captured captureProxy first of + Nothing -> return Nothing + Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ + pathInfo = rest + } + _ -> return Nothing + + where captureProxy = Proxy :: Proxy (Capture capture a) + +instance (KnownSymbol capture, ToText a, HasClient sublayout) + => HasClient (Capture capture a :> sublayout) where + + type Client (Capture capture a :> sublayout) = + a -> Client sublayout + + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy sublayout) $ + appendToPath p req + + where p = unpack (toText val) diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs new file mode 100644 index 00000000..26b7d562 --- /dev/null +++ b/src/Servant/API/Get.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.API.Get where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Proxy +import Data.String.Conversions +import Network.HTTP.Types +import Network.URI +import Network.Wai +import Servant.Client +import Servant.Server + +import qualified Network.HTTP.Client as Client + +-- | Endpoint for simple GET requests. The server doesn't receive any arguments +-- and serves the contained type as JSON. +data Get a + +instance ToJSON result => HasServer (Get result) where + type Server (Get result) = EitherT (Int, String) IO result + route Proxy action request + | null (pathInfo request) && requestMethod request == methodGet = do + e <- runEitherT action + return $ Just $ case e of + Right output -> + responseLBS ok200 [("Content-Type", "application/json")] (encode output) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | otherwise = return Nothing + +instance FromJSON result => HasClient (Get result) where + type Client (Get result) = URI -> EitherT String IO result + clientWithRoute Proxy req uri = do + innerRequest <- liftIO $ reqToRequest req uri + + innerResponse <- liftIO $ __withGlobalManager $ \ manager -> + Client.httpLbs innerRequest manager + when (Client.responseStatus innerResponse /= ok200) $ + left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse)) + maybe (left "HTTP GET request returned invalid json") return $ + decode' (Client.responseBody innerResponse) diff --git a/src/Servant/API/GetParam.hs b/src/Servant/API/GetParam.hs new file mode 100644 index 00000000..fbc120fa --- /dev/null +++ b/src/Servant/API/GetParam.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.API.GetParam where + +import Data.Proxy +import Data.String.Conversions +import Data.Text +import GHC.TypeLits +import Network.HTTP.Types +import Network.Wai +import Servant.API.Sub +import Servant.Client +import Servant.Server +import Servant.Text + +-- * GET params support (i.e query string arguments) +data GetParam sym a + +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (GetParam sym a :> sublayout) where + + type Server (GetParam sym a :> sublayout) = + Maybe a -> Server sublayout + + route Proxy subserver request = 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 + + where paramName = cs $ symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (GetParam sym a :> sublayout) where + + type Client (GetParam sym a :> sublayout) = + Maybe a -> Client sublayout + + -- if mparam = Nothing, we don't add it to the query string + clientWithRoute Proxy req mparam = + clientWithRoute (Proxy :: Proxy sublayout) $ + appendToQueryString pname mparamText req + + where pname = pack pname' + pname' = symbolVal (Proxy :: Proxy sym) + mparamText = fmap toText mparam diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs new file mode 100644 index 00000000..3c0c15ad --- /dev/null +++ b/src/Servant/API/Post.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.API.Post where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Proxy +import Data.String.Conversions +import Network.HTTP.Types +import Network.URI +import Network.Wai +import Servant.Client +import Servant.Server + +import qualified Network.HTTP.Client as Client + +-- | Endpoint for POST requests. +data Post a + +instance ToJSON a => HasServer (Post a) where + type Server (Post a) = EitherT (Int, String) IO a + + route Proxy action request + | null (pathInfo request) && requestMethod request == methodPost = do + e <- runEitherT action + return $ Just $ case e of + Right out -> + responseLBS status201 [("Content-Type", "application/json")] (encode out) + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | otherwise = return Nothing + +instance FromJSON a => HasClient (Post a) where + type Client (Post a) = URI -> EitherT String IO a + + clientWithRoute Proxy req uri = do + partialRequest <- liftIO $ reqToRequest req uri + + let request = partialRequest { Client.method = methodPost + } + + innerResponse <- liftIO . __withGlobalManager $ \ manager -> + Client.httpLbs request manager + + when (Client.responseStatus innerResponse /= status201) $ + left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse)) + + maybe (left "HTTP POST request returned invalid json") return $ + decode' (Client.responseBody innerResponse) diff --git a/src/Servant/API/RQBody.hs b/src/Servant/API/RQBody.hs new file mode 100644 index 00000000..b08ed8ff --- /dev/null +++ b/src/Servant/API/RQBody.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.API.RQBody where + +import Control.Applicative +import Data.Aeson +import Data.Proxy +import Data.Text +import Network.Wai +import Servant.API.Sub +import Servant.Client +import Servant.Server + +-- * Request Body support +data RQBody a + +instance (FromJSON a, HasServer sublayout) + => HasServer (RQBody a :> sublayout) where + + type Server (RQBody a :> sublayout) = + a -> Server sublayout + + route Proxy subserver request = do + mrqbody <- decode' <$> lazyRequestBody request + case mrqbody of + Nothing -> return Nothing + Just v -> route (Proxy :: Proxy sublayout) (subserver v) request + +instance (ToJSON a, HasClient sublayout) + => HasClient (RQBody a :> sublayout) where + + type Client (RQBody a :> sublayout) = + a -> Client sublayout + + clientWithRoute Proxy req body = + clientWithRoute (Proxy :: Proxy sublayout) $ + setRQBody (encode body) req diff --git a/src/Servant/API/Sub.hs b/src/Servant/API/Sub.hs new file mode 100644 index 00000000..5c402c06 --- /dev/null +++ b/src/Servant/API/Sub.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.API.Sub where + +import Data.Proxy +import Data.String.Conversions +import GHC.TypeLits +import Network.Wai +import Servant.Client +import Servant.Server + +-- | The contained API (second argument) can be found under @("/" ++ path)@ +-- (path being the first argument). +data (path :: k) :> a = Proxy path :> a +infixr 9 :> + +instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where + type Server (path :> sublayout) = Server sublayout + route Proxy subserver request = case pathInfo request of + (first : rest) + | first == cs (symbolVal proxyPath) + -> route (Proxy :: Proxy sublayout) subserver request{ + pathInfo = rest + } + _ -> return Nothing + + where proxyPath = Proxy :: Proxy path + +instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where + type Client (path :> sublayout) = Client sublayout + + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy sublayout) $ + appendToPath p req + + where p = symbolVal (Proxy :: Proxy path) + diff --git a/src/Servant/API/Union.hs b/src/Servant/API/Union.hs new file mode 100644 index 00000000..55c392b6 --- /dev/null +++ b/src/Servant/API/Union.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.API.Union where + +import Data.Proxy +import Servant.Client +import Servant.Server + +-- | Union of two APIs, first takes precedence in case of overlap. +data a :<|> b = a :<|> b +infixr 8 :<|> + +instance (HasServer a, HasServer b) => HasServer (a :<|> b) where + type Server (a :<|> b) = Server a :<|> Server b + route Proxy (a :<|> b) request = do + m <- route (Proxy :: Proxy a) a request + case m of + Nothing -> route (Proxy :: Proxy b) b request + Just response -> return $ Just response + +instance (HasClient a, HasClient b) => HasClient (a :<|> b) where + type Client (a :<|> b) = Client a :<|> Client b + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy a) req :<|> + clientWithRoute (Proxy :: Proxy b) req \ No newline at end of file diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs new file mode 100644 index 00000000..a49bd5a6 --- /dev/null +++ b/src/Servant/Client.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.Client where + +import Control.Concurrent +import Control.Monad.Catch +import Data.ByteString.Lazy +import Data.Proxy +import Data.Text +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Types +import Network.URI +import System.IO.Unsafe + +-- * Accessing APIs as a Client + +-- | 'client' allows you to produce operations to query an API from a client. +client :: HasClient layout => Proxy layout -> Client layout +client p = clientWithRoute p defReq + +class HasClient layout where + type Client layout :: * + clientWithRoute :: Proxy layout -> Req -> Client layout + +data Req = Req + { reqPath :: String + , qs :: QueryText + , reqBody :: ByteString + } + +defReq :: Req +defReq = Req "" [] "" + +appendToPath :: String -> Req -> Req +appendToPath p req = + req { reqPath = reqPath req ++ "/" ++ p } + +appendToQueryString :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> Req + -> Req +appendToQueryString pname pvalue req + | pvalue == Nothing = req + | otherwise = req { qs = qs req ++ [(pname, pvalue)] + } + +setRQBody :: ByteString -> Req -> Req +setRQBody b req = req { reqBody = b } + +reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Request +reqToRequest req uri = fmap (setrqb . setQS ) $ parseUrl url + + where url = show $ nullURI { uriPath = reqPath req } + `relativeTo` uri + + setrqb r = r { requestBody = RequestBodyLBS (reqBody req) } + setQS = setQueryString $ queryTextToQuery (qs req) + +{-# NOINLINE __manager #-} +__manager :: MVar Manager +__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar) + +__withGlobalManager :: (Manager -> IO a) -> IO a +__withGlobalManager action = modifyMVar __manager $ \ manager -> do + result <- action manager + return (manager, result) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs new file mode 100644 index 00000000..bc6e7e6a --- /dev/null +++ b/src/Servant/Server.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.Server where + +import Data.Proxy +import Network.HTTP.Types +import Network.Wai + +-- * Implementing Servers + +-- | 'serve' allows you to implement an API and produce a wai 'Application'. +serve :: HasServer layout => Proxy layout -> Server layout -> Application +serve p server = toApplication (route p server) + +toApplication :: RoutingApplication -> Application +toApplication ra = \ request respond -> do + m <- ra request + case m of + Nothing -> respond $ responseLBS notFound404 [] "not found" + Just response -> respond response + +type RoutingApplication = + Request -> IO (Maybe Response) + +class HasServer layout where + type Server layout :: * + route :: Proxy layout -> Server layout -> RoutingApplication diff --git a/src/Servant/Text.hs b/src/Servant/Text.hs new file mode 100644 index 00000000..26efdc16 --- /dev/null +++ b/src/Servant/Text.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +module Servant.Text where + +import Data.Text + +class FromText a where + fromText :: Text -> Maybe a + +class ToText a where + toText :: a -> Text + +instance FromText Text where + fromText = Just + +instance ToText Text where + toText = id + +instance FromText Bool where + fromText "true" = Just True + fromText "false" = Just False + fromText _ = Nothing + +instance ToText Bool where + toText True = "true" + toText False = "false" \ No newline at end of file diff --git a/src/Soenke.hs b/src/Soenke.hs deleted file mode 100644 index 4be66dfc..00000000 --- a/src/Soenke.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleInstances, OverloadedStrings, PolyKinds, - ScopedTypeVariables, TypeFamilies, TypeOperators #-} -module Soenke where - -import Control.Concurrent -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Trans.Either -import Data.Aeson -import Data.ByteString.Lazy (ByteString) -import Data.Proxy -import Data.String.Conversions -import Data.Text (Text) -import GHC.TypeLits -import Network.HTTP.Client (Manager, defaultManagerSettings, - newManager) -import qualified Network.HTTP.Client as Http.Client -import Network.HTTP.Types -import Network.URI -import Network.Wai -import System.IO.Unsafe (unsafePerformIO) - - --- * Url Layout - --- $url_layout --- These types allow you to specify a url layout for a REST API using a type --- alias. The defined API doesn't really have value. It is convenient to define --- a Proxy for every API. --- --- The provided constructors are used in 'HasServer' and 'HasClient'. - --- | Endpoint for simple GET requests. The server doesn't receive any arguments --- and serves the contained type as JSON. -data Get a - --- | Endpoint for POST requests. -data Post a - --- | The contained API (second argument) can be found under @("/" ++ path)@ --- (path being the first argument). -data (path :: k) :> a = Proxy path :> a -infixr 9 :> - --- | Union of two APIs, first takes precedence in case of overlap. -data a :<|> b = a :<|> b -infixr 8 :<|> - - --- * Implementing Servers - --- | 'serve' allows you to implement an API and produce a wai 'Application'. -serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (route p server) - -toApplication :: RoutingApplication -> Application -toApplication ra = \ request respond -> do - m <- ra request - case m of - Nothing -> respond $ responseLBS notFound404 [] "not found" - Just response -> respond response - -type RoutingApplication = - Request -> IO (Maybe Response) - -class HasServer layout where - type Server layout :: * - route :: Proxy layout -> Server layout -> RoutingApplication - -instance ToJSON result => HasServer (Get result) where - type Server (Get result) = EitherT (Int, String) IO result - route Proxy action request - | null (pathInfo request) && requestMethod request == methodGet = do - e <- runEitherT action - return $ Just $ case e of - Right output -> - responseLBS ok200 [("Content-Type", "application/json")] (encode output) - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) - | otherwise = return Nothing - -instance ToJSON a => HasServer (Post a) where - type Server (Post a) = EitherT (Int, String) IO a - - route Proxy action request - | null (pathInfo request) && requestMethod request == methodPost = do - e <- runEitherT action - return $ Just $ case e of - Right out -> - responseLBS status201 [("Content-Type", "application/json")] (encode out) - Left (status, message) -> - responseLBS (mkStatus status (cs message)) [] (cs message) - | otherwise = return Nothing - -instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where - type Server (path :> sublayout) = Server sublayout - route Proxy subserver request = case pathInfo request of - (first : rest) - | first == cs (symbolVal proxyPath) - -> route (Proxy :: Proxy sublayout) subserver request{ - pathInfo = rest - } - _ -> return Nothing - - where proxyPath = Proxy :: Proxy path - -instance (HasServer a, HasServer b) => HasServer (a :<|> b) where - type Server (a :<|> b) = Server a :<|> Server b - route Proxy (a :<|> b) request = do - m <- route (Proxy :: Proxy a) a request - case m of - Nothing -> route (Proxy :: Proxy b) b request - Just response -> return $ Just response - - --- * Accessing APIs as a Client - --- | 'client' allows you to produce operations to query an API from a client. -client :: forall layout . HasClient layout => Proxy layout -> Client layout -client Proxy = clientWithRoute (Proxy :: Proxy layout) defReq - -class HasClient layout where - type Client layout :: * - clientWithRoute :: Proxy layout -> Req -> Client layout - -data Req = Req - { reqPath :: String - , qs :: QueryText - , reqBody :: ByteString - } - -defReq :: Req -defReq = Req "" [] "" - -appendToPath :: String -> Req -> Req -appendToPath p req = - req { reqPath = reqPath req ++ "/" ++ p } - -appendToQueryString :: Text -- ^ param name - -> Maybe Text -- ^ param value - -> Req - -> Req -appendToQueryString pname pvalue req - | pvalue == Nothing = req - | otherwise = req { qs = qs req ++ [(pname, pvalue)] - } - -setRQBody :: ByteString -> Req -> Req -setRQBody b req = req { reqBody = b } - -reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Http.Client.Request -reqToRequest req uri = fmap (setrqb . setQS ) $ Http.Client.parseUrl url - - where url = show $ nullURI { uriPath = reqPath req } - `relativeTo` uri - - setrqb r = r { Http.Client.requestBody = Http.Client.RequestBodyLBS (reqBody req) } - setQS = Http.Client.setQueryString $ queryTextToQuery (qs req) - -{-# NOINLINE __manager #-} -__manager :: MVar Manager -__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar) - -__withGlobalManager :: (Manager -> IO a) -> IO a -__withGlobalManager action = modifyMVar __manager $ \ manager -> do - result <- action manager - return (manager, result) - -instance FromJSON result => HasClient (Get result) where - type Client (Get result) = URI -> EitherT String IO result - clientWithRoute Proxy req uri = do - innerRequest <- liftIO $ reqToRequest req uri - - innerResponse <- liftIO $ __withGlobalManager $ \ manager -> - Http.Client.httpLbs innerRequest manager - when (Http.Client.responseStatus innerResponse /= ok200) $ - left ("HTTP GET request failed with status: " ++ show (Http.Client.responseStatus innerResponse)) - maybe (left "HTTP GET request returned invalid json") return $ - decode' (Http.Client.responseBody innerResponse) - -instance FromJSON a => HasClient (Post a) where - type Client (Post a) = URI -> EitherT String IO a - - clientWithRoute Proxy req uri = do - partialRequest <- liftIO $ reqToRequest req uri - - let request = partialRequest { Http.Client.method = methodPost - } - - innerResponse <- liftIO . __withGlobalManager $ \ manager -> - Http.Client.httpLbs request manager - - when (Http.Client.responseStatus innerResponse /= status201) $ - left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse)) - - maybe (left "HTTP POST request returned invalid json") return $ - decode' (Http.Client.responseBody innerResponse) - -instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where - type Client (path :> sublayout) = Client sublayout - - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy sublayout) $ - appendToPath p req - - where p = symbolVal (Proxy :: Proxy path) - -instance (HasClient a, HasClient b) => HasClient (a :<|> b) where - type Client (a :<|> b) = Client a :<|> Client b - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy a) req :<|> - clientWithRoute (Proxy :: Proxy b) req