commit c35a510f12b4c5021d2f11e7d6f9d200d216326c Author: Alp Mestanogullari Date: Tue Oct 21 15:25:34 2014 +0200 beginning of a new implementation, using Soenke's typed rest diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..1f6f3e42 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Alp Mestanogullari + +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 Alp Mestanogullari 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 index 00000000..9a994af6 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant.cabal b/servant.cabal new file mode 100644 index 00000000..d69f1dfe --- /dev/null +++ b/servant.cabal @@ -0,0 +1,33 @@ +name: servant +version: 0.2 +-- synopsis: +-- description: +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alpmestan@gmail.com +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Servant Soenke + -- other-modules: + -- other-extensions: + build-depends: + base >=4 && <5 + , either + , aeson + , string-conversions + , http-client + , http-types + , network-uri + , wai + , warp + , transformers + , text + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -O2 \ No newline at end of file diff --git a/src/Servant.hs b/src/Servant.hs new file mode 100644 index 00000000..242bd932 --- /dev/null +++ b/src/Servant.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant where + +import Data.Aeson +import Data.Monoid +import Data.Proxy +import Data.Text +import GHC.Generics +import GHC.TypeLits +import Network.Wai +import Network.Wai.Handler.Warp +import Soenke + +data Capture sym a + +class Captured a where + capture :: Text -> Maybe a + +instance Captured Text where + capture = Just + +captured :: Captured a => proxy (Capture sym a) -> Text -> Maybe a +captured _ = capture + +instance (KnownSymbol capture, Captured a, HasServer sublayout) + => HasServer (Capture capture a :> sublayout) where + + type Server (Capture capture a :> sublayout) = + Capture capture a :> (a -> Server sublayout) + + route Proxy (capture :> subserver) request = case pathInfo request of + (first : rest) + -> case captured capture first of + Nothing -> return Nothing + Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ + pathInfo = rest + } + _ -> return Nothing + +type TestApi = "hello" :> Capture "name" Text :> Get Greet + +testApi :: Proxy TestApi +testApi = Proxy + +data Greet = Greet { msg :: Text } + deriving Generic + +instance ToJSON Greet + +server :: Server TestApi +server = + (Proxy :: Proxy "hello") + :> (Proxy :: Proxy (Capture "name" Text)) + :> (return . func) + + where func name = Greet ("Hello, " <> name) + +test :: Application +test = serve testApi server + +runTest :: Port -> IO () +runTest port = run port test + +-- load in ghci, call 'runTest 8000' +-- visit http://localhost/hello/world +-- visit http://localhost/hello/soenke +-- visit http://localhost/hello/alp + diff --git a/src/Soenke.hs b/src/Soenke.hs new file mode 100644 index 00000000..8026673a --- /dev/null +++ b/src/Soenke.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DataKinds, FlexibleInstances, OverloadedStrings, PolyKinds, + ScopedTypeVariables, TypeFamilies, TypeOperators #-} +module Soenke where + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Proxy +import Data.String.Conversions +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 + +-- | 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 = 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) + +instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where + type Server (path :> sublayout) = path :> (Server sublayout) + route Proxy (path :> subserver) request = case pathInfo request of + (first : rest) + | first == cs (symbolVal path) + -> route (Proxy :: Proxy sublayout) subserver request{ + pathInfo = rest + } + _ -> return Nothing + +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) "" + +class HasClient layout where + type Client layout :: * + clientWithRoute :: Proxy layout -> String -> Client layout + +{-# 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 path uri = do + innerRequest <- liftIO $ + Http.Client.parseUrl (show (nullURI{uriPath = path} `relativeTo` uri)) + innerResponse <- liftIO $ __withGlobalManager $ \ manager -> + Http.Client.httpLbs innerRequest manager + when (Http.Client.responseStatus innerResponse /= ok200) $ + left ("kraken daemon returned: " ++ show (Http.Client.responseStatus innerResponse)) + maybe (left "kraken daemon returned invalid json") return $ + decode' (Http.Client.responseBody innerResponse) + +instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where + type Client (path :> sublayout) = path :> (Client sublayout) + clientWithRoute Proxy path = + (Proxy :: Proxy path) :> + clientWithRoute (Proxy :: Proxy sublayout) + (path ++ "/" ++ (symbolVal (Proxy :: Proxy path))) + +instance (HasClient a, HasClient b) => HasClient (a :<|> b) where + type Client (a :<|> b) = (Client a :<|> Client b) + clientWithRoute Proxy path = + clientWithRoute (Proxy :: Proxy a) path :<|> + clientWithRoute (Proxy :: Proxy b) path