diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for borl-trader + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Manuel Schneckenreither (c) 2019 + +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 Manuel Schneckenreither 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,63 @@ +# Api Maker: Implementing APIs like never before + +Api Maker let's you implement APIs simply by implementing the `class Request` for each possible +request. It is built on top of the [Req](https://hackage.haskell.org/package/req) library. + +Lets say we want to implement a `GET` request that returns orders taken in an account. This actually +implements the [GET orders request of +oanda.com](https://developer.oanda.com/rest-live-v20/order-ep/). So we create a data type structure +to hold what we want: + + -- | GET Order(s) request + data GetOrder = + GetOrder AccountId OrderConfig + + -- | This data type defines the header options that we can send + data OrderConfig = OrderConfig + { ids :: Maybe [OrderId] -- ^ List of Order IDs to retrieve + , state :: Maybe OrderStateFilter -- ^ The state to filter the requested Orders by [default=PENDING] + , instrument :: Maybe InstrumentName -- ^ The instrument to filter the requested orders by + , orderCount :: Maybe Int -- ^ The maximum number of Orders to return [default=50, maximum=500] + , beforeID :: Maybe OrderId -- ^ The maximum Order ID to return. If not provided the most recent Orders in the Account are returned + } deriving (Show, Eq, Ord, ToJSON, Generic, NFData) + + +and then we implement the class + + instance Request OandaConfig GetOrder where + type Method GetOrder = GET -- It's a GET request + type Body GetOrder = NoReqBody -- We do not send a body + type Response GetOrder = JsonResponse OrderList -- The response is a JSON list of orders + type Output GetOrder = OrderList -- We simply output the list in the `process` function without transformation + method _ GetOrder {} = GET -- GET request again + url cfg (GetOrder accId _) = ".../account/orders" -- The URL + body _ (GetOrder _ req) = NoReqBody -- No Body to send + response _ GetOrder {} = jsonResponse -- The expected response is in JSON format and is parsed using `aeson` with this function. + option _ (GetOrder _ cfg) = -- What header options to send + headerRFC3339DatetimeFormat <> configs + where + configs = + case cfg of + OrderConfig ids state instrument count beforeID -> + "ids" `queryParam` fmap (T.intercalate ";") ids <> + "state" `queryParam` fmap show state <> + "instrument" `queryParam` instrument <> + "count" `queryParam` count <> + "beforeID" `queryParam` beforeID + + -- Defines how to process the Response. One might change it here, e.g. filter values that cannot be specified by the request options. + process _ GetOrder {} response = return $ responseBody response + +The request `State` monad is then run like this: + + runSessReqM cfg $ runRequests $ do + orders <- mkReq $ GetOrder myAccountId (OrderConfig Nothing Nothing (Just "USD/EUR") (Just 100) Nothing) + print orders + +This will create the session and run the requests. All `HttpException`s errors are caught and +converted to exceptions. Thus `runSessReqM` returns a `Either HttpException a`. The function `mkReq` +is used to actually make the requests, the data-type `GetOrder` defines what request to make and +uses the corresponding account ID and the configuration provided. The result is a list of Orders, +with type `OrderList`. + + 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/api-maker.cabal b/api-maker.cabal new file mode 100644 --- /dev/null +++ b/api-maker.cabal @@ -0,0 +1,88 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 6a6fa3f0f379eade6020b6c856c601ee0501ed76dedb9ef47f70a2a62406e38c + +name: api-maker +version: 0.1.0.0 +synopsis: Package to make APIs +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/schnecki/api-maker#readme +bug-reports: https://github.com/schnecki/api-maker/issues +author: Manuel Schneckenreither +maintainer: manuel.schneckenreither@uibk.ac.at +copyright: 2019 Manuel Schneckenreither +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/schnecki/api-maker + +library + exposed-modules: + ApiMaker + Network.HTTP.ApiMaker.Class + Network.HTTP.ApiMaker.HeaderContent + Network.HTTP.ApiMaker.Ops + Network.HTTP.ApiMaker.SessionState + other-modules: + Paths_api_maker + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwarn-tabs -fno-warn-name-shadowing -O2 -funbox-strict-fields + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , containers + , http-client + , http-client-tls + , http-types + , lens + , monad-control + , mtl + , req + , text + , transformers + , transformers-base + if impl(ghc < 8.0) + ghc-options: -fno-warn-incomplete-patterns + cpp-options: -DType=* + if impl(ghc >= 8.6) + default-extensions: NoStarIsType + default-language: Haskell2010 + +test-suite api-maker-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_api_maker + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , api-maker + , base >=4.7 && <5 + , bytestring + , containers + , http-client + , http-client-tls + , http-types + , lens + , monad-control + , mtl + , req + , text + , transformers + , transformers-base + default-language: Haskell2010 diff --git a/src/ApiMaker.hs b/src/ApiMaker.hs new file mode 100644 --- /dev/null +++ b/src/ApiMaker.hs @@ -0,0 +1,11 @@ +module ApiMaker + ( module R + ) where + +import Network.HTTP.ApiMaker.Class as R +import Network.HTTP.ApiMaker.Ops as R + +import Network.HTTP.ApiMaker.HeaderContent as R + +import Network.HTTP.Req as R + diff --git a/src/Network/HTTP/ApiMaker/Class.hs b/src/Network/HTTP/ApiMaker/Class.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/ApiMaker/Class.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +module Network.HTTP.ApiMaker.Class + ( Request(..) + , Config (..) + , SessionState (..) + , Session(..) + , emptySession + , runSafeReqM + , askConfig + , askApiConfig + , SafeReqSt + , SafeReq + , SafeReqM (..) + ) where + +import Control.Monad.Base +import Control.Monad.Except +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Data.Kind (Type) +import Data.Proxy +import Network.HTTP.Req + +import Network.HTTP.ApiMaker.SessionState + + +-- | Class definition for a 'Request'. Every request should implement this, the rest is then handled by the library. See 'Network.HTTP.ApiMaker.Ops.mkReq' to create a request, the functions +-- 'Network.HTTP.ApiMaker.Ops.mkReqM' and 'Network.HTTP.ApiMaker.Ops.runRequests' to build a 'SafeReqM' monad that shares the same state, session and configuration, and finally +-- 'Network.HTTP.ApiMaker.Ops.runReqM', 'Network.HTTP.ApiMaker.Ops.runSessReqM', 'Network.HTTP.ApiMaker.Ops.runReqWithParamsM' and 'Network.HTTP.ApiMaker.Ops.runSessReqWithParamsM' to run the monad. +class (HttpMethod (Method r), HttpBody (Body r), HttpResponse (Response r), HttpBodyAllowed (AllowsBody (Method r)) (ProvidesBody (Body r))) => + Request cfg r + where + type Method r :: Type + type Body r :: Type + type Response r :: Type + type Output r :: Type + -- type Protocol r :: Scheme + method :: cfg -> r -> Method r + url :: cfg -> r -> Url 'Https -- (Protocol r) + body :: cfg -> r -> Body r + response :: cfg -> r -> Proxy (Response r) + option :: cfg -> r -> Option 'Https -- (Protocol r) + process :: (MonadHttp m, SessionState st) => cfg -> r -> Response r -> StateT st m (Output r) + + +-- Type safe request + +-- | Configuration that is passed from request to request to hold the session and default https header options. It also holds a user defined configuration. +data Config cfg = Config + { httpConfig :: HttpConfig + , apiDefaultParameters :: [Option 'Https] + , apiConfig :: cfg + } + +type SafeReqSt sessionState cfg a = StateT sessionState (SafeReqM cfg) a +type SafeReq cfg a = SafeReqSt Session cfg a + +-- | Safe request, e.g. all errors are caught and tured into exceptions. +newtype SafeReqM cfg a = + SafeReqM (ExceptT HttpException (ReaderT (Config cfg) IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +askConfig :: SafeReqM cfg (Config cfg) +askConfig = SafeReqM (lift ask) + +askApiConfig :: SafeReqM cfg cfg +askApiConfig = apiConfig <$> SafeReqM (lift ask) + +instance MonadBase IO (SafeReqM cfg) where + liftBase = liftIO + +instance MonadHttp (SafeReqM cfg) where + handleHttpException = SafeReqM . throwError + getHttpConfig = httpConfig <$> SafeReqM (lift ask) + +-- | Safely run the request monad. +runSafeReqM :: + MonadIO m + => Config cfg -- ^ Config including 'HttpConfig' to use + -> SafeReqM cfg a -- ^ Computation to run + -> m (Either HttpException a) +runSafeReqM config (SafeReqM m) = liftIO (runReaderT (runExceptT m) config) + + diff --git a/src/Network/HTTP/ApiMaker/HeaderContent.hs b/src/Network/HTTP/ApiMaker/HeaderContent.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/ApiMaker/HeaderContent.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +module Network.HTTP.ApiMaker.HeaderContent + ( headerContentTypeJson + , headerContentTypeMultipart + , headerContentDispositionFile + ) where + +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Network.HTTP.Req + + +-- | Option for specifying `application/json`. +headerContentTypeJson :: Option scheme +headerContentTypeJson = header "content-type" "application/json" + +-- | Option for specifying `multipart/form-data`. +headerContentTypeMultipart :: Option scheme +headerContentTypeMultipart = header "content-type" "multipart/form-data" + +-- | Option for specifying a file. +headerContentDispositionFile :: T.Text -> Option scheme +headerContentDispositionFile filename = header "Content-Disposition" (E.encodeUtf8 $ T.concat ["attachment; filename=\"", filename, "\""]) + + diff --git a/src/Network/HTTP/ApiMaker/Ops.hs b/src/Network/HTTP/ApiMaker/Ops.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/ApiMaker/Ops.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.HTTP.ApiMaker.Ops + ( mkReq + , runRequests + , runStRequests + , runReqM + , runReqWithParamsM + , runSessReqM + , runSessReqWithParamsM + ) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Trans.State +import qualified Data.ByteString.Char8 as B +import Data.List (find) +import qualified Network.HTTP.Client as C +import Network.HTTP.Req + +import Network.HTTP.ApiMaker.Class + + +-- | Prepare to run requests. +runReqM :: (MonadIO m) => SafeReqM () a -> m (Either HttpException a) +runReqM = runSafeReqM (Config defaultHttpConfig [] ()) + +-- | Prepare to run requests with addional header options. +runReqWithParamsM :: (MonadIO m) => [Option 'Https] -> SafeReqM () a -> m (Either HttpException a) +runReqWithParamsM params = runSafeReqM (Config defaultHttpConfig params ()) + +-- | Prepare to run request with config. +runSessReqM :: (MonadIO m) => cfg -> SafeReqM cfg a -> m (Either HttpException a) +runSessReqM cfg = runSafeReqM (Config defaultHttpConfig [] cfg) + +-- | Prepare to run request with config and additional header options. +runSessReqWithParamsM :: (MonadIO m) => [Option 'Https] -> cfg -> SafeReqM cfg a -> m (Either HttpException a) +runSessReqWithParamsM params cfg = runSafeReqM (Config defaultHttpConfig params cfg) + + +-- | Run a normal session based request state monad. +runRequests :: StateT Session (SafeReqM cfg) a -> SafeReqM cfg a +runRequests = flip evalStateT (Session Nothing Nothing Nothing) + + +-- | Run a user defined session request state monad. +runStRequests :: st -> StateT st (SafeReqM cfg) a -> SafeReqM cfg a +runStRequests = flip evalStateT + + +-- | Call a single request. See 'runRequest' and 'runStRequests' to build and execute a set of requests that share the +-- same state, session and configuration. +mkReq :: (Request cfg request, SessionState st) => request -> SafeReqSt st cfg (Output request) +mkReq r = do + session <- get + cfg <- lift askConfig + apiCfg <- lift askApiConfig + + let ops = option apiCfg r <> mkSessionOps session <> mconcat (apiDefaultParameters cfg) + -- liftIO $ putStrLn $ "Running a request to " <> show (url r) + resp <- lift $ req (method apiCfg r) (url apiCfg r) (body apiCfg r) (response apiCfg r) ops + updateSession r resp + process apiCfg r resp + where + mkSessionOps session = + maybe mempty cookieJar (session ^. cookieJarData) <> header "Cookie" (B.intercalate ";" (mkSessionCookie session ++ mkCsrfCookie session)) <> mkCsrfHeader session + +updateSession :: (Request cfg request, SessionState st) => request -> Response request -> SafeReqSt st cfg () +updateSession _ resp = + let cookies = C.destroyCookieJar $ responseCookieJar resp + sessData = C.cookie_value <$> find ((== "_SESSION") . C.cookie_name) cookies + in sessionData .= sessData >> cookieJarData ?= responseCookieJar resp + + +-- Note: Server does not check/receive cookie! +mkSessionCookie :: (SessionState st) => st -> [B.ByteString] +mkSessionCookie st = + case st ^. sessionData of + Nothing -> mempty + Just sess -> ["_SESSION=" <> sess] + +mkCsrfCookie :: (SessionState st) => st -> [B.ByteString] +mkCsrfCookie st = + case st ^. csrfToken of + Nothing -> mempty + Just csrf -> ["XSRF-TOKEN=" <> csrf] + +mkCsrfHeader :: (SessionState st) => st -> Option scheme +mkCsrfHeader st = + case st ^. csrfToken of + Nothing -> mempty + Just csrf -> header "X-XSRF-TOKEN" csrf diff --git a/src/Network/HTTP/ApiMaker/SessionState.hs b/src/Network/HTTP/ApiMaker/SessionState.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/ApiMaker/SessionState.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +module Network.HTTP.ApiMaker.SessionState + ( SessionState(..) + , Session(..) + , emptySession + ) where + +import Control.Lens +import qualified Data.ByteString.Char8 as B +import qualified Network.HTTP.Client as C + +-- | Session state contract. +class SessionState st where + csrfToken :: Lens' st (Maybe B.ByteString) + sessionData :: Lens' st (Maybe B.ByteString) + cookieJarData :: Lens' st (Maybe C.CookieJar) + + +-- | Simple session state. This probably is sufficient for the day-to-day use. +data Session = Session + -- { unSession :: C.CookieJar } -- TODO: Does not work? Bug in req library? + { sessCsrfToken :: Maybe B.ByteString + , sessSessionData :: Maybe B.ByteString + , sessCookieJarData :: Maybe C.CookieJar + } deriving (Show) + +-- | Simple session state implemention. +instance SessionState Session where + csrfToken = lens sessCsrfToken (\sess c' -> sess {sessCsrfToken = c'}) + sessionData = lens sessSessionData (\sess d' -> sess {sessSessionData = d'}) + cookieJarData = lens sessCookieJarData (\sess d' -> sess {sessCookieJarData = d'}) + + +-- | Empty session state. +emptySession :: Session +emptySession = Session Nothing Nothing Nothing + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"