beginning of a new implementation, using Soenke's typed rest

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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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

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
+

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