initial commit

.gitignore

@@ -0,0 +1,6 @@
+.stack-work/
+*.cabal
+*~
+.idea/
+*.iml
+out/

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2017
+
+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 Author name here 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.

README.md

@@ -0,0 +1 @@
+# orderbook

Setup.hs

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

app/Main.hs

@@ -0,0 +1,26 @@
+module Main where
+
+import MyPrelude
+import qualified Api.Docs
+import qualified Api.Handler as Handler
+import qualified Api
+import qualified Servant.Server as SS
+import Servant.API
+import qualified Network.HTTP.Client.TLS     as HTTPS
+import qualified Network.Wai.Handler.Warp    as Warp
+import qualified Network.HTTP.Client         as HTTP
+
+
+server :: HTTP.Manager -> SS.Server Api.Api
+server man = Handler.listVenues
+   :<|> Handler.listMarkets man
+   :<|> Handler.slipBuy man
+   :<|> Handler.slipSell man
+
+app :: HTTP.Manager -> SS.Application
+app man = SS.serve (Proxy :: Proxy Api.Api) (server man)
+
+main :: IO ()
+main = do
+   man <- HTTPS.newTlsManager
+   Warp.run 8080 (app man)

package.yaml

@@ -0,0 +1,102 @@
+name:                rest-depth
+version:             0.1.0.0
+github:              "runeksvendsen/rest-depth"
+license:             BSD3
+author:              "Rune K. Svendsen"
+maintainer:          "example@example.com"
+copyright:           "2017 Author name here"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+# Metadata used when publishing your package
+synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on Github at <https://github.com/githubuser/rest-depth#readme>
+
+default-extensions:
+- StrictData
+- BangPatterns
+- NoImplicitPrelude
+- ScopedTypeVariables
+- MultiParamTypeClasses
+- ScopedTypeVariables
+- OverloadedStrings
+- KindSignatures
+- DataKinds
+- FlexibleInstances
+- DeriveGeneric
+- RecordWildCards
+- DuplicateRecordFields
+- FlexibleContexts
+- DeriveFunctor
+- TypeOperators
+
+dependencies:
+- base            >= 4.7    && < 5
+- protolude
+- orderbook
+- crypto-venues
+- safe-money      >= 0.4.1  && < 0.5
+- servant         >= 0.11   && < 0.12
+- servant-client  >= 0.11   && < 0.12
+- servant-server
+- servant-docs
+- aeson
+- vector
+- bytestring
+- scientific
+- json-schema
+- pretty-show
+- text
+- safe
+- http-client
+- http-client-tls
+- typelits-witnesses
+- errors
+# Venues
+- template-haskell
+- http-types
+- mtl
+- unordered-containers
+
+library:
+  source-dirs: src
+
+executables:
+  rest-depth-exe:
+    main:                Main.hs
+    source-dirs:
+    - app
+#    - src
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - rest-depth
+    - warp
+
+tests:
+  rest-depth-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - rest-depth
+    - QuickCheck
+    - hspec
+    - HUnit
+    - tasty
+    - tasty-smallcheck
+    - tasty-quickcheck
+    - smallcheck
+    - hspec-smallcheck

src/Api.hs

@@ -0,0 +1,44 @@
+module Api
+( Api
+, ListVenues
+, ListMarkets
+, SlippageBuy
+, SlippageSell
+, AnyVenue(..)
+, AnyMarket(..)
+, Market(..)
+, SlippageInfo(..)
+) where
+
+import RPrelude
+import Markets.Types
+import Venue.Types
+import OrderBook.Output
+import Fetch.MarketBook
+import Servant.API
+
+
+type Api = ListVenues :<|> ListMarkets :<|> SlippageSell :<|> SlippageBuy
+
+type ListVenues
+   = "list_venues"
+   :> Get '[JSON] [AnyVenue]
+
+type ListMarkets
+   = Capture "venue" Text
+   :> "list_markets"
+   :> Get '[JSON] [AnyMarket]
+
+type SlippageSell
+   = Capture "venue" Text
+   :> "slippage_sell"
+   :> Capture "market" Text
+   :> Capture "slippage" Double
+   :> Get '[JSON] SlippageInfo
+
+type SlippageBuy
+   = Capture "venue" Text
+   :> "slippage_buy"
+   :> Capture "market" Text
+   :> Capture "slippage" Double
+   :> Get '[JSON] SlippageInfo

src/Api/Docs.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Api.Docs where
+
+import RPrelude
+import Api
+import Venues
+import Data.ByteString.Lazy (ByteString)
+import Data.Proxy
+import Data.Text.Lazy.Encoding (encodeUtf8)
+import Data.Text.Lazy (pack)
+import Network.HTTP.Types
+--import Network.Wai
+import Servant.API
+import Servant.Docs
+import Servant.Server
+
+{-
+apiDocs :: API
+apiDocs = docs (Proxy :: Proxy Api)
+
+apiMarkdown :: String
+apiMarkdown = markdown apiDocs
+
+
+instance ToCapture (Capture "venue" Text) where
+  toCapture _ =
+    DocCapture "venue"                                -- name
+               "(string) venue name; returned by 'list_venues'" -- description
+
+instance ToCapture (Capture "market" Text) where
+  toCapture _ =
+    DocCapture "market"                                -- name
+               "(string) market name; returned by 'list_markets'" -- description
+
+instance ToSample AnyVenue  where
+  toSamples _ = [ ("", AnyVenue (Proxy :: Proxy "bitfinex")) ]
+
+instance ToSample AnyMarket where
+  toSamples _ =
+    [ ("", AnyMarket (Market "BTC" "USD" "btcusd" :: Market "bitfinex") )
+
+    ]
+    -- mutliple examples to display this time
+
+instance ToParam (QueryParam "slippage" Double) where
+   toParam _ =
+      DocQueryParam "slippage"                     -- name
+                  ["0.1", "1.0", "2.3"] -- example of values (not necessarily exhaustive)
+                  "Target slippage in percent" -- description
+                  Normal -- Normal, List or Flag
+
+instance ToSample SlippageInfo where
+   toSamples _ =
+      [ ("", SlippageInfo
+               { base_qty = 7469440144397 % 16423200000
+               , quote_qty = 1821654531855684757 % 456200000000
+               , init_price = Just (43488 % 5)
+               , slippage_percent = Just (1 % 1)
+               , orders_exhausted = False
+               }
+        )
+      ]
+-}
+

src/Api/Handler.hs

@@ -0,0 +1,64 @@
+module Api.Handler where
+
+import RPrelude
+import Api.Util
+import Markets
+import Fetch
+import OrderBook
+import OrderBook.Output
+import Venues
+import qualified Network.HTTP.Client   as HTTP
+import qualified Servant.Server        as SS
+import Control.Monad.Error.Class       (throwError)
+
+
+listVenues :: SS.Handler [AnyVenue]
+listVenues = return allVenues
+
+listMarkets
+   :: HTTP.Manager
+   -> Text
+   -> SS.Handler [AnyMarket]
+listMarkets man venueName =
+   withVenue venueName $ \venue ->
+      throwErr =<< liftIO (marketList man venue)
+
+slipSell :: HTTP.Manager
+         -> Text
+         -> Text
+         -> Double
+         -> SS.Handler SlippageInfo
+slipSell man venueName market slip =
+   withMarket venueName market $ \(AnyMarket market) -> do
+      AnyBook ob <- throwErr =<< liftIO (fetchFromMarket man market)
+      return $ fromMatchRes (slippageSell ob (realToFrac slip))
+
+slipBuy :: HTTP.Manager
+        -> Text
+        -> Text
+        -> Double
+        -> SS.Handler SlippageInfo
+slipBuy man venueName market slip =
+   withMarket venueName market $ \(AnyMarket market) -> do
+      AnyBook ob <- throwErr =<< liftIO (fetchFromMarket man market)
+      return $ fromMatchRes (slippageBuy ob (realToFrac slip))
+
+
+-- Helpers
+withVenue :: Text -> (AnyVenue -> SS.Handler r) -> SS.Handler r
+withVenue venueName f =
+   case venueLookup venueName of
+      Nothing    -> throwError SS.err404
+      Just venue -> f venue
+
+withMarket :: Text -> Text -> (AnyMarket -> SS.Handler r) -> SS.Handler r
+withMarket venueName marketName f =
+   withVenue venueName $ \venue ->
+      case fromString venue marketName of
+         Just anyMarket -> f anyMarket
+         Nothing        -> throwError
+            SS.err400 { SS.errReasonPhrase = "Invalid market: " <> toS marketName
+                      , SS.errBody = "Failed to parse market from string: " <> toS marketName
+                      }
+
+